diff --git a/Data/Array/Accelerate.hs b/Data/Array/Accelerate.hs --- a/Data/Array/Accelerate.hs +++ b/Data/Array/Accelerate.hs @@ -1,9 +1,7 @@ -{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-} - -- only for the deprecated class aliases - -- | -- Module : Data.Array.Accelerate --- Copyright : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell +-- Copyright : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee +-- [2009..2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell -- License : BSD3 -- -- Maintainer : Manuel M T Chakravarty @@ -37,49 +35,213 @@ module Data.Array.Accelerate ( - -- * Scalar element types - Int, Int8, Int16, Int32, Int64, Word, Word8, Word16, Word32, Word64, - CShort, CUShort, CInt, CUInt, CLong, CULong, CLLong, CULLong, - Float, Double, CFloat, CDouble, - Bool, Char, CChar, CSChar, CUChar, + -- * The /Accelerate/ Array Language + -- ** Array data types + L.Acc, S.Arrays, S.Array, S.Scalar, S.Vector, S.Segments, - -- * Scalar type classes - IsScalar, IsNum, IsBounded, IsIntegral, IsFloating, IsNonNum, + -- ** Array element types + S.Elt, - -- * Array data types - Arrays, Array, Scalar, Vector, Segments, + -- ** Shapes & Indices + -- + -- | Array indices are snoc type lists; that is, they are backwards and the + -- end-of-list token, `Z`, occurs on the left. For example, the type of a + -- rank-2 array index is @Z :. Int :. Int@. + -- + S.Z(..), (S.:.)(..), S.Shape, S.All(..), S.Any(..), S.Slice(..), + S.DIM0, S.DIM1, S.DIM2, S.DIM3, S.DIM4, S.DIM5, S.DIM6, S.DIM7, S.DIM8, S.DIM9, - -- * Array element types - Elt, + -- ** Accessors + -- *** Indexing + (L.!), (L.!!), L.the, - -- * Array shapes & indices - Z(..), (:.)(..), Shape, All(..), Any(..), Slice(..), - DIM0, DIM1, DIM2, DIM3, DIM4, DIM5, DIM6, DIM7, DIM8, DIM9, + -- *** Shape information + L.null, L.shape, L.size, L.shapeSize, - -- * Operations to use Accelerate arrays from plain Haskell - arrayDim, arrayShape, arraySize, indexArray, fromIArray, toIArray, fromList, toList, + -- *** Extracting sub-arrays + L.slice, + P.init, P.tail, P.take, P.drop, P.slit, - -- * The /Accelerate/ language - module Data.Array.Accelerate.Language, - module Data.Array.Accelerate.Prelude, + -- ** Construction + -- *** Introduction + L.use, L.unit, - -- * Deprecated names for backwards compatibility - Elem, Ix, SliceIx, tuple, untuple, - - -- * Diagnostics - initTrace + -- *** Initialisation + L.generate, L.replicate, P.fill, + -- *** Enumeration + P.enumFromN, P.enumFromStepN, + + -- ** Composition + -- *** Flow control + (L.?|), L.cond, + + -- *** Pipelining + (L.>->), + + -- ** Modifying Arrays + -- *** Shape manipulation + L.reshape, P.flatten, + + -- *** Permutations + L.permute, L.backpermute, L.ignore, + + -- *** Specialised permutations + P.reverse, P.transpose, + + -- ** Element-wise operations + -- *** Mapping + L.map, + + -- *** Zipping + L.zipWith, P.zipWith3, P.zipWith4, + P.zip, P.zip3, P.zip4, + + -- *** Unzipping + P.unzip, P.unzip3, P.unzip4, + + -- ** Working with predicates + -- *** Filtering + P.filter, + + -- *** Scatter + P.scatter, P.scatterIf, + + -- *** Gather + P.gather, P.gatherIf, + + -- ** Folding + L.fold, L.fold1, P.foldAll, P.fold1All, + + -- *** Segmented reductions + L.foldSeg, L.fold1Seg, + + -- *** Specialised folds + P.all, P.any, P.and, P.or, P.sum, P.product, P.minimum, P.maximum, + + -- ** Prefix sums (scans) + L.scanl, L.scanl1, L.scanl', L.scanr, L.scanr1, L.scanr', + P.prescanl, P.postscanl, P.prescanr, P.postscanr, + + -- *** Segmented scans + P.scanlSeg, P.scanl1Seg, P.scanl'Seg, P.prescanlSeg, P.postscanlSeg, + P.scanrSeg, P.scanr1Seg, P.scanr'Seg, P.prescanrSeg, P.postscanrSeg, + + -- ** Stencil + L.stencil, L.stencil2, + + -- *** Specification + L.Stencil, L.Boundary(..), + + -- *** Common stencil patterns + L.Stencil3, L.Stencil5, L.Stencil7, L.Stencil9, + L.Stencil3x3, L.Stencil5x3, L.Stencil3x5, L.Stencil5x5, + L.Stencil3x3x3, L.Stencil5x3x3, L.Stencil3x5x3, L.Stencil3x3x5, L.Stencil5x5x3, L.Stencil5x3x5, + L.Stencil3x5x5, L.Stencil5x5x5, + + -- ** Foreign + L.foreignAcc, L.foreignAcc2, L.foreignAcc3, + L.foreignExp, L.foreignExp2, L.foreignExp3, + + -- --------------------------------------------------------------------------- + + -- * The /Accelerate/ Expression Language + -- ** Scalar data types + L.Exp, + + -- ** Type classes + T.IsScalar, T.IsNum, T.IsBounded, T.IsIntegral, T.IsFloating, T.IsNonNum, + + -- ** Element types + T.Int, T.Int8, T.Int16, T.Int32, T.Int64, T.Word, T.Word8, T.Word16, T.Word32, T.Word64, + T.CShort, T.CUShort, T.CInt, T.CUInt, T.CLong, T.CULong, T.CLLong, T.CULLong, + Float, Double, T.CFloat, T.CDouble, + Bool, Char, T.CChar, T.CSChar, T.CUChar, + + -- ** Lifting and Unlifting + + -- | A value of type `Int` is a plain Haskell value (unlifted), whereas an + -- @Exp Int@ is a /lifted/ value, that is, an integer lifted into the domain + -- of expressions (an abstract syntax tree in disguise). Both `Acc` and `Exp` + -- are /surface types/ into which values may be lifted. + -- + -- In general an @Exp Int@ cannot be unlifted into an `Int`, because the + -- actual number will not be available until a later stage of execution (e.g. + -- GPU execution, when `run` is called). However, in some cases unlifting + -- makes sense. For example, unlifting can convert, or unpack, an expression + -- of tuple type into a tuple of expressions; those expressions, at runtime, + -- will become tuple dereferences. + -- + L.Lift(..), L.Unlift(..), L.lift1, L.lift2, L.ilift1, L.ilift2, + + -- ** Operations + -- + -- | Some of the standard Haskell 98 typeclass functions need to be + -- reimplemented because their types change. If so, function names kept the + -- same and infix operations are suffixed by an asterisk. If not reimplemented + -- here, the standard typeclass instances apply. + -- + + -- *** Introduction + L.constant, + + -- *** Tuples + L.fst, L.snd, L.curry, L.uncurry, + + -- *** Conditional + (L.?), + + -- *** Basic operations + (L.&&*), (L.||*), L.not, + (L.==*), (L./=*), (L.<*), (L.<=*), (L.>*), (L.>=*), L.max, L.min, + + -- *** Numeric functions + L.truncate, L.round, L.floor, L.ceiling, + + -- *** Bitwise functions + L.bit, L.setBit, L.clearBit, L.complementBit, L.testBit, + L.shift, L.shiftL, L.shiftR, + L.rotate, L.rotateL, L.rotateR, + + -- *** Shape manipulation + L.index0, L.index1, L.unindex1, L.index2, L.unindex2, + L.indexHead, L.indexTail, + L.toIndex, L.fromIndex, + + -- *** Conversions + L.boolToInt, L.fromIntegral, + + -- --------------------------------------------------------------------------- + + -- * Plain arrays + -- ** Operations + arrayDim, arrayShape, arraySize, indexArray, + + -- ** Conversions + -- + -- | For additional conversion routines, see the accelerate-io package: + -- + + -- *** Lists + S.fromList, S.toList, + + -- *** 'Data.Array.IArray.IArray' + S.fromIArray, S.toIArray, + ) where -- friends -import Data.Array.Accelerate.Type -import Data.Array.Accelerate.Array.Sugar hiding ((!), shape, dim, size) -import qualified Data.Array.Accelerate.Array.Sugar as Sugar -import Data.Array.Accelerate.Language -import Data.Array.Accelerate.Prelude -import Data.Array.Accelerate.Debug +import Data.Array.Accelerate.Trafo () -- show instances +import qualified Data.Array.Accelerate.Array.Sugar as S +import qualified Data.Array.Accelerate.Language as L +import qualified Data.Array.Accelerate.Prelude as P +import qualified Data.Array.Accelerate.Type as T +-- system +import Prelude (Float, Double, Bool, Char) +import qualified Prelude + -- Renamings -- @@ -89,42 +251,23 @@ -- |Array indexing in plain Haskell code -- -indexArray :: Array sh e -> sh -> e -indexArray = (Sugar.!) - --- rename as 'shape' is already used by the EDSL to query an array's shape +indexArray :: S.Array sh e -> sh -> e +indexArray = (S.!) --- |Array shape in plain Haskell code +-- | Rank of an array -- -arrayShape :: Shape sh => Array sh e -> sh -arrayShape = Sugar.shape - +arrayDim :: S.Shape sh => sh -> T.Int +arrayDim = S.dim -- FIXME: Rename to rank -arrayDim :: Shape sh => sh -> Int -arrayDim = Sugar.dim -arraySize :: Shape sh => sh -> Int -arraySize = Sugar.size - --- Deprecated aliases for backwards compatibility +-- |Array shape in plain Haskell code -- - -{-# DEPRECATED Elem "Use 'Elt' instead" #-} -class Elt e => Elem e -instance Elt e => Elem e - -{-# DEPRECATED Ix "Use 'Shape' instead" #-} -class Shape sh => Ix sh -instance Shape sh => Ix sh - -{-# DEPRECATED SliceIx "Use 'Slice' instead" #-} -class Slice sh => SliceIx sh -instance Slice sh => SliceIx sh +arrayShape :: S.Shape sh => S.Array sh e -> sh +arrayShape = S.shape +-- rename as 'shape' is already used by the EDSL to query an array's shape -{-# DEPRECATED tuple "Use 'lift' instead" #-} -tuple :: Lift Exp e => e -> Exp (Plain e) -tuple = lift +-- | Total number of elements in an array of the given 'Shape' +-- +arraySize :: S.Shape sh => sh -> T.Int +arraySize = S.size -{-# DEPRECATED untuple "Use 'unlift' instead" #-} -untuple :: Unlift Exp e => Exp (Plain e) -> e -untuple = unlift 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 @@ -1,10 +1,19 @@ -{-# LANGUAGE BangPatterns, CPP, GADTs, DeriveDataTypeable, StandaloneDeriving #-} -{-# LANGUAGE FlexibleContexts, FlexibleInstances, TypeFamilies, TypeOperators #-} -{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances, ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.AST -- Copyright : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee +-- [2009..2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell -- License : BSD3 -- -- Maintainer : Manuel M T Chakravarty @@ -25,7 +34,7 @@ -- In fact, collective operations cannot produce any values other than -- multi-dimensional arrays; when they yield a scalar, this is in the form of -- a 0-dimensional, singleton array. Similarly, scalar expression can -as --- their name indicates- only produce tuples of scalar, but not arrays. +-- their name indicates- only produce tuples of scalar, but not arrays. -- -- There are, however, two expression forms that take arrays as arguments. As -- a result scalar and array expressions are recursively dependent. As we @@ -58,7 +67,7 @@ -- module 'Types'). Reified dictionaries also ensure that constants -- (constructor 'Const') are representable on compute acceleration hardware. -- --- The AST contains both reified dictionaries and type class constraints. +-- The AST contains both reified dictionaries and type class constraints. -- Type classes are used for array-related functionality that is uniformly -- available for all supported types. In contrast, reified dictionaries are -- used for functionality that is only available for certain types, such as @@ -68,7 +77,7 @@ module Data.Array.Accelerate.AST ( -- * Typed de Bruijn indices - Idx(..), idxToInt, + Idx(..), idxToInt, tupleIdxToInt, -- * Valuation environment Val(..), ValElt(..), prj, prjElt, @@ -79,18 +88,22 @@ -- * Scalar expressions PreOpenFun(..), OpenFun, PreFun, Fun, PreOpenExp(..), OpenExp, PreExp, Exp, PrimConst(..), - PrimFun(..) + PrimFun(..), + -- debugging + showPreAccOp, showPreExpOp, + ) where --standard library +import Data.List import Data.Typeable -- friends import Data.Array.Accelerate.Type import Data.Array.Accelerate.Tuple -import Data.Array.Accelerate.Array.Representation (SliceIndex) -import Data.Array.Accelerate.Array.Sugar as Sugar +import Data.Array.Accelerate.Array.Representation ( SliceIndex ) +import Data.Array.Accelerate.Array.Sugar as Sugar #include "accelerate.h" @@ -111,7 +124,11 @@ idxToInt ZeroIdx = 0 idxToInt (SuccIdx idx) = 1 + idxToInt idx +tupleIdxToInt :: TupleIdx tup e -> Int +tupleIdxToInt ZeroTupIdx = 0 +tupleIdxToInt (SuccTupIdx idx) = 1 + tupleIdxToInt idx + -- Environments -- ------------ @@ -127,7 +144,7 @@ -- data ValElt env where EmptyElt :: ValElt () - PushElt :: Elt t + PushElt :: Elt t => ValElt env -> EltRepr t -> ValElt (env, t) -- Projection of a value from a valuation using a de Bruijn index @@ -151,9 +168,8 @@ -- |Function abstraction over parametrised array computations -- data PreOpenAfun acc aenv t where - Abody :: acc aenv t -> PreOpenAfun acc aenv t - Alam :: (Arrays as, Arrays t) - => PreOpenAfun acc (aenv, as) t -> PreOpenAfun acc aenv (as -> t) + Abody :: Arrays t => acc aenv t -> PreOpenAfun acc aenv t + Alam :: Arrays a => PreOpenAfun acc (aenv, a) t -> PreOpenAfun acc aenv (a -> t) -- Function abstraction over vanilla open array computations -- @@ -190,10 +206,10 @@ -- Local binding to represent sharing and demand explicitly; this is an -- eager(!) binding - Alet :: (Arrays bndArrs, Arrays bodyArrs) - => acc aenv bndArrs -- bound expression - -> acc (aenv, bndArrs) bodyArrs -- the bound expression scope - -> PreOpenAcc acc aenv bodyArrs + Alet :: (Arrays bndArrs, Arrays bodyArrs) + => acc aenv bndArrs -- bound expression + -> acc (aenv, bndArrs) bodyArrs -- the bound expression scope + -> PreOpenAcc acc aenv bodyArrs -- Variable bound by a 'Let', represented by a de Bruijn index Avar :: Arrays arrs @@ -216,6 +232,15 @@ -> acc aenv arrs1 -> PreOpenAcc acc aenv arrs2 + -- Apply a backend-specific foreign function to an array, with a pure + -- Accelerate version for use with other backends. The functions must be + -- closed. + Aforeign :: (Arrays arrs, Arrays a, Foreign f) + => f arrs a -- The foreign function for a given backend + -> PreAfun acc (arrs -> a) -- A pure accelerate version + -> acc aenv arrs -- Arguments to the function + -> PreOpenAcc acc aenv a + -- If-then-else for array-level computations Acond :: (Arrays arrs) => PreExp acc aenv Bool @@ -236,36 +261,45 @@ -- Change the shape of an array without altering its contents -- > precondition: size dim == size dim' Reshape :: (Shape sh, Shape sh', Elt e) - => PreExp acc aenv sh -- new shape - -> acc aenv (Array sh' e) -- array to be reshaped + => PreExp acc aenv sh -- new shape + -> acc aenv (Array sh' e) -- array to be reshaped -> PreOpenAcc acc aenv (Array sh e) -- Construct a new array by applying a function to each index. Generate :: (Shape sh, Elt e) - => PreExp acc aenv sh -- output shape - -> PreFun acc aenv (sh -> e) -- representation function + => PreExp acc aenv sh -- output shape + -> PreFun acc aenv (sh -> e) -- representation function -> PreOpenAcc acc aenv (Array sh e) + -- Hybrid map/backpermute, where we separate the index and value + -- transformations. + Transform :: (Elt a, Elt b, Shape sh, Shape sh') + => PreExp acc aenv sh' -- dimension of the result + -> PreFun acc aenv (sh' -> sh) -- index permutation function + -> PreFun acc aenv (a -> b) -- function to apply at each element + -> acc aenv (Array sh a) -- source array + -> PreOpenAcc acc aenv (Array sh' b) + -- Replicate an array across one or more dimensions as given by the first -- argument Replicate :: (Shape sh, Shape sl, Elt slix, Elt e) - => SliceIndex (EltRepr slix) -- slice type specification + => SliceIndex (EltRepr slix) -- slice type specification (EltRepr sl) - co' + co (EltRepr sh) - -> PreExp acc aenv slix -- slice value specification - -> acc aenv (Array sl e) -- data to be replicated + -> PreExp acc aenv slix -- slice value specification + -> acc aenv (Array sl e) -- data to be replicated -> PreOpenAcc acc aenv (Array sh e) - -- Index a subarray out of an array; i.e., the dimensions not indexed are + -- Index a sub-array out of an array; i.e., the dimensions not indexed are -- returned whole - Index :: (Shape sh, Shape sl, Elt slix, Elt e) - => SliceIndex (EltRepr slix) -- slice type specification + Slice :: (Shape sh, Shape sl, Elt slix, Elt e) + => SliceIndex (EltRepr slix) -- slice type specification (EltRepr sl) - co' + co (EltRepr sh) - -> acc aenv (Array sh e) -- array to be indexed - -> PreExp acc aenv slix -- slice value specification + -> acc aenv (Array sh e) -- array to be indexed + -> PreExp acc aenv slix -- slice value specification -> PreOpenAcc acc aenv (Array sl e) -- Apply the given unary function to all elements of the given array @@ -285,74 +319,74 @@ -- Fold along the innermost dimension of an array with a given /associative/ function. Fold :: (Shape sh, Elt e) - => PreFun acc aenv (e -> e -> e) -- combination function - -> PreExp acc aenv e -- default value - -> acc aenv (Array (sh:.Int) e) -- folded array + => PreFun acc aenv (e -> e -> e) -- combination function + -> PreExp acc aenv e -- default value + -> acc aenv (Array (sh:.Int) e) -- folded array -> PreOpenAcc acc aenv (Array sh e) -- 'Fold' without a default value Fold1 :: (Shape sh, Elt e) - => PreFun acc aenv (e -> e -> e) -- combination function - -> acc aenv (Array (sh:.Int) e) -- folded array + => PreFun acc aenv (e -> e -> e) -- combination function + -> acc aenv (Array (sh:.Int) e) -- folded array -> PreOpenAcc acc aenv (Array sh e) -- Segmented fold along the innermost dimension of an array with a given /associative/ function FoldSeg :: (Shape sh, Elt e, Elt i, IsIntegral i) - => PreFun acc aenv (e -> e -> e) -- combination function - -> PreExp acc aenv e -- default value - -> acc aenv (Array (sh:.Int) e) -- folded array - -> acc aenv (Segments i) -- segment descriptor + => PreFun acc aenv (e -> e -> e) -- combination function + -> PreExp acc aenv e -- default value + -> acc aenv (Array (sh:.Int) e) -- folded array + -> acc aenv (Segments i) -- segment descriptor -> PreOpenAcc acc aenv (Array (sh:.Int) e) -- 'FoldSeg' without a default value Fold1Seg :: (Shape sh, Elt e, Elt i, IsIntegral i) - => PreFun acc aenv (e -> e -> e) -- combination function - -> acc aenv (Array (sh:.Int) e) -- folded array - -> acc aenv (Segments i) -- segment descriptor + => PreFun acc aenv (e -> e -> e) -- combination function + -> acc aenv (Array (sh:.Int) e) -- folded array + -> acc aenv (Segments i) -- segment descriptor -> PreOpenAcc acc aenv (Array (sh:.Int) e) -- Left-to-right Haskell-style scan of a linear array with a given *associative* -- function and an initial element (which does not need to be the neutral of the -- associative operations) Scanl :: Elt e - => PreFun acc aenv (e -> e -> e) -- combination function - -> PreExp acc aenv e -- initial value - -> acc aenv (Vector e) -- linear array + => PreFun acc aenv (e -> e -> e) -- combination function + -> PreExp acc aenv e -- initial value + -> acc aenv (Vector e) -- linear array -> PreOpenAcc acc aenv (Vector e) -- FIXME: Make the scans rank-polymorphic? -- Like 'Scan', but produces a rightmost fold value and an array with the same length as the input -- array (the fold value would be the rightmost element in a Haskell-style scan) Scanl' :: Elt e - => PreFun acc aenv (e -> e -> e) -- combination function - -> PreExp acc aenv e -- initial value - -> acc aenv (Vector e) -- linear array + => PreFun acc aenv (e -> e -> e) -- combination function + -> PreExp acc aenv e -- initial value + -> acc aenv (Vector e) -- linear array -> PreOpenAcc acc aenv (Vector e, Scalar e) -- Haskell-style scan without an initial value Scanl1 :: Elt e - => PreFun acc aenv (e -> e -> e) -- combination function - -> acc aenv (Vector e) -- linear array + => PreFun acc aenv (e -> e -> e) -- combination function + -> acc aenv (Vector e) -- linear array -> PreOpenAcc acc aenv (Vector e) -- Right-to-left version of 'Scanl' Scanr :: Elt e - => PreFun acc aenv (e -> e -> e) -- combination function - -> PreExp acc aenv e -- initial value - -> acc aenv (Vector e) -- linear array + => PreFun acc aenv (e -> e -> e) -- combination function + -> PreExp acc aenv e -- initial value + -> acc aenv (Vector e) -- linear array -> PreOpenAcc acc aenv (Vector e) -- Right-to-left version of 'Scanl\'' Scanr' :: Elt e - => PreFun acc aenv (e -> e -> e) -- combination function - -> PreExp acc aenv e -- initial value - -> acc aenv (Vector e) -- linear array + => PreFun acc aenv (e -> e -> e) -- combination function + -> PreExp acc aenv e -- initial value + -> acc aenv (Vector e) -- linear array -> PreOpenAcc acc aenv (Vector e, Scalar e) -- Right-to-left version of 'Scanl1' Scanr1 :: Elt e - => PreFun acc aenv (e -> e -> e) -- combination function - -> acc aenv (Vector e) -- linear array + => PreFun acc aenv (e -> e -> e) -- combination function + -> acc aenv (Vector e) -- linear array -> PreOpenAcc acc aenv (Vector e) -- Generalised forward permutation is characterised by a permutation @@ -367,41 +401,42 @@ -- permutation functions). The combination function needs to be -- /associative/ and /commutative/ . We drop every element for which the -- permutation function yields -1 (i.e., a tuple of -1 values). - Permute :: (Shape sh, Elt e) - => PreFun acc aenv (e -> e -> e) -- combination function - -> acc aenv (Array sh' e) -- default values - -> PreFun acc aenv (sh -> sh') -- permutation function - -> acc aenv (Array sh e) -- source array + Permute :: (Shape sh, Shape sh', Elt e) + => PreFun acc aenv (e -> e -> e) -- combination function + -> acc aenv (Array sh' e) -- default values + -> PreFun acc aenv (sh -> sh') -- permutation function + -> acc aenv (Array sh e) -- source array -> PreOpenAcc acc aenv (Array sh' e) -- Generalised multi-dimensional backwards permutation; the permutation can -- be between arrays of varying shape; the permutation function must be total Backpermute :: (Shape sh, Shape sh', Elt e) - => PreExp acc aenv sh' -- dimensions of the result - -> PreFun acc aenv (sh' -> sh) -- permutation function - -> acc aenv (Array sh e) -- source array + => PreExp acc aenv sh' -- dimensions of the result + -> PreFun acc aenv (sh' -> sh) -- permutation function + -> acc aenv (Array sh e) -- source array -> PreOpenAcc acc aenv (Array sh' e) -- 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') + 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') -- 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 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') + -- Vanilla open array computations -- newtype OpenAcc aenv t = OpenAcc (PreOpenAcc OpenAcc aenv t) @@ -518,9 +553,9 @@ 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)) + 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 @@ -621,9 +656,8 @@ -- |Parametrised open function abstraction -- data PreOpenFun (acc :: * -> * -> *) env aenv t where - Body :: PreOpenExp acc env aenv t -> PreOpenFun acc env aenv t - Lam :: Elt a - => PreOpenFun acc (env, a) aenv t -> PreOpenFun acc env aenv (a -> t) + Body :: Elt t => PreOpenExp acc env aenv t -> PreOpenFun acc env aenv t + Lam :: Elt a => PreOpenFun acc (env, a) aenv t -> PreOpenFun acc env aenv (a -> t) -- |Vanilla open function abstraction -- @@ -639,86 +673,142 @@ -- |Parametrised open expressions using de Bruijn indices for variables ranging over tuples -- of scalars and arrays of tuples. All code, except Cond, is evaluated eagerly. N-tuples are --- represented as nested pairs. +-- represented as nested pairs. -- -- The data type is parametrised over the surface types (not the representation type). -- data PreOpenExp (acc :: * -> * -> *) env aenv t where -- Local binding of a scalar expression - Let :: (Elt bnd_t, Elt body_t) - => PreOpenExp acc env aenv bnd_t - -> PreOpenExp acc (env, bnd_t) aenv body_t - -> PreOpenExp acc env aenv body_t + Let :: (Elt bnd_t, Elt body_t) + => PreOpenExp acc env aenv bnd_t + -> PreOpenExp acc (env, bnd_t) aenv body_t + -> PreOpenExp acc env aenv body_t -- Variable index, ranging only over tuples or scalars - Var :: Elt t - => Idx env t - -> PreOpenExp acc env aenv t + Var :: Elt t + => Idx env t + -> PreOpenExp acc env aenv t + -- Apply a backend-specific foreign function + Foreign :: (Foreign f, Elt x, Elt y) + => f x y + -> PreFun acc () (x -> y) + -> PreOpenExp acc env aenv x + -> PreOpenExp acc env aenv y + -- Constant values - Const :: Elt t - => EltRepr t - -> PreOpenExp acc env aenv t + Const :: Elt t + => EltRepr t + -> PreOpenExp acc env aenv t -- Tuples - Tuple :: (Elt t, IsTuple t) - => Tuple (PreOpenExp acc env aenv) (TupleRepr t) - -> PreOpenExp acc env aenv t - Prj :: (Elt t, IsTuple t, Elt e) - => TupleIdx (TupleRepr t) e - -> PreOpenExp acc env aenv t - -> PreOpenExp acc env aenv e + Tuple :: (Elt t, IsTuple t) + => Tuple (PreOpenExp acc env aenv) (TupleRepr t) + -> PreOpenExp acc env aenv t + Prj :: (Elt t, IsTuple t, Elt e) + => TupleIdx (TupleRepr t) e + -> PreOpenExp acc env aenv t + -> PreOpenExp acc env aenv e + -- Array indices & shapes - IndexNil :: PreOpenExp acc env aenv Z - IndexCons :: (Slice sl, Elt a) - => PreOpenExp acc env aenv sl - -> PreOpenExp acc env aenv a - -> PreOpenExp acc env aenv (sl:.a) - IndexHead :: (Slice sl, Elt a) - => PreOpenExp acc env aenv (sl:.a) - -> PreOpenExp acc env aenv a - IndexTail :: (Slice sl, Elt a) - => PreOpenExp acc env aenv (sl:.a) - -> PreOpenExp acc env aenv sl - IndexAny :: Shape sh => PreOpenExp acc env aenv (Any sh) + IndexNil :: PreOpenExp acc env aenv Z + IndexCons :: (Slice sl, Elt a) + => PreOpenExp acc env aenv sl + -> PreOpenExp acc env aenv a + -> PreOpenExp acc env aenv (sl:.a) + + IndexHead :: (Slice sl, Elt a) + => PreOpenExp acc env aenv (sl:.a) + -> PreOpenExp acc env aenv a + + IndexTail :: (Slice sl, Elt a) + => PreOpenExp acc env aenv (sl:.a) + -> PreOpenExp acc env aenv sl + + IndexAny :: Shape sh + => PreOpenExp acc env aenv (Any sh) + + IndexSlice :: (Shape sh, Shape sl, Elt slix) + => SliceIndex (EltRepr slix) (EltRepr sl) co (EltRepr sh) + -> PreOpenExp acc env aenv slix + -> PreOpenExp acc env aenv sh + -> PreOpenExp acc env aenv sl + + IndexFull :: (Shape sh, Shape sl, Elt slix) + => SliceIndex (EltRepr slix) (EltRepr sl) co (EltRepr sh) + -> PreOpenExp acc env aenv slix + -> PreOpenExp acc env aenv sl + -> PreOpenExp acc env aenv sh + + -- Shape and index conversion + ToIndex :: Shape sh + => PreOpenExp acc env aenv sh -- shape of the array + -> PreOpenExp acc env aenv sh -- index into the array + -> PreOpenExp acc env aenv Int + + FromIndex :: Shape sh + => PreOpenExp acc env aenv sh -- shape of the array + -> PreOpenExp acc env aenv Int -- index into linear representation + -> PreOpenExp acc env aenv sh + -- Conditional expression (non-strict in 2nd and 3rd argument) - Cond :: PreOpenExp acc env aenv Bool - -> PreOpenExp acc env aenv t - -> PreOpenExp acc env aenv t - -> PreOpenExp acc env aenv t + Cond :: Elt t + => PreOpenExp acc env aenv Bool + -> PreOpenExp acc env aenv t + -> PreOpenExp acc env aenv t + -> PreOpenExp acc env aenv t + -- Value recursion with static loop count + Iterate :: Elt a + => PreOpenExp acc env aenv Int -- number of times to repeat + -> PreOpenExp acc (env, a) aenv a -- function to iterate + -> PreOpenExp acc env aenv a -- initial value + -> PreOpenExp acc env aenv a + -- Primitive constants - PrimConst :: Elt t - => PrimConst t - -> PreOpenExp acc env aenv t + PrimConst :: Elt t + => PrimConst t + -> PreOpenExp acc env aenv t -- Primitive scalar operations - PrimApp :: (Elt a, Elt r) - => PrimFun (a -> r) - -> PreOpenExp acc env aenv a - -> PreOpenExp acc env aenv r + PrimApp :: (Elt a, Elt r) + => PrimFun (a -> r) + -> PreOpenExp acc env aenv a + -> PreOpenExp acc env aenv r - -- Project a single scalar from an array - -- the array expression can not contain any free scalar variables - IndexScalar :: (Shape dim, Elt t) - => acc aenv (Array dim t) - -> PreOpenExp acc env aenv dim - -> PreOpenExp acc env aenv t + -- Project a single scalar from an array. + -- The array expression can not contain any free scalar variables. + Index :: (Shape dim, Elt t) + => acc aenv (Array dim t) + -> PreOpenExp acc env aenv dim + -> PreOpenExp acc env aenv t - -- Array shape - -- the array expression can not contain any free scalar variables - Shape :: (Shape dim, Elt e) - => acc aenv (Array dim e) - -> PreOpenExp acc env aenv dim + LinearIndex :: (Shape dim, Elt t) + => acc aenv (Array dim t) + -> PreOpenExp acc env aenv Int + -> PreOpenExp acc env aenv t + -- Array shape. + -- The array expression can not contain any free scalar variables. + Shape :: (Shape dim, Elt e) + => acc aenv (Array dim e) + -> PreOpenExp acc env aenv dim + -- Number of elements of an array given its shape - ShapeSize :: Shape dim - => PreOpenExp acc env aenv dim - -> PreOpenExp acc env aenv Int + ShapeSize :: Shape dim + => PreOpenExp acc env aenv dim + -> PreOpenExp acc env aenv Int + -- Intersection of two shapes + Intersect :: Shape dim + => PreOpenExp acc env aenv dim + -> PreOpenExp acc env aenv dim + -> PreOpenExp acc env aenv dim + + -- |Vanilla open expression -- type OpenExp = PreOpenExp OpenAcc @@ -769,7 +859,7 @@ PrimBRotateR :: IntegralType a -> PrimFun ((a, Int) -> a) -- operators from Fractional, Floating, RealFrac & RealFloat - + PrimFDiv :: FloatingType a -> PrimFun ((a, a) -> a) PrimRecip :: FloatingType a -> PrimFun (a -> a) PrimSin :: FloatingType a -> PrimFun (a -> a) @@ -814,7 +904,7 @@ -- FIXME: use IntegralType? -- FIXME: conversions between various integer types - -- should we have an overloaded functions like 'toInt'? + -- should we have an overloaded functions like 'toInt'? -- (or 'fromEnum' for enums?) PrimBoolToInt :: PrimFun (Bool -> Int) PrimFromIntegral :: IntegralType a -> NumType b -> PrimFun (a -> b) @@ -822,4 +912,87 @@ -- FIXME: what do we want to do about Enum? succ and pred are only -- moderatly useful without user-defined enumerations, but we want -- the range constructs for arrays (but that's not scalar primitives) + + +-- Debugging +-- --------- + +showPreAccOp :: forall acc aenv arrs. PreOpenAcc acc aenv arrs -> String +showPreAccOp Alet{} = "Alet" +showPreAccOp (Avar ix) = "Avar a" ++ show (idxToInt ix) +showPreAccOp (Use a) = "Use " ++ showArrays (toArr a :: arrs) +showPreAccOp Apply{} = "Apply" +showPreAccOp Aforeign{} = "Aforeign" +showPreAccOp Acond{} = "Acond" +showPreAccOp Atuple{} = "Atuple" +showPreAccOp Aprj{} = "Aprj" +showPreAccOp Unit{} = "Unit" +showPreAccOp Generate{} = "Generate" +showPreAccOp Transform{} = "Transform" +showPreAccOp Reshape{} = "Reshape" +showPreAccOp Replicate{} = "Replicate" +showPreAccOp Slice{} = "Slice" +showPreAccOp Map{} = "Map" +showPreAccOp ZipWith{} = "ZipWith" +showPreAccOp Fold{} = "Fold" +showPreAccOp Fold1{} = "Fold1" +showPreAccOp FoldSeg{} = "FoldSeg" +showPreAccOp Fold1Seg{} = "Fold1Seg" +showPreAccOp Scanl{} = "Scanl" +showPreAccOp Scanl'{} = "Scanl'" +showPreAccOp Scanl1{} = "Scanl1" +showPreAccOp Scanr{} = "Scanr" +showPreAccOp Scanr'{} = "Scanr'" +showPreAccOp Scanr1{} = "Scanr1" +showPreAccOp Permute{} = "Permute" +showPreAccOp Backpermute{} = "Backpermute" +showPreAccOp Stencil{} = "Stencil" +showPreAccOp Stencil2{} = "Stencil2" + +showArrays :: forall arrs. Arrays arrs => arrs -> String +showArrays = display . collect (arrays (undefined::arrs)) . fromArr + where + collect :: ArraysR a -> a -> [String] + collect ArraysRunit _ = [] + collect ArraysRarray arr = [showShortendArr arr] + collect (ArraysRpair r1 r2) (a1, a2) = collect r1 a1 ++ collect r2 a2 + -- + display [] = [] + display [x] = x + display xs = "(" ++ intercalate ", " xs ++ ")" + + +showShortendArr :: Elt e => Array sh e -> String +showShortendArr arr + = show (take cutoff l) ++ if length l > cutoff then ".." else "" + where + l = Sugar.toList arr + cutoff = 5 + + +showPreExpOp :: forall acc env aenv t. PreOpenExp acc env aenv t -> String +showPreExpOp Let{} = "Let" +showPreExpOp (Var ix) = "Var x" ++ show (idxToInt ix) +showPreExpOp (Const c) = "Const " ++ show (toElt c :: t) +showPreExpOp Foreign{} = "Foreign" +showPreExpOp Tuple{} = "Tuple" +showPreExpOp Prj{} = "Prj" +showPreExpOp IndexNil = "IndexNil" +showPreExpOp IndexCons{} = "IndexCons" +showPreExpOp IndexHead{} = "IndexHead" +showPreExpOp IndexTail{} = "IndexTail" +showPreExpOp IndexAny = "IndexAny" +showPreExpOp IndexSlice{} = "IndexSlice" +showPreExpOp IndexFull{} = "IndexFull" +showPreExpOp ToIndex{} = "ToIndex" +showPreExpOp FromIndex{} = "FromIndex" +showPreExpOp Cond{} = "Cond" +showPreExpOp Iterate{} = "Iterate" +showPreExpOp PrimConst{} = "PrimConst" +showPreExpOp PrimApp{} = "PrimApp" +showPreExpOp Index{} = "Index" +showPreExpOp LinearIndex{} = "LinearIndex" +showPreExpOp Shape{} = "Shape" +showPreExpOp ShapeSize{} = "ShapeSize" +showPreExpOp Intersect{} = "Intersect" diff --git a/Data/Array/Accelerate/Analysis/Match.hs b/Data/Array/Accelerate/Analysis/Match.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/Analysis/Match.hs @@ -0,0 +1,1037 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_HADDOCK hide #-} +-- | +-- Module : Data.Array.Accelerate.Analysis.Match +-- Copyright : [2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Manuel M T Chakravarty +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.Analysis.Match ( + + -- matching expressions + MatchAcc, + (:=:)(..), + matchOpenAcc, matchPreOpenAcc, + matchOpenAfun, matchPreOpenAfun, + matchOpenExp, matchPreOpenExp, + matchOpenFun, matchPreOpenFun, + matchPrimFun, matchPrimFun', + + -- auxiliary + 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 ) + +-- friends +import Data.Array.Accelerate.AST +import Data.Array.Accelerate.Type +import Data.Array.Accelerate.Array.Sugar +import Data.Array.Accelerate.Array.Representation ( SliceIndex(..) ) +import Data.Array.Accelerate.Tuple hiding ( Tuple ) +import qualified Data.Array.Accelerate.Tuple as Tuple + + +-- Witness equality between types. A value of a :=: b is a proof that types a +-- and b are equal. By pattern matching on REFL this fact is introduced to the +-- type checker. +-- +data s :=: t where + REFL :: s :=: s + +deriving instance Show (s :=: t) + + +-- The type of matching array computations +-- +type MatchAcc acc = forall aenv s t. acc aenv s -> acc aenv t -> Maybe (s :=: t) + + +-- Compute the congruence of two array computations. The nodes are congruent if +-- they have the same operator and their operands are congruent. +-- +matchOpenAcc :: OpenAcc aenv s -> OpenAcc aenv t -> Maybe (s :=: t) +matchOpenAcc (OpenAcc acc1) (OpenAcc acc2) = + matchPreOpenAcc matchOpenAcc hashOpenAcc acc1 acc2 + + +matchPreOpenAcc + :: forall acc aenv s t. + MatchAcc acc + -> HashAcc acc + -> PreOpenAcc acc aenv s + -> PreOpenAcc acc aenv t + -> Maybe (s :=: t) +matchPreOpenAcc matchAcc hashAcc = match + where + matchFun :: PreOpenFun acc env aenv u -> PreOpenFun acc env aenv v -> Maybe (u :=: v) + matchFun = matchPreOpenFun matchAcc hashAcc + + matchExp :: PreOpenExp acc env aenv u -> PreOpenExp acc env aenv v -> Maybe (u :=: v) + matchExp = matchPreOpenExp matchAcc hashAcc + + match :: PreOpenAcc acc aenv s -> PreOpenAcc acc aenv t -> Maybe (s :=: t) + match (Alet x1 a1) (Alet x2 a2) + | Just REFL <- matchAcc x1 x2 + , Just REFL <- matchAcc a1 a2 + = Just REFL + + match (Avar v1) (Avar v2) + = matchIdx v1 v2 + + match (Atuple t1) (Atuple t2) + | Just REFL <- matchAtuple matchAcc t1 t2 + = gcast REFL -- surface/representation type + + match (Aprj ix1 t1) (Aprj ix2 t2) + | Just REFL <- matchAcc t1 t2 + , Just REFL <- matchTupleIdx ix1 ix2 + = Just REFL + + match (Apply f1 a1) (Apply f2 a2) + | Just REFL <- matchPreOpenAfun matchAcc f1 f2 + , Just REFL <- matchAcc a1 a2 + = Just REFL + + match (Aforeign ff1 _ a1) (Aforeign ff2 _ a2) + | Just REFL <- matchAcc a1 a2, + unsafePerformIO $ do + sn1 <- makeStableName ff1 + sn2 <- makeStableName ff2 + return $! hashStableName sn1 == hashStableName sn2 + = gcast REFL + + match (Acond p1 t1 e1) (Acond p2 t2 e2) + | Just REFL <- matchExp p1 p2 + , Just REFL <- matchAcc t1 t2 + , Just REFL <- matchAcc e1 e2 + = Just REFL + + match (Use a1) (Use a2) + | Just REFL <- matchArrays (arrays (undefined::s)) (arrays (undefined::t)) a1 a2 + = gcast REFL + + match (Unit e1) (Unit e2) + | Just REFL <- matchExp e1 e2 + = Just REFL + + match (Reshape sh1 a1) (Reshape sh2 a2) + | Just REFL <- matchExp sh1 sh2 + , Just REFL <- matchAcc a1 a2 + = Just REFL + + match (Generate sh1 f1) (Generate sh2 f2) + | Just REFL <- matchExp sh1 sh2 + , Just REFL <- matchFun f1 f2 + = Just REFL + + match (Transform sh1 ix1 f1 a1) (Transform sh2 ix2 f2 a2) + | Just REFL <- matchExp sh1 sh2 + , Just REFL <- matchFun ix1 ix2 + , Just REFL <- matchFun f1 f2 + , Just REFL <- matchAcc a1 a2 + = Just REFL + + match (Replicate _ ix1 a1) (Replicate _ ix2 a2) + | Just REFL <- matchExp ix1 ix2 + , Just REFL <- matchAcc a1 a2 + = gcast REFL -- slice specification ?? + + match (Slice _ a1 ix1) (Slice _ a2 ix2) + | Just REFL <- matchAcc a1 a2 + , Just REFL <- matchExp ix1 ix2 + = gcast REFL -- slice specification ?? + + match (Map f1 a1) (Map f2 a2) + | Just REFL <- matchFun f1 f2 + , Just REFL <- matchAcc a1 a2 + = Just REFL + + match (ZipWith f1 a1 b1) (ZipWith f2 a2 b2) + | Just REFL <- matchFun f1 f2 + , Just REFL <- matchAcc a1 a2 + , Just REFL <- matchAcc b1 b2 + = Just REFL + + match (Fold f1 z1 a1) (Fold f2 z2 a2) + | Just REFL <- matchFun f1 f2 + , Just REFL <- matchExp z1 z2 + , Just REFL <- matchAcc a1 a2 + = Just REFL + + match (Fold1 f1 a1) (Fold1 f2 a2) + | Just REFL <- matchFun f1 f2 + , Just REFL <- matchAcc a1 a2 + = Just REFL + + match (FoldSeg f1 z1 a1 s1) (FoldSeg f2 z2 a2 s2) + | Just REFL <- matchFun f1 f2 + , Just REFL <- matchExp z1 z2 + , Just REFL <- matchAcc a1 a2 + , Just REFL <- matchAcc s1 s2 + = Just REFL + + match (Fold1Seg f1 a1 s1) (Fold1Seg f2 a2 s2) + | Just REFL <- matchFun f1 f2 + , Just REFL <- matchAcc a1 a2 + , Just REFL <- matchAcc s1 s2 + = Just REFL + + match (Scanl f1 z1 a1) (Scanl f2 z2 a2) + | Just REFL <- matchFun f1 f2 + , Just REFL <- matchExp z1 z2 + , Just REFL <- matchAcc a1 a2 + = Just REFL + + match (Scanl' f1 z1 a1) (Scanl' f2 z2 a2) + | Just REFL <- matchFun f1 f2 + , Just REFL <- matchExp z1 z2 + , Just REFL <- matchAcc a1 a2 + = Just REFL + + match (Scanl1 f1 a1) (Scanl1 f2 a2) + | Just REFL <- matchFun f1 f2 + , Just REFL <- matchAcc a1 a2 + = Just REFL + + match (Scanr f1 z1 a1) (Scanr f2 z2 a2) + | Just REFL <- matchFun f1 f2 + , Just REFL <- matchExp z1 z2 + , Just REFL <- matchAcc a1 a2 + = Just REFL + + match (Scanr' f1 z1 a1) (Scanr' f2 z2 a2) + | Just REFL <- matchFun f1 f2 + , Just REFL <- matchExp z1 z2 + , Just REFL <- matchAcc a1 a2 + = Just REFL + + match (Scanr1 f1 a1) (Scanr1 f2 a2) + | Just REFL <- matchFun f1 f2 + , Just REFL <- matchAcc a1 a2 + = Just REFL + + match (Permute f1 d1 p1 a1) (Permute f2 d2 p2 a2) + | Just REFL <- matchFun f1 f2 + , Just REFL <- matchAcc d1 d2 + , Just REFL <- matchFun p1 p2 + , Just REFL <- matchAcc a1 a2 + = Just REFL + + match (Backpermute sh1 ix1 a1) (Backpermute sh2 ix2 a2) + | Just REFL <- matchExp sh1 sh2 + , Just REFL <- matchFun ix1 ix2 + , 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))) + | Just REFL <- matchFun f1 f2 + , Just REFL <- matchAcc a1 a2 + , matchBoundary (eltType (undefined::e1)) 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'))) + | 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' + = Just REFL + + match _ _ + = Nothing + + +-- Array tuples +-- +matchAtuple + :: MatchAcc acc + -> Atuple (acc aenv) s + -> Atuple (acc aenv) t + -> Maybe (s :=: t) +matchAtuple matchAcc (SnocAtup t1 a1) (SnocAtup t2 a2) + | Just REFL <- matchAtuple matchAcc t1 t2 + , Just REFL <- matchAcc a1 a2 + = Just REFL + +matchAtuple _ NilAtup NilAtup = Just REFL +matchAtuple _ _ _ = Nothing + + +-- Array functions +-- +matchOpenAfun :: OpenAfun aenv s -> OpenAfun aenv t -> Maybe (s :=: t) +matchOpenAfun = matchPreOpenAfun matchOpenAcc + +matchPreOpenAfun :: MatchAcc acc -> PreOpenAfun acc aenv s -> PreOpenAfun acc aenv t -> Maybe (s :=: t) +matchPreOpenAfun m (Alam s) (Alam t) + | Just REFL <- matchEnvTop s t + , Just REFL <- matchPreOpenAfun m s t + = Just REFL + where + matchEnvTop :: (Arrays s, Arrays t) + => PreOpenAfun acc (aenv, s) f -> PreOpenAfun acc (aenv, t) g -> Maybe (s :=: t) + matchEnvTop _ _ = gcast REFL -- ??? + +matchPreOpenAfun m (Abody s) (Abody t) = m s t +matchPreOpenAfun _ _ _ = Nothing + + +-- 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 + + +-- Match arrays +-- +-- As a convenience, we are just comparing the stable names, but we could also +-- walk the structure comparing the underlying ptrsOfArrayData. +-- +matchArrays :: ArraysR s -> ArraysR t -> s -> t -> Maybe (s :=: t) +matchArrays ArraysRunit ArraysRunit () () + = Just REFL + +matchArrays (ArraysRpair a1 b1) (ArraysRpair a2 b2) (arr1,brr1) (arr2,brr2) + | Just REFL <- matchArrays a1 a2 arr1 arr2 + , Just REFL <- matchArrays b1 b2 brr1 brr2 + = Just REFL + +matchArrays ArraysRarray ArraysRarray (Array _ ad1) (Array _ ad2) + | unsafePerformIO $ do + sn1 <- makeStableName ad1 + sn2 <- makeStableName ad2 + return $! hashStableName sn1 == hashStableName sn2 + = gcast REFL + +matchArrays _ _ _ _ + = Nothing + + +-- Compute the congruence of two scalar expressions. Two nodes are congruent if +-- either: +-- +-- 1. The nodes label constants and the contents are equal +-- 2. They have the same operator and their operands are congruent +-- +-- The below attempts to use real typed equality, but occasionally still needs +-- to use a cast, particularly when we can only match the representation types. +-- +matchOpenExp :: OpenExp env aenv s -> OpenExp env aenv t -> Maybe (s :=: t) +matchOpenExp = matchPreOpenExp matchOpenAcc hashOpenAcc + +matchPreOpenExp + :: forall acc env aenv s t. + MatchAcc acc + -> HashAcc acc + -> PreOpenExp acc env aenv s + -> PreOpenExp acc env aenv t + -> Maybe (s :=: t) +matchPreOpenExp matchAcc hashAcc = match + where + match :: forall env' aenv' s' t'. PreOpenExp acc env' aenv' s' -> PreOpenExp acc env' aenv' t' -> Maybe (s' :=: t') + match (Let x1 e1) (Let x2 e2) + | Just REFL <- match x1 x2 + , Just REFL <- match e1 e2 + = Just REFL + + match (Var v1) (Var v2) + = matchIdx v1 v2 + + match (Foreign ff1 _ e1) (Foreign ff2 _ e2) + | Just REFL <- match e1 e2 + , unsafePerformIO $ do + sn1 <- makeStableName ff1 + sn2 <- makeStableName ff2 + return $! hashStableName sn1 == hashStableName sn2 + = gcast REFL + + match (Const c1) (Const c2) + | Just REFL <- matchTupleType (eltType (undefined::s')) (eltType (undefined::t')) + , matchConst (eltType (undefined::s')) c1 c2 + = gcast REFL -- surface/representation type + + match (Tuple t1) (Tuple t2) + | Just REFL <- matchTuple matchAcc hashAcc t1 t2 + = gcast REFL -- surface/representation type + + match (Prj ix1 t1) (Prj ix2 t2) + | Just REFL <- match t1 t2 + , Just REFL <- matchTupleIdx ix1 ix2 + = Just REFL + + match IndexAny IndexAny + = gcast REFL -- ??? + + match IndexNil IndexNil + = Just REFL + + match (IndexCons sl1 a1) (IndexCons sl2 a2) + | Just REFL <- match sl1 sl2 + , Just REFL <- match a1 a2 + = Just REFL + + match (IndexHead sl1) (IndexHead sl2) + | Just REFL <- match sl1 sl2 + = Just REFL + + match (IndexTail sl1) (IndexTail sl2) + | Just REFL <- match sl1 sl2 + = Just REFL + + match (IndexSlice sliceIndex1 ix1 sh1) (IndexSlice sliceIndex2 ix2 sh2) + | Just REFL <- match ix1 ix2 + , Just REFL <- match sh1 sh2 + , Just REFL <- matchSliceRestrict sliceIndex1 sliceIndex2 + = gcast REFL -- SliceIndex representation/surface type + + match (IndexFull sliceIndex1 ix1 sl1) (IndexFull sliceIndex2 ix2 sl2) + | Just REFL <- match ix1 ix2 + , Just REFL <- match sl1 sl2 + , Just REFL <- matchSliceExtend sliceIndex1 sliceIndex2 + = gcast REFL -- SliceIndex representation/surface type + + match (ToIndex sh1 i1) (ToIndex sh2 i2) + | Just REFL <- match sh1 sh2 + , Just REFL <- match i1 i2 + = Just REFL + + match (FromIndex sh1 i1) (FromIndex sh2 i2) + | Just REFL <- match i1 i2 + , Just REFL <- match sh1 sh2 + = Just REFL + + match (Cond p1 t1 e1) (Cond p2 t2 e2) + | Just REFL <- match p1 p2 + , Just REFL <- match t1 t2 + , Just REFL <- match e1 e2 + = Just REFL + + match (Iterate n1 f1 x1) (Iterate n2 f2 x2) + | Just REFL <- match n1 n2 + , Just REFL <- match x1 x2 + , Just REFL <- match f1 f2 + = Just REFL + + match (PrimConst c1) (PrimConst c2) + = matchPrimConst c1 c2 + + match (PrimApp f1 x1) (PrimApp f2 x2) + | Just x1' <- commutes hashAcc f1 x1 + , Just x2' <- commutes hashAcc f2 x2 + , Just REFL <- match x1' x2' + , Just REFL <- matchPrimFun f1 f2 + = Just REFL + + | Just REFL <- match x1 x2 + , Just REFL <- matchPrimFun f1 f2 + = Just REFL + + match (Index a1 x1) (Index a2 x2) + | Just REFL <- matchAcc a1 a2 -- should only be array indices + , Just REFL <- match x1 x2 + = Just REFL + + match (LinearIndex a1 x1) (LinearIndex a2 x2) + | Just REFL <- matchAcc a1 a2 + , Just REFL <- match x1 x2 + = Just REFL + + match (Shape a1) (Shape a2) + | Just REFL <- matchAcc a1 a2 -- should only be array indices + = Just REFL + + match (ShapeSize sh1) (ShapeSize sh2) + | Just REFL <- match sh1 sh2 + = Just REFL + + match (Intersect sa1 sb1) (Intersect sa2 sb2) + | Just REFL <- match sa1 sa2 + , Just REFL <- match sb1 sb2 + = Just REFL + + match _ _ + = Nothing + + +-- Match scalar functions +-- +matchOpenFun :: OpenFun env aenv s -> OpenFun env aenv t -> Maybe (s :=: t) +matchOpenFun = matchPreOpenFun matchOpenAcc hashOpenAcc + +matchPreOpenFun + :: MatchAcc acc + -> HashAcc acc + -> PreOpenFun acc env aenv s + -> PreOpenFun acc env aenv t + -> Maybe (s :=: t) +matchPreOpenFun m h (Lam s) (Lam t) + | Just REFL <- matchEnvTop s t + , Just REFL <- matchPreOpenFun m h s t + = Just REFL + where + matchEnvTop :: (Elt s, Elt t) => PreOpenFun acc (env, s) aenv f -> PreOpenFun acc (env, t) aenv g -> Maybe (s :=: t) + matchEnvTop _ _ = gcast REFL -- ??? + +matchPreOpenFun m h (Body s) (Body t) = matchPreOpenExp m h s t +matchPreOpenFun _ _ _ _ = Nothing + +-- Matching constants +-- +matchConst :: TupleType a -> a -> a -> Bool +matchConst UnitTuple () () = True +matchConst (SingleTuple ty) a b = evalEq ty (a,b) +matchConst (PairTuple ta tb) (a1,b1) (a2,b2) = matchConst ta a1 a2 && matchConst tb b1 b2 + +evalEq :: ScalarType a -> (a, a) -> Bool +evalEq (NumScalarType (IntegralNumType ty)) | IntegralDict <- integralDict ty = uncurry (==) +evalEq (NumScalarType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = uncurry (==) +evalEq (NonNumScalarType ty) | NonNumDict <- nonNumDict ty = uncurry (==) + + +-- Environment projection indices +-- +matchIdx :: Idx env s -> Idx env t -> Maybe (s :=: t) +matchIdx ZeroIdx ZeroIdx = Just REFL +matchIdx (SuccIdx u) (SuccIdx v) = matchIdx u v +matchIdx _ _ = Nothing + + +-- Tuple projection indices. Given the same tuple expression structure (tup), +-- check that the indices project identical elements. +-- +matchTupleIdx :: TupleIdx tup s -> TupleIdx tup t -> Maybe (s :=: t) +matchTupleIdx ZeroTupIdx ZeroTupIdx = Just REFL +matchTupleIdx (SuccTupIdx s) (SuccTupIdx t) = matchTupleIdx s t +matchTupleIdx _ _ = Nothing + +-- Tuples +-- +matchTuple + :: MatchAcc acc + -> HashAcc acc + -> Tuple.Tuple (PreOpenExp acc env aenv) s + -> Tuple.Tuple (PreOpenExp acc env aenv) t + -> Maybe (s :=: t) +matchTuple _ _ NilTup NilTup = Just REFL +matchTuple m h (SnocTup t1 e1) (SnocTup t2 e2) + | Just REFL <- matchTuple m h t1 t2 + , Just REFL <- matchPreOpenExp m h e1 e2 + = Just REFL + +matchTuple _ _ _ _ = Nothing + + +-- Slice specifications +-- +matchSliceRestrict + :: SliceIndex slix s co sh + -> SliceIndex slix t co' sh + -> Maybe (s :=: t) +matchSliceRestrict SliceNil SliceNil + = Just REFL + +matchSliceRestrict (SliceAll sl1) (SliceAll sl2) + | Just REFL <- matchSliceRestrict sl1 sl2 + = Just REFL + +matchSliceRestrict (SliceFixed sl1) (SliceFixed sl2) + | Just REFL <- matchSliceRestrict sl1 sl2 + = Just REFL + +matchSliceRestrict _ _ + = Nothing + + +matchSliceExtend + :: SliceIndex slix sl co s + -> SliceIndex slix sl co' t + -> Maybe (s :=: t) +matchSliceExtend SliceNil SliceNil + = Just REFL + +matchSliceExtend (SliceAll sl1) (SliceAll sl2) + | Just REFL <- matchSliceExtend sl1 sl2 + = Just REFL + +matchSliceExtend (SliceFixed sl1) (SliceFixed sl2) + | Just REFL <- matchSliceExtend sl1 sl2 + = Just REFL + +matchSliceExtend _ _ + = Nothing + + +-- Primitive constants and functions +-- +matchPrimConst :: (Elt s, Elt t) => PrimConst s -> PrimConst t -> Maybe (s :=: t) +matchPrimConst (PrimMinBound s) (PrimMinBound t) = matchBoundedType s t +matchPrimConst (PrimMaxBound s) (PrimMaxBound t) = matchBoundedType s t +matchPrimConst (PrimPi s) (PrimPi t) = matchFloatingType s t +matchPrimConst _ _ = Nothing + + +-- Covariant function matching +-- +matchPrimFun :: (Elt s, Elt t) => PrimFun (a -> s) -> PrimFun (a -> t) -> Maybe (s :=: t) +matchPrimFun (PrimAdd _) (PrimAdd _) = Just REFL +matchPrimFun (PrimSub _) (PrimSub _) = Just REFL +matchPrimFun (PrimMul _) (PrimMul _) = Just REFL +matchPrimFun (PrimNeg _) (PrimNeg _) = Just REFL +matchPrimFun (PrimAbs _) (PrimAbs _) = Just REFL +matchPrimFun (PrimSig _) (PrimSig _) = Just REFL +matchPrimFun (PrimQuot _) (PrimQuot _) = Just REFL +matchPrimFun (PrimRem _) (PrimRem _) = Just REFL +matchPrimFun (PrimIDiv _) (PrimIDiv _) = Just REFL +matchPrimFun (PrimMod _) (PrimMod _) = Just REFL +matchPrimFun (PrimBAnd _) (PrimBAnd _) = Just REFL +matchPrimFun (PrimBOr _) (PrimBOr _) = Just REFL +matchPrimFun (PrimBXor _) (PrimBXor _) = Just REFL +matchPrimFun (PrimBNot _) (PrimBNot _) = Just REFL +matchPrimFun (PrimBShiftL _) (PrimBShiftL _) = Just REFL +matchPrimFun (PrimBShiftR _) (PrimBShiftR _) = Just REFL +matchPrimFun (PrimBRotateL _) (PrimBRotateL _) = Just REFL +matchPrimFun (PrimBRotateR _) (PrimBRotateR _) = Just REFL +matchPrimFun (PrimFDiv _) (PrimFDiv _) = Just REFL +matchPrimFun (PrimRecip _) (PrimRecip _) = Just REFL +matchPrimFun (PrimSin _) (PrimSin _) = Just REFL +matchPrimFun (PrimCos _) (PrimCos _) = Just REFL +matchPrimFun (PrimTan _) (PrimTan _) = Just REFL +matchPrimFun (PrimAsin _) (PrimAsin _) = Just REFL +matchPrimFun (PrimAcos _) (PrimAcos _) = Just REFL +matchPrimFun (PrimAtan _) (PrimAtan _) = Just REFL +matchPrimFun (PrimAsinh _) (PrimAsinh _) = Just REFL +matchPrimFun (PrimAcosh _) (PrimAcosh _) = Just REFL +matchPrimFun (PrimAtanh _) (PrimAtanh _) = Just REFL +matchPrimFun (PrimExpFloating _) (PrimExpFloating _) = Just REFL +matchPrimFun (PrimSqrt _) (PrimSqrt _) = Just REFL +matchPrimFun (PrimLog _) (PrimLog _) = Just REFL +matchPrimFun (PrimFPow _) (PrimFPow _) = Just REFL +matchPrimFun (PrimLogBase _) (PrimLogBase _) = Just REFL +matchPrimFun (PrimAtan2 _) (PrimAtan2 _) = Just REFL +matchPrimFun (PrimTruncate _ s) (PrimTruncate _ t) = matchIntegralType s t +matchPrimFun (PrimRound _ s) (PrimRound _ t) = matchIntegralType s t +matchPrimFun (PrimFloor _ s) (PrimFloor _ t) = matchIntegralType s t +matchPrimFun (PrimCeiling _ s) (PrimCeiling _ t) = matchIntegralType s t +matchPrimFun (PrimLt _) (PrimLt _) = Just REFL +matchPrimFun (PrimGt _) (PrimGt _) = Just REFL +matchPrimFun (PrimLtEq _) (PrimLtEq _) = Just REFL +matchPrimFun (PrimGtEq _) (PrimGtEq _) = Just REFL +matchPrimFun (PrimEq _) (PrimEq _) = Just REFL +matchPrimFun (PrimNEq _) (PrimNEq _) = Just REFL +matchPrimFun (PrimMax _) (PrimMax _) = Just REFL +matchPrimFun (PrimMin _) (PrimMin _) = Just REFL +matchPrimFun (PrimFromIntegral _ s) (PrimFromIntegral _ t) = matchNumType s t +matchPrimFun PrimLAnd PrimLAnd = Just REFL +matchPrimFun PrimLOr PrimLOr = Just REFL +matchPrimFun PrimLNot PrimLNot = Just REFL +matchPrimFun PrimOrd PrimOrd = Just REFL +matchPrimFun PrimChr PrimChr = Just REFL +matchPrimFun PrimBoolToInt PrimBoolToInt = Just REFL +matchPrimFun _ _ = Nothing + + +-- Contravariant function matching +-- +matchPrimFun' :: (Elt s, Elt t) => PrimFun (s -> a) -> PrimFun (t -> a) -> Maybe (s :=: t) +matchPrimFun' (PrimAdd _) (PrimAdd _) = Just REFL +matchPrimFun' (PrimSub _) (PrimSub _) = Just REFL +matchPrimFun' (PrimMul _) (PrimMul _) = Just REFL +matchPrimFun' (PrimNeg _) (PrimNeg _) = Just REFL +matchPrimFun' (PrimAbs _) (PrimAbs _) = Just REFL +matchPrimFun' (PrimSig _) (PrimSig _) = Just REFL +matchPrimFun' (PrimQuot _) (PrimQuot _) = Just REFL +matchPrimFun' (PrimRem _) (PrimRem _) = Just REFL +matchPrimFun' (PrimIDiv _) (PrimIDiv _) = Just REFL +matchPrimFun' (PrimMod _) (PrimMod _) = Just REFL +matchPrimFun' (PrimBAnd _) (PrimBAnd _) = Just REFL +matchPrimFun' (PrimBOr _) (PrimBOr _) = Just REFL +matchPrimFun' (PrimBXor _) (PrimBXor _) = Just REFL +matchPrimFun' (PrimBNot _) (PrimBNot _) = Just REFL +matchPrimFun' (PrimBShiftL _) (PrimBShiftL _) = Just REFL +matchPrimFun' (PrimBShiftR _) (PrimBShiftR _) = Just REFL +matchPrimFun' (PrimBRotateL _) (PrimBRotateL _) = Just REFL +matchPrimFun' (PrimBRotateR _) (PrimBRotateR _) = Just REFL +matchPrimFun' (PrimFDiv _) (PrimFDiv _) = Just REFL +matchPrimFun' (PrimRecip _) (PrimRecip _) = Just REFL +matchPrimFun' (PrimSin _) (PrimSin _) = Just REFL +matchPrimFun' (PrimCos _) (PrimCos _) = Just REFL +matchPrimFun' (PrimTan _) (PrimTan _) = Just REFL +matchPrimFun' (PrimAsin _) (PrimAsin _) = Just REFL +matchPrimFun' (PrimAcos _) (PrimAcos _) = Just REFL +matchPrimFun' (PrimAtan _) (PrimAtan _) = Just REFL +matchPrimFun' (PrimAsinh _) (PrimAsinh _) = Just REFL +matchPrimFun' (PrimAcosh _) (PrimAcosh _) = Just REFL +matchPrimFun' (PrimAtanh _) (PrimAtanh _) = Just REFL +matchPrimFun' (PrimExpFloating _) (PrimExpFloating _) = Just REFL +matchPrimFun' (PrimSqrt _) (PrimSqrt _) = Just REFL +matchPrimFun' (PrimLog _) (PrimLog _) = Just REFL +matchPrimFun' (PrimFPow _) (PrimFPow _) = Just REFL +matchPrimFun' (PrimLogBase _) (PrimLogBase _) = Just REFL +matchPrimFun' (PrimAtan2 _) (PrimAtan2 _) = Just REFL +matchPrimFun' (PrimTruncate s _) (PrimTruncate t _) = matchFloatingType s t +matchPrimFun' (PrimRound s _) (PrimRound t _) = matchFloatingType s t +matchPrimFun' (PrimFloor s _) (PrimFloor t _) = matchFloatingType s t +matchPrimFun' (PrimCeiling s _) (PrimCeiling t _) = matchFloatingType s t +matchPrimFun' (PrimMax _) (PrimMax _) = Just REFL +matchPrimFun' (PrimMin _) (PrimMin _) = Just REFL +matchPrimFun' (PrimFromIntegral s _) (PrimFromIntegral t _) = matchIntegralType s t +matchPrimFun' PrimLAnd PrimLAnd = Just REFL +matchPrimFun' PrimLOr PrimLOr = Just REFL +matchPrimFun' PrimLNot PrimLNot = Just REFL +matchPrimFun' PrimOrd PrimOrd = Just REFL +matchPrimFun' PrimChr PrimChr = Just REFL +matchPrimFun' PrimBoolToInt PrimBoolToInt = Just REFL +matchPrimFun' (PrimLt s) (PrimLt t) + | Just REFL <- matchScalarType s t + = Just REFL + +matchPrimFun' (PrimGt s) (PrimGt t) + | Just REFL <- matchScalarType s t + = Just REFL + +matchPrimFun' (PrimLtEq s) (PrimLtEq t) + | Just REFL <- matchScalarType s t + = Just REFL + +matchPrimFun' (PrimGtEq s) (PrimGtEq t) + | Just REFL <- matchScalarType s t + = Just REFL + +matchPrimFun' (PrimEq s) (PrimEq t) + | Just REFL <- matchScalarType s t + = Just REFL + +matchPrimFun' (PrimNEq s) (PrimNEq t) + | Just REFL <- matchScalarType s t + = Just REFL + +matchPrimFun' _ _ + = Nothing + + +-- Match reified types +-- +matchTupleType :: TupleType s -> TupleType t -> Maybe (s :=: t) +matchTupleType UnitTuple UnitTuple = Just REFL +matchTupleType (SingleTuple s) (SingleTuple t) = matchScalarType s t +matchTupleType (PairTuple s1 s2) (PairTuple t1 t2) + | Just REFL <- matchTupleType s1 t1 + , Just REFL <- matchTupleType s2 t2 + = Just REFL + +matchTupleType _ _ + = Nothing + + +-- Match reified type dictionaries +-- +matchScalarType :: ScalarType s -> ScalarType t -> Maybe (s :=: t) +matchScalarType (NumScalarType s) (NumScalarType t) = matchNumType s t +matchScalarType (NonNumScalarType s) (NonNumScalarType t) = matchNonNumType s t +matchScalarType _ _ = Nothing + +matchNumType :: NumType s -> NumType t -> Maybe (s :=: t) +matchNumType (IntegralNumType s) (IntegralNumType t) = matchIntegralType s t +matchNumType (FloatingNumType s) (FloatingNumType t) = matchFloatingType s t +matchNumType _ _ = Nothing + +matchBoundedType :: BoundedType s -> BoundedType t -> Maybe (s :=: t) +matchBoundedType (IntegralBoundedType s) (IntegralBoundedType t) = matchIntegralType s t +matchBoundedType (NonNumBoundedType s) (NonNumBoundedType t) = matchNonNumType s t +matchBoundedType _ _ = Nothing + +matchIntegralType :: IntegralType s -> IntegralType t -> Maybe (s :=: t) +matchIntegralType (TypeInt _) (TypeInt _) = Just REFL +matchIntegralType (TypeInt8 _) (TypeInt8 _) = Just REFL +matchIntegralType (TypeInt16 _) (TypeInt16 _) = Just REFL +matchIntegralType (TypeInt32 _) (TypeInt32 _) = Just REFL +matchIntegralType (TypeInt64 _) (TypeInt64 _) = Just REFL +matchIntegralType (TypeWord _) (TypeWord _) = Just REFL +matchIntegralType (TypeWord8 _) (TypeWord8 _) = Just REFL +matchIntegralType (TypeWord16 _) (TypeWord16 _) = Just REFL +matchIntegralType (TypeWord32 _) (TypeWord32 _) = Just REFL +matchIntegralType (TypeWord64 _) (TypeWord64 _) = Just REFL +matchIntegralType (TypeCShort _) (TypeCShort _) = Just REFL +matchIntegralType (TypeCUShort _) (TypeCUShort _) = Just REFL +matchIntegralType (TypeCInt _) (TypeCInt _) = Just REFL +matchIntegralType (TypeCUInt _) (TypeCUInt _) = Just REFL +matchIntegralType (TypeCLong _) (TypeCLong _) = Just REFL +matchIntegralType (TypeCULong _) (TypeCULong _) = Just REFL +matchIntegralType (TypeCLLong _) (TypeCLLong _) = Just REFL +matchIntegralType (TypeCULLong _) (TypeCULLong _) = Just REFL +matchIntegralType _ _ = Nothing + +matchFloatingType :: FloatingType s -> FloatingType t -> Maybe (s :=: t) +matchFloatingType (TypeFloat _) (TypeFloat _) = Just REFL +matchFloatingType (TypeDouble _) (TypeDouble _) = Just REFL +matchFloatingType (TypeCFloat _) (TypeCFloat _) = Just REFL +matchFloatingType (TypeCDouble _) (TypeCDouble _) = Just REFL +matchFloatingType _ _ = Nothing + +matchNonNumType :: NonNumType s -> NonNumType t -> Maybe (s :=: t) +matchNonNumType (TypeBool _) (TypeBool _) = Just REFL +matchNonNumType (TypeChar _) (TypeChar _) = Just REFL +matchNonNumType (TypeCChar _) (TypeCChar _) = Just REFL +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 + +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 + + 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 + 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 + + +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 -> Tuple.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 + Iterate n f x -> hash "Iterate" `hashE` n `hashE` 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 + 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.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 (PrimIDiv _) = hash "PrimIDiv" +hashPrimFun (PrimMod _) = hash "PrimMod" +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 (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 (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 (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 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/Analysis/Shape.hs b/Data/Array/Accelerate/Analysis/Shape.hs --- a/Data/Array/Accelerate/Analysis/Shape.hs +++ b/Data/Array/Accelerate/Analysis/Shape.hs @@ -1,8 +1,11 @@ -{-# LANGUAGE ScopedTypeVariables, GADTs, RankNTypes #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Analysis.Shape --- Copyright : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell +-- Copyright : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee +-- [2009..2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell -- License : BSD3 -- -- Maintainer : Manuel M T Chakravarty @@ -13,12 +16,14 @@ module Data.Array.Accelerate.Analysis.Shape ( -- * query AST dimensionality - AccDim, accDim, preAccDim, + AccDim, accDim, delayedDim, preAccDim, + expDim, ) where import Data.Array.Accelerate.AST import Data.Array.Accelerate.Type +import Data.Array.Accelerate.Trafo.Base import Data.Array.Accelerate.Array.Sugar @@ -29,6 +34,11 @@ accDim :: AccDim OpenAcc accDim (OpenAcc acc) = preAccDim accDim acc +delayedDim :: AccDim DelayedOpenAcc +delayedDim (Manifest acc) = preAccDim delayedDim acc +delayedDim (Delayed sh _ _) = expDim sh + + -- |Reify dimensionality of a computation parameterised over a recursive closure -- preAccDim :: forall acc aenv sh e. AccDim acc -> PreOpenAcc acc aenv (Array sh e) -> Int @@ -43,6 +53,10 @@ ArraysRarray -> ndim (eltType (undefined::sh)) _ -> error "umm, hello" + Aforeign _ _ _ -> case arrays' (undefined :: Array sh e) of + ArraysRarray -> ndim (eltType (undefined::sh)) + _ -> error "I don't even like snails!" + Atuple _ -> case arrays' (undefined :: Array sh e) of ArraysRarray -> ndim (eltType (undefined::sh)) _ -> error "can we keep him?" @@ -55,9 +69,10 @@ Use ((),(Array _ _)) -> ndim (eltType (undefined::sh)) Unit _ -> 0 Generate _ _ -> ndim (eltType (undefined::sh)) + Transform _ _ _ _ -> ndim (eltType (undefined::sh)) Reshape _ _ -> ndim (eltType (undefined::sh)) Replicate _ _ _ -> ndim (eltType (undefined::sh)) - Index _ _ _ -> ndim (eltType (undefined::sh)) + Slice _ _ _ -> ndim (eltType (undefined::sh)) Map _ acc -> k acc ZipWith _ _ acc -> k acc Fold _ _ acc -> k acc - 1 @@ -72,6 +87,12 @@ Backpermute _ _ _ -> ndim (eltType (undefined::sh)) Stencil _ _ acc -> k acc Stencil2 _ _ acc _ _ -> k acc + + +-- |Reify dimensionality of a scalar expression yielding a shape +-- +expDim :: forall acc env aenv sh. Elt sh => PreOpenExp acc env aenv sh -> Int +expDim _ = ndim (eltType (undefined :: sh)) -- Count the number of components to a tuple type diff --git a/Data/Array/Accelerate/Analysis/Stencil.hs b/Data/Array/Accelerate/Analysis/Stencil.hs --- a/Data/Array/Accelerate/Analysis/Stencil.hs +++ b/Data/Array/Accelerate/Analysis/Stencil.hs @@ -1,4 +1,6 @@ -{-# LANGUAGE GADTs, ScopedTypeVariables #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.CUDA.Analysis.Stencil @@ -40,40 +42,49 @@ -- |Position calculation on reified stencil values. -- positionsR :: StencilR sh e pat -> [sh] -positionsR StencilRunit3 = map (Z:.) [ 1, 0,-1 ] -positionsR StencilRunit5 = map (Z:.) [ 2, 1, 0,-1,-2 ] -positionsR StencilRunit7 = map (Z:.) [ 3, 2, 1, 0,-1,-2,-3 ] -positionsR StencilRunit9 = map (Z:.) [ 4, 3, 2, 1, 0,-1,-2,-3,-4 ] +positionsR StencilRunit3 = map (Z:.) [ -1, 0, 1 ] +positionsR StencilRunit5 = map (Z:.) [ -2,-1, 0, 1, 2 ] +positionsR StencilRunit7 = map (Z:.) [ -3,-2,-1, 0, 1, 2, 3 ] +positionsR StencilRunit9 = map (Z:.) [-4,-3,-2,-1, 0, 1, 2, 3, 4 ] positionsR (StencilRtup3 c b a) = concat - [ map (:. 1 ) $ positionsR c - , map (:. 0 ) $ positionsR b - , map (:.(-1)) $ positionsR a ] + [ map (innermost (:. -1)) $ positionsR c + , map (innermost (:. 0)) $ positionsR b + , map (innermost (:. 1)) $ positionsR a ] positionsR (StencilRtup5 e d c b a) = concat - [ map (:. 2 ) $ positionsR e - , map (:. 1 ) $ positionsR d - , map (:. 0 ) $ positionsR c - , map (:.(-1)) $ positionsR b - , map (:.(-2)) $ positionsR a ] + [ map (innermost (:. -2)) $ positionsR e + , map (innermost (:. -1)) $ positionsR d + , map (innermost (:. 0)) $ positionsR c + , map (innermost (:. 1)) $ positionsR b + , map (innermost (:. 2)) $ positionsR a ] positionsR (StencilRtup7 g f e d c b a) = concat - [ map (:. 3 ) $ positionsR g - , map (:. 2 ) $ positionsR f - , map (:. 1 ) $ positionsR e - , map (:. 0 ) $ positionsR d - , map (:.(-1)) $ positionsR c - , map (:.(-2)) $ positionsR b - , map (:.(-3)) $ positionsR a ] + [ map (innermost (:. -3)) $ positionsR g + , map (innermost (:. -2)) $ positionsR f + , map (innermost (:. -1)) $ positionsR e + , map (innermost (:. 0)) $ positionsR d + , map (innermost (:. 1)) $ positionsR c + , map (innermost (:. 2)) $ positionsR b + , map (innermost (:. 3)) $ positionsR a ] positionsR (StencilRtup9 i h g f e d c b a) = concat - [ map (:. 4 ) $ positionsR i - , map (:. 3 ) $ positionsR h - , map (:. 2 ) $ positionsR g - , map (:. 1 ) $ positionsR f - , map (:. 0 ) $ positionsR e - , map (:.(-1)) $ positionsR d - , map (:.(-2)) $ positionsR c - , map (:.(-3)) $ positionsR b - , map (:.(-4)) $ positionsR a ] + [ map (innermost (:. -4)) $ positionsR i + , map (innermost (:. -3)) $ positionsR h + , map (innermost (:. -2)) $ positionsR g + , map (innermost (:. -1)) $ positionsR f + , map (innermost (:. 0)) $ positionsR e + , map (innermost (:. 1)) $ positionsR d + , map (innermost (:. 2)) $ positionsR c + , map (innermost (:. 3)) $ positionsR b + , map (innermost (:. 4)) $ positionsR a ] + + +-- Inject a dimension component inner-most +-- +innermost :: Shape sh => (sh -> sh :. Int) -> sh -> sh :. Int +innermost f = invertShape . f . invertShape + +invertShape :: Shape sh => sh -> sh +invertShape = listToShape . reverse . shapeToList diff --git a/Data/Array/Accelerate/Analysis/Type.hs b/Data/Array/Accelerate/Analysis/Type.hs --- a/Data/Array/Accelerate/Analysis/Type.hs +++ b/Data/Array/Accelerate/Analysis/Type.hs @@ -1,9 +1,13 @@ -{-# LANGUAGE RankNTypes, ScopedTypeVariables #-} -{-# LANGUAGE GADTs, TypeFamilies, PatternGuards #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Analysis.Type --- Copyright : [2009..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell +-- Copyright : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee +-- [2009..2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell -- License : BSD3 -- -- Maintainer : Manuel M T Chakravarty @@ -20,8 +24,8 @@ module Data.Array.Accelerate.Analysis.Type ( -- * Query AST types - AccType, - arrayType, accType, expType, sizeOf, + AccType, arrayType, sizeOf, + accType, expType, delayedAccType, delayedExpType, preAccType, preExpType ) where @@ -33,6 +37,7 @@ import Data.Array.Accelerate.Type import Data.Array.Accelerate.Array.Sugar import Data.Array.Accelerate.AST +import Data.Array.Accelerate.Trafo @@ -55,6 +60,13 @@ accType :: AccType OpenAcc accType (OpenAcc acc) = preAccType accType acc +delayedAccType :: AccType DelayedOpenAcc +delayedAccType (Manifest acc) = preAccType delayedAccType acc +delayedAccType (Delayed _ f _) + | Lam (Body e) <- f = delayedExpType e + | otherwise = error "my favourite place in the world is wherever you happen to be" + + -- |Reify the element type of the result of an array computation using the array computation AST -- before tying the knot. -- @@ -85,13 +97,18 @@ ArraysRarray -> eltType (undefined::e) _ -> error "Hey look! even the leaves are falling for you." + Aforeign _ _ _ -> case arrays' (undefined :: Array sh e) of + ArraysRarray -> eltType (undefined::e) + _ -> error "Who on earth wrote all these weird error messages?" + Acond _ acc _ -> k acc Use ((),a) -> arrayType a Unit _ -> eltType (undefined::e) Generate _ _ -> eltType (undefined::e) + Transform _ _ _ _ -> eltType (undefined::e) Reshape _ acc -> k acc Replicate _ _ acc -> k acc - Index _ acc _ -> k acc + Slice _ acc _ -> k acc Map _ _ -> eltType (undefined::e) ZipWith _ _ _ -> eltType (undefined::e) Fold _ _ acc -> k acc @@ -110,9 +127,12 @@ -- |Reify the result type of a scalar expression. -- -expType :: OpenExp aenv env t -> TupleType (EltRepr t) +expType :: OpenExp env aenv t -> TupleType (EltRepr t) expType = preExpType accType +delayedExpType :: DelayedOpenExp env aenv t -> TupleType (EltRepr t) +delayedExpType = preExpType delayedAccType + -- |Reify the result types of of a scalar expression using the expression AST before tying the -- knot. -- @@ -132,12 +152,20 @@ IndexHead _ -> eltType (undefined::t) IndexTail _ -> eltType (undefined::t) IndexAny -> eltType (undefined::t) + IndexSlice _ _ _ -> eltType (undefined::t) + IndexFull _ _ _ -> eltType (undefined::t) + ToIndex _ _ -> eltType (undefined::t) + FromIndex _ _ -> eltType (undefined::t) Cond _ t _ -> preExpType k t + Iterate _ _ _ -> eltType (undefined::t) PrimConst _ -> eltType (undefined::t) PrimApp _ _ -> eltType (undefined::t) - IndexScalar acc _ -> k acc + Index acc _ -> k acc + LinearIndex acc _ -> k acc Shape _ -> eltType (undefined::t) ShapeSize _ -> eltType (undefined::t) + Intersect _ _ -> eltType (undefined::t) + Foreign _ _ _ -> eltType (undefined::t) -- |Size of a tuple type, in bytes 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 @@ -4,7 +4,8 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Array.Data --- Copyright : [2009..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee +-- Copyright : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee +-- [2009..2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell -- License : BSD3 -- -- Maintainer : Manuel M T Chakravarty @@ -30,16 +31,23 @@ -- standard libraries import Foreign (Ptr) +import Foreign.C.Types import GHC.Base (Int(..)) import GHC.Prim (newPinnedByteArray#, byteArrayContents#, unsafeFreezeByteArray#, Int#, (*#)) import GHC.Ptr (Ptr(Ptr)) import GHC.ST (ST(ST)) import Data.Typeable +import Data.Functor ((<$>)) import Control.Monad import Control.Monad.ST import qualified Data.Array.IArray as IArray -import qualified Data.Array.MArray as MArray hiding (newArray) +#ifdef ACCELERATE_UNSAFE_CHECKS +import qualified Data.Array.Base as MArray (readArray, writeArray) +#else +import qualified Data.Array.Base as MArray (unsafeRead, unsafeWrite) +import qualified Data.Array.Base as IArray (unsafeAt) +#endif #if __GLASGOW_HASKELL__ >= 700 && __GLASGOW_HASKELL__ < 703 import qualified Data.Array.MArray as Unsafe #else @@ -47,6 +55,7 @@ #endif import Data.Array.ST (STUArray) import Data.Array.Unboxed (UArray) +import Data.Array.MArray (MArray) import Data.Array.Base (UArray(UArray), STUArray(STUArray), wORD_SCALE, fLOAT_SCALE, dOUBLE_SCALE) @@ -80,23 +89,23 @@ data instance GArrayData ba Word16 = AD_Word16 (ba Word16) data instance GArrayData ba Word32 = AD_Word32 (ba Word32) data instance GArrayData ba Word64 = AD_Word64 (ba Word64) --- data instance GArrayData ba CShort = AD_CShort (ba CShort) --- data instance GArrayData ba CUShort = AD_CUShort (ba CUShort) --- data instance GArrayData ba CInt = AD_CInt (ba CInt) --- data instance GArrayData ba CUInt = AD_CUInt (ba CUInt) --- data instance GArrayData ba CLong = AD_CLong (ba CLong) --- data instance GArrayData ba CULong = AD_CULong (ba CULong) --- data instance GArrayData ba CLLong = AD_CLLong (ba CLLong) --- data instance GArrayData ba CULLong = AD_CULLong (ba CULLong) +data instance GArrayData ba CShort = AD_CShort (ba Int16) +data instance GArrayData ba CUShort = AD_CUShort (ba Word16) +data instance GArrayData ba CInt = AD_CInt (ba Int32) +data instance GArrayData ba CUInt = AD_CUInt (ba Word32) +data instance GArrayData ba CLong = AD_CLong (ba Int64) +data instance GArrayData ba CULong = AD_CULong (ba Word64) +data instance GArrayData ba CLLong = AD_CLLong (ba Int64) +data instance GArrayData ba CULLong = AD_CULLong (ba Word64) data instance GArrayData ba Float = AD_Float (ba Float) data instance GArrayData ba Double = AD_Double (ba Double) --- data instance GArrayData ba CFloat = AD_CFloat (ba CFloat) --- data instance GArrayData ba CDouble = AD_CDouble (ba CDouble) +data instance GArrayData ba CFloat = AD_CFloat (ba Float) +data instance GArrayData ba CDouble = AD_CDouble (ba Double) data instance GArrayData ba Bool = AD_Bool (ba Word8) data instance GArrayData ba Char = AD_Char (ba Char) --- data instance GArrayData ba CChar = AD_CChar (ba CChar) --- data instance GArrayData ba CSChar = AD_CSChar (ba CSChar) --- data instance GArrayData ba CUChar = AD_CUChar (ba CUChar) +data instance GArrayData ba CChar = AD_CChar (ba Int8) +data instance GArrayData ba CSChar = AD_CSChar (ba Int8) +data instance GArrayData ba CUChar = AD_CUChar (ba Word8) data instance GArrayData ba (a, b) = AD_Pair (GArrayData ba a) (GArrayData ba b) @@ -108,36 +117,52 @@ -- | GADT to reify the 'ArrayElt' class. -- data ArrayEltR a where - ArrayEltRunit :: ArrayEltR () - ArrayEltRint :: ArrayEltR Int - ArrayEltRint8 :: ArrayEltR Int8 - ArrayEltRint16 :: ArrayEltR Int16 - ArrayEltRint32 :: ArrayEltR Int32 - ArrayEltRint64 :: ArrayEltR Int64 - ArrayEltRword :: ArrayEltR Word - ArrayEltRword8 :: ArrayEltR Word8 - ArrayEltRword16 :: ArrayEltR Word16 - ArrayEltRword32 :: ArrayEltR Word32 - ArrayEltRword64 :: ArrayEltR Word64 - ArrayEltRfloat :: ArrayEltR Float - ArrayEltRdouble :: ArrayEltR Double - ArrayEltRbool :: ArrayEltR Bool - ArrayEltRchar :: ArrayEltR Char - ArrayEltRpair :: (ArrayElt a, ArrayElt b) - => ArrayEltR a -> ArrayEltR b -> ArrayEltR (a,b) + ArrayEltRunit :: ArrayEltR () + ArrayEltRint :: ArrayEltR Int + ArrayEltRint8 :: ArrayEltR Int8 + ArrayEltRint16 :: ArrayEltR Int16 + ArrayEltRint32 :: ArrayEltR Int32 + ArrayEltRint64 :: ArrayEltR Int64 + ArrayEltRword :: ArrayEltR Word + ArrayEltRword8 :: ArrayEltR Word8 + ArrayEltRword16 :: ArrayEltR Word16 + ArrayEltRword32 :: ArrayEltR Word32 + ArrayEltRword64 :: ArrayEltR Word64 + ArrayEltRcshort :: ArrayEltR CShort + ArrayEltRcushort :: ArrayEltR CUShort + ArrayEltRcint :: ArrayEltR CInt + ArrayEltRcuint :: ArrayEltR CUInt + ArrayEltRclong :: ArrayEltR CLong + ArrayEltRculong :: ArrayEltR CULong + ArrayEltRcllong :: ArrayEltR CLLong + ArrayEltRcullong :: ArrayEltR CULLong + ArrayEltRfloat :: ArrayEltR Float + ArrayEltRdouble :: ArrayEltR Double + ArrayEltRcfloat :: ArrayEltR CFloat + ArrayEltRcdouble :: ArrayEltR CDouble + ArrayEltRbool :: ArrayEltR Bool + ArrayEltRchar :: ArrayEltR Char + ArrayEltRcchar :: ArrayEltR CChar + ArrayEltRcschar :: ArrayEltR CSChar + ArrayEltRcuchar :: ArrayEltR CUChar + ArrayEltRpair :: (ArrayElt a, ArrayElt b) + => ArrayEltR a -> ArrayEltR b -> ArrayEltR (a,b) -- Array operations -- ---------------- +-- +-- TLM: do we need to INLINE these functions to get good performance interfacing +-- to external libraries, especially Repa? class ArrayElt e where type ArrayPtrs e -- - indexArrayData :: ArrayData e -> Int -> e + unsafeIndexArrayData :: ArrayData e -> Int -> e ptrsOfArrayData :: ArrayData e -> ArrayPtrs e -- newArrayData :: Int -> ST s (MutableArrayData s e) - readArrayData :: MutableArrayData s e -> Int -> ST s e - writeArrayData :: MutableArrayData s e -> Int -> e -> ST s () + unsafeReadArrayData :: MutableArrayData s e -> Int -> ST s e + unsafeWriteArrayData :: MutableArrayData s e -> Int -> e -> ST s () unsafeFreezeArrayData :: MutableArrayData s e -> ST s (ArrayData e) ptrsOfMutableArrayData :: MutableArrayData s e -> ST s (ArrayPtrs e) -- @@ -145,165 +170,267 @@ instance ArrayElt () where type ArrayPtrs () = () - indexArrayData AD_Unit i = i `seq` () - ptrsOfArrayData AD_Unit = () - newArrayData size = size `seq` return AD_Unit - readArrayData AD_Unit i = i `seq` return () - writeArrayData AD_Unit i () = i `seq` return () - unsafeFreezeArrayData AD_Unit = return AD_Unit - ptrsOfMutableArrayData AD_Unit = return () - arrayElt = ArrayEltRunit + unsafeIndexArrayData AD_Unit i = i `seq` () + ptrsOfArrayData AD_Unit = () + newArrayData size = size `seq` return AD_Unit + unsafeReadArrayData AD_Unit i = i `seq` return () + unsafeWriteArrayData AD_Unit i () = i `seq` return () + unsafeFreezeArrayData AD_Unit = return AD_Unit + ptrsOfMutableArrayData AD_Unit = return () + arrayElt = ArrayEltRunit instance ArrayElt Int where type ArrayPtrs Int = Ptr Int - indexArrayData (AD_Int ba) i = ba IArray.! i - ptrsOfArrayData (AD_Int ba) = uArrayPtr ba - newArrayData size = liftM AD_Int $ unsafeNewArray_ size wORD_SCALE - readArrayData (AD_Int ba) i = MArray.readArray ba i - writeArrayData (AD_Int ba) i e = MArray.writeArray ba i e - unsafeFreezeArrayData (AD_Int ba) = liftM AD_Int $ Unsafe.unsafeFreeze ba - ptrsOfMutableArrayData (AD_Int ba) = sTUArrayPtr ba - arrayElt = ArrayEltRint + unsafeIndexArrayData (AD_Int ba) i = unsafeIndexArray ba i + ptrsOfArrayData (AD_Int ba) = uArrayPtr ba + newArrayData size = liftM AD_Int $ unsafeNewArray_ size wORD_SCALE + unsafeReadArrayData (AD_Int ba) i = unsafeReadArray ba i + unsafeWriteArrayData (AD_Int ba) i e = unsafeWriteArray ba i e + unsafeFreezeArrayData (AD_Int ba) = liftM AD_Int $ Unsafe.unsafeFreeze ba + ptrsOfMutableArrayData (AD_Int ba) = sTUArrayPtr ba + arrayElt = ArrayEltRint instance ArrayElt Int8 where type ArrayPtrs Int8 = Ptr Int8 - indexArrayData (AD_Int8 ba) i = ba IArray.! i - ptrsOfArrayData (AD_Int8 ba) = uArrayPtr ba - newArrayData size = liftM AD_Int8 $ unsafeNewArray_ size (\x -> x) - readArrayData (AD_Int8 ba) i = MArray.readArray ba i - writeArrayData (AD_Int8 ba) i e = MArray.writeArray ba i e - unsafeFreezeArrayData (AD_Int8 ba) = liftM AD_Int8 $ Unsafe.unsafeFreeze ba - ptrsOfMutableArrayData (AD_Int8 ba) = sTUArrayPtr ba - arrayElt = ArrayEltRint8 + unsafeIndexArrayData (AD_Int8 ba) i = unsafeIndexArray ba i + ptrsOfArrayData (AD_Int8 ba) = uArrayPtr ba + newArrayData size = liftM AD_Int8 $ unsafeNewArray_ size (\x -> x) + unsafeReadArrayData (AD_Int8 ba) i = unsafeReadArray ba i + unsafeWriteArrayData (AD_Int8 ba) i e = unsafeWriteArray ba i e + unsafeFreezeArrayData (AD_Int8 ba) = liftM AD_Int8 $ Unsafe.unsafeFreeze ba + ptrsOfMutableArrayData (AD_Int8 ba) = sTUArrayPtr ba + arrayElt = ArrayEltRint8 instance ArrayElt Int16 where type ArrayPtrs Int16 = Ptr Int16 - indexArrayData (AD_Int16 ba) i = ba IArray.! i - ptrsOfArrayData (AD_Int16 ba) = uArrayPtr ba - newArrayData size = liftM AD_Int16 $ unsafeNewArray_ size (*# 2#) - readArrayData (AD_Int16 ba) i = MArray.readArray ba i - writeArrayData (AD_Int16 ba) i e = MArray.writeArray ba i e - unsafeFreezeArrayData (AD_Int16 ba) = liftM AD_Int16 $ Unsafe.unsafeFreeze ba - ptrsOfMutableArrayData (AD_Int16 ba) = sTUArrayPtr ba - arrayElt = ArrayEltRint16 + unsafeIndexArrayData (AD_Int16 ba) i = unsafeIndexArray ba i + ptrsOfArrayData (AD_Int16 ba) = uArrayPtr ba + newArrayData size = liftM AD_Int16 $ unsafeNewArray_ size (*# 2#) + unsafeReadArrayData (AD_Int16 ba) i = unsafeReadArray ba i + unsafeWriteArrayData (AD_Int16 ba) i e = unsafeWriteArray ba i e + unsafeFreezeArrayData (AD_Int16 ba) = liftM AD_Int16 $ Unsafe.unsafeFreeze ba + ptrsOfMutableArrayData (AD_Int16 ba) = sTUArrayPtr ba + arrayElt = ArrayEltRint16 instance ArrayElt Int32 where type ArrayPtrs Int32 = Ptr Int32 - indexArrayData (AD_Int32 ba) i = ba IArray.! i - ptrsOfArrayData (AD_Int32 ba) = uArrayPtr ba - newArrayData size = liftM AD_Int32 $ unsafeNewArray_ size (*# 4#) - readArrayData (AD_Int32 ba) i = MArray.readArray ba i - writeArrayData (AD_Int32 ba) i e = MArray.writeArray ba i e - unsafeFreezeArrayData (AD_Int32 ba) = liftM AD_Int32 $ Unsafe.unsafeFreeze ba - ptrsOfMutableArrayData (AD_Int32 ba) = sTUArrayPtr ba - arrayElt = ArrayEltRint32 + unsafeIndexArrayData (AD_Int32 ba) i = unsafeIndexArray ba i + ptrsOfArrayData (AD_Int32 ba) = uArrayPtr ba + newArrayData size = liftM AD_Int32 $ unsafeNewArray_ size (*# 4#) + unsafeReadArrayData (AD_Int32 ba) i = unsafeReadArray ba i + unsafeWriteArrayData (AD_Int32 ba) i e = unsafeWriteArray ba i e + unsafeFreezeArrayData (AD_Int32 ba) = liftM AD_Int32 $ Unsafe.unsafeFreeze ba + ptrsOfMutableArrayData (AD_Int32 ba) = sTUArrayPtr ba + arrayElt = ArrayEltRint32 instance ArrayElt Int64 where type ArrayPtrs Int64 = Ptr Int64 - indexArrayData (AD_Int64 ba) i = ba IArray.! i - ptrsOfArrayData (AD_Int64 ba) = uArrayPtr ba - newArrayData size = liftM AD_Int64 $ unsafeNewArray_ size (*# 8#) - readArrayData (AD_Int64 ba) i = MArray.readArray ba i - writeArrayData (AD_Int64 ba) i e = MArray.writeArray ba i e - unsafeFreezeArrayData (AD_Int64 ba) = liftM AD_Int64 $ Unsafe.unsafeFreeze ba - ptrsOfMutableArrayData (AD_Int64 ba) = sTUArrayPtr ba - arrayElt = ArrayEltRint64 + unsafeIndexArrayData (AD_Int64 ba) i = unsafeIndexArray ba i + ptrsOfArrayData (AD_Int64 ba) = uArrayPtr ba + newArrayData size = liftM AD_Int64 $ unsafeNewArray_ size (*# 8#) + unsafeReadArrayData (AD_Int64 ba) i = unsafeReadArray ba i + unsafeWriteArrayData (AD_Int64 ba) i e = unsafeWriteArray ba i e + unsafeFreezeArrayData (AD_Int64 ba) = liftM AD_Int64 $ Unsafe.unsafeFreeze ba + ptrsOfMutableArrayData (AD_Int64 ba) = sTUArrayPtr ba + arrayElt = ArrayEltRint64 instance ArrayElt Word where type ArrayPtrs Word = Ptr Word - indexArrayData (AD_Word ba) i = ba IArray.! i - ptrsOfArrayData (AD_Word ba) = uArrayPtr ba - newArrayData size = liftM AD_Word $ unsafeNewArray_ size wORD_SCALE - readArrayData (AD_Word ba) i = MArray.readArray ba i - writeArrayData (AD_Word ba) i e = MArray.writeArray ba i e - unsafeFreezeArrayData (AD_Word ba) = liftM AD_Word $ Unsafe.unsafeFreeze ba - ptrsOfMutableArrayData (AD_Word ba) = sTUArrayPtr ba - arrayElt = ArrayEltRword + unsafeIndexArrayData (AD_Word ba) i = unsafeIndexArray ba i + ptrsOfArrayData (AD_Word ba) = uArrayPtr ba + newArrayData size = liftM AD_Word $ unsafeNewArray_ size wORD_SCALE + unsafeReadArrayData (AD_Word ba) i = unsafeReadArray ba i + unsafeWriteArrayData (AD_Word ba) i e = unsafeWriteArray ba i e + unsafeFreezeArrayData (AD_Word ba) = liftM AD_Word $ Unsafe.unsafeFreeze ba + ptrsOfMutableArrayData (AD_Word ba) = sTUArrayPtr ba + arrayElt = ArrayEltRword instance ArrayElt Word8 where type ArrayPtrs Word8 = Ptr Word8 - indexArrayData (AD_Word8 ba) i = ba IArray.! i - ptrsOfArrayData (AD_Word8 ba) = uArrayPtr ba - newArrayData size = liftM AD_Word8 $ unsafeNewArray_ size (\x -> x) - readArrayData (AD_Word8 ba) i = MArray.readArray ba i - writeArrayData (AD_Word8 ba) i e = MArray.writeArray ba i e - unsafeFreezeArrayData (AD_Word8 ba) = liftM AD_Word8 $ Unsafe.unsafeFreeze ba - ptrsOfMutableArrayData (AD_Word8 ba) = sTUArrayPtr ba - arrayElt = ArrayEltRword8 + unsafeIndexArrayData (AD_Word8 ba) i = unsafeIndexArray ba i + ptrsOfArrayData (AD_Word8 ba) = uArrayPtr ba + newArrayData size = liftM AD_Word8 $ unsafeNewArray_ size (\x -> x) + unsafeReadArrayData (AD_Word8 ba) i = unsafeReadArray ba i + unsafeWriteArrayData (AD_Word8 ba) i e = unsafeWriteArray ba i e + unsafeFreezeArrayData (AD_Word8 ba) = liftM AD_Word8 $ Unsafe.unsafeFreeze ba + ptrsOfMutableArrayData (AD_Word8 ba) = sTUArrayPtr ba + arrayElt = ArrayEltRword8 instance ArrayElt Word16 where type ArrayPtrs Word16 = Ptr Word16 - indexArrayData (AD_Word16 ba) i = ba IArray.! i - ptrsOfArrayData (AD_Word16 ba) = uArrayPtr ba - newArrayData size = liftM AD_Word16 $ unsafeNewArray_ size (*# 2#) - readArrayData (AD_Word16 ba) i = MArray.readArray ba i - writeArrayData (AD_Word16 ba) i e = MArray.writeArray ba i e - unsafeFreezeArrayData (AD_Word16 ba) - = liftM AD_Word16 $ Unsafe.unsafeFreeze ba - ptrsOfMutableArrayData (AD_Word16 ba) = sTUArrayPtr ba - arrayElt = ArrayEltRword16 + unsafeIndexArrayData (AD_Word16 ba) i = unsafeIndexArray ba i + ptrsOfArrayData (AD_Word16 ba) = uArrayPtr ba + newArrayData size = liftM AD_Word16 $ unsafeNewArray_ size (*# 2#) + unsafeReadArrayData (AD_Word16 ba) i = unsafeReadArray ba i + unsafeWriteArrayData (AD_Word16 ba) i e = unsafeWriteArray ba i e + unsafeFreezeArrayData (AD_Word16 ba) = liftM AD_Word16 $ Unsafe.unsafeFreeze ba + ptrsOfMutableArrayData (AD_Word16 ba) = sTUArrayPtr ba + arrayElt = ArrayEltRword16 instance ArrayElt Word32 where type ArrayPtrs Word32 = Ptr Word32 - indexArrayData (AD_Word32 ba) i = ba IArray.! i - ptrsOfArrayData (AD_Word32 ba) = uArrayPtr ba - newArrayData size = liftM AD_Word32 $ unsafeNewArray_ size (*# 4#) - readArrayData (AD_Word32 ba) i = MArray.readArray ba i - writeArrayData (AD_Word32 ba) i e = MArray.writeArray ba i e - unsafeFreezeArrayData (AD_Word32 ba) - = liftM AD_Word32 $ Unsafe.unsafeFreeze ba - ptrsOfMutableArrayData (AD_Word32 ba) = sTUArrayPtr ba - arrayElt = ArrayEltRword32 + unsafeIndexArrayData (AD_Word32 ba) i = unsafeIndexArray ba i + ptrsOfArrayData (AD_Word32 ba) = uArrayPtr ba + newArrayData size = liftM AD_Word32 $ unsafeNewArray_ size (*# 4#) + unsafeReadArrayData (AD_Word32 ba) i = unsafeReadArray ba i + unsafeWriteArrayData (AD_Word32 ba) i e = unsafeWriteArray ba i e + unsafeFreezeArrayData (AD_Word32 ba) = liftM AD_Word32 $ Unsafe.unsafeFreeze ba + ptrsOfMutableArrayData (AD_Word32 ba) = sTUArrayPtr ba + arrayElt = ArrayEltRword32 instance ArrayElt Word64 where type ArrayPtrs Word64 = Ptr Word64 - indexArrayData (AD_Word64 ba) i = ba IArray.! i - ptrsOfArrayData (AD_Word64 ba) = uArrayPtr ba - newArrayData size = liftM AD_Word64 $ unsafeNewArray_ size (*# 8#) - readArrayData (AD_Word64 ba) i = MArray.readArray ba i - writeArrayData (AD_Word64 ba) i e = MArray.writeArray ba i e - unsafeFreezeArrayData (AD_Word64 ba) - = liftM AD_Word64 $ Unsafe.unsafeFreeze ba - ptrsOfMutableArrayData (AD_Word64 ba) = sTUArrayPtr ba - arrayElt = ArrayEltRword64 + unsafeIndexArrayData (AD_Word64 ba) i = unsafeIndexArray ba i + ptrsOfArrayData (AD_Word64 ba) = uArrayPtr ba + newArrayData size = liftM AD_Word64 $ unsafeNewArray_ size (*# 8#) + unsafeReadArrayData (AD_Word64 ba) i = unsafeReadArray ba i + unsafeWriteArrayData (AD_Word64 ba) i e = unsafeWriteArray ba i e + unsafeFreezeArrayData (AD_Word64 ba) = liftM AD_Word64 $ Unsafe.unsafeFreeze ba + ptrsOfMutableArrayData (AD_Word64 ba) = sTUArrayPtr ba + arrayElt = ArrayEltRword64 --- FIXME: --- CShort --- CUShort --- CInt --- CUInt --- CLong --- CULong --- CLLong --- CULLong +instance ArrayElt CShort where + type ArrayPtrs CShort = Ptr Int16 + unsafeIndexArrayData (AD_CShort ba) i = CShort $ unsafeIndexArray ba i + ptrsOfArrayData (AD_CShort ba) = uArrayPtr ba + newArrayData size = liftM AD_CShort $ unsafeNewArray_ size (*# 2#) + unsafeReadArrayData (AD_CShort ba) i = CShort <$> unsafeReadArray ba i + unsafeWriteArrayData (AD_CShort ba) i (CShort e) + = unsafeWriteArray ba i e + unsafeFreezeArrayData (AD_CShort ba) = liftM AD_CShort $ Unsafe.unsafeFreeze ba + ptrsOfMutableArrayData (AD_CShort ba) = sTUArrayPtr ba + arrayElt = ArrayEltRcshort +instance ArrayElt CUShort where + type ArrayPtrs CUShort = Ptr Word16 + unsafeIndexArrayData (AD_CUShort ba) i = CUShort $ unsafeIndexArray ba i + ptrsOfArrayData (AD_CUShort ba) = uArrayPtr ba + newArrayData size = liftM AD_CUShort $ unsafeNewArray_ size (*# 2#) + unsafeReadArrayData (AD_CUShort ba) i = CUShort <$> unsafeReadArray ba i + unsafeWriteArrayData (AD_CUShort ba) i (CUShort e) + = unsafeWriteArray ba i e + unsafeFreezeArrayData (AD_CUShort ba) = liftM AD_CUShort $ Unsafe.unsafeFreeze ba + ptrsOfMutableArrayData (AD_CUShort ba) = sTUArrayPtr ba + arrayElt = ArrayEltRcushort + +instance ArrayElt CInt where + type ArrayPtrs CInt = Ptr Int32 + unsafeIndexArrayData (AD_CInt ba) i = CInt $ unsafeIndexArray ba i + ptrsOfArrayData (AD_CInt ba) = uArrayPtr ba + newArrayData size = liftM AD_CInt $ unsafeNewArray_ size (*# 4#) + unsafeReadArrayData (AD_CInt ba) i = CInt <$> unsafeReadArray ba i + unsafeWriteArrayData (AD_CInt ba) i (CInt e) + = unsafeWriteArray ba i e + unsafeFreezeArrayData (AD_CInt ba) = liftM AD_CInt $ Unsafe.unsafeFreeze ba + ptrsOfMutableArrayData (AD_CInt ba) = sTUArrayPtr ba + arrayElt = ArrayEltRcint + +instance ArrayElt CUInt where + type ArrayPtrs CUInt = Ptr Word32 + unsafeIndexArrayData (AD_CUInt ba) i = CUInt $ unsafeIndexArray ba i + ptrsOfArrayData (AD_CUInt ba) = uArrayPtr ba + newArrayData size = liftM AD_CUInt $ unsafeNewArray_ size (*# 4#) + unsafeReadArrayData (AD_CUInt ba) i = CUInt <$> unsafeReadArray ba i + unsafeWriteArrayData (AD_CUInt ba) i (CUInt e) + = unsafeWriteArray ba i e + unsafeFreezeArrayData (AD_CUInt ba) = liftM AD_CUInt $ Unsafe.unsafeFreeze ba + ptrsOfMutableArrayData (AD_CUInt ba) = sTUArrayPtr ba + arrayElt = ArrayEltRcuint + +instance ArrayElt CLong where + type ArrayPtrs CLong = Ptr Int64 + unsafeIndexArrayData (AD_CLong ba) i = CLong $ unsafeIndexArray ba i + ptrsOfArrayData (AD_CLong ba) = uArrayPtr ba + newArrayData size = liftM AD_CLong $ unsafeNewArray_ size (*# 8#) + unsafeReadArrayData (AD_CLong ba) i = CLong <$> unsafeReadArray ba i + unsafeWriteArrayData (AD_CLong ba) i (CLong e) + = unsafeWriteArray ba i e + unsafeFreezeArrayData (AD_CLong ba) = liftM AD_CLong $ Unsafe.unsafeFreeze ba + ptrsOfMutableArrayData (AD_CLong ba) = sTUArrayPtr ba + arrayElt = ArrayEltRclong + +instance ArrayElt CULong where + type ArrayPtrs CULong = Ptr Word64 + unsafeIndexArrayData (AD_CULong ba) i = CULong $ unsafeIndexArray ba i + ptrsOfArrayData (AD_CULong ba) = uArrayPtr ba + newArrayData size = liftM AD_CULong $ unsafeNewArray_ size (*# 8#) + unsafeReadArrayData (AD_CULong ba) i = CULong <$> unsafeReadArray ba i + unsafeWriteArrayData (AD_CULong ba) i (CULong e) + = unsafeWriteArray ba i e + unsafeFreezeArrayData (AD_CULong ba) = liftM AD_CULong $ Unsafe.unsafeFreeze ba + ptrsOfMutableArrayData (AD_CULong ba) = sTUArrayPtr ba + arrayElt = ArrayEltRculong + +instance ArrayElt CLLong where + type ArrayPtrs CLLong = Ptr Int64 + unsafeIndexArrayData (AD_CLLong ba) i = CLLong $ unsafeIndexArray ba i + ptrsOfArrayData (AD_CLLong ba) = uArrayPtr ba + newArrayData size = liftM AD_CLLong $ unsafeNewArray_ size (*# 8#) + unsafeReadArrayData (AD_CLLong ba) i = CLLong <$> unsafeReadArray ba i + unsafeWriteArrayData (AD_CLLong ba) i (CLLong e) + = unsafeWriteArray ba i e + unsafeFreezeArrayData (AD_CLLong ba) = liftM AD_CLLong $ Unsafe.unsafeFreeze ba + ptrsOfMutableArrayData (AD_CLLong ba) = sTUArrayPtr ba + arrayElt = ArrayEltRcllong + +instance ArrayElt CULLong where + type ArrayPtrs CULLong = Ptr Word64 + unsafeIndexArrayData (AD_CULLong ba) i = CULLong $ unsafeIndexArray ba i + ptrsOfArrayData (AD_CULLong ba) = uArrayPtr ba + newArrayData size = liftM AD_CULLong $ unsafeNewArray_ size (*# 8#) + unsafeReadArrayData (AD_CULLong ba) i = CULLong <$> unsafeReadArray ba i + unsafeWriteArrayData (AD_CULLong ba) i (CULLong e) + = unsafeWriteArray ba i e + unsafeFreezeArrayData (AD_CULLong ba) = liftM AD_CULLong $ Unsafe.unsafeFreeze ba + ptrsOfMutableArrayData (AD_CULLong ba) = sTUArrayPtr ba + arrayElt = ArrayEltRcullong + instance ArrayElt Float where type ArrayPtrs Float = Ptr Float - indexArrayData (AD_Float ba) i = ba IArray.! i - ptrsOfArrayData (AD_Float ba) = uArrayPtr ba - newArrayData size = liftM AD_Float $ unsafeNewArray_ size fLOAT_SCALE - readArrayData (AD_Float ba) i = MArray.readArray ba i - writeArrayData (AD_Float ba) i e = MArray.writeArray ba i e - unsafeFreezeArrayData (AD_Float ba) = liftM AD_Float $ Unsafe.unsafeFreeze ba - ptrsOfMutableArrayData (AD_Float ba) = sTUArrayPtr ba - arrayElt = ArrayEltRfloat + unsafeIndexArrayData (AD_Float ba) i = unsafeIndexArray ba i + ptrsOfArrayData (AD_Float ba) = uArrayPtr ba + newArrayData size = liftM AD_Float $ unsafeNewArray_ size fLOAT_SCALE + unsafeReadArrayData (AD_Float ba) i = unsafeReadArray ba i + unsafeWriteArrayData (AD_Float ba) i e = unsafeWriteArray ba i e + unsafeFreezeArrayData (AD_Float ba) = liftM AD_Float $ Unsafe.unsafeFreeze ba + ptrsOfMutableArrayData (AD_Float ba) = sTUArrayPtr ba + arrayElt = ArrayEltRfloat instance ArrayElt Double where type ArrayPtrs Double = Ptr Double - indexArrayData (AD_Double ba) i = ba IArray.! i - ptrsOfArrayData (AD_Double ba) = uArrayPtr ba - newArrayData size = liftM AD_Double $ unsafeNewArray_ size dOUBLE_SCALE - readArrayData (AD_Double ba) i = MArray.readArray ba i - writeArrayData (AD_Double ba) i e = MArray.writeArray ba i e - unsafeFreezeArrayData (AD_Double ba) - = liftM AD_Double $ Unsafe.unsafeFreeze ba - ptrsOfMutableArrayData (AD_Double ba) = sTUArrayPtr ba - arrayElt = ArrayEltRdouble + unsafeIndexArrayData (AD_Double ba) i = unsafeIndexArray ba i + ptrsOfArrayData (AD_Double ba) = uArrayPtr ba + newArrayData size = liftM AD_Double $ unsafeNewArray_ size dOUBLE_SCALE + unsafeReadArrayData (AD_Double ba) i = unsafeReadArray ba i + unsafeWriteArrayData (AD_Double ba) i e = unsafeWriteArray ba i e + unsafeFreezeArrayData (AD_Double ba) = liftM AD_Double $ Unsafe.unsafeFreeze ba + ptrsOfMutableArrayData (AD_Double ba) = sTUArrayPtr ba + arrayElt = ArrayEltRdouble --- FIXME: --- CFloat --- CDouble +instance ArrayElt CFloat where + type ArrayPtrs CFloat = Ptr Float + unsafeIndexArrayData (AD_CFloat ba) i = CFloat $ unsafeIndexArray ba i + ptrsOfArrayData (AD_CFloat ba) = uArrayPtr ba + newArrayData size = liftM AD_CFloat $ unsafeNewArray_ size fLOAT_SCALE + unsafeReadArrayData (AD_CFloat ba) i = CFloat <$> unsafeReadArray ba i + unsafeWriteArrayData (AD_CFloat ba) i (CFloat e) + = unsafeWriteArray ba i e + unsafeFreezeArrayData (AD_CFloat ba) = liftM AD_CFloat $ Unsafe.unsafeFreeze ba + ptrsOfMutableArrayData (AD_CFloat ba) = sTUArrayPtr ba + arrayElt = ArrayEltRcfloat +instance ArrayElt CDouble where + type ArrayPtrs CDouble = Ptr Double + unsafeIndexArrayData (AD_CDouble ba) i = CDouble $ unsafeIndexArray ba i + ptrsOfArrayData (AD_CDouble ba) = uArrayPtr ba + newArrayData size = liftM AD_CDouble $ unsafeNewArray_ size dOUBLE_SCALE + unsafeReadArrayData (AD_CDouble ba) i = CDouble <$> unsafeReadArray ba i + unsafeWriteArrayData (AD_CDouble ba) i (CDouble e) + = unsafeWriteArray ba i e + unsafeFreezeArrayData (AD_CDouble ba) = liftM AD_CDouble $ Unsafe.unsafeFreeze ba + ptrsOfMutableArrayData (AD_CDouble ba) = sTUArrayPtr ba + arrayElt = ArrayEltRcdouble + -- Bool arrays are stored as arrays of bytes. While this is memory inefficient, -- it is better suited to parallel backends than the native Unboxed Bool -- array representation that uses packed bit vectors, as that would require @@ -311,14 +438,14 @@ -- instance ArrayElt Bool where type ArrayPtrs Bool = Ptr Word8 - indexArrayData (AD_Bool ba) i = toBool (ba IArray.! i) - ptrsOfArrayData (AD_Bool ba) = uArrayPtr ba - newArrayData size = liftM AD_Bool $ unsafeNewArray_ size (\x -> x) - readArrayData (AD_Bool ba) i = liftM toBool $ MArray.readArray ba i - writeArrayData (AD_Bool ba) i e = MArray.writeArray ba i (fromBool e) - unsafeFreezeArrayData (AD_Bool ba) = liftM AD_Bool $ Unsafe.unsafeFreeze ba - ptrsOfMutableArrayData (AD_Bool ba) = sTUArrayPtr ba - arrayElt = ArrayEltRbool + unsafeIndexArrayData (AD_Bool ba) i = toBool (unsafeIndexArray ba i) + ptrsOfArrayData (AD_Bool ba) = uArrayPtr ba + newArrayData size = liftM AD_Bool $ unsafeNewArray_ size (\x -> x) + unsafeReadArrayData (AD_Bool ba) i = liftM toBool $ unsafeReadArray ba i + unsafeWriteArrayData (AD_Bool ba) i e = unsafeWriteArray ba i (fromBool e) + unsafeFreezeArrayData (AD_Bool ba) = liftM AD_Bool $ Unsafe.unsafeFreeze ba + ptrsOfMutableArrayData (AD_Bool ba) = sTUArrayPtr ba + arrayElt = ArrayEltRbool {-# INLINE toBool #-} toBool :: Word8 -> Bool @@ -335,38 +462,69 @@ -- instance ArrayElt Char where type ArrayPtrs Char = Ptr Char - indexArrayData (AD_Char ba) i = ba IArray.! i - ptrsOfArrayData (AD_Char ba) = uArrayPtr ba - newArrayData size = liftM AD_Char $ unsafeNewArray_ size (*# 4#) - readArrayData (AD_Char ba) i = MArray.readArray ba i - writeArrayData (AD_Char ba) i e = MArray.writeArray ba i e - unsafeFreezeArrayData (AD_Char ba) = liftM AD_Char $ Unsafe.unsafeFreeze ba - ptrsOfMutableArrayData (AD_Char ba) = sTUArrayPtr ba - arrayElt = ArrayEltRchar + unsafeIndexArrayData (AD_Char ba) i = unsafeIndexArray ba i + ptrsOfArrayData (AD_Char ba) = uArrayPtr ba + newArrayData size = liftM AD_Char $ unsafeNewArray_ size (*# 4#) + unsafeReadArrayData (AD_Char ba) i = unsafeReadArray ba i + unsafeWriteArrayData (AD_Char ba) i e = unsafeWriteArray ba i e + unsafeFreezeArrayData (AD_Char ba) = liftM AD_Char $ Unsafe.unsafeFreeze ba + ptrsOfMutableArrayData (AD_Char ba) = sTUArrayPtr ba + arrayElt = ArrayEltRchar --- FIXME: --- CChar --- CSChar --- CUChar +instance ArrayElt CChar where + type ArrayPtrs CChar = Ptr Int8 + unsafeIndexArrayData (AD_CChar ba) i = CChar $ unsafeIndexArray ba i + ptrsOfArrayData (AD_CChar ba) = uArrayPtr ba + newArrayData size = liftM AD_CChar $ unsafeNewArray_ size (\x -> x) + unsafeReadArrayData (AD_CChar ba) i = CChar <$> unsafeReadArray ba i + unsafeWriteArrayData (AD_CChar ba) i (CChar e) + = unsafeWriteArray ba i e + unsafeFreezeArrayData (AD_CChar ba) = liftM AD_CChar $ Unsafe.unsafeFreeze ba + ptrsOfMutableArrayData (AD_CChar ba) = sTUArrayPtr ba + arrayElt = ArrayEltRcchar +instance ArrayElt CSChar where + type ArrayPtrs CSChar = Ptr Int8 + unsafeIndexArrayData (AD_CSChar ba) i = CSChar $ unsafeIndexArray ba i + ptrsOfArrayData (AD_CSChar ba) = uArrayPtr ba + newArrayData size = liftM AD_CSChar $ unsafeNewArray_ size (\x -> x) + unsafeReadArrayData (AD_CSChar ba) i = CSChar <$> unsafeReadArray ba i + unsafeWriteArrayData (AD_CSChar ba) i (CSChar e) + = unsafeWriteArray ba i e + unsafeFreezeArrayData (AD_CSChar ba) = liftM AD_CSChar $ Unsafe.unsafeFreeze ba + ptrsOfMutableArrayData (AD_CSChar ba) = sTUArrayPtr ba + arrayElt = ArrayEltRcschar + +instance ArrayElt CUChar where + type ArrayPtrs CUChar = Ptr Word8 + unsafeIndexArrayData (AD_CUChar ba) i = CUChar $ unsafeIndexArray ba i + ptrsOfArrayData (AD_CUChar ba) = uArrayPtr ba + newArrayData size = liftM AD_CUChar $ unsafeNewArray_ size (\x -> x) + unsafeReadArrayData (AD_CUChar ba) i = CUChar <$> unsafeReadArray ba i + unsafeWriteArrayData (AD_CUChar ba) i (CUChar e) + = unsafeWriteArray ba i e + unsafeFreezeArrayData (AD_CUChar ba) = liftM AD_CUChar $ Unsafe.unsafeFreeze ba + ptrsOfMutableArrayData (AD_CUChar ba) = sTUArrayPtr ba + arrayElt = ArrayEltRcuchar + instance (ArrayElt a, ArrayElt b) => ArrayElt (a, b) where - type ArrayPtrs (a, b) = (ArrayPtrs a, ArrayPtrs b) - indexArrayData (AD_Pair a b) i = (indexArrayData a i, indexArrayData b i) - ptrsOfArrayData (AD_Pair a b) = (ptrsOfArrayData a, ptrsOfArrayData b) + type ArrayPtrs (a, b) = (ArrayPtrs a, ArrayPtrs b) + unsafeIndexArrayData (AD_Pair a b) i = (unsafeIndexArrayData a i, unsafeIndexArrayData b i) + ptrsOfArrayData (AD_Pair a b) = (ptrsOfArrayData a, ptrsOfArrayData b) newArrayData size = do a <- newArrayData size b <- newArrayData size return $ AD_Pair a b - readArrayData (AD_Pair a b) i + unsafeReadArrayData (AD_Pair a b) i = do - x <- readArrayData a i - y <- readArrayData b i + x <- unsafeReadArrayData a i + y <- unsafeReadArrayData b i return (x, y) - writeArrayData (AD_Pair a b) i (x, y) + unsafeWriteArrayData (AD_Pair a b) i (x, y) = do - writeArrayData a i x - writeArrayData b i y + unsafeWriteArrayData a i x + unsafeWriteArrayData b i y unsafeFreezeArrayData (AD_Pair a b) = do a' <- unsafeFreezeArrayData a @@ -381,11 +539,12 @@ -- |Safe combination of creating and fast freezing of array data. -- +{-# INLINE runArrayData #-} runArrayData :: ArrayElt e => (forall s. ST s (MutableArrayData s e, e)) -> (ArrayData e, e) runArrayData st = runST $ do (mad, r) <- st - ad <- unsafeFreezeArrayData mad + ad <- unsafeFreezeArrayData mad return (ad, r) -- Array tuple operations @@ -405,9 +564,54 @@ -- Auxiliary functions -- ------------------- +-- Returns the element of an immutable array at the specified index. +-- +-- This does no bounds checking unless you configured with -funsafe-checks. This +-- is usually OK, since the functions that convert from multidimensional to +-- linear indexing do bounds checking by default. +-- +{-# INLINE unsafeIndexArray #-} +unsafeIndexArray :: IArray.IArray UArray e => UArray Int e -> Int -> e +#ifdef ACCELERATE_UNSAFE_CHECKS +unsafeIndexArray = IArray.! +#else +unsafeIndexArray = IArray.unsafeAt +#endif + + +-- Read an element from a mutable array. +-- +-- This does no bounds checking unless you configured with -funsafe-checks. This +-- is usually OK, since the functions that convert from multidimensional to +-- linear indexing do bounds checking by default. +-- +{-# INLINE unsafeReadArray #-} +unsafeReadArray :: MArray a e m => a Int e -> Int -> m e +#ifdef ACCELERATE_UNSAFE_CHECKS +unsafeReadArray = MArray.readArray +#else +unsafeReadArray = MArray.unsafeRead +#endif + +-- Write an element into a mutable array. +-- +-- This does no bounds checking unless you configured with -funsafe-checks. This +-- is usually OK, since the functions that convert from multidimensional to +-- linear indexing do bounds checking by default. +-- +{-# INLINE unsafeWriteArray #-} +unsafeWriteArray :: MArray a e m => a Int e -> Int -> e -> m () +#ifdef ACCELERATE_UNSAFE_CHECKS +unsafeWriteArray = MArray.writeArray +#else +unsafeWriteArray = MArray.unsafeWrite +#endif + + -- Our own version of the 'STUArray' allocation that uses /pinned/ memory, -- which is aligned to 16 bytes. -- +{-# INLINE unsafeNewArray_ #-} unsafeNewArray_ :: Int -> (Int# -> Int#) -> ST s (STUArray s Int e) unsafeNewArray_ n@(I# n#) elemsToBytes = ST $ \s1# -> @@ -419,6 +623,7 @@ -- -- PRECONDITION: The unboxed array must be pinned. -- +{-# INLINE uArrayPtr #-} uArrayPtr :: UArray Int a -> Ptr a uArrayPtr (UArray _ _ _ ba) = Ptr (byteArrayContents# ba) @@ -426,6 +631,7 @@ -- -- PRECONDITION: The unboxed ST array must be pinned. -- +{-# INLINE sTUArrayPtr #-} sTUArrayPtr :: STUArray s Int a -> ST s (Ptr a) sTUArrayPtr (STUArray _ _ _ mba) = ST $ \s -> case unsafeFreezeByteArray# mba s of diff --git a/Data/Array/Accelerate/Array/Delayed.hs b/Data/Array/Accelerate/Array/Delayed.hs --- a/Data/Array/Accelerate/Array/Delayed.hs +++ b/Data/Array/Accelerate/Array/Delayed.hs @@ -1,7 +1,10 @@ -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} -- | -- Module : Data.Array.Accelerate -- Copyright : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee +-- [2009..2013] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell -- License : BSD3 -- -- Maintainer : Manuel M T Chakravarty @@ -15,7 +18,7 @@ module Data.Array.Accelerate.Array.Delayed ( -- * Delayed array interface - Delayable(delay, force), Delayed(..) + Delayed, DelayedR(..), delay, force, ) where @@ -23,31 +26,51 @@ import Data.Array.Accelerate.Array.Sugar +type Delayed a = DelayedR (ArrRepr a) + + +delay :: Arrays a => a -> Delayed a +delay arr = go (arrays arr) (fromArr arr) + where + go :: ArraysR a -> a -> DelayedR a + go ArraysRunit () = DelayedRunit + go ArraysRarray a = delayR a + go (ArraysRpair r1 r2) (a1, a2) = DelayedRpair (go r1 a1) (go r2 a2) + + +force :: forall a. Arrays a => Delayed a -> a +force arr = toArr $ go (arrays (undefined::a)) arr + where + go :: ArraysR a' -> DelayedR a' -> a' + go ArraysRunit DelayedRunit = () + go ArraysRarray a = forceR a + go (ArraysRpair r1 r2) (DelayedRpair d1 d2) = (go r1 d1, go r2 d2) + + -- Delayed arrays are characterised by the domain of an array and its functional -- representation --- - +-- class Delayable a where - data Delayed a - delay :: a -> Delayed a - force :: Delayed a -> a - + data DelayedR a + delayR :: a -> DelayedR a + forceR :: DelayedR a -> a + instance Delayable () where - data Delayed () = DelayedUnit - delay () = DelayedUnit - force DelayedUnit = () + data DelayedR () = DelayedRunit + delayR () = DelayedRunit + forceR DelayedRunit = () instance Delayable (Array sh e) where - data Delayed (Array sh e) - = (Shape sh, Elt e) => - DelayedArray { shapeDA :: EltRepr sh - , repfDA :: EltRepr sh -> EltRepr e - } - delay arr@(Array sh _) = DelayedArray sh (fromElt . (arr!) . toElt) - force (DelayedArray sh f) = newArray (toElt sh) (toElt . f . fromElt) - + data DelayedR (Array sh e) + = (Shape sh, Elt e) => + DelayedRarray { shapeDA :: EltRepr sh + , repfDA :: EltRepr sh -> EltRepr e + } + delayR arr@(Array sh _) = DelayedRarray sh (fromElt . (arr!) . toElt) + forceR (DelayedRarray sh f) = newArray (toElt sh) (toElt . f . fromElt) + instance (Delayable a1, Delayable a2) => Delayable (a1, a2) where - data Delayed (a1, a2) = DelayedPair (Delayed a1) (Delayed a2) - delay (a1, a2) = DelayedPair (delay a1) (delay a2) - force (DelayedPair a1 a2) = (force a1, force a2) + data DelayedR (a1, a2) = DelayedRpair (DelayedR a1) (DelayedR a2) + delayR (a1, a2) = DelayedRpair (delayR a1) (delayR a2) + forceR (DelayedRpair a1 a2) = (forceR a1, forceR a2) 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 @@ -1,9 +1,15 @@ -{-# LANGUAGE CPP, GADTs, FlexibleContexts, FlexibleInstances #-} -{-# LANGUAGE TypeOperators, TypeFamilies #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Array.Representation --- Copyright : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell +-- Copyright : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee +-- [2009..2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell -- License : BSD3 -- -- Maintainer : Manuel M T Chakravarty @@ -18,9 +24,12 @@ ) where --- friends +-- friends import Data.Array.Accelerate.Type +-- standard library +import GHC.Base ( quotInt, remInt ) + #include "accelerate.h" @@ -37,8 +46,9 @@ -- internal methods intersect :: sh -> sh -> sh -- yield the intersection of two shapes ignore :: sh -- identifies ignored elements in 'permute' - index :: sh -> sh -> Int -- yield the index position in a linear, row-major representation of + 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 @@ -62,12 +72,13 @@ listToShape :: [Int] -> sh -- convert a list of dimensions into a shape instance Shape () where - dim () = 0 + dim _ = 0 size () = 1 () `intersect` () = () ignore = () - index () () = 0 + toIndex () () = 0 + fromIndex () _ = () bound () () _ = Right () iter () f _ _ = f () iter1 () f _ = f () @@ -80,14 +91,22 @@ listToShape _ = INTERNAL_ERROR(error) "listToShape" "non-empty list when converting to unit" instance Shape sh => Shape (sh, Int) where - dim (sh, _) = dim sh + 1 + dim _ = dim (undefined :: sh) + 1 size (sh, sz) = size sh * sz (sh1, sz1) `intersect` (sh2, sz2) = (sh1 `intersect` sh2, sz1 `min` sz2) ignore = (ignore, -1) - index (sh, sz) (ix, i) = BOUNDS_CHECK(checkIndex) "index" i sz - $ index sh ix * sz + i + toIndex (sh, sz) (ix, i) = BOUNDS_CHECK(checkIndex) "toIndex" i sz + $ toIndex sh ix * sz + i + fromIndex (sh, sz) i = (fromIndex sh (i `quotInt` sz), r) + -- If we assume that the index is in range, there is no point in computing + -- the remainder for the highest dimension since i < sz must hold. + -- + where + r | dim sh == 0 = BOUNDS_CHECK(checkIndex) "fromIndex" i sz i + | otherwise = i `remInt` sz + bound (sh, sz) (ix, i) bndy | i < 0 = case bndy of Clamp -> bound sh ix bndy `addDim` 0 @@ -115,11 +134,11 @@ iter1' (ix,i) | i == sz-1 = f (ix,i) | otherwise = f (ix,i) `c` iter1' (ix,i+1) - rangeToShape ((sh1, sz1), (sh2, sz2)) + rangeToShape ((sh1, sz1), (sh2, sz2)) = (rangeToShape (sh1, sh2), sz2 - sz1 + 1) - shapeToRange (sh, sz) + shapeToRange (sh, sz) = let (low, high) = shapeToRange sh - in + in ((low, 0), (high, sz - 1)) shapeToList (sh,sz) = sz : shapeToList sh @@ -142,19 +161,19 @@ instance Slice () where type SliceShape () = () type CoSliceShape () = () - type FullShape () = () + type FullShape () = () sliceIndex _ = SliceNil instance Slice sl => Slice (sl, ()) where - type SliceShape (sl, ()) = (SliceShape sl, Int) + type SliceShape (sl, ()) = (SliceShape sl, Int) type CoSliceShape (sl, ()) = CoSliceShape sl - type FullShape (sl, ()) = (FullShape sl, Int) + type FullShape (sl, ()) = (FullShape sl, Int) sliceIndex _ = SliceAll (sliceIndex (undefined::sl)) instance Slice sl => Slice (sl, Int) where type SliceShape (sl, Int) = SliceShape sl type CoSliceShape (sl, Int) = (CoSliceShape sl, Int) - type FullShape (sl, Int) = (FullShape sl, Int) + type FullShape (sl, Int) = (FullShape sl, Int) sliceIndex _ = SliceFixed (sliceIndex (undefined::sl)) -- |Generalised array index, which may index only in a subset of the dimensions @@ -162,13 +181,13 @@ -- data SliceIndex ix slice coSlice sliceDim where SliceNil :: SliceIndex () () () () - SliceAll :: + SliceAll :: SliceIndex ix slice co dim -> SliceIndex (ix, ()) (slice, Int) co (dim, Int) - SliceFixed :: + SliceFixed :: SliceIndex ix slice co dim -> SliceIndex (ix, Int) slice (co, Int) (dim, Int) instance Show (SliceIndex ix slice coSlice sliceDim) where show SliceNil = "SliceNil" - show (SliceAll rest) = "SliceAll ("++ show rest ++ ")" + show (SliceAll rest) = "SliceAll (" ++ show rest ++ ")" show (SliceFixed rest) = "SliceFixed (" ++ show rest ++ ")" 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,10 +1,20 @@ -{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts, FlexibleInstances #-} -{-# LANGUAGE GADTs, ScopedTypeVariables, StandaloneDeriving, TupleSections #-} -{-# LANGUAGE TypeOperators, TypeFamilies, BangPatterns #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Array.Sugar --- Copyright : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell +-- Copyright : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee +-- [2009..2013] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- [2013] Robert Clifton-Everest -- License : BSD3 -- -- Maintainer : Manuel M T Chakravarty @@ -34,55 +44,73 @@ shape, (!), newArray, allocateArray, fromIArray, toIArray, fromList, toList, -- * Miscellaneous - showShape, + showShape, Foreign(..) ) where -- standard library -import Data.Array.IArray (IArray) -import qualified Data.Array.IArray as IArray import Data.Typeable +import Data.Array.IArray ( IArray ) +import qualified Data.Array.IArray as IArray -- friends import Data.Array.Accelerate.Type import Data.Array.Accelerate.Array.Data -import qualified Data.Array.Accelerate.Array.Representation as Repr +import qualified Data.Array.Accelerate.Array.Representation as Repr -- Surface types representing array indices and slices -- --------------------------------------------------- - --- |Array indices are snoc type lists. --- For example, the type of a rank-2 array index is @Z :.Int :. Int@. +-- +-- Array indices are snoc type lists. That is, they're backwards -- +-- the end-of-list token, `Z`, occurs first. For example, the type of a +-- rank-2 array index is @Z :. Int :. Int@. +-- +-- In Accelerate the rightmost dimension is the /fastest varying/ or innermost. -- |Rank-0 index -- data Z = Z - deriving (Typeable, Show) + deriving (Typeable, Show, Eq) --- |Increase an index rank by one dimension +-- |Increase an index rank by one dimension. The `:.` operator is +-- used to construct both values and types. -- infixl 3 :. data tail :. head = tail :. head - deriving (Typeable, Show) + deriving (Typeable, Show, Eq) --- |Marker for entire dimensions in slice descriptors +-- | Marker for entire dimensions in slice descriptors. -- +-- For example, when used in slices passed to `replicate`, the +-- occurrences of `All` indicate the dimensions into which the array's +-- existing extent will be placed, rather than the new dimensions +-- introduced by replication. +-- data All = All - deriving (Typeable, Show) + deriving (Typeable, Show, Eq) --- |Marker for arbitrary shapes in slice descriptors +-- |Marker for arbitrary shapes in slice descriptors. Such arbitrary +-- shapes may include an unknown number of dimensions. -- +-- `Any` can be used in the leftmost position of a slice instead of +-- `Z`, for example @(Any :. _ :. _)@. In the following definition +-- `Any` is used to match against whatever shape the type variable +-- `sh` takes: +-- +-- > repN :: (Shape sh, Elt e) => Int -> Acc (Array sh e) -> Acc (Array (sh:.Int) e) +-- > repN n a = replicate (constant $ Any :. n) a +-- data Any sh = Any - deriving (Typeable, Show) + deriving (Typeable, Show, Eq) -- Representation change for array element types -- --------------------------------------------- --- |Type representation mapping +-- | Type representation mapping -- --- We represent tuples by using '()' and '(,)' as type-level nil and snoc to construct snoc-lists of --- types. +-- We represent tuples by using '()' and '(,)' as type-level nil and snoc to +-- construct snoc-lists of types. -- type family EltRepr a :: * type instance EltRepr () = () @@ -125,7 +153,7 @@ type instance EltRepr (a, b, c, d, e, f) = (EltRepr (a, b, c, d, e), EltRepr' f) type instance EltRepr (a, b, c, d, e, f, g) = (EltRepr (a, b, c, d, e, f), EltRepr' g) type instance EltRepr (a, b, c, d, e, f, g, h) = (EltRepr (a, b, c, d, e, f, g), EltRepr' h) -type instance EltRepr (a, b, c, d, e, f, g, h, i) +type instance EltRepr (a, b, c, d, e, f, g, h, i) = (EltRepr (a, b, c, d, e, f, g, h), EltRepr' i) -- To avoid overly nested pairs, we use a flattened representation at the @@ -172,17 +200,21 @@ type instance EltRepr' (a, b, c, d, e, f) = (EltRepr (a, b, c, d, e), EltRepr' f) type instance EltRepr' (a, b, c, d, e, f, g) = (EltRepr (a, b, c, d, e, f), EltRepr' g) type instance EltRepr' (a, b, c, d, e, f, g, h) = (EltRepr (a, b, c, d, e, f, g), EltRepr' h) -type instance EltRepr' (a, b, c, d, e, f, g, h, i) +type instance EltRepr' (a, b, c, d, e, f, g, h, i) = (EltRepr (a, b, c, d, e, f, g, h), EltRepr' i) -- Array elements (tuples of scalars) -- ---------------------------------- --- |Class that characterises the types of values that can be array elements, and hence, appear in --- scalar Accelerate expressions. +-- | Accelerate supports as array elements only simple atomic types, and tuples +-- thereof. These element types are stored efficiently in memory, unpacked as +-- consecutive elements without pointers. -- -class (Show a, Typeable a, +-- This class characterises the types of values that can be array elements, and +-- hence, appear in scalar Accelerate expressions. +-- +class (Show a, Typeable a, Typeable (EltRepr a), Typeable (EltRepr' a), ArrayElt (EltRepr a), ArrayElt (EltRepr' a)) => Elt a where @@ -193,7 +225,7 @@ eltType' :: {-dummy-} a -> TupleType (EltRepr' a) fromElt' :: a -> EltRepr' a toElt' :: EltRepr' a -> a - + instance Elt () where eltType _ = UnitTuple fromElt = id @@ -226,27 +258,27 @@ fromElt All = ((), ()) toElt ((), ()) = All - eltType' _ = UnitTuple - fromElt' All = () - toElt' () = All + eltType' _ = UnitTuple + fromElt' All = () + toElt' () = All instance Elt (Any Z) where eltType _ = UnitTuple fromElt _ = () - toElt _ = Any - + toElt _ = Any + eltType' _ = UnitTuple fromElt' _ = () - toElt' _ = Any + toElt' _ = Any instance Shape sh => Elt (Any (sh:.Int)) where eltType _ = PairTuple (eltType (undefined::Any sh)) UnitTuple fromElt _ = (fromElt (undefined :: Any sh), ()) - toElt _ = Any + toElt _ = Any eltType' _ = PairTuple (eltType' (undefined::Any sh)) UnitTuple fromElt' _ = (fromElt' (undefined :: Any sh), ()) - toElt' _ = Any + toElt' _ = Any instance Elt Int where eltType = singletonScalarType @@ -338,79 +370,78 @@ fromElt' = id toElt' = id -{- + instance Elt CShort where - --eltType = singletonScalarType + eltType = singletonScalarType fromElt v = ((), v) toElt ((), v) = v - --eltType' _ = SingleTuple scalarType + eltType' _ = SingleTuple scalarType fromElt' = id toElt' = id instance Elt CUShort where - --eltType = singletonScalarType + eltType = singletonScalarType fromElt v = ((), v) toElt ((), v) = v - --eltType' _ = SingleTuple scalarType + eltType' _ = SingleTuple scalarType fromElt' = id toElt' = id instance Elt CInt where - --eltType = singletonScalarType + eltType = singletonScalarType fromElt v = ((), v) toElt ((), v) = v - --eltType' _ = SingleTuple scalarType + eltType' _ = SingleTuple scalarType fromElt' = id toElt' = id instance Elt CUInt where - --eltType = singletonScalarType + eltType = singletonScalarType fromElt v = ((), v) toElt ((), v) = v - --eltType' _ = SingleTuple scalarType + eltType' _ = SingleTuple scalarType fromElt' = id toElt' = id instance Elt CLong where - --eltType = singletonScalarType + eltType = singletonScalarType fromElt v = ((), v) toElt ((), v) = v - --eltType' _ = SingleTuple scalarType + eltType' _ = SingleTuple scalarType fromElt' = id toElt' = id instance Elt CULong where - --eltType = singletonScalarType + eltType = singletonScalarType fromElt v = ((), v) toElt ((), v) = v - --eltType' _ = SingleTuple scalarType + eltType' _ = SingleTuple scalarType fromElt' = id toElt' = id instance Elt CLLong where - --eltType = singletonScalarType + eltType = singletonScalarType fromElt v = ((), v) toElt ((), v) = v - --eltType' _ = SingleTuple scalarType + eltType' _ = SingleTuple scalarType fromElt' = id toElt' = id instance Elt CULLong where - --eltType = singletonScalarType + eltType = singletonScalarType fromElt v = ((), v) toElt ((), v) = v - --eltType' _ = SingleTuple scalarType + eltType' _ = SingleTuple scalarType fromElt' = id toElt' = id --} instance Elt Float where eltType = singletonScalarType @@ -430,26 +461,25 @@ fromElt' = id toElt' = id -{- instance Elt CFloat where - --eltType = singletonScalarType + eltType = singletonScalarType fromElt v = ((), v) toElt ((), v) = v - --eltType' _ = SingleTuple scalarType + eltType' _ = SingleTuple scalarType fromElt' = id toElt' = id instance Elt CDouble where - --eltType = singletonScalarType + eltType = singletonScalarType fromElt v = ((), v) toElt ((), v) = v - --eltType' _ = SingleTuple scalarType + eltType' _ = SingleTuple scalarType fromElt' = id toElt' = id --} + instance Elt Bool where eltType = singletonScalarType fromElt v = ((), v) @@ -468,135 +498,133 @@ fromElt' = id toElt' = id -{- instance Elt CChar where - --eltType = singletonScalarType + eltType = singletonScalarType fromElt v = ((), v) toElt ((), v) = v - --eltType' _ = SingleTuple scalarType + eltType' _ = SingleTuple scalarType fromElt' = id toElt' = id instance Elt CSChar where - --eltType = singletonScalarType + eltType = singletonScalarType fromElt v = ((), v) toElt ((), v) = v - --eltType' _ = SingleTuple scalarType + eltType' _ = SingleTuple scalarType fromElt' = id toElt' = id instance Elt CUChar where - --eltType = singletonScalarType + eltType = singletonScalarType fromElt v = ((), v) toElt ((), v) = v - --eltType' _ = SingleTuple scalarType + eltType' _ = SingleTuple scalarType fromElt' = id toElt' = id --} instance (Elt a, Elt b) => Elt (a, b) where - eltType (_::(a, b)) + eltType (_::(a, b)) = PairTuple (eltType (undefined :: a)) (eltType' (undefined :: b)) fromElt (a, b) = (fromElt a, fromElt' b) toElt (a, b) = (toElt a, toElt' b) - eltType' (_::(a, b)) + eltType' (_::(a, b)) = PairTuple (eltType (undefined :: a)) (eltType' (undefined :: b)) fromElt' (a, b) = (fromElt a, fromElt' b) toElt' (a, b) = (toElt a, toElt' b) instance (Elt a, Elt b, Elt c) => Elt (a, b, c) where - eltType (_::(a, b, c)) + eltType (_::(a, b, c)) = PairTuple (eltType (undefined :: (a, b))) (eltType' (undefined :: c)) fromElt (a, b, c) = (fromElt (a, b), fromElt' c) toElt (ab, c) = let (a, b) = toElt ab in (a, b, toElt' c) - - eltType' (_::(a, b, c)) + + eltType' (_::(a, b, c)) = PairTuple (eltType (undefined :: (a, b))) (eltType' (undefined :: c)) fromElt' (a, b, c) = (fromElt (a, b), fromElt' c) toElt' (ab, c) = let (a, b) = toElt ab in (a, b, toElt' c) - + instance (Elt a, Elt b, Elt c, Elt d) => Elt (a, b, c, d) where - eltType (_::(a, b, c, d)) + eltType (_::(a, b, c, d)) = PairTuple (eltType (undefined :: (a, b, c))) (eltType' (undefined :: d)) fromElt (a, b, c, d) = (fromElt (a, b, c), fromElt' d) toElt (abc, d) = let (a, b, c) = toElt abc in (a, b, c, toElt' d) - eltType' (_::(a, b, c, d)) + eltType' (_::(a, b, c, d)) = PairTuple (eltType (undefined :: (a, b, c))) (eltType' (undefined :: d)) fromElt' (a, b, c, d) = (fromElt (a, b, c), fromElt' d) toElt' (abc, d) = let (a, b, c) = toElt abc in (a, b, c, toElt' d) instance (Elt a, Elt b, Elt c, Elt d, Elt e) => Elt (a, b, c, d, e) where - eltType (_::(a, b, c, d, e)) - = PairTuple (eltType (undefined :: (a, b, c, d))) + eltType (_::(a, b, c, d, e)) + = PairTuple (eltType (undefined :: (a, b, c, d))) (eltType' (undefined :: e)) fromElt (a, b, c, d, e) = (fromElt (a, b, c, d), fromElt' e) toElt (abcd, e) = let (a, b, c, d) = toElt abcd in (a, b, c, d, toElt' e) - eltType' (_::(a, b, c, d, e)) - = PairTuple (eltType (undefined :: (a, b, c, d))) + eltType' (_::(a, b, c, d, e)) + = PairTuple (eltType (undefined :: (a, b, c, d))) (eltType' (undefined :: e)) fromElt' (a, b, c, d, e) = (fromElt (a, b, c, d), fromElt' e) toElt' (abcd, e) = let (a, b, c, d) = toElt abcd in (a, b, c, d, toElt' e) instance (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f) => Elt (a, b, c, d, e, f) where - eltType (_::(a, b, c, d, e, f)) - = PairTuple (eltType (undefined :: (a, b, c, d, e))) + eltType (_::(a, b, c, d, e, f)) + = PairTuple (eltType (undefined :: (a, b, c, d, e))) (eltType' (undefined :: f)) fromElt (a, b, c, d, e, f) = (fromElt (a, b, c, d, e), fromElt' f) toElt (abcde, f) = let (a, b, c, d, e) = toElt abcde in (a, b, c, d, e, toElt' f) - eltType' (_::(a, b, c, d, e, f)) - = PairTuple (eltType (undefined :: (a, b, c, d, e))) + eltType' (_::(a, b, c, d, e, f)) + = PairTuple (eltType (undefined :: (a, b, c, d, e))) (eltType' (undefined :: f)) fromElt' (a, b, c, d, e, f) = (fromElt (a, b, c, d, e), fromElt' f) toElt' (abcde, f) = let (a, b, c, d, e) = toElt abcde in (a, b, c, d, e, toElt' f) -instance (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g) +instance (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g) => Elt (a, b, c, d, e, f, g) where - eltType (_::(a, b, c, d, e, f, g)) - = PairTuple (eltType (undefined :: (a, b, c, d, e, f))) + eltType (_::(a, b, c, d, e, f, g)) + = PairTuple (eltType (undefined :: (a, b, c, d, e, f))) (eltType' (undefined :: g)) fromElt (a, b, c, d, e, f, g) = (fromElt (a, b, c, d, e, f), fromElt' g) toElt (abcdef, g) = let (a, b, c, d, e, f) = toElt abcdef in (a, b, c, d, e, f, toElt' g) - eltType' (_::(a, b, c, d, e, f, g)) - = PairTuple (eltType (undefined :: (a, b, c, d, e, f))) + eltType' (_::(a, b, c, d, e, f, g)) + = PairTuple (eltType (undefined :: (a, b, c, d, e, f))) (eltType' (undefined :: g)) fromElt' (a, b, c, d, e, f, g) = (fromElt (a, b, c, d, e, f), fromElt' g) toElt' (abcdef, g) = let (a, b, c, d, e, f) = toElt abcdef in (a, b, c, d, e, f, toElt' g) -instance (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h) +instance (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h) => Elt (a, b, c, d, e, f, g, h) where - eltType (_::(a, b, c, d, e, f, g, h)) - = PairTuple (eltType (undefined :: (a, b, c, d, e, f, g))) + eltType (_::(a, b, c, d, e, f, g, h)) + = PairTuple (eltType (undefined :: (a, b, c, d, e, f, g))) (eltType' (undefined :: h)) fromElt (a, b, c, d, e, f, g, h) = (fromElt (a, b, c, d, e, f, g), fromElt' h) - toElt (abcdefg, h) = let (a, b, c, d, e, f, g) = toElt abcdefg + toElt (abcdefg, h) = let (a, b, c, d, e, f, g) = toElt abcdefg in (a, b, c, d, e, f, g, toElt' h) - eltType' (_::(a, b, c, d, e, f, g, h)) - = PairTuple (eltType (undefined :: (a, b, c, d, e, f, g))) + eltType' (_::(a, b, c, d, e, f, g, h)) + = PairTuple (eltType (undefined :: (a, b, c, d, e, f, g))) (eltType' (undefined :: h)) fromElt' (a, b, c, d, e, f, g, h) = (fromElt (a, b, c, d, e, f, g), fromElt' h) - toElt' (abcdefg, h) = let (a, b, c, d, e, f, g) = toElt abcdefg + toElt' (abcdefg, h) = let (a, b, c, d, e, f, g) = toElt abcdefg in (a, b, c, d, e, f, g, toElt' h) -instance (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i) +instance (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i) => Elt (a, b, c, d, e, f, g, h, i) where - eltType (_::(a, b, c, d, e, f, g, h, i)) - = PairTuple (eltType (undefined :: (a, b, c, d, e, f, g, h))) + eltType (_::(a, b, c, d, e, f, g, h, i)) + = PairTuple (eltType (undefined :: (a, b, c, d, e, f, g, h))) (eltType' (undefined :: i)) fromElt (a, b, c, d, e, f, g, h, i) = (fromElt (a, b, c, d, e, f, g, h), fromElt' i) toElt (abcdefgh, i) = let (a, b, c, d, e, f, g, h) = toElt abcdefgh in (a, b, c, d, e, f, g, h, toElt' i) - eltType' (_::(a, b, c, d, e, f, g, h, i)) - = PairTuple (eltType (undefined :: (a, b, c, d, e, f, g, h))) + eltType' (_::(a, b, c, d, e, f, g, h, i)) + = PairTuple (eltType (undefined :: (a, b, c, d, e, f, g, h))) (eltType' (undefined :: i)) fromElt' (a, b, c, d, e, f, g, h, i) = (fromElt (a, b, c, d, e, f, g, h), fromElt' i) toElt' (abcdefgh, i) = let (a, b, c, d, e, f, g, h) = toElt abcdefgh @@ -608,25 +636,25 @@ singletonScalarType :: IsScalar a => a -> TupleType ((), a) singletonScalarType _ = PairTuple UnitTuple (SingleTuple scalarType) -liftToElt :: (Elt a, Elt b) +liftToElt :: (Elt a, Elt b) => (EltRepr a -> EltRepr b) -> (a -> b) {-# INLINE liftToElt #-} liftToElt f = toElt . f . fromElt -liftToElt2 :: (Elt a, Elt b, Elt c) +liftToElt2 :: (Elt a, Elt b, Elt c) => (EltRepr a -> EltRepr b -> EltRepr c) -> (a -> b -> c) {-# INLINE liftToElt2 #-} liftToElt2 f = \x y -> toElt $ f (fromElt x) (fromElt y) -sinkFromElt :: (Elt a, Elt b) +sinkFromElt :: (Elt a, Elt b) => (a -> b) -> (EltRepr a -> EltRepr b) {-# INLINE sinkFromElt #-} sinkFromElt f = fromElt . f . toElt -sinkFromElt2 :: (Elt a, Elt b, Elt c) +sinkFromElt2 :: (Elt a, Elt b, Elt c) => (a -> b -> c) -> (EltRepr a -> EltRepr b -> EltRepr c) {-# INLINE sinkFromElt2 #-} @@ -639,6 +667,23 @@ #-} + +-- Foreign functions +-- ----------------- + +-- Class for backends to choose their own representation of foreign functions. +-- By default it has no instances. If a backend wishes to have an FFI it must +-- provide an instance. +-- +class Typeable2 f => Foreign (f :: * -> * -> *) where + + -- Backends should be able to produce a string representation of the foreign + -- function for pretty printing. It should contain the backend name and + -- ideally a string uniquely identifying the foreign function being used. + -- + strForeign :: f args results -> String + + -- Surface arrays -- -------------- @@ -782,32 +827,33 @@ fromArr' (i, h, g, f, e, d, c, b, a) = (fromArr (i, h, g, f, e, d, c, b), fromArr' a) --- |Multi-dimensional arrays for array processing +-- |Multi-dimensional arrays for array processing. -- --- * If device and host memory are separate, arrays will be transferred to the --- device when necessary (if possible asynchronously and in parallel with --- other tasks) and cached on the device if sufficient memory is available. +-- If device and host memory are separate, arrays will be transferred to the +-- device when necessary (if possible asynchronously and in parallel with other +-- tasks) and cached on the device if sufficient memory is available. -- data Array sh e where - Array :: (Shape sh, Elt e) + Array :: (Shape sh, Elt e) => EltRepr sh -- extent of dimensions = shape -> ArrayData (EltRepr e) -- array payload -> Array sh e -deriving instance Typeable2 Array +deriving instance Typeable2 Array --- |Scalars +-- |Scalars arrays hold a single element -- type Scalar e = Array DIM0 e --- |Vectors +-- |Vectors are one-dimensional arrays -- type Vector e = Array DIM1 e --- |Segment descriptor (vector of segment lengths) +-- |Segment descriptor (vector of segment lengths). -- --- To represent nested one-dimensional arrays, we use a flat array of data values in conjunction --- with a /segment descriptor/, which stores the lengths of the subarrays. +-- To represent nested one-dimensional arrays, we use a flat array of data +-- values in conjunction with a /segment descriptor/, which stores the lengths +-- of the subarrays. -- type Segments i = Vector i @@ -825,7 +871,7 @@ type DIM9 = DIM8:.Int -- Shape constraints and indexing --- +-- ------------------------------ -- |Shapes and indices of multi-dimensional arrays -- @@ -833,18 +879,24 @@ -- |Number of dimensions of a /shape/ or /index/ (>= 0). dim :: sh -> Int - + -- |Total number of elements in an array of the given /shape/. size :: sh -> Int -- |Magic value identifying elements ignored in 'permute'. ignore :: sh - - -- |Map a multi-dimensional index into one in a linear, row-major - -- representation of the array (first argument is the /shape/, second + + -- |Yield the intersection of two shapes + intersect :: sh -> sh -> sh + + -- |Map a multi-dimensional index into one in a linear, row-major + -- representation of the array (first argument is the /shape/, second -- argument is the index). - index :: sh -> sh -> Int + toIndex :: sh -> sh -> Int + -- |Inverse of 'toIndex'. + fromIndex :: sh -> Int -> sh + -- |Apply a boundary condition to an index. bound :: sh -> sh -> Boundary a -> Either a sh @@ -855,7 +907,7 @@ -- |Convert a minpoint-maxpoint index into a /shape/. rangeToShape :: (sh, sh) -> sh - + -- |Convert a /shape/ into a minpoint-maxpoint index. shapeToRange :: sh -> (sh, sh) @@ -868,20 +920,23 @@ -- | The slice index for slice specifier 'Any sh' sliceAnyIndex :: sh -> Repr.SliceIndex (EltRepr (Any sh)) (EltRepr sh) () (EltRepr sh) - dim = Repr.dim . fromElt - size = Repr.size . fromElt - -- (#) must be individually defined, as it only hold for all instances *except* the one with the - -- largest arity + dim = Repr.dim . fromElt + size = Repr.size . fromElt + -- (#) must be individually defined, as it holds for all instances *except* + -- the one with the largest arity - ignore = toElt Repr.ignore - index sh ix = Repr.index (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' + ignore = toElt Repr.ignore + intersect sh1 sh2 = toElt (Repr.intersect (fromElt sh1) (fromElt sh2)) + fromIndex sh ix = toElt (Repr.fromIndex (fromElt sh) ix) + toIndex sh ix = Repr.toIndex (fromElt sh) (fromElt ix) - iter sh f c r = Repr.iter (fromElt sh) (f . toElt) c r + bound sh ix bndy = case Repr.bound (fromElt sh) (fromElt ix) bndy of + Left v -> Left v + Right ix' -> Right $ toElt ix' - rangeToShape (low, high) + iter sh f c r = Repr.iter (fromElt sh) (f . toElt) c r + + rangeToShape (low, high) = toElt (Repr.rangeToShape (fromElt low, fromElt high)) shapeToRange ix = let (low, high) = Repr.shapeToRange (fromElt ix) @@ -893,22 +948,22 @@ instance Shape Z where sliceAnyIndex _ = Repr.SliceNil - + instance Shape sh => Shape (sh:.Int) where sliceAnyIndex _ = Repr.SliceAll (sliceAnyIndex (undefined :: sh)) --- |Slices, aka generalised indices, as /n/-tuples and mappings of slice indices to slices, --- co-slices, and slice dimensions +-- | Slices, aka generalised indices, as /n/-tuples and mappings of slice +-- indices to slices, co-slices, and slice dimensions -- -class (Elt sl, Shape (SliceShape sl), Shape (CoSliceShape sl), Shape (FullShape sl)) +class (Elt sl, Shape (SliceShape sl), Shape (CoSliceShape sl), Shape (FullShape sl)) => Slice sl where - type SliceShape sl :: * - type CoSliceShape sl :: * - type FullShape sl :: * - sliceIndex :: sl -> Repr.SliceIndex (EltRepr sl) - (EltRepr (SliceShape sl)) - (EltRepr (CoSliceShape sl)) - (EltRepr (FullShape sl)) + type SliceShape sl :: * -- the projected slice + type CoSliceShape sl :: * -- the complement of the slice + type FullShape sl :: * -- the combined dimension + sliceIndex :: sl {- dummy -} -> Repr.SliceIndex (EltRepr sl) + (EltRepr (SliceShape sl)) + (EltRepr (CoSliceShape sl)) + (EltRepr (FullShape sl)) instance Slice Z where type SliceShape Z = Z @@ -917,16 +972,16 @@ sliceIndex _ = Repr.SliceNil instance Slice sl => Slice (sl:.All) where - type SliceShape (sl:.All) = SliceShape sl :. Int + type SliceShape (sl:.All) = SliceShape sl :. Int type CoSliceShape (sl:.All) = CoSliceShape sl - type FullShape (sl:.All) = FullShape sl :. Int - sliceIndex _ = Repr.SliceAll (sliceIndex (undefined::sl)) + type FullShape (sl:.All) = FullShape sl :. Int + sliceIndex _ = Repr.SliceAll (sliceIndex (undefined :: sl)) instance Slice sl => Slice (sl:.Int) where - type SliceShape (sl:.Int) = SliceShape sl + type SliceShape (sl:.Int) = SliceShape sl type CoSliceShape (sl:.Int) = CoSliceShape sl :. Int - type FullShape (sl:.Int) = FullShape sl :. Int - sliceIndex _ = Repr.SliceFixed (sliceIndex (undefined::sl)) + type FullShape (sl:.Int) = FullShape sl :. Int + sliceIndex _ = Repr.SliceFixed (sliceIndex (undefined :: sl)) instance Shape sh => Slice (Any sh) where type SliceShape (Any sh) = sh @@ -934,6 +989,7 @@ type FullShape (Any sh) = sh sliceIndex _ = sliceAnyIndex (undefined :: sh) + -- Array operations -- ---------------- @@ -949,18 +1005,18 @@ {-# INLINE (!) #-} -- (Array sh adata) ! ix = toElt (adata `indexArrayData` index sh ix) -- FIXME: using this due to a bug in 6.10.x -(!) (Array sh adata) ix = toElt (adata `indexArrayData` index (toElt sh) ix) +(!) (Array sh adata) ix = toElt (adata `unsafeIndexArrayData` toIndex (toElt sh) ix) -- |Create an array from its representation function -- newArray :: (Shape sh, Elt e) => sh -> (sh -> e) -> Array sh e {-# INLINE newArray #-} newArray sh f = adata `seq` Array (fromElt sh) adata - where + where (adata, _) = runArrayData $ do arr <- newArrayData (size sh) - let write ix = writeArrayData arr (index sh ix) - (fromElt (f ix)) + let write ix = unsafeWriteArrayData arr (toIndex sh ix) + (fromElt (f ix)) iter sh write (>>) (return ()) return (arr, undefined) @@ -973,8 +1029,13 @@ (adata, _) = runArrayData $ (,undefined) `fmap` newArrayData (size sh) --- |Convert an 'IArray' to an accelerated array. +-- | Convert an 'IArray' to an accelerated array. -- +-- While the type signature mentions Accelerate internals that are not exported, +-- in practice satisfying the type equality is straight forward. The index type +-- @ix@ must be the unit type @()@ for singleton arrays, or an @Int@ or tuple of +-- @Int@'s for multidimensional arrays. +-- fromIArray :: (EltRepr ix ~ EltRepr sh, IArray a e, IArray.Ix ix, Shape sh, Elt ix, Elt e) => a ix e -> Array sh e fromIArray iarr = newArray (toElt sh) (\ix -> iarr IArray.! toElt (fromElt ix)) @@ -982,43 +1043,51 @@ (lo,hi) = IArray.bounds iarr sh = Repr.rangeToShape (fromElt lo, fromElt hi) --- |Convert an accelerated array to an 'IArray' --- -toIArray :: (EltRepr ix ~ EltRepr sh, IArray a e, IArray.Ix ix, Shape sh, Elt ix, Elt e) +-- | Convert an accelerated array to an 'IArray'. +-- +toIArray :: (EltRepr ix ~ EltRepr sh, IArray a e, IArray.Ix ix, Shape sh, Elt ix, Elt e) => Array sh e -> a ix e toIArray arr = IArray.array bnds [(ix, arr ! toElt (fromElt ix)) | ix <- IArray.range bnds] where (lo,hi) = Repr.shapeToRange (fromElt (shape arr)) bnds = (toElt lo, toElt hi) --- |Convert a list (with elements in row-major order) to an accelerated array. +-- | Convert a list, with elements in row-major order, into an accelerated array. -- fromList :: (Shape sh, Elt e) => sh -> [e] -> Array sh e {-# INLINE fromList #-} fromList sh xs = adata `seq` Array (fromElt sh) adata where + -- Assume the array is in dense row-major order. This is safe because + -- otherwise backends would not be able to directly memcpy. + -- !n = size sh (adata, _) = runArrayData $ do - arr <- newArrayData (size sh) + arr <- newArrayData n let go !i _ | i >= n = return () - go !i (v:vs) = writeArrayData arr i (fromElt v) >> go (i+1) vs + go !i (v:vs) = unsafeWriteArrayData arr i (fromElt v) >> go (i+1) vs go _ [] = error "Data.Array.Accelerate.fromList: not enough input data" -- go 0 xs return (arr, undefined) --- |Convert an accelerated array to a list in row-major order. +-- | Convert an accelerated array to a list in row-major order. -- toList :: forall sh e. Array sh e -> [e] -toList (Array sh adata) = iter sh' idx (.) id [] +{-# INLINE toList #-} +toList (Array sh adata) = go 0 where - sh' = toElt sh :: sh - idx ix = \l -> toElt (adata `indexArrayData` index sh' ix) : l + -- Assume underling array is in row-major order. This is safe because + -- otherwise backends would not be able to directly memcpy. + -- + !n = Repr.size sh + go !i | i >= n = [] + | otherwise = toElt (adata `unsafeIndexArrayData` i) : go (i+1) -- Convert an array to a string -- instance Show (Array sh e) where - show arr@(Array sh _adata) + show arr@(Array sh _adata) = "Array (" ++ showShape (toElt sh :: sh) ++ ") " ++ show (toList arr) -- | Nicely format a shape as a string diff --git a/Data/Array/Accelerate/Debug.hs b/Data/Array/Accelerate/Debug.hs --- a/Data/Array/Accelerate/Debug.hs +++ b/Data/Array/Accelerate/Debug.hs @@ -1,7 +1,13 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS -fno-warn-unused-imports #-} +{-# OPTIONS -fno-warn-unused-binds #-} +{-# OPTIONS_HADDOCK hide #-} -- | --- Module : Data.Array.Accelerate.AST +-- Module : Data.Array.Accelerate.Debug -- Copyright : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee +-- [2009..2013] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell -- License : BSD3 -- -- Maintainer : Manuel M T Chakravarty @@ -15,63 +21,352 @@ module Data.Array.Accelerate.Debug ( - -- * Conditional tracing - initTrace, queryTrace, traceLine, traceChunk, tracePure + -- * Dynamic debugging flags + dump_sharing, dump_simpl_stats, dump_simpl_iterations, verbose, + queryFlag, setFlag, + -- * Tracing + traceMessage, traceEvent, tracePure, + + -- * Statistics + inline, ruleFired, knownBranch, betaReduce, substitution, simplifierDone, fusionDone, + resetSimplCount, simplCount, + ) where -- standard libraries -import Control.Monad +import Data.Function ( on ) import Data.IORef -import Debug.Trace -import System.IO.Unsafe (unsafePerformIO) +import Data.Label +import Data.List ( groupBy, sortBy, isPrefixOf ) +import Data.Ord ( comparing ) +import Numeric +import Text.PrettyPrint +import System.CPUTime +import System.Environment +import System.IO.Unsafe ( unsafePerformIO ) +import qualified Data.Map as Map --- friends -import Data.Array.Accelerate.Pretty () -#if __GLASGOW_HASKELL__ < 704 +#if __GLASGOW_HASKELL__ >= 704 +import Debug.Trace ( traceIO, traceEventIO ) +#else +import Debug.Trace ( putTraceMsg ) + traceIO :: String -> IO () traceIO = putTraceMsg + +traceEventIO :: String -> IO () +traceEventIO = traceIO #endif --- This flag indicates whether tracing messages should be emitted. +#if !MIN_VERSION_base(4,6,0) +modifyIORef' :: IORef a -> (a -> a) -> IO () +modifyIORef' ref f = do + x <- readIORef ref + let x' = f x + x' `seq` writeIORef ref x' +#endif + + +-- ----------------------------------------------------------------------------- +-- Flag option parsing + +data FlagSpec flag = Option String -- external form + flag -- internal form + +data Flags = Flags + { + -- debugging + _dump_sharing :: !Bool -- sharing recovery phase + , _dump_simpl_stats :: !Bool -- statistics form fusion/simplification + , _dump_simpl_iterations :: !Bool -- output from each simplifier iteration + , _verbose :: !Bool -- additional, uncategorised status messages + + -- functionality / phase control + , _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 + } + +$(mkLabels [''Flags]) + +allFlags :: [FlagSpec (Flags -> Flags)] +allFlags + = map (enable 'd') dflags + ++ map (enable 'f') fflags ++ map (disable 'f') fflags + where + enable p (Option f go) = Option ('-':p:f) (go True) + disable p (Option f go) = Option ('-':p:"no-"++f) (go False) + + +-- These @-d\@ flags can be reversed with @-dno-\@ -- -traceFlag :: IORef Bool -{-# NOINLINE traceFlag #-} -traceFlag = unsafePerformIO $ newIORef False +dflags :: [FlagSpec (Bool -> Flags -> Flags)] +dflags = + [ + Option "dump-sharing" (set dump_sharing) -- print sharing recovery trace + , Option "dump-simpl-stats" (set dump_simpl_stats) -- dump simplifier stats + , Option "dump-simpl-iterations" (set dump_simpl_iterations) -- dump output from each simplifier iteration + , Option "verbose" (set verbose) -- print additional information + ] --- |Initialise the /trace flag/, which determines whether tracing messages should be emitted. +-- These @-f\@ flags can be reversed with @-fno-\@ -- -initTrace :: Bool -> IO () -initTrace = writeIORef traceFlag +fflags :: [FlagSpec (Bool -> Flags -> Flags)] +fflags = + [ Option "acc-sharing" (set' acc_sharing) -- sharing of array computations + , Option "exp-sharing" (set' exp_sharing) -- sharing of scalar expressions + , Option "fusion" (set' fusion) -- fusion of array computations + , Option "simplify" (set' simplify) -- scalar expression simplification +-- , Option "unfolding-use-threshold" -- the magic cut-off figure for inlining + ] + where + set' f v = set f (Just v) --- |Read the value of the /trace flag/. + +initialise :: IO Flags +initialise = parse `fmap` getArgs + where + defaults = Flags False False False False Nothing Nothing Nothing Nothing + parse = foldl parse1 defaults + parse1 opts this = + case filter (\(Option flag _) -> this `isPrefixOf` flag) allFlags of + [Option _ go] -> go opts + _ -> opts -- not specified, or ambiguous + + +-- Indicates which tracing messages are to be emitted, and which phases are to +-- be run. -- -queryTrace :: IO Bool -queryTrace = readIORef traceFlag +{-# NOINLINE options #-} +options :: IORef Flags +options = unsafePerformIO $ newIORef =<< initialise --- |Emit a trace message if the /trace flag/ is set. The first string indicates the location of --- the message. The second one is the message itself. The output is formatted to be on one line. +-- Query the status of a flag -- -traceLine :: String -> String -> IO () -traceLine header msg - = do { doTrace <- queryTrace - ; when doTrace - $ traceIO (header ++ ": " ++ msg) - } +queryFlag :: (Flags :-> a) -> IO a +queryFlag f = get f `fmap` readIORef options --- |Emit a trace message if the /trace flag/ is set. The first string indicates the location of --- the message. The second one is the message itself. The output is formatted over multiple --- lines. +-- Set the status of a debug flag -- -traceChunk :: String -> String -> IO () -traceChunk header msg - = do { doTrace <- queryTrace - ; when doTrace - $ traceIO (header ++ "\n " ++ msg) - } +setFlag :: (Flags :-> a) -> a -> IO () +setFlag f v = modifyIORef' options (set f v) --- |Perform 'traceLine' in a pure computation. + +-- Execute an action only if the corresponding flag is set -- -tracePure :: String -> String -> a -> a -tracePure header msg val = unsafePerformIO (traceLine header msg) `seq` val +when :: (Flags :-> Bool) -> IO () -> IO () +#ifdef ACCELERATE_DEBUG +when f action = do + enabled <- queryFlag f + if enabled then action + else return () +#else +when _ _ = return () +#endif + + +-- ----------------------------------------------------------------------------- +-- Trace messages + +-- Emit a trace message if the corresponding debug flag is set. +-- +traceMessage :: (Flags :-> Bool) -> String -> IO () +#ifdef ACCELERATE_DEBUG +traceMessage f str + = when f + $ do psec <- getCPUTime + let sec = fromIntegral psec * 1E-12 :: Double + traceIO $ showFFloat (Just 2) sec (':':str) +#else +traceMessage _ _ = return () +#endif + +-- Emit a message to the event log if the corresponding debug flag is set +-- +traceEvent :: (Flags :-> Bool) -> String -> IO () +#ifdef ACCELERATE_DEBUG +traceEvent f str = when f (traceEventIO str) +#else +traceEvent _ _ = return () +#endif + +-- Emit a trace message from a pure computation +-- +tracePure :: (Flags :-> Bool) -> String -> a -> a +#ifdef ACCELERATE_DEBUG +tracePure f msg next = unsafePerformIO (traceMessage f msg) `seq` next +#else +tracePure _ _ next = next +#endif + + +-- ----------------------------------------------------------------------------- +-- Recording statistics + +ruleFired, inline, knownBranch, betaReduce, substitution :: String -> a -> a +inline = annotate Inline +ruleFired = annotate RuleFired +knownBranch = annotate KnownBranch +betaReduce = annotate BetaReduce +substitution = annotate Substitution + +simplifierDone, fusionDone :: a -> a +simplifierDone = tick SimplifierDone +fusionDone = tick FusionDone + + +-- Add an entry to the statistics counters +-- +tick :: Tick -> a -> a +#ifdef ACCELERATE_DEBUG +tick t next = unsafePerformIO (modifyIORef' statistics (simplTick t)) `seq` next +#else +tick _ next = next +#endif + +-- Add an entry to the statistics counters with an annotation +-- +annotate :: (Id -> Tick) -> String -> a -> a +annotate name ctx = tick (name (Id ctx)) + + +-- Simplifier counts +-- ----------------- + +data SimplStats + = Simple {-# UNPACK #-} !Int -- when we don't want detailed stats + + | Detail { + ticks :: {-# UNPACK #-} !Int, -- total ticks + details :: !TickCount -- how many of each type + } + +instance Show SimplStats where + show = render . pprSimplCount + + +-- Stores the current statistics counters +-- +{-# NOINLINE statistics #-} +statistics :: IORef SimplStats +statistics = unsafePerformIO $ newIORef =<< initSimplCount + + +-- Initialise the statistics counters. If we are dumping the stats +-- (-ddump-simpl-stats) record extra information, else just a total tick count. +-- +initSimplCount :: IO SimplStats +#ifdef ACCELERATE_DEBUG +initSimplCount = do + d <- queryFlag dump_simpl_stats + return $! if d then Detail { ticks = 0, details = Map.empty } + else Simple 0 +#else +initSimplCount = return $! Simple 0 +#endif + +-- Reset the statistics counters. Do this at the beginning at each HOAS -> de +-- Bruijn conversion + optimisation pass. +-- +resetSimplCount :: IO () +#ifdef ACCELERATE_DEBUG +resetSimplCount = writeIORef statistics =<< initSimplCount +#else +resetSimplCount = return () +#endif + +-- Tick a counter +-- +simplTick :: Tick -> SimplStats -> SimplStats +simplTick _ (Simple n) = Simple (n+1) +simplTick t (Detail n dts) = Detail (n+1) (dts `addTick` t) + +-- Pretty print the tick counts. Remarkably reminiscent of GHC style... +-- +pprSimplCount :: SimplStats -> Doc +pprSimplCount (Simple n) = text "Total ticks:" <+> int n +pprSimplCount (Detail n dts) + = vcat [ text "Total ticks:" <+> int n + , text "" + , pprTickCount dts + ] + +simplCount :: IO Doc +simplCount = pprSimplCount `fmap` readIORef statistics + + +-- Ticks +-- ----- + +type TickCount = Map.Map Tick Int + +data Id = Id String + deriving (Eq, Ord) + +data Tick + = Inline Id + | RuleFired Id + | KnownBranch Id + | BetaReduce Id + | Substitution Id + + -- tick at each iteration + | SimplifierDone + | FusionDone + deriving (Eq, Ord) + + +addTick :: TickCount -> Tick -> TickCount +addTick tc t = + let x = 1 + Map.findWithDefault 0 t tc + in x `seq` Map.insert t x tc + +pprTickCount :: TickCount -> Doc +pprTickCount counts = + vcat (map pprTickGroup groups) + where + groups = groupBy sameTag (Map.toList counts) + sameTag = (==) `on` tickToTag . fst + +pprTickGroup :: [(Tick,Int)] -> Doc +pprTickGroup [] = error "pprTickGroup" +pprTickGroup group = + hang (int groupTotal <+> text groupName) + 2 (vcat [ int n <+> pprTickCtx t | (t,n) <- sortBy (flip (comparing snd)) group ]) + where + groupName = tickToStr (fst (head group)) + groupTotal = sum [n | (_,n) <- group] + +tickToTag :: Tick -> Int +tickToTag Inline{} = 0 +tickToTag RuleFired{} = 1 +tickToTag KnownBranch{} = 2 +tickToTag BetaReduce{} = 3 +tickToTag Substitution{} = 4 +tickToTag SimplifierDone = 99 +tickToTag FusionDone = 100 + +tickToStr :: Tick -> String +tickToStr Inline{} = "Inline" +tickToStr RuleFired{} = "RuleFired" +tickToStr KnownBranch{} = "KnownBranch" +tickToStr BetaReduce{} = "BetaReduce" +tickToStr Substitution{} = "Substitution" +tickToStr SimplifierDone = "SimplifierDone" +tickToStr FusionDone = "FusionDone" + +pprTickCtx :: Tick -> Doc +pprTickCtx (Inline v) = pprId v +pprTickCtx (RuleFired v) = pprId v +pprTickCtx (KnownBranch v) = pprId v +pprTickCtx (BetaReduce v) = pprId v +pprTickCtx (Substitution v) = pprId v +pprTickCtx SimplifierDone = empty +pprTickCtx FusionDone = empty + +pprId :: Id -> Doc +pprId (Id s) = text s + diff --git a/Data/Array/Accelerate/Internal/Check.hs b/Data/Array/Accelerate/Internal/Check.hs --- a/Data/Array/Accelerate/Internal/Check.hs +++ b/Data/Array/Accelerate/Internal/Check.hs @@ -18,12 +18,13 @@ -- * Bounds checking and assertion infrastructure Checks(..), doChecks, - error, check, assert, checkIndex, checkLength, checkSlice + error, check, warning, assert, checkIndex, checkLength, checkSlice ) where -import Prelude hiding( error ) -import qualified Prelude as P +import Prelude hiding ( error ) +import Debug.Trace +import qualified Prelude as P data Checks = Bounds | Unsafe | Internal deriving( Eq ) @@ -55,21 +56,33 @@ doChecks Unsafe = doUnsafeChecks doChecks Internal = doInternalChecks +message :: String -> Int -> Checks -> String -> String -> String +{-# INLINE message #-} +message file line kind loc msg + = unlines + $ (if kind == Internal + then (["" + ,"*** Internal error in package accelerate ***" + ,"*** Please submit a bug report at https://github.com/AccelerateHS/accelerate/issues"]++) + else id) + [ file ++ ":" ++ show line ++ " (" ++ loc ++ "): " ++ msg ] + error :: String -> Int -> Checks -> String -> String -> a +{-# INLINE error #-} error file line kind loc msg - = P.error . unlines $ - (if kind == Internal - then (["" - ,"*** Internal error in package accelerate ***" - ,"*** Please submit a bug report at https://github.com/mchakravarty/accelerate/issues"]++) - else id) - [ file ++ ":" ++ show line ++ " (" ++ loc ++ "): " ++ msg ] + = P.error (message file line kind loc msg) check :: String -> Int -> Checks -> String -> String -> Bool -> a -> a {-# INLINE check #-} check file line kind loc msg cond x | not (doChecks kind) || cond = x - | otherwise = error file line kind loc msg + | otherwise = error file line kind loc msg + +warning :: String -> Int -> Checks -> String -> String -> Bool -> a -> a +{-# INLINE warning #-} +warning file line kind loc msg cond x + | not (doChecks kind) || cond = x + | otherwise = trace (message file line kind loc msg) x assert_msg :: String assert_msg = "assertion failure" 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 @@ -1,9 +1,14 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} {-# OPTIONS_HADDOCK prune #-} -{-# LANGUAGE CPP, GADTs, BangPatterns, TypeOperators, PatternGuards #-} -{-# LANGUAGE TypeFamilies, ScopedTypeVariables, FlexibleContexts #-} -- | -- Module : Data.Array.Accelerate.Interpreter --- Copyright : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell +-- Copyright : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee +-- [2009..2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell -- License : BSD3 -- -- Maintainer : Manuel M T Chakravarty @@ -27,7 +32,7 @@ module Data.Array.Accelerate.Interpreter ( -- * Interpret an array expression - Arrays, run, stream, + Arrays, run, run1, stream, -- Internal (hidden) evalPrim, evalPrimConst, evalPrj @@ -44,15 +49,16 @@ -- friends import Data.Array.Accelerate.Type import Data.Array.Accelerate.Array.Data +import Data.Array.Accelerate.Array.Delayed import Data.Array.Accelerate.Array.Representation hiding ( sliceIndex ) import Data.Array.Accelerate.Array.Sugar ( - Z(..), (:.)(..), Array(..), ArraysR(..), Arrays, Scalar, Vector, Segments) + Z(..), (:.)(..), Array(..), Arrays, Scalar, Vector, Segments ) import Data.Array.Accelerate.AST import Data.Array.Accelerate.Tuple -import Data.Array.Accelerate.Array.Delayed hiding ( force, delay, Delayed ) +import Data.Array.Accelerate.Trafo.Substitution +import qualified Data.Array.Accelerate.Trafo.Sharing as Sharing import qualified Data.Array.Accelerate.Smart as Sugar import qualified Data.Array.Accelerate.Array.Sugar as Sugar -import qualified Data.Array.Accelerate.Array.Delayed as Sugar #include "accelerate.h" @@ -60,43 +66,30 @@ -- Program execution -- ----------------- --- |Run a complete embedded array program using the reference interpreter. +-- | Run a complete embedded array program using the reference interpreter. -- run :: Arrays a => Sugar.Acc a -> a -run = force . evalAcc . Sugar.convertAcc +run = force . evalAcc . Sharing.convertAcc True True True --- | Stream a lazily read list of input arrays through the given program, --- collecting results as we go + +-- | Prepare and run an embedded array program of one argument -- -stream :: (Arrays a, Arrays b) => (Sugar.Acc a -> Sugar.Acc b) -> [a] -> [b] -stream afun = map (run1 acc) +run1 :: (Arrays a, Arrays b) => (Sugar.Acc a -> Sugar.Acc b) -> a -> b +run1 afun = \a -> exec acc a where - acc = Sugar.convertAccFun1 afun + acc = Sharing.convertAccFun1 True True True afun - run1 :: Afun (a -> b) -> a -> b - run1 (Alam (Abody f)) = \a -> force (evalOpenAcc f (Empty `Push` a)) - run1 _ = error "Hey type checker! We can not get here!" + exec :: Afun (a -> b) -> a -> b + exec (Alam (Abody f)) a = force $ evalOpenAcc f (Empty `Push` a) + exec _ _ = error "Hey type checker! We can not get here!" --- Delayed arrays +-- | Stream a lazily read list of input arrays through the given program, +-- collecting results as we go -- -type Delayed a = Sugar.Delayed (Sugar.ArrRepr a) - -delay :: Arrays a => a -> Delayed a -delay arr = go (Sugar.arrays arr) (Sugar.fromArr arr) - where - go :: ArraysR a -> a -> Sugar.Delayed a - go ArraysRunit () = DelayedUnit - go ArraysRarray a = Sugar.delay a - go (ArraysRpair r1 r2) (a1, a2) = DelayedPair (go r1 a1) (go r2 a2) - -force :: forall a. Arrays a => Delayed a -> a -force arr = Sugar.toArr $ go (Sugar.arrays (undefined::a)) arr - where - go :: ArraysR a' -> Sugar.Delayed a' -> a' - go ArraysRunit DelayedUnit = () - go ArraysRarray a = Sugar.force a - go (ArraysRpair r1 r2) (DelayedPair d1 d2) = (go r1 d1, go r2 d2) +stream :: (Arrays a, Arrays b) => (Sugar.Acc a -> Sugar.Acc b) -> [a] -> [b] +stream afun arrs = let go = run1 afun + in map go arrs -- Array expression evaluation @@ -137,15 +130,18 @@ evalPreOpenAcc (Generate sh f) aenv = generateOp (evalExp sh aenv) (evalFun f aenv) -evalPreOpenAcc (Reshape e acc) aenv +evalPreOpenAcc (Transform sh ix f acc) aenv + = transformOp (evalExp sh aenv) (evalFun ix aenv) (evalFun f aenv) (evalOpenAcc acc aenv) + +evalPreOpenAcc (Reshape e acc) aenv = reshapeOp (evalExp e aenv) (evalOpenAcc acc aenv) evalPreOpenAcc (Replicate sliceIndex slix acc) aenv = replicateOp sliceIndex (evalExp slix aenv) (evalOpenAcc acc aenv) - -evalPreOpenAcc (Index sliceIndex acc slix) aenv - = indexOp sliceIndex (evalOpenAcc acc aenv) (evalExp slix aenv) +evalPreOpenAcc (Slice sliceIndex acc slix) aenv + = sliceOp sliceIndex (evalOpenAcc acc aenv) (evalExp slix aenv) + evalPreOpenAcc (Map f acc) aenv = mapOp (evalFun f aenv) (evalOpenAcc acc aenv) evalPreOpenAcc (ZipWith f acc1 acc2) aenv @@ -197,6 +193,13 @@ evalPreOpenAcc (Stencil2 sten bndy1 acc1 bndy2 acc2) aenv = stencil2Op (evalFun sten aenv) bndy1 (evalOpenAcc acc1 aenv) bndy2 (evalOpenAcc acc2 aenv) +-- The interpreter does not handle foreign functions so use the pure accelerate version +evalPreOpenAcc (Aforeign _ (Alam (Abody funAcc)) acc) aenv + = let !arr = force $ evalOpenAcc acc aenv + in evalOpenAcc funAcc (Empty `Push` arr) +evalPreOpenAcc (Aforeign _ _ _) _ + = error "This case is not possible" + -- Evaluate a closed array expressions -- evalAcc :: Acc a -> Delayed a @@ -215,20 +218,33 @@ unitOp :: Sugar.Elt e => e -> Delayed (Scalar e) unitOp e - = DelayedPair DelayedUnit - $ DelayedArray {shapeDA = (), repfDA = const (Sugar.fromElt e)} + = DelayedRpair DelayedRunit + $ DelayedRarray {shapeDA = (), repfDA = const (Sugar.fromElt e)} generateOp :: (Sugar.Shape dim, Sugar.Elt e) => dim -> (dim -> e) -> Delayed (Array dim e) generateOp sh rf - = DelayedPair DelayedUnit - $ DelayedArray (Sugar.fromElt sh) (Sugar.sinkFromElt rf) + = DelayedRpair DelayedRunit + $ DelayedRarray (Sugar.fromElt sh) (Sugar.sinkFromElt rf) +transformOp + :: (Sugar.Shape sh', Sugar.Elt b) + => sh' + -> (sh' -> sh) + -> (a -> b) + -> Delayed (Array sh a) + -> Delayed (Array sh' b) +transformOp sh' ix f (DelayedRpair DelayedRunit (DelayedRarray _sh rf)) + = DelayedRpair DelayedRunit + $ DelayedRarray (Sugar.fromElt sh') + (Sugar.sinkFromElt f . rf . Sugar.sinkFromElt ix) + + reshapeOp :: Sugar.Shape dim => dim -> Delayed (Array dim' e) -> Delayed (Array dim e) -reshapeOp newShape darr@(DelayedPair DelayedUnit (DelayedArray {shapeDA = oldShape})) +reshapeOp newShape darr@(DelayedRpair DelayedRunit (DelayedRarray {shapeDA = oldShape})) = let Array _ adata = force darr in BOUNDS_CHECK(check) "reshape" "shape mismatch" (Sugar.size newShape == size oldShape) @@ -242,8 +258,8 @@ -> slix -> Delayed (Array sl e) -> Delayed (Array dim e) -replicateOp sliceIndex slix (DelayedPair DelayedUnit (DelayedArray sh pf)) - = DelayedPair DelayedUnit (DelayedArray sh' (pf . pf')) +replicateOp sliceIndex slix (DelayedRpair DelayedRunit (DelayedRarray sh pf)) + = DelayedRpair DelayedRunit (DelayedRarray sh' (pf . pf')) where (sh', pf') = extend sliceIndex (Sugar.fromElt slix) sh @@ -261,7 +277,7 @@ in ((dim', sz), \(ix, _) -> f' ix) -indexOp :: (Sugar.Shape sl, Sugar.Elt slix) +sliceOp :: (Sugar.Shape sl, Sugar.Elt slix) => SliceIndex (Sugar.EltRepr slix) (Sugar.EltRepr sl) co @@ -269,8 +285,8 @@ -> Delayed (Array dim e) -> slix -> Delayed (Array sl e) -indexOp sliceIndex (DelayedPair DelayedUnit (DelayedArray sh pf)) slix - = DelayedPair DelayedUnit (DelayedArray sh' (pf . pf')) +sliceOp sliceIndex (DelayedRpair DelayedRunit (DelayedRarray sh pf)) slix + = DelayedRpair DelayedRunit (DelayedRarray sh' (pf . pf')) where (sh', pf') = restrict sliceIndex (Sugar.fromElt slix) sh @@ -286,24 +302,24 @@ restrict (SliceFixed sliceIdx) (slx, i) (sl, sz) = let (sl', f') = restrict sliceIdx slx sl in - BOUNDS_CHECK(checkIndex) "index" i sz $ (sl', \ix -> (f' ix, i)) + BOUNDS_CHECK(checkIndex) "slice" i sz $ (sl', \ix -> (f' ix, i)) mapOp :: Sugar.Elt e' => (e -> e') -> Delayed (Array dim e) -> Delayed (Array dim e') -mapOp f (DelayedPair DelayedUnit (DelayedArray sh rf)) - = DelayedPair DelayedUnit - $ DelayedArray sh (Sugar.sinkFromElt f . rf) +mapOp f (DelayedRpair DelayedRunit (DelayedRarray sh rf)) + = DelayedRpair DelayedRunit + $ DelayedRarray sh (Sugar.sinkFromElt f . rf) zipWithOp :: Sugar.Elt e3 => (e1 -> e2 -> e3) -> Delayed (Array dim e1) -> Delayed (Array dim e2) -> Delayed (Array dim e3) -zipWithOp f (DelayedPair DelayedUnit (DelayedArray sh1 rf1)) (DelayedPair DelayedUnit (DelayedArray sh2 rf2)) - = DelayedPair DelayedUnit - $ DelayedArray (sh1 `intersect` sh2) +zipWithOp f (DelayedRpair DelayedRunit (DelayedRarray sh1 rf1)) (DelayedRpair DelayedRunit (DelayedRarray sh2 rf2)) + = DelayedRpair DelayedRunit + $ DelayedRarray (sh1 `intersect` sh2) (\ix -> (Sugar.sinkFromElt2 f) (rf1 ix) (rf2 ix)) foldOp :: Sugar.Shape dim @@ -311,24 +327,24 @@ -> e -> Delayed (Array (dim:.Int) e) -> Delayed (Array dim e) -foldOp f e (DelayedPair DelayedUnit (DelayedArray (sh, n) rf)) +foldOp f e (DelayedRpair DelayedRunit (DelayedRarray (sh, n) rf)) | size sh == 0 - = DelayedPair DelayedUnit - $ DelayedArray (listToShape . map (max 1) . shapeToList $ sh) + = DelayedRpair DelayedRunit + $ DelayedRarray (listToShape . map (max 1) . shapeToList $ sh) (\_ -> Sugar.fromElt e) -- | otherwise - = DelayedPair DelayedUnit - $ DelayedArray sh + = DelayedRpair DelayedRunit + $ DelayedRarray sh (\ix -> iter ((), n) (\((), i) -> rf (ix, i)) (Sugar.sinkFromElt2 f) (Sugar.fromElt e)) fold1Op :: Sugar.Shape dim => (e -> e -> e) -> Delayed (Array (dim:.Int) e) -> Delayed (Array dim e) -fold1Op f (DelayedPair DelayedUnit (DelayedArray (sh, n) rf)) - = DelayedPair DelayedUnit - $ DelayedArray sh (\ix -> iter1 ((), n) (\((), i) -> rf (ix, i)) (Sugar.sinkFromElt2 f)) +fold1Op f (DelayedRpair DelayedRunit (DelayedRarray (sh, n) rf)) + = DelayedRpair DelayedRunit + $ DelayedRarray sh (\ix -> iter1 ((), n) (\((), i) -> rf (ix, i)) (Sugar.sinkFromElt2 f)) foldSegOp :: IntegralType i -> (e -> e -> e) @@ -345,10 +361,10 @@ -> Delayed (Array (dim:.Int) e) -> Delayed (Segments i) -> Delayed (Array (dim:.Int) e) -foldSegOp' f e (DelayedPair DelayedUnit (DelayedArray (sh, _n) rf)) seg@(DelayedPair DelayedUnit (DelayedArray shSeg rfSeg)) +foldSegOp' f e (DelayedRpair DelayedRunit (DelayedRarray (sh, _n) rf)) seg@(DelayedRpair DelayedRunit (DelayedRarray shSeg rfSeg)) = delay arr where - DelayedPair (DelayedPair DelayedUnit (DelayedArray _shSeg rfStarts)) _ = scanl'Op (+) 0 seg + DelayedRpair (DelayedRpair DelayedRunit (DelayedRarray _shSeg rfStarts)) _ = scanl'Op (+) 0 seg arr = Sugar.newArray (Sugar.toElt (sh, Sugar.toElt shSeg)) foldOne -- foldOne :: dim:.Int -> e @@ -379,11 +395,11 @@ -> Delayed (Array (dim:.Int) e) -> Delayed (Segments i) -> Delayed (Array (dim:.Int) e) -fold1SegOp' f (DelayedPair DelayedUnit (DelayedArray (sh, _n) rf)) seg@(DelayedPair DelayedUnit (DelayedArray shSeg rfSeg)) +fold1SegOp' f (DelayedRpair DelayedRunit (DelayedRarray (sh, _n) rf)) seg@(DelayedRpair DelayedRunit (DelayedRarray shSeg rfSeg)) = delay arr where - DelayedPair prefix _sum = scanl'Op (+) 0 seg - DelayedPair DelayedUnit (DelayedArray _shSeg rfStarts) = prefix + DelayedRpair prefix _sum = scanl'Op (+) 0 seg + DelayedRpair DelayedRunit (DelayedRarray _shSeg rfStarts) = prefix arr = Sugar.newArray (Sugar.toElt (sh, Sugar.toElt shSeg)) foldOne -- foldOne :: dim:.Int -> e @@ -408,7 +424,7 @@ -> e -> Delayed (Vector e) -> Delayed (Vector e) -scanlOp f e (DelayedPair DelayedUnit (DelayedArray sh rf)) +scanlOp f e (DelayedRpair DelayedRunit (DelayedRarray sh rf)) = delay $ adata `seq` Array ((), n + 1) adata where n = size sh @@ -417,27 +433,27 @@ (adata, _) = runArrayData $ do arr <- newArrayData (n + 1) final <- traverse arr 0 (Sugar.fromElt e) - writeArrayData arr n final + unsafeWriteArrayData arr n final return (arr, undefined) traverse :: MutableArrayData s (Sugar.EltRepr e) -> Int -> (Sugar.EltRepr e) -> ST s (Sugar.EltRepr e) traverse arr i v | i >= n = return v | otherwise = do - writeArrayData arr i v + unsafeWriteArrayData arr i v traverse arr (i + 1) (f' v (rf ((), i))) scanl'Op :: forall e. (e -> e -> e) -> e -> Delayed (Vector e) -> Delayed (Vector e, Scalar e) -scanl'Op f e (DelayedPair DelayedUnit (DelayedArray sh rf)) - = DelayedPair (delay $ adata `seq` Array sh adata) final +scanl'Op f e (DelayedRpair DelayedRunit (DelayedRarray sh rf)) + = DelayedRpair (delay $ adata `seq` Array sh adata) final where n = size sh f' = Sugar.sinkFromElt2 f -- - DelayedPair DelayedUnit final = unitOp (Sugar.toElt asum) + DelayedRpair DelayedRunit final = unitOp (Sugar.toElt asum) (adata, asum) = runArrayData $ do arr <- newArrayData n @@ -448,13 +464,13 @@ traverse arr i v | i >= n = return v | otherwise = do - writeArrayData arr i v + unsafeWriteArrayData arr i v traverse arr (i + 1) (f' v (rf ((), i))) scanl1Op :: forall e. (e -> e -> e) -> Delayed (Vector e) -> Delayed (Vector e) -scanl1Op f (DelayedPair DelayedUnit (DelayedArray sh rf)) +scanl1Op f (DelayedRpair DelayedRunit (DelayedRarray sh rf)) = delay $ adata `seq` Array sh adata where n = size sh @@ -470,18 +486,18 @@ | i >= n = return () | i == 0 = do let e = rf ((), i) - writeArrayData arr i e + unsafeWriteArrayData arr i e traverse arr (i + 1) e | otherwise = do let e = f' v (rf ((), i)) - writeArrayData arr i e + unsafeWriteArrayData arr i e traverse arr (i + 1) e scanrOp :: forall e. (e -> e -> e) -> e -> Delayed (Vector e) -> Delayed (Vector e) -scanrOp f e (DelayedPair DelayedUnit (DelayedArray sh rf)) +scanrOp f e (DelayedRpair DelayedRunit (DelayedRarray sh rf)) = delay $ adata `seq` Array ((), n + 1) adata where n = size sh @@ -490,27 +506,27 @@ (adata, _) = runArrayData $ do arr <- newArrayData (n + 1) final <- traverse arr n (Sugar.fromElt e) - writeArrayData arr 0 final + unsafeWriteArrayData arr 0 final return (arr, undefined) traverse :: MutableArrayData s (Sugar.EltRepr e) -> Int -> (Sugar.EltRepr e) -> ST s (Sugar.EltRepr e) traverse arr i v | i == 0 = return v | otherwise = do - writeArrayData arr i v + unsafeWriteArrayData arr i v traverse arr (i - 1) (f' v (rf ((), i-1))) scanr'Op :: forall e. (e -> e -> e) -> e -> Delayed (Vector e) -> Delayed (Vector e, Scalar e) -scanr'Op f e (DelayedPair DelayedUnit (DelayedArray sh rf)) - = DelayedPair (delay $ adata `seq` Array sh adata) final +scanr'Op f e (DelayedRpair DelayedRunit (DelayedRarray sh rf)) + = DelayedRpair (delay $ adata `seq` Array sh adata) final where n = size sh f' = Sugar.sinkFromElt2 f -- - DelayedPair DelayedUnit final = unitOp (Sugar.toElt asum) + DelayedRpair DelayedRunit final = unitOp (Sugar.toElt asum) (adata, asum) = runArrayData $ do arr <- newArrayData n @@ -521,13 +537,13 @@ traverse arr i v | i < 0 = return v | otherwise = do - writeArrayData arr i v + unsafeWriteArrayData arr i v traverse arr (i - 1) (f' v (rf ((), i))) scanr1Op :: forall e. (e -> e -> e) -> Delayed (Vector e) -> Delayed (Vector e) -scanr1Op f (DelayedPair DelayedUnit (DelayedArray sh rf)) +scanr1Op f (DelayedRpair DelayedRunit (DelayedRarray sh rf)) = delay $ adata `seq` Array sh adata where n = size sh @@ -543,11 +559,11 @@ | i < 0 = return () | i == (n - 1) = do let e = rf ((), i) - writeArrayData arr i e + unsafeWriteArrayData arr i e traverse arr (i - 1) e | otherwise = do let e = f' v (rf ((), i)) - writeArrayData arr i e + unsafeWriteArrayData arr i e traverse arr (i - 1) e permuteOp :: (e -> e -> e) @@ -555,20 +571,20 @@ -> (dim -> dim') -> Delayed (Array dim e) -> Delayed (Array dim' e) -permuteOp f (DelayedPair DelayedUnit (DelayedArray dftsSh dftsPf)) - p (DelayedPair DelayedUnit (DelayedArray sh pf)) +permuteOp f (DelayedRpair DelayedRunit (DelayedRarray dftsSh dftsPf)) + p (DelayedRpair DelayedRunit (DelayedRarray sh pf)) = delay $ adata `seq` Array dftsSh adata - where + where f' = Sugar.sinkFromElt2 f -- - (adata, _) + (adata, _) = runArrayData $ do -- new array in target dimension arr <- newArrayData (size dftsSh) -- initialise it with the default values - let write ix = writeArrayData arr (index dftsSh ix) (dftsPf ix) + let write ix = unsafeWriteArrayData arr (toIndex dftsSh ix) (dftsPf ix) iter dftsSh write (>>) (return ()) -- traverse the source dimension and project each element into @@ -577,9 +593,9 @@ let update ix = do let target = (Sugar.sinkFromElt p) ix unless (target == ignore) $ do - let i = index dftsSh target - e <- readArrayData arr i - writeArrayData arr i (pf ix `f'` e) + let i = toIndex dftsSh target + e <- unsafeReadArrayData arr i + unsafeWriteArrayData arr i (pf ix `f'` e) iter sh update (>>) (return ()) -- return the updated array @@ -590,18 +606,18 @@ -> (dim' -> dim) -> Delayed (Array dim e) -> Delayed (Array dim' e) -backpermuteOp sh' p (DelayedPair DelayedUnit (DelayedArray _sh rf)) - = DelayedPair DelayedUnit - $ DelayedArray (Sugar.fromElt sh') (rf . Sugar.sinkFromElt p) +backpermuteOp sh' p (DelayedRpair DelayedRunit (DelayedRarray _sh rf)) + = DelayedRpair DelayedRunit + $ DelayedRarray (Sugar.fromElt sh') (rf . Sugar.sinkFromElt p) stencilOp :: forall dim e e' stencil. (Sugar.Elt e, Sugar.Elt e', Stencil dim e stencil) => (stencil -> e') -> Boundary (Sugar.EltRepr e) -> Delayed (Array dim e) -> Delayed (Array dim e') -stencilOp sten bndy (DelayedPair DelayedUnit (DelayedArray sh rf)) - = DelayedPair DelayedUnit - $ DelayedArray sh rf' +stencilOp sten bndy (DelayedRpair DelayedRunit (DelayedRarray sh rf)) + = DelayedRpair DelayedRunit + $ DelayedRarray sh rf' where rf' = Sugar.sinkFromElt (sten . stencilAccess rfBounded) @@ -620,9 +636,9 @@ -> Boundary (Sugar.EltRepr e2) -> Delayed (Array dim e2) -> Delayed (Array dim e') -stencil2Op sten bndy1 (DelayedPair DelayedUnit (DelayedArray sh1 rf1)) - bndy2 (DelayedPair DelayedUnit (DelayedArray sh2 rf2)) - = DelayedPair DelayedUnit (DelayedArray (sh1 `intersect` sh2) rf') +stencil2Op sten bndy1 (DelayedRpair DelayedRunit (DelayedRarray sh1 rf1)) + bndy2 (DelayedRpair DelayedRunit (DelayedRarray sh2 rf2)) + = DelayedRpair DelayedRunit (DelayedRarray (sh1 `intersect` sh2) rf') where rf' = Sugar.sinkFromElt (\ix -> sten (stencilAccess rf1Bounded ix) (stencilAccess rf2Bounded ix)) @@ -656,7 +672,7 @@ -- Evaluate an open expression -- --- NB: The implementation of 'IndexScalar' and 'Shape' demonstrate clearly why +-- NB: The implementation of 'Index' and 'Shape' demonstrate clearly why -- array expressions must be hoisted out of scalar expressions before code -- execution. If these operations are in the body of a function that -- gets mapped over an array, the array argument would be forced many times @@ -695,30 +711,94 @@ evalOpenExp (IndexAny) _ _ = Sugar.Any -evalOpenExp (Cond c t e) env aenv +evalOpenExp (IndexSlice sliceIndex slix sh) env aenv + = Sugar.toElt + $ restrict sliceIndex (Sugar.fromElt $ evalOpenExp slix env aenv) + (Sugar.fromElt $ evalOpenExp sh env aenv) + where + restrict :: SliceIndex slix sl co sh -> slix -> sh -> sl + restrict SliceNil () () = () + restrict (SliceAll sliceIdx) (slx, ()) (sl, sz) + = let sl' = restrict sliceIdx slx sl + in (sl', sz) + restrict (SliceFixed sliceIdx) (slx, _i) (sl, _sz) + = restrict sliceIdx slx sl + +evalOpenExp (IndexFull sliceIndex slix sh) env aenv + = Sugar.toElt + $ extend sliceIndex (Sugar.fromElt $ evalOpenExp slix env aenv) + (Sugar.fromElt $ evalOpenExp sh env aenv) + where + extend :: SliceIndex slix sl co sh -> slix -> sl -> sh + extend SliceNil () () = () + extend (SliceAll sliceIdx) (slx, ()) (sl, sz) + = let sh' = extend sliceIdx slx sl + in (sh', sz) + extend (SliceFixed sliceIdx) (slx, sz) sl + = let sh' = extend sliceIdx slx sl + in (sh', sz) + +evalOpenExp (ToIndex sh ix) env aenv + = Sugar.toIndex (evalOpenExp sh env aenv) (evalOpenExp ix env aenv) + +evalOpenExp (FromIndex sh ix) env aenv + = Sugar.fromIndex (evalOpenExp sh env aenv) (evalOpenExp ix env aenv) + +evalOpenExp (Cond c t e) env aenv = if evalOpenExp c env aenv then evalOpenExp t env aenv else evalOpenExp e env aenv +evalOpenExp (Iterate limit loop seed) env aenv + = let f = evalOpenFun (Lam (Body loop)) env aenv + x = evalOpenExp seed env aenv + n = evalOpenExp limit env aenv + -- + go !i !acc | i >= n = acc + | otherwise = go (i+1) (f acc) + in go 0 x + evalOpenExp (PrimConst c) _ _ = evalPrimConst c -evalOpenExp (PrimApp p arg) env aenv +evalOpenExp (PrimApp p arg) env aenv = evalPrim p (evalOpenExp arg env aenv) -evalOpenExp (IndexScalar acc ix) env aenv +evalOpenExp (Index acc ix) env aenv = case evalOpenAcc acc aenv of - DelayedPair DelayedUnit (DelayedArray sh pf) -> + DelayedRpair DelayedRunit (DelayedRarray sh pf) -> let ix' = Sugar.fromElt $ evalOpenExp ix env aenv in - index sh ix' `seq` (Sugar.toElt $ pf ix') + toIndex sh ix' `seq` (Sugar.toElt $ pf ix') -- FIXME: This is ugly, but (possibly) needed to -- ensure bounds checking -evalOpenExp (Shape acc) _ aenv +evalOpenExp (LinearIndex acc i) env aenv = case evalOpenAcc acc aenv of - DelayedPair DelayedUnit (DelayedArray sh _) -> Sugar.toElt sh + DelayedRpair DelayedRunit (DelayedRarray sh pf) -> + let i' = evalOpenExp i env aenv + v = pf (fromIndex sh i') + in Sugar.toElt v -evalOpenExp (ShapeSize sh) env aenv = size $ Sugar.fromElt $ evalOpenExp sh env aenv +evalOpenExp (Shape acc) _ aenv + = case evalOpenAcc acc aenv of + DelayedRpair DelayedRunit (DelayedRarray sh _) -> Sugar.toElt sh + +evalOpenExp (ShapeSize sh) env aenv + = Sugar.size (evalOpenExp sh env aenv) + +evalOpenExp (Intersect sh1 sh2) env aenv + = Sugar.intersect (evalOpenExp sh1 env aenv) (evalOpenExp sh2 env aenv) + +evalOpenExp (Foreign _ f e) env aenv + = evalOpenExp e' env aenv + where + wExp :: Idx ((),a) t -> Idx (env,a) t + wExp ZeroIdx = ZeroIdx + wExp _ = INTERNAL_ERROR(error) "wExp" "unreachable case" + + e' = case f of + (Lam (Body b)) -> Let e $ weakenEA rebuildOpenAcc undefined (weakenE wExp b) + _ -> INTERNAL_ERROR(error) "travE" "unreachable case" -- Evaluate a closed expression -- 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 @@ -1,9 +1,17 @@ -{-# LANGUAGE TypeOperators, FlexibleContexts, TypeFamilies, RankNTypes, ScopedTypeVariables #-} -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} {-# OPTIONS_GHC -fno-warn-missing-methods -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.Language --- Copyright : [2009..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell +-- Copyright : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee +-- [2009..2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell -- License : BSD3 -- -- Maintainer : Manuel M T Chakravarty @@ -59,13 +67,30 @@ -- ** Stencil operations stencil, stencil2, + -- ** Foreign functions + foreignAcc, foreignAcc2, foreignAcc3, + foreignExp, foreignExp2, foreignExp3, + -- ** Pipelining (>->), -- ** Array-level flow-control cond, (?|), - -- ** Lifting and unlifting + -- ** Lifting and Unlifting + -- | A value of type `Int` is a plain Haskell value (unlifted), + -- whereas an @Exp Int@ is a /lifted/ value, that is, an integer + -- lifted into the domain of expressions (an abstract syntax tree + -- in disguise). Both `Acc` and `Exp` are /surface types/ into + -- which values may be lifted. + -- + -- In general an @Exp Int@ cannot be unlifted into an `Int`, + -- because the actual number will not be available until a later stage of + -- execution (e.g. GPU execution, when `run` is called). However, + -- in some cases unlifting makes sense. For example, unlifting + -- can convert unpack an expression of tuple type into a tuple of + -- expressions; those expressions, at runtime, will become tuple + -- dereferences. Lift(..), Unlift(..), lift1, lift2, ilift1, ilift2, -- ** Tuple construction and destruction @@ -73,12 +98,13 @@ -- ** Index construction and destruction index0, index1, unindex1, index2, unindex2, + indexHead, indexTail, toIndex, fromIndex, -- ** Conditional expressions (?), -- ** Array operations with a scalar result - (!), the, shape, size, shapeSize, + (!), (!!), the, null, shape, size, shapeSize, -- ** Methods of H98 classes that we need to redefine as their signatures change (==*), (/=*), (<*), (<=*), (>*), (>=*), max, min, @@ -102,9 +128,10 @@ ) where -- avoid clashes with Prelude functions -import Prelude hiding (replicate, zip, unzip, map, scanl, scanl1, scanr, scanr1, zipWith, - filter, max, min, not, fst, snd, curry, uncurry, - truncate, round, floor, ceiling, fromIntegral) +import Prelude hiding ( + (!!), replicate, zip, unzip, map, scanl, scanl1, scanr, scanr1, zipWith, + filter, max, min, not, fst, snd, curry, uncurry, null, truncate, round, floor, + ceiling, fromIntegral) -- standard libraries import Data.Bits (Bits((.&.), (.|.), xor, complement)) @@ -112,28 +139,31 @@ -- friends import Data.Array.Accelerate.Type import Data.Array.Accelerate.Tuple -import Data.Array.Accelerate.Array.Sugar hiding ((!), ignore, shape, size, index) -import qualified Data.Array.Accelerate.Array.Sugar as Sugar import Data.Array.Accelerate.Smart +import Data.Array.Accelerate.Array.Sugar hiding ((!), ignore, shape, size, toIndex, fromIndex) +import qualified Data.Array.Accelerate.Array.Sugar as Sugar -- Array introduction -- ------------------ --- |Array inlet: makes an array available for processing using the Accelerate --- language; triggers asynchronous host->device transfer if necessary. +-- | Array inlet: makes an array available for processing using the Accelerate +-- language. -- +-- Depending upon the backend used to execute array computations, this may +-- trigger (asynchronous) data transfer. +-- use :: Arrays arrays => arrays -> Acc arrays use = Acc . Use --- |Scalar inlet: injects a scalar (or a tuple of scalars) into a singleton +-- | Scalar inlet: injects a scalar (or a tuple of scalars) into a singleton -- array for use in the Accelerate language. -- unit :: Elt e => Exp e -> Acc (Scalar e) unit = Acc . Unit --- |Replicate an array across one or more dimensions as specified by the --- *generalised* array index provided as the first argument. +-- | Replicate an array across one or more dimensions as specified by the +-- /generalised/ array index provided as the first argument. -- -- For example, assuming 'arr' is a vector (one-dimensional array), -- @@ -148,7 +178,7 @@ -> Acc (Array (FullShape slix) e) replicate = Acc $$ Replicate --- |Construct a new array by applying a function to each index. +-- | Construct a new array by applying a function to each index. -- -- For example, the following will generate a one-dimensional array -- (`Vector`) of three floating point numbers: @@ -174,7 +204,8 @@ -- Shape manipulation -- ------------------ --- |Change the shape of an array without altering its contents, where +-- | Change the shape of an array without altering its contents. The 'size' of +-- the source and result arrays must be identical. -- -- > precondition: size ix == size ix' -- @@ -187,20 +218,29 @@ -- 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 --- all dimensions 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. -- +-- This can be used to /cut out/ entire dimensions. The opposite of +-- `replicate`. For example, if 'mat' is a two dimensional array, the +-- following will select a specific row and yield a one dimensional +-- result: +-- +-- > slice mat (constant (Z :. (2::Int) :. All)) +-- +-- A fully specified index (with no `All`s) would return a single +-- element (zero dimensional array). slice :: (Slice slix, Elt e) => Acc (Array (FullShape slix) e) -> Exp slix -> Acc (Array (SliceShape slix) e) -slice = Acc $$ Index +slice = Acc $$ Slice -- Map-like functions -- ------------------ --- |Apply the given function element-wise to the given array. +-- | Apply the given function element-wise to the given array. -- map :: (Shape ix, Elt a, Elt b) => (Exp a -> Exp b) @@ -208,7 +248,7 @@ -> Acc (Array ix b) map = Acc $$ Map --- |Apply the given binary function element-wise to the two arrays. The extent of the resulting +-- | Apply the given binary function element-wise to the two arrays. The extent of the resulting -- array is the intersection of the extents of the two source arrays. -- zipWith :: (Shape ix, Elt a, Elt b, Elt c) @@ -221,8 +261,9 @@ -- Reductions -- ---------- --- |Reduction of the innermost dimension of an array of arbitrary rank. The first argument needs to --- be an /associative/ function to enable an efficient parallel implementation. +-- | Reduction of the innermost dimension of an array of arbitrary rank. The +-- first argument needs to be an /associative/ function to enable an efficient +-- parallel implementation. -- fold :: (Shape ix, Elt a) => (Exp a -> Exp a -> Exp a) @@ -231,8 +272,9 @@ -> Acc (Array ix a) fold = Acc $$$ Fold --- |Variant of 'fold' that requires the reduced array to be non-empty and doesn't need an default --- value. +-- | Variant of 'fold' that requires the reduced array to be non-empty and +-- doesn't need an default value. The first argument needs to be an +-- /associative/ function to enable an efficient parallel implementation. -- fold1 :: (Shape ix, Elt a) => (Exp a -> Exp a -> Exp a) @@ -240,11 +282,12 @@ -> Acc (Array ix a) fold1 = Acc $$ Fold1 --- |Segmented reduction along the innermost dimension. Performs one individual reduction per --- segment of the source array. These reductions proceed in parallel. +-- | Segmented reduction along the innermost dimension. Performs one individual +-- reduction per segment of the source array. These reductions proceed in +-- parallel. -- --- The source array must have at least rank 1. The 'Segments' array determines the lengths of the --- logical sub-arrays, each of which is folded separately. +-- The source array must have at least rank 1. The 'Segments' array determines +-- the lengths of the logical sub-arrays, each of which is folded separately. -- foldSeg :: (Shape ix, Elt a, Elt i, IsIntegral i) => (Exp a -> Exp a -> Exp a) @@ -254,11 +297,11 @@ -> Acc (Array (ix:.Int) a) foldSeg = Acc $$$$ FoldSeg --- |Variant of 'foldSeg' that requires /all/ segments of the reduced array to be non-empty and --- doesn't need a default value. +-- | Variant of 'foldSeg' that requires /all/ segments of the reduced array to +-- be non-empty and doesn't need a default value. -- --- The source array must have at least rank 1. The 'Segments' array determines the lengths of the --- logical sub-arrays, each of which is folded separately. +-- The source array must have at least rank 1. The 'Segments' array determines +-- the lengths of the logical sub-arrays, each of which is folded separately. -- fold1Seg :: (Shape ix, Elt a, Elt i, IsIntegral i) => (Exp a -> Exp a -> Exp a) @@ -270,9 +313,10 @@ -- Scan functions -- -------------- --- |'Data.List'-style left-to-right scan, but with the additional restriction that the first --- argument needs to be an /associative/ function to enable an efficient parallel implementation. --- The initial value (second argument) may be arbitrary. +-- | Data.List style left-to-right scan, but with the additional restriction +-- that the first argument needs to be an /associative/ function to enable an +-- efficient parallel implementation. The initial value (second argument) may be +-- arbitrary. -- scanl :: Elt a => (Exp a -> Exp a -> Exp a) @@ -281,10 +325,10 @@ -> Acc (Vector a) scanl = Acc $$$ Scanl --- |Variant of 'scanl', where the final result of the reduction is returned separately. --- Denotationally, we have +-- | Variant of 'scanl', where the final result of the reduction is returned +-- separately. Denotationally, we have -- --- > scanl' f e arr = (crop 0 (len - 1) res, unit (res!len)) +-- > scanl' f e arr = (init res, unit (res!len)) -- > where -- > len = shape arr -- > res = scanl f e arr @@ -296,13 +340,11 @@ -> (Acc (Vector a), Acc (Scalar a)) scanl' = unlift . Acc $$$ Scanl' --- |'Data.List' style left-to-right scan without an initial value (aka inclusive scan). Again, the --- first argument needs to be an /associative/ function. Denotationally, we have +-- | Data.List style left-to-right scan without an initial value (aka inclusive +-- scan). Again, the first argument needs to be an /associative/ function. +-- Denotationally, we have -- --- > scanl1 f e arr = crop 1 len res --- > where --- > len = shape arr --- > res = scanl f e arr +-- > scanl1 f e arr = tail (scanl f e arr) -- scanl1 :: Elt a => (Exp a -> Exp a -> Exp a) @@ -310,7 +352,7 @@ -> Acc (Vector a) scanl1 = Acc $$ Scanl1 --- |Right-to-left variant of 'scanl'. +-- | Right-to-left variant of 'scanl'. -- scanr :: Elt a => (Exp a -> Exp a -> Exp a) @@ -319,7 +361,7 @@ -> Acc (Vector a) scanr = Acc $$$ Scanr --- |Right-to-left variant of 'scanl''. +-- | Right-to-left variant of 'scanl''. -- scanr' :: Elt a => (Exp a -> Exp a -> Exp a) @@ -328,7 +370,7 @@ -> (Acc (Vector a), Acc (Scalar a)) scanr' = unlift . Acc $$$ Scanr' --- |Right-to-left variant of 'scanl1'. +-- | Right-to-left variant of 'scanl1'. -- scanr1 :: Elt a => (Exp a -> Exp a -> Exp a) @@ -339,13 +381,13 @@ -- Permutations -- ------------ --- |Forward permutation specified by an index mapping. The result array is +-- | Forward permutation specified by an index mapping. The result array is -- initialised with the given defaults and any further values that are permuted -- into the result array are added to the current value using the given -- combination function. -- -- The combination function must be /associative/. Elements that are mapped to --- the magic value 'ignore' by the permutation function are being dropped. +-- the magic value 'ignore' by the permutation function are dropped. -- permute :: (Shape ix, Shape ix', Elt a) => (Exp a -> Exp a -> Exp a) -- ^combination function @@ -355,7 +397,8 @@ -> Acc (Array ix' a) permute = Acc $$$$ Permute --- |Backward permutation +-- | Backward permutation specified by an index mapping from the destination +-- array specifying which element of the source array to read. -- backpermute :: (Shape ix, Shape ix', Elt a) => Exp ix' -- ^shape of the result array @@ -410,8 +453,8 @@ -> Acc (Array ix b) -- ^destination array stencil = Acc $$$ Stencil --- |Map a binary stencil of an array. The extent of the resulting array is the intersection of --- the extents of the two source arrays. +-- | Map a binary stencil of an array. The extent of the resulting array is the +-- intersection of the extents of the two source arrays. -- stencil2 :: (Shape ix, Elt a, Elt b, Elt c, Stencil ix a stencil1, @@ -424,11 +467,74 @@ -> Acc (Array ix c) -- ^destination array stencil2 = Acc $$$$$ Stencil2 +-- Foreign function calling +-- ------------------------ +-- | Call a foreign function. The form the function takes is dependent on the backend being used. +-- The arguments are passed as either a single array or as a tuple of arrays. In addition a pure +-- Accelerate version of the function needs to be provided to support backends other than the one +-- being targeted. +foreignAcc :: (Arrays acc, Arrays res, Foreign ff) + => ff acc res + -> (Acc acc -> Acc res) + -> Acc acc + -> Acc res +foreignAcc = Acc $$$ Aforeign + +-- | Call a foreign function with foreign implementations for two different backends. +foreignAcc2 :: (Arrays acc, Arrays res, Foreign ff1, Foreign ff2) + => ff1 acc res + -> ff2 acc res + -> (Acc acc -> Acc res) + -> Acc acc + -> Acc res +foreignAcc2 ff1 = Acc $$$ Aforeign ff1 $$ Acc $$$ Aforeign + +-- | Call a foreign function with foreign implementations for three different backends. +foreignAcc3 :: (Arrays acc, Arrays res, Foreign ff1, Foreign ff2, Foreign ff3) + => ff1 acc res + -> ff2 acc res + -> ff3 acc res + -> (Acc acc -> Acc res) + -> Acc acc + -> Acc res +foreignAcc3 ff1 ff2 = Acc $$$ Aforeign ff1 $$ Acc $$$ Aforeign ff2 $$ Acc $$$ Aforeign + +-- | Call a foreign expression function. The form the function takes is dependent on the +-- backend being used. The arguments are passed as either a single scalar element or as a +-- tuple of elements. In addition a pure Accelerate version of the function needs to be +-- provided to support backends other than the one being targeted. +foreignExp :: (Elt e, Elt res, Foreign ff) + => ff e res + -> (Exp e -> Exp res) + -> Exp e + -> Exp res +foreignExp = Exp $$$ Foreign + +-- | Call a foreign function with foreign implementations for two different backends. +foreignExp2 :: (Elt e, Elt res, Foreign ff1, Foreign ff2) + => ff1 e res + -> ff2 e res + -> (Exp e -> Exp res) + -> Exp e + -> Exp res +foreignExp2 ff1 = Exp $$$ Foreign ff1 $$ Exp $$$ Foreign + +-- | Call a foreign function with foreign implementations for three different backends. +foreignExp3 :: (Elt e, Elt res, Foreign ff1, Foreign ff2, Foreign ff3) + => ff1 e res + -> ff2 e res + -> ff3 e res + -> (Exp e -> Exp res) + -> Exp e + -> Exp res +foreignExp3 ff1 ff2 = Exp $$$ Foreign ff1 $$ Exp $$$ Foreign ff2 $$ Exp $$$ Foreign + + -- Composition of array computations -- --------------------------------- --- |Pipelining of two array computations. +-- | Pipelining of two array computations. -- -- Denotationally, we have -- @@ -446,7 +552,7 @@ -- Flow control constructs -- ----------------------- --- |An array-level if-then-else construct. +-- | An array-level if-then-else construct. -- cond :: (Arrays a) => Exp Bool -- ^if-condition @@ -455,7 +561,7 @@ -> Acc a cond = Acc $$$ Acond --- |Infix version of 'cond'. +-- | Infix version of 'cond'. -- infix 0 ?| (?|) :: (Arrays a) => Exp Bool -> (Acc a, Acc a) -> Acc a @@ -465,7 +571,16 @@ -- Lifting surface expressions -- --------------------------- +-- | The class of types @e@ which can be lifted into @c@. class Lift c e where + -- | An associated-type (i.e. a type-level function) that strips all + -- instances of surface type constructors @c@ from the input type @e@. + -- + -- For example, the tuple types @(Exp Int, Int)@ and @(Int, Exp + -- Int)@ have the same \"Plain\" representation. That is, the + -- following type equality holds: + -- + -- @Plain (Exp Int, Int) ~ (Int,Int) ~ Plain (Int, Exp Int)@ type Plain e -- | Lift the given value into a surface type 'c' --- either 'Exp' for scalar @@ -474,6 +589,7 @@ -- lift :: e -> c (Plain e) +-- | A limited subset of types which can be lifted, can also be unlifted. class Lift c e => Unlift c e where -- | Unlift the outermost constructor through the surface type. This is only @@ -513,6 +629,9 @@ instance (Elt e, Slice (Plain ix), Unlift Exp ix) => Unlift Exp (ix :. Exp e) where unlift e = unlift (Exp $ IndexTail e) :. Exp (IndexHead e) +instance (Elt e, Slice ix) => Unlift Exp (Exp ix :. Exp e) where + unlift e = (Exp $ IndexTail e) :. Exp (IndexHead e) + instance Shape sh => Lift Exp (Any sh) where type Plain (Any sh) = Any sh lift Any = Exp $ IndexAny @@ -831,23 +950,28 @@ -- |Lift a unary function into 'Exp'. -- lift1 :: (Unlift Exp e1, Lift Exp e2) - => (e1 -> e2) -> Exp (Plain e1) -> Exp (Plain e2) + => (e1 -> e2) + -> Exp (Plain e1) + -> Exp (Plain e2) lift1 f = lift . f . unlift -- |Lift a binary function into 'Exp'. -- lift2 :: (Unlift Exp e1, Unlift Exp e2, Lift Exp e3) - => (e1 -> e2 -> e3) -> Exp (Plain e1) -> Exp (Plain e2) -> Exp (Plain e3) + => (e1 -> e2 -> e3) + -> Exp (Plain e1) + -> Exp (Plain e2) + -> Exp (Plain e3) lift2 f x y = lift $ f (unlift x) (unlift y) -- |Lift a unary function to a computation over rank-1 indices. -- -ilift1 :: (Exp Int -> Exp Int) -> Exp (Z :. Int) -> Exp (Z :. Int) +ilift1 :: (Exp Int -> Exp Int) -> Exp DIM1 -> Exp DIM1 ilift1 f = lift1 (\(Z:.i) -> Z :. f i) -- |Lift a binary function to a computation over rank-1 indices. -- -ilift2 :: (Exp Int -> Exp Int -> Exp Int) -> Exp (Z :. Int) -> Exp (Z :. Int) -> Exp (Z :. Int) +ilift2 :: (Exp Int -> Exp Int -> Exp Int) -> Exp DIM1 -> Exp DIM1 -> Exp DIM1 ilift2 f = lift2 (\(Z:.i) (Z:.j) -> Z :. f i j) @@ -855,22 +979,22 @@ -- |Extract the first component of a pair. -- -fst :: forall a b. (Elt a, Elt b) => Exp (a, b) -> Exp a -fst e = let (x, _:: Exp b) = unlift e in x +fst :: forall f a b. Unlift f (f a, f b) => f (Plain (f a), Plain (f b)) -> f a +fst e = let (x, _:: f b) = unlift e in x -- |Extract the second component of a pair. -- -snd :: forall a b. (Elt a, Elt b) => Exp (a, b) -> Exp b -snd e = let (_ :: Exp a, y) = unlift e in y +snd :: forall f a b. Unlift f (f a, f b) => f (Plain (f a), Plain (f b)) -> f b +snd e = let (_::f a, y) = unlift e in y -- |Converts an uncurried function to a curried function. -- -curry :: (Elt a, Elt b) => (Exp (a, b) -> Exp c) -> Exp a -> Exp b -> Exp c +curry :: Lift f (f a, f b) => (f (Plain (f a), Plain (f b)) -> f c) -> f a -> f b -> f c curry f x y = f (lift (x, y)) -- |Converts a curried function to a function on pairs. -- -uncurry :: (Elt a, Elt b) => (Exp a -> Exp b -> Exp c) -> Exp (a, b) -> Exp c +uncurry :: Unlift f (f a, f b) => (f a -> f b -> f c) -> f (Plain (f a), Plain (f b)) -> f c uncurry f t = let (x, y) = unlift t in f x y -- Helpers to lift shapes and indices @@ -882,29 +1006,58 @@ -- |Turn an 'Int' expression into a rank-1 indexing expression. -- -index1 :: Exp Int -> Exp (Z:. Int) -index1 = lift . (Z:.) +index1 :: Elt i => Exp i -> Exp (Z :. i) +index1 i = lift (Z :. i) -- |Turn a rank-1 indexing expression into an 'Int' expression. -- -unindex1 :: Exp (Z:. Int) -> Exp Int -unindex1 ix = let Z:.i = unlift ix in i +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 :: Exp Int -> Exp Int -> Exp DIM2 +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 :: Exp DIM2 -> Exp (Int, Int) -unindex2 ix = let Z :. i :. j = unlift ix in lift ((i, j) :: (Exp Int, Exp Int)) +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) +-- | Get the outermost dimension of a shape +-- +indexHead :: Slice sh => Exp (sh :. Int) -> Exp Int +indexHead = Exp . IndexHead +-- | Get all but the outermost element of a shape +-- +indexTail :: Slice sh => Exp (sh :. Int) -> Exp sh +indexTail = Exp . IndexTail + +-- | Map a multi-dimensional index into a linear, row-major representation of an +-- array. The first argument is the array shape, the second is the index. +-- +toIndex :: Shape sh => Exp sh -> Exp sh -> Exp Int +toIndex = Exp $$ ToIndex + +-- | Inverse of 'fromIndex' +-- +fromIndex :: Shape sh => Exp sh -> Exp Int -> Exp sh +fromIndex = Exp $$ FromIndex + + -- Conditional expressions -- ----------------------- --- |Conditional expression. +-- |Conditional expression. If the predicate evaluates to 'True', the first +-- component of the tuple is returned, else the second. -- infix 0 ? (?) :: Elt t => Exp Bool -> (Exp t, Exp t) -> Exp t @@ -914,29 +1067,39 @@ -- Array operations with a scalar result -- ------------------------------------- --- |Expression form that extracts a scalar from an array. +-- |Expression form that extracts a scalar from an array -- infixl 9 ! (!) :: (Shape ix, Elt e) => Acc (Array ix e) -> Exp ix -> Exp e -(!) arr ix = Exp $ IndexScalar arr ix +(!) arr ix = Exp $ Index arr ix --- |Extraction of the element in a singleton array. +-- |Expression form that extracts a scalar from an array at a linear index -- +infixl 9 !! +(!!) :: (Shape ix, Elt e) => Acc (Array ix e) -> Exp Int -> Exp e +(!!) arr i = Exp $ LinearIndex arr i + +-- |Extraction of the element in a singleton array +-- the :: Elt e => Acc (Scalar e) -> Exp e the = (!index0) --- |Expression form that yields the shape of an array. +-- |Test whether an array is empty -- +null :: (Shape ix, Elt e) => Acc (Array ix e) -> Exp Bool +null arr = size arr ==* 0 + +-- |Expression form that yields the shape of an array +-- shape :: (Shape ix, Elt e) => Acc (Array ix e) -> Exp ix shape = Exp . Shape --- |Expression form that yields the size of an array. +-- |Expression form that yields the size of an array -- size :: (Shape ix, Elt e) => Acc (Array ix e) -> Exp Int size = shapeSize . shape --- |The same as `size` but not operates directly on a shape without the --- array. +-- |The total number of elements in an array of the given 'Shape' -- shapeSize :: Shape ix => Exp ix -> Exp Int shapeSize = Exp . ShapeSize @@ -969,24 +1132,71 @@ complement = mkBNot -- FIXME: argh, the rest have fixed types in their signatures -shift, shiftL, shiftR :: (Elt t, IsIntegral t) => Exp t -> Exp Int -> Exp t + +-- | @'shift' x i@ shifts @x@ left by @i@ bits if @i@ is positive, or right by +-- @-i@ bits otherwise. Right shifts perform sign extension on signed number +-- types; i.e. they fill the top bits with 1 if the @x@ is negative and with 0 +-- otherwise. +-- +shift :: (Elt t, IsIntegral t) => Exp t -> Exp Int -> Exp t shift x i = i ==* 0 ? (x, i <* 0 ? (x `shiftR` (-i), x `shiftL` i)) -shiftL = mkBShiftL -shiftR = mkBShiftR -rotate, rotateL, rotateR :: (Elt t, IsIntegral t) => Exp t -> Exp Int -> Exp t -rotate x i = i ==* 0 ? (x, i <* 0 ? (x `rotateR` (-i), x `rotateL` i)) -rotateL = mkBRotateL -rotateR = mkBRotateR +-- | Shift the argument left by the specified number of bits +-- (which must be non-negative). +-- +shiftL :: (Elt t, IsIntegral t) => Exp t -> Exp Int -> Exp t +shiftL = mkBShiftL +-- | Shift the first argument right by the specified number of bits. The result +-- is undefined for negative shift amounts and shift amounts greater or equal to +-- the 'bitSize'. +-- +-- Right shifts perform sign extension on signed number types; i.e. they fill +-- the top bits with 1 if the @x@ is negative and with 0 otherwise. +-- +shiftR :: (Elt t, IsIntegral t) => Exp t -> Exp Int -> Exp t +shiftR = mkBShiftR + +-- | @'rotate' x i@ rotates @x@ left by @i@ bits if @i@ is positive, or right by +-- @-i@ bits otherwise. +-- +rotate :: (Elt t, IsIntegral t) => Exp t -> Exp Int -> Exp t +rotate x i = i ==* 0 ? (x, i <* 0 ? (x `rotateR` (-i), x `rotateL` i)) + +-- | Rotate the argument left by the specified number of bits +-- (which must be non-negative). +-- +rotateL :: (Elt t, IsIntegral t) => Exp t -> Exp Int -> Exp t +rotateL = mkBRotateL + +-- | Rotate the argument right by the specified number of bits +-- (which must be non-negative). +-- +rotateR :: (Elt t, IsIntegral t) => Exp t -> Exp Int -> Exp t +rotateR = mkBRotateR + +-- | @bit i@ is a value with the @i@th bit set and all other bits clear +-- bit :: (Elt t, IsIntegral t) => Exp Int -> Exp t bit x = 1 `shiftL` x -setBit, clearBit, complementBit :: (Elt t, IsIntegral t) => Exp t -> Exp Int -> Exp t -x `setBit` i = x .|. bit i -x `clearBit` i = x .&. complement (bit i) +-- | @x \`setBit\` i@ is the same as @x .|. bit i@ +-- +setBit :: (Elt t, IsIntegral t) => Exp t -> Exp Int -> Exp t +x `setBit` i = x .|. bit i + +-- | @x \`clearBit\` i@ is the same as @x .&. complement (bit i)@ +-- +clearBit :: (Elt t, IsIntegral t) => Exp t -> Exp Int -> Exp t +x `clearBit` i = x .&. complement (bit i) + +-- | @x \`complementBit\` i@ is the same as @x \`xor\` bit i@ +-- +complementBit :: (Elt t, IsIntegral t) => Exp t -> Exp Int -> Exp t x `complementBit` i = x `xor` bit i +-- | Return 'True' if the @n@th bit of the argument is 1 +-- testBit :: (Elt t, IsIntegral t) => Exp t -> Exp Int -> Exp Bool x `testBit` i = (x .&. bit i) /=* 0 @@ -1091,17 +1301,27 @@ min :: (Elt t, IsScalar t) => Exp t -> Exp t -> Exp t min = mkMin --- |Conversions from the RealFrac class +-- Conversions from the RealFrac class -- + +-- | @truncate x@ returns the integer nearest @x@ between zero and @x@. +-- truncate :: (Elt a, Elt b, IsFloating a, IsIntegral b) => Exp a -> Exp b truncate = mkTruncate +-- | @round x@ returns the nearest integer to @x@, or the even integer if @x@ is +-- equidistant between two integers. +-- round :: (Elt a, Elt b, IsFloating a, IsIntegral b) => Exp a -> Exp b round = mkRound +-- | @floor x@ returns the greatest integer not greater than @x@. +-- floor :: (Elt a, Elt b, IsFloating a, IsIntegral b) => Exp a -> Exp b floor = mkFloor +-- | @ceiling x@ returns the least integer not less than @x@. +-- ceiling :: (Elt a, Elt b, IsFloating a, IsIntegral b) => Exp a -> Exp b ceiling = mkCeiling @@ -1145,7 +1365,8 @@ -- Constants -- --------- --- |Magic value identifying elements that are ignored in a forward permutation +-- |Magic value identifying elements that are ignored in a forward permutation. +-- Note that this currently does not work for singleton arrays. -- ignore :: Shape ix => Exp ix ignore = constant Sugar.ignore 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 @@ -1,7 +1,8 @@ {-# LANGUAGE TypeOperators, ScopedTypeVariables #-} -- | -- Module : Data.Array.Accelerate.Prelude --- Copyright : [2010..2011] Manuel M T Chakravarty, Ben Lever +-- Copyright : [2010..2011] Manuel M T Chakravarty, Gabriele Keller, Ben Lever +-- [2009..2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell -- License : BSD3 -- -- Maintainer : Manuel M T Chakravarty @@ -14,51 +15,91 @@ module Data.Array.Accelerate.Prelude ( - -- ** Map-like + -- * Zipping + zipWith3, zipWith4, zip, zip3, zip4, + + -- * Unzipping unzip, unzip3, unzip4, - -- ** Reductions + -- * Reductions foldAll, fold1All, - -- ** Scans + -- ** Specialised folds + all, any, and, or, sum, product, minimum, maximum, + + -- * Scans prescanl, postscanl, prescanr, postscanr, -- ** Segmented scans scanlSeg, scanl'Seg, scanl1Seg, prescanlSeg, postscanlSeg, scanrSeg, scanr'Seg, scanr1Seg, prescanrSeg, postscanrSeg, - -- ** Reshaping of arrays + -- * Shape manipulation flatten, - -- ** Enumeration and filling + -- * Enumeration and filling fill, enumFromN, enumFromStepN, - -- ** Gather and scatter - gather, gatherIf, scatter, scatterIf, + -- * Working with predicates + -- ** Filtering + filter, - -- ** Subvector extraction + -- ** Scatter / Gather + scatter, scatterIf, + gather, gatherIf, + + -- * Permutations + reverse, transpose, + + -- * Extracting sub-vectors init, tail, take, drop, slit ) where -- avoid clashes with Prelude functions -import Prelude hiding ( - replicate, zip, zip3, unzip, unzip3, map, zipWith, scanl, scanl1, scanr, - scanr1, init, tail, take, drop, filter, max, min, not, fst, snd, curry, - uncurry, fromIntegral, abs, pred ) -import qualified Prelude +-- +import Data.Bits +import Data.Bool +import Prelude ((.), ($), (+), (-), (*), const, subtract, id) +import qualified Prelude as P -- friends -import Data.Array.Accelerate.Array.Sugar hiding ((!), ignore, shape, size, index) +import Data.Array.Accelerate.Array.Sugar hiding ((!), ignore, shape, size) import Data.Array.Accelerate.Language +import Data.Array.Accelerate.Smart import Data.Array.Accelerate.Type -- Map-like composites -- ------------------- --- |Combine the elements of two arrays pairwise. The shape of the result is +-- | Zip three arrays with the given function +-- +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 + = map (\x -> let (a,b,c) = unlift x in f a b c) + $ zip3 as bs cs + +-- | Zip four arrays with the given function +-- +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 + = map (\x -> let (a,b,c,d) = unlift x in f a b c d) + $ zip4 as bs cs ds + +-- | Combine the elements of two arrays pairwise. The shape of the result is -- the intersection of the two argument shapes. -- zip :: (Shape sh, Elt a, Elt b) @@ -67,7 +108,7 @@ -> Acc (Array sh (a, b)) zip = zipWith (curry lift) --- |Take three arrays and and return an array of triples, analogous to zip. +-- | Take three arrays and return an array of triples, analogous to zip. -- zip3 :: forall sh. forall a. forall b. forall c. (Shape sh, Elt a, Elt b, Elt c) => Acc (Array sh a) @@ -78,7 +119,7 @@ = zipWith (\a bc -> let (b, c) = unlift bc :: (Exp b, Exp c) in lift (a, b, c)) as $ zip bs cs --- |Take three arrays and and return an array of quadruples, analogous to zip. +-- | Take four arrays and return an array of quadruples, analogous to zip. -- zip4 :: forall sh. forall a. forall b. forall c. forall d. (Shape sh, Elt a, Elt b, Elt c, Elt d) => Acc (Array sh a) @@ -90,7 +131,7 @@ = zipWith (\a bcd -> let (b, c, d) = unlift bcd :: (Exp b, Exp c, Exp d) in lift (a, b, c, d)) as $ zip3 bs cs ds --- |The converse of 'zip', but the shape of the two results is identical to the +-- | The converse of 'zip', but the shape of the two results is identical to the -- shape of the argument. -- unzip :: (Shape sh, Elt a, Elt b) @@ -98,64 +139,130 @@ -> (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 - :: forall sh a b c. (Shape sh, Elt a, Elt b, Elt c) - => Acc (Array sh (a, b, c)) - -> (Acc (Array sh a), Acc (Array sh b), Acc (Array sh c)) -unzip3 abcs = (as, bs, cs) +unzip3 :: (Shape sh, Elt a, Elt b, Elt c) + => Acc (Array sh (a, b, c)) + -> (Acc (Array sh a), Acc (Array sh b), Acc (Array sh c)) +unzip3 xs = (map get1 xs, map get2 xs, map get3 xs) where - (bs, cs) = unzip bcs - (as, bcs) = unzip $ map swizzle abcs + get1 :: forall a b c. (Elt a, Elt b, Elt c) => Exp (a,b,c) -> Exp a + get1 x = let (a, _ :: Exp b, _ :: Exp c) = unlift x in a - swizzle :: Exp (a, b, c) -> Exp (a, (b, c)) - swizzle abc = let (a, b, c) = unlift abc :: (Exp a, Exp b, Exp c) - bc = lift (b, c) :: Exp (b, c) - in lift (a, bc) + get2 :: forall a b c. (Elt a, Elt b, Elt c) => Exp (a,b,c) -> Exp b + get2 x = let (_ :: Exp a, b, _ :: Exp c) = unlift x in b --- |Take an array of quadruples and return four arrays, analogous to unzip. + get3 :: forall a b c. (Elt a, Elt b, Elt c) => Exp (a,b,c) -> Exp c + get3 x = let (_ :: Exp a, _ :: Exp b, c) = unlift x in c + + +-- | Take an array of quadruples and return four arrays, analogous to unzip. -- -unzip4 - :: forall sh a b c d. (Shape sh, Elt a, Elt b, Elt c, Elt d) - => Acc (Array sh (a, b, c, d)) - -> (Acc (Array sh a), Acc (Array sh b), Acc (Array sh c), Acc (Array sh d)) -unzip4 abcds = (as, bs, cs, ds) +unzip4 :: (Shape sh, Elt a, Elt b, Elt c, Elt d) + => Acc (Array sh (a, b, c, d)) + -> (Acc (Array sh a), Acc (Array sh b), Acc (Array sh c), Acc (Array sh d)) +unzip4 xs = (map get1 xs, map get2 xs, map get3 xs, map get4 xs) where - (abs, cds) = unzip $ map swizzle abcds - (as, bs) = unzip abs - (cs, ds) = unzip cds + get1 :: forall a b c d. (Elt a, Elt b, Elt c, Elt d) => Exp (a,b,c,d) -> Exp a + get1 x = let (a, _ :: Exp b, _ :: Exp c, _ :: Exp d) = unlift x in a - swizzle :: Exp (a, b, c, d) -> Exp ((a, b), (c, d)) - swizzle abcd = let (a, b, c, d) = unlift abcd :: (Exp a, Exp b, Exp c, Exp d) - ab = lift (a, b) :: Exp (a, b) - cd = lift (c, d) :: Exp (c, d) - in lift (ab, cd) + get2 :: forall a b c d. (Elt a, Elt b, Elt c, Elt d) => Exp (a,b,c,d) -> Exp b + get2 x = let (_ :: Exp a, b, _ :: Exp c, _ :: Exp d) = unlift x in b + get3 :: forall a b c d. (Elt a, Elt b, Elt c, Elt d) => Exp (a,b,c,d) -> Exp c + get3 x = let (_ :: Exp a, _ :: Exp b, c, _ :: Exp d) = unlift x in c + get4 :: forall a b c d. (Elt a, Elt b, Elt c, Elt d) => Exp (a,b,c,d) -> Exp d + get4 x = let (_ :: Exp a, _ :: Exp b, _ :: Exp c, d) = unlift x in d + + -- Reductions -- ---------- --- |Reduction of an array of arbitrary rank to a single scalar value. The first argument needs to be --- an /associative/ function to enable an efficient parallel implementation. +-- | Reduction of an array of arbitrary rank to a single scalar value. -- 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 (reshape (index1 $ size arr) arr) +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. +-- | Variant of 'foldAll' that requires the reduced array to be non-empty and +-- doesn't need an default value. -- fold1All :: (Shape sh, Elt a) => (Exp a -> Exp a -> Exp a) -> Acc (Array sh a) -> Acc (Scalar a) -fold1All f arr = fold1 f (reshape (index1 $ size arr) arr) +fold1All f arr = fold1 f (flatten arr) +-- Specialised reductions +-- ---------------------- +-- +-- 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 +-- +all :: (Shape sh, Elt e) + => (Exp e -> Exp Bool) + -> Acc (Array sh e) + -> Acc (Scalar Bool) +all f = and . map f + +-- | Check if any element satisfies the predicate +-- +any :: (Shape sh, Elt e) + => (Exp e -> Exp Bool) + -> Acc (Array sh e) + -> Acc (Scalar Bool) +any f = or . map f + +-- | Check if all elements are 'True' +-- +and :: Shape sh + => Acc (Array sh Bool) + -> Acc (Scalar Bool) +and = foldAll (&&*) (constant True) + +-- | Check if any element is 'True' +-- +or :: Shape sh + => Acc (Array sh Bool) + -> Acc (Scalar Bool) +or = foldAll (||*) (constant False) + +-- | Compute the sum of elements +-- +sum :: (Shape sh, Elt e, IsNum e) + => Acc (Array sh e) + -> Acc (Scalar e) +sum = foldAll (+) 0 + +-- | Compute the product of the elements +-- +product :: (Shape sh, Elt e, IsNum e) + => Acc (Array sh e) + -> Acc (Scalar e) +product = foldAll (*) 1 + +-- | Yield the minimum element of an array. The array must not be empty. +-- +minimum :: (Shape sh, Elt e, IsScalar e) + => Acc (Array sh e) + -> Acc (Scalar e) +minimum = fold1All min + +-- | Yield the maximum element of an array. The array must not be empty. +-- +maximum :: (Shape sh, Elt e, IsScalar e) + => Acc (Array sh e) + -> Acc (Scalar e) +maximum = fold1All max + + -- Composite scans -- --------------- @@ -169,7 +276,7 @@ -> Exp a -> Acc (Vector a) -> Acc (Vector a) -prescanl f e = Prelude.fst . scanl' f e +prescanl f e = P.fst . scanl' f e -- |Left-to-right postscan, a variant of 'scanl1' with an initial value. Denotationally, we have -- @@ -192,7 +299,7 @@ -> Exp a -> Acc (Vector a) -> Acc (Vector a) -prescanr f e = Prelude.fst . scanr' f e +prescanr f e = P.fst . scanr' f e -- |Right-to-left postscan, a variant of 'scanr1' with an initial value. Denotationally, we have -- @@ -209,49 +316,40 @@ -- Segmented scans -- --------------- --- |Segmented version of 'scanl'. +-- |Segmented version of 'scanl' -- -scanlSeg :: forall a i. (Elt a, Elt i, IsIntegral i) +scanlSeg :: (Elt a, Elt i, IsIntegral i) => (Exp a -> Exp a -> Exp a) -> Exp a -> Acc (Vector a) -> Acc (Segments i) -> Acc (Vector a) -scanlSeg f e arr seg = scans +scanlSeg f z vec seg = scanl1Seg f vec' seg' where - -- Segmented scan implemented by performing segmented exclusive-scan (scan1) - -- on a vector formed by injecting the identity element at the start of each - -- segment. - scans = scanl1Seg f idInjArr seg' - idInjArr = zipWith (\h x -> h ==* 1 ? (fst x, snd x)) headFlags $ zip idsArr arrShifted - - headFlags = permute (+) zerosArr' (\ix -> index1' $ segOffsets' ! ix) - $ generate (shape seg) (const (1 :: Exp i)) - - arrShifted = backpermute nSh (\ix -> index1' $ shiftCoords ! ix) arr - - idsArr = generate nSh (const e) - - -- As the identity elements are injected in to the vector for each segment, the - -- remaining elements must be shifted forwarded (to the left). shiftCoords specifies - -- how each element is backpermuted to its shifted position. - shiftCoords = permute (+) zerosArr' (ilift1 $ \i -> i + (offsetArr ! index1' i) + 1) coords - coords = Prelude.fst $ scanl' (+) 0 onesArr - - offsetArr = scanl1 max $ permute (+) zerosArr (\ix -> index1' $ segOffsets ! ix) segIxs - segIxs = Prelude.fst $ scanl' (+) 0 $ generate (index1' $ size seg) (const 1) - - segOffsets' = Prelude.fst $ scanl' (+) 0 seg' - segOffsets = Prelude.fst $ scanl' (+) 0 seg + -- Segmented exclusive scan is implemented by first injecting the seed + -- element at the head of each segment, and then performing a segmented + -- inclusive scan. + -- + -- This is done by creating a creating a vector entirely of the seed + -- element, and overlaying the input data in all places other than at the + -- start of a segment. + -- + seg' = map (+1) seg + vec' = permute const + (fill (index1 $ size vec + size seg) z) + (\ix -> index1' $ unindex1' ix + inc ! ix) + vec + -- Each element in the segments must be shifted to the right one additional + -- place for each successive segment, to make room for the seed element. + -- Here, we make use of the fact that the vector returned by 'mkHeadFlags' + -- contains non-unit entries, which indicate zero length segments. -- - nSh = index1' $ size arr + size seg - seg' = map (+ 1) seg - onesArr = generate (shape arr) (const 1) - zerosArr = generate (shape arr) (const 0) - zerosArr' = generate nSh (const 0) + flags = mkHeadFlags seg + inc = scanl1 (+) flags --- |Segmented version of 'scanl''. + +-- |Segmented version of 'scanl'' -- -- The first element of the resulting tuple is a vector of scanned values. The -- second element is a vector of segment scan totals and has the same size as @@ -262,31 +360,51 @@ -> Exp a -> Acc (Vector a) -> Acc (Segments i) - -> (Acc (Vector a), Acc (Vector a)) -scanl'Seg f e arr seg = (scans, sums) + -> Acc (Vector a, Vector a) +scanl'Seg f z vec seg = result where - -- Segmented scan' implemented by performing segmented exclusive-scan on vector - -- fromed by inserting identity element in at the start of each segment, shifting - -- elements right, with the final element in the segment being removed. - scans = scanl1Seg f idInjArr seg - idInjArr = zipWith (\h x -> h ==* 1 ? (fst x, snd x)) headFlags $ zip idsArr arrShifted + -- Returned the result combined, so that the sub-calculations are shared + -- should the user require both results. + -- + result = lift (body, sums) - headFlags = permute (+) zerosArr (\ix -> index1' $ segOffsets ! ix) - $ generate (shape seg) (const (1 :: Exp i)) - segOffsets = Prelude.fst $ scanl' (+) 0 seg + -- Segmented scan' is implemented by deconstructing a segmented exclusive + -- scan, to separate the final value and scan body. + -- + -- TLM: Segmented scans, and this version in particular, expend a lot of + -- effort scanning flag arrays. On inspection it appears that several + -- of these operations are duplicated, but this will not be picked up + -- by sharing _observation_. Perhaps a global CSE-style pass would be + -- beneficial. + -- + vec' = scanlSeg f z vec seg - arrShifted = backpermute (shape arr) (ilift1 $ \i -> i ==* 0 ? (i, i - 1)) arr + -- Extract the final reduction value for each segment, which is at the last + -- index of each segment. + -- + seg' = map (+1) seg + tails = zipWith (+) seg . P.fst $ scanl' (+) 0 seg' + sums = backpermute (shape seg) (\ix -> index1' $ tails ! ix) vec' - idsArr = generate (shape arr) (const e) - zerosArr = generate (shape arr) (const 0) + -- Slice out the body of each segment. + -- + -- Build a head-flags representation based on the original segment + -- descriptor. This contains the target length of each of the body segments, + -- which is one fewer element than the actual bodies stored in vec'. Thus, + -- the flags align with the last element of each body section, and when + -- scanned, this element will be incremented over. + -- + offset = scanl1 (+) seg + inc = scanl1 (+) + $ permute (+) (fill (index1 $ size vec + 1) 0) + (\ix -> index1' $ offset ! ix) + (fill (shape seg) (1 :: Exp i)) - -- Sum of each segment is computed by performing a segmented postscan on - -- the original vector and taking the tail elements. - sums = map (`f` e) - $ backpermute (shape seg) (\ix -> index1' $ sumOffsets ! ix) - $ scanl1Seg f arr seg - sumOffsets = map (subtract 1) $ scanl1 (+) seg + body = backpermute (shape vec) + (\ix -> index1' $ unindex1' ix + inc ! ix) + vec' + -- |Segmented version of 'scanl1'. -- scanl1Seg :: (Elt a, Elt i, IsIntegral i) @@ -294,7 +412,11 @@ -> Acc (Vector a) -> Acc (Segments i) -> Acc (Vector a) -scanl1Seg f arr seg = map snd $ scanl1 (mkSegApply f) $ zip (mkHeadFlags seg) arr +scanl1Seg f vec seg + = P.snd + . unzip + . scanl1 (segmented f) + $ zip (mkHeadFlags seg) vec -- |Segmented version of 'prescanl'. -- @@ -304,7 +426,10 @@ -> Acc (Vector a) -> Acc (Segments i) -> Acc (Vector a) -prescanlSeg f e arr seg = Prelude.fst $ scanl'Seg f e arr seg +prescanlSeg f e vec seg + = P.fst + . unatup2 + $ scanl'Seg f e vec seg -- |Segmented version of 'postscanl'. -- @@ -314,46 +439,32 @@ -> Acc (Vector a) -> Acc (Segments i) -> Acc (Vector a) -postscanlSeg f e arr seg = map (e `f`) $ scanl1Seg f arr seg +postscanlSeg f e vec seg + = map (f e) + $ scanl1Seg f vec seg -- |Segmented version of 'scanr'. -- -scanrSeg :: forall a i. (Elt a, Elt i, IsIntegral i) +scanrSeg :: (Elt a, Elt i, IsIntegral i) => (Exp a -> Exp a -> Exp a) -> Exp a -> Acc (Vector a) -> Acc (Segments i) -> Acc (Vector a) -scanrSeg f e arr seg = scans +scanrSeg f z vec seg = scanr1Seg f vec' seg' where - -- Using technique described for scanlSeg. - scans = scanr1Seg f idInjArr seg' - idInjArr = zipWith (\h x -> h ==* 1 ? (fst x, snd x)) tailFlags $ zip idsArr arrShifted - - tailFlags = permute (+) zerosArr' (\ix -> index1' $ (segOffsets' ! ix) - 1) - $ generate (shape seg) (const (1 :: Exp i)) - - arrShifted = backpermute nSh (\ix -> index1' $ shiftCoords ! ix) arr - - idsArr = generate nSh (const e) - + -- Using technique described for 'scanlSeg', where we intersperse the array + -- with the seed element at the start of each segment, and then perform an + -- inclusive segmented scan. -- - shiftCoords = permute (+) zerosArr' (ilift1 $ \i -> i + (offsetArr ! index1' i)) coords - coords = Prelude.fst $ scanl' (+) 0 onesArr + inc = scanl1 (+) (mkHeadFlags seg) + seg' = map (+1) seg + vec' = permute const + (fill (index1 $ size vec + size seg) z) + (\ix -> index1' $ unindex1' ix + inc ! ix - 1) + vec - offsetArr = scanl1 max $ permute (+) zerosArr (\ix -> index1' $ segOffsets ! ix) segIxs - segIxs = Prelude.fst $ scanl' (+) 0 $ generate (shape seg) (const 1) - segOffsets' = scanl1 (+) seg' - segOffsets = Prelude.fst $ scanl' (+) 0 seg - - -- - nSh = index1' $ size arr + size seg - seg' = map (+ 1) seg - onesArr = generate (shape arr) (const 1) - zerosArr = generate (shape arr) (const 0) - zerosArr' = generate nSh (const 0) - -- | Segmented version of 'scanr''. -- scanr'Seg :: forall a i. (Elt a, Elt i, IsIntegral i) @@ -361,27 +472,26 @@ -> Exp a -> Acc (Vector a) -> Acc (Segments i) - -> (Acc (Vector a), Acc (Vector a)) -scanr'Seg f e arr seg = (scans, sums) + -> Acc (Vector a, Vector a) +scanr'Seg f z vec seg = result where -- Using technique described for scanl'Seg - scans = scanr1Seg f idInjArr seg - idInjArr = zipWith (\t x -> t ==* 1 ? (fst x, snd x)) tailFlags $ zip idsArr arrShifted + -- + result = lift (body, sums) + vec' = scanrSeg f z vec seg - tailFlags = permute (+) zerosArr (\ix -> index1' $ (segOffsets ! ix) - 1) - $ generate (shape seg) (const (1 :: Exp i)) - segOffsets = scanl1 (+) seg + -- reduction values + seg' = map (+1) seg + heads = P.fst $ scanl' (+) 0 seg' + sums = backpermute (shape seg) (\ix -> index1' $ heads ! ix) vec' - arrShifted = backpermute (shape arr) (ilift1 $ \i -> i ==* (size arr - 1) ? (i, i + 1)) arr + -- body segments + inc = scanl1 (+) $ mkHeadFlags seg + body = backpermute (shape vec) + (\ix -> index1' $ unindex1' ix + inc ! ix) + vec' - idsArr = generate (shape arr) (const e) - zerosArr = generate (shape arr) (const 0) - -- - sums = map (`f` e) $ backpermute (shape seg) (\ix -> index1' $ sumOffsets ! ix) - $ scanr1Seg f arr seg - sumOffsets = Prelude.fst $ scanl' (+) 0 seg - -- |Segmented version of 'scanr1'. -- scanr1Seg :: (Elt a, Elt i, IsIntegral i) @@ -389,7 +499,11 @@ -> Acc (Vector a) -> Acc (Segments i) -> Acc (Vector a) -scanr1Seg f arr seg = map snd $ scanr1 (mkSegApply f) $ zip (mkTailFlags seg) arr +scanr1Seg f vec seg + = P.snd + . unzip + . scanr1 (segmented f) + $ zip (mkTailFlags seg) vec -- |Segmented version of 'prescanr'. -- @@ -399,7 +513,10 @@ -> Acc (Vector a) -> Acc (Segments i) -> Acc (Vector a) -prescanrSeg f e arr seg = Prelude.fst $ scanr'Seg f e arr seg +prescanrSeg f e vec seg + = P.fst + . unatup2 + $ scanr'Seg f e vec seg -- |Segmented version of 'postscanr'. -- @@ -409,7 +526,9 @@ -> Acc (Vector a) -> Acc (Segments i) -> Acc (Vector a) -postscanrSeg f e arr seg = map (`f` e) $ scanr1Seg f arr seg +postscanrSeg f e vec seg + = map (f e) + $ scanr1Seg f vec seg -- Segmented scan helpers @@ -417,49 +536,69 @@ -- |Compute head flags vector from segment vector for left-scans. -- +-- The vector will be full of zeros in the body of a segment, and non-zero +-- otherwise. The "flag" value, if greater than one, indicates that several +-- empty segments are represented by this single flag entry. This is additional +-- data is used by exclusive segmented scan. +-- mkHeadFlags :: (Elt i, IsIntegral i) => Acc (Segments i) -> Acc (Segments i) -mkHeadFlags seg = permute (\_ _ -> 1) zerosArr (\ix -> index1' (segOffsets ! ix)) segOffsets +mkHeadFlags seg + = init + $ permute (+) zeros (\ix -> index1' (offset ! ix)) ones where - (segOffsets, len) = scanl' (+) 0 seg - zerosArr = generate (index1' $ the len) (const 0) + (offset, len) = scanl' (+) 0 seg + zeros = fill (index1' $ the len + 1) 0 + ones = fill (index1 $ size offset) 1 --- |Compute tail flags vector from segment vector for right-scans. +-- |Compute tail flags vector from segment vector for right-scans. That is, the +-- flag is placed at the last place in each segment. -- mkTailFlags :: (Elt i, IsIntegral i) => Acc (Segments i) -> Acc (Segments i) mkTailFlags seg - = permute (\_ _ -> 1) zerosArr (ilift1 $ \i -> (fromIntegral $ segOffsets ! index1' i) - 1) segOffsets + = init + $ permute (+) zeros (\ix -> index1' (the len - 1 - offset ! ix)) ones where - segOffsets = scanl1 (+) seg - len = segOffsets ! index1' (size seg - 1) - zerosArr = generate (index1' len) (const 0) + (offset, len) = scanr' (+) 0 seg + zeros = fill (index1' $ the len + 1) 0 + ones = fill (index1 $ size offset) 1 --- |Construct a segmented version of apply from a non-segmented version. The segmented apply --- operates on a head-flag value tuple. +-- |Construct a segmented version of a function from a non-segmented version. +-- The segmented apply operates on a head-flag value tuple, and follows the +-- procedure of Sengupta et. al. -- -mkSegApply :: (Elt e, Elt i, IsIntegral i) - => (Exp e -> Exp e -> Exp e) - -> (Exp (i, e) -> Exp (i, e) -> Exp (i, e)) -mkSegApply op = apply - where - apply a b = lift (fromIntegral $ boolToInt (aF ==* 1 ||* bF ==* 1), bF ==* 1 ? (bV, aV `op` bV)) - where - aF = fst a - aV = snd a - bF = fst b - bV = snd b +segmented :: (Elt e, Elt i, IsIntegral i) + => (Exp e -> Exp e -> Exp e) + -> Exp (i, e) -> Exp (i, e) -> Exp (i, e) +segmented f a b = + let (aF, aV) = unlift a + (bF, bV) = unlift b + in + lift (aF .|. bF, bF /=* 0 ? (bV, f aV bV)) --- As 'index1', but parameterised in the first argument over integral types +-- |Index construction and destruction generalised to integral types. -- -index1' :: (Elt i, IsIntegral i) => Exp i -> Exp (Z :. Int) -index1' = index1 . fromIntegral +-- We generalise the segment descriptor to integral types because some +-- architectures, such as GPUs, have poor performance for 64-bit types. So, +-- there is a tension between performance and requiring 64-bit indices for some +-- applications, and we would not like to restrict ourselves to either one. +-- +-- As we don't yet support non-Int dimensions in shapes, we will need to convert +-- back to concrete Int. However, don't put these generalised forms into the +-- base library, because it results in too many ambiguity errors. +-- +index1' :: (Elt i, IsIntegral i) => Exp i -> Exp DIM1 +index1' i = lift (Z :. fromIntegral i) +unindex1' :: (Elt i, IsIntegral i) => Exp DIM1 -> Exp i +unindex1' ix = let Z :. i = unlift ix in fromIntegral i + -- Reshaping of arrays -- ------------------- -- | Flattens a given array of arbitrary dimension. -- -flatten :: (Shape ix, Elt a) => Acc (Array ix a) -> Acc (Array DIM1 a) +flatten :: (Shape ix, Elt a) => Acc (Array ix a) -> Acc (Vector a) flatten a = reshape (index1 $ size a) a -- Enumeration and filling @@ -476,30 +615,60 @@ enumFromN :: (Shape sh, Elt e, IsNum e) => Exp sh -> Exp e -> Acc (Array sh e) enumFromN sh x = enumFromStepN sh x 1 --- | Create an array of the given shape containing the values x, x+y, x+y+y, etc --- (in row-major order). +-- | Create an array of the given shape containing the values @x@, @x+y@, +-- @x+y+y@ etc. (in row-major order). -- enumFromStepN :: (Shape sh, Elt e, IsNum e) => Exp sh - -> Exp e -- ^x - -> Exp e -- ^y + -> Exp e -- ^ x: start + -> Exp e -- ^ y: step -> Acc (Array sh e) -enumFromStepN sh x y = reshape sh - $ generate (index1 $ shapeSize sh) - ((\i -> ((fromIntegral i) * y) + x) . unindex1) +enumFromStepN sh x y + = reshape sh + $ generate (index1 $ shapeSize sh) + (\ix -> (fromIntegral (unindex1 ix :: Exp Int) * y) + x) +-- Filtering +-- --------- + +-- | Drop elements that do not satisfy the predicate +-- +filter :: Elt a + => (Exp a -> Exp Bool) + -> Acc (Vector a) + -> Acc (Vector a) +filter p arr + = let flags = map (boolToInt . p) arr + (targetIdx, len) = scanl' (+) 0 flags + arr' = backpermute (index1 $ the len) id arr + in + permute const arr' (\ix -> flags!ix ==* 0 ? (ignore, index1 $ targetIdx!ix)) arr + -- FIXME: This is abusing 'permute' in that the first two arguments are + -- only justified because we know the permutation function will + -- write to each location in the target exactly once. + -- Instead, we should have a primitive that directly encodes the + -- compaction pattern of the permutation function. + +{-# RULES + "ACC filter/filter" forall f g arr. + filter f (filter g arr) = filter (\x -> g x &&* f x) arr + #-} + + -- Gather operations -- ----------------- -- | Copy elements from source array to destination array according to a map. This --- is a backpermute operation where a 'map' vector encodes the ouput to input --- index mapping. For example: +-- is a backpermute operation where a 'map' vector encodes the output to input +-- index mapping. -- --- input = [1, 9, 6, 4, 4, 2, 0, 1, 2] --- map = [1, 3, 7, 2, 5, 3] +-- For example: -- --- output = [9, 4, 1, 6, 2, 4] +-- > input = [1, 9, 6, 4, 4, 2, 0, 1, 2] +-- > map = [1, 3, 7, 2, 5, 3] +-- > +-- > output = [9, 4, 1, 6, 2, 4] -- gather :: (Elt e) => Acc (Vector Int) -- ^map @@ -511,19 +680,20 @@ -- | Conditionally copy elements from source array to destination array according --- to a map. This is a backpermute opereation where a 'map' vector encdes the +-- to a map. This is a backpermute operation where a 'map' vector encodes the -- output to input index mapping. In addition, there is a 'mask' vector, and an -- associated predication function, that specifies whether an element will be -- copied. If not copied, the output array assumes the default vector's value. --- For example: -- --- default = [6, 6, 6, 6, 6, 6] --- map = [1, 3, 7, 2, 5, 3] --- mask = [3, 4, 9, 2, 7, 5] --- pred = (> 4) --- input = [1, 9, 6, 4, 4, 2, 0, 1, 2] +-- For example: -- --- output = [6, 6, 1, 6, 2, 4] +-- > default = [6, 6, 6, 6, 6, 6] +-- > map = [1, 3, 7, 2, 5, 3] +-- > mask = [3, 4, 9, 2, 7, 5] +-- > pred = (> 4) +-- > input = [1, 9, 6, 4, 4, 2, 0, 1, 2] +-- > +-- > output = [6, 6, 1, 6, 2, 4] -- gatherIf :: (Elt e, Elt e') => Acc (Vector Int) -- ^map @@ -545,13 +715,15 @@ -- | Copy elements from source array to destination array according to a map. This -- is a forward-permute operation where a 'map' vector encodes an input to output -- index mapping. Output elements for indices that are not mapped assume the --- default vector's value. For example: +-- default vector's value. -- --- default = [0, 0, 0, 0, 0, 0, 0, 0, 0] --- map = [1, 3, 7, 2, 5, 8] --- input = [1, 9, 6, 4, 4, 2, 5] +-- For example: -- --- output = [0, 1, 4, 9, 0, 4, 0, 6, 2] +-- > default = [0, 0, 0, 0, 0, 0, 0, 0, 0] +-- > map = [1, 3, 7, 2, 5, 8] +-- > input = [1, 9, 6, 4, 4, 2, 5] +-- > +-- > output = [0, 1, 4, 9, 0, 4, 0, 6, 2] -- -- Note if the same index appears in the map more than once, the result is -- undefined. The map vector cannot be larger than the input vector. @@ -571,15 +743,16 @@ -- input to output index mapping. In addition, there is a 'mask' vector, and an -- associated predicate function, that specifies whether an elements will be -- copied. If not copied, the output array assumes the default vector's value. --- For example: -- --- default = [0, 0, 0, 0, 0, 0, 0, 0, 0] --- map = [1, 3, 7, 2, 5, 8] --- mask = [3, 4, 9, 2, 7, 5] --- pred = (> 4) --- input = [1, 9, 6, 4, 4, 2] +-- For example: -- --- output = [0, 0, 0, 0, 0, 4, 0, 6, 2] +-- > default = [0, 0, 0, 0, 0, 0, 0, 0, 0] +-- > map = [1, 3, 7, 2, 5, 8] +-- > mask = [3, 4, 9, 2, 7, 5] +-- > pred = (> 4) +-- > input = [1, 9, 6, 4, 4, 2] +-- > +-- > output = [0, 0, 0, 0, 0, 4, 0, 6, 2] -- -- Note if the same index appears in the map more than once, the result is -- undefined. The map and input vector must be of the same length. @@ -596,44 +769,67 @@ pF ix = (pred (maskV ! ix)) ? (lift (Z :. (mapV ! ix)), ignore) +-- Permutations +-- ------------ --- Extracting subvectors --- --------------------- +-- | Reverse the elements of a vector. +-- +reverse :: Elt e => Acc (Vector e) -> Acc (Vector e) +reverse xs = + let len = unindex1 (shape xs) + pf i = len - i - 1 + in backpermute (shape xs) (ilift1 pf) xs +-- | Transpose the rows and columns of a matrix. +-- +transpose :: Elt e => Acc (Array DIM2 e) -> Acc (Array DIM2 e) +transpose mat = + let swap = lift1 $ \(Z:.x:.y) -> Z:.y:.x :: Z:.Exp Int:.Exp Int + in backpermute (swap $ shape mat) swap mat --- | Yield the first 'n' elements of the input vector. The vector must contain --- no more than 'n' elements. + +-- Extracting sub-vectors +-- ---------------------- + +-- | Yield the first @n@ elements of the input vector. The vector must contain +-- no more than @n@ elements. -- take :: Elt e => Exp Int -> Acc (Vector e) -> Acc (Vector e) -take n = backpermute (index1 n) id +take n = + let n' = the (unit n) + in backpermute (index1 n') id --- | Yield all but the first 'n' elements of the input vector. The vector must --- contain no more than 'n' elements. +-- | Yield all but the first @n@ elements of the input vector. The vector must +-- contain no fewer than @n@ elements. -- drop :: Elt e => Exp Int -> Acc (Vector e) -> Acc (Vector e) -drop n arr = backpermute (ilift1 (\x -> x - n) $ shape arr) (ilift1 (+ n)) arr +drop n arr = + let n' = the (unit n) + in backpermute (ilift1 (subtract n') (shape arr)) (ilift1 (+ n')) arr --- | Yield all but the last element of the input vector. The vector may not --- be empty. +-- | Yield all but the last element of the input vector. The vector must not be +-- empty. -- init :: Elt e => Acc (Vector e) -> Acc (Vector e) init arr = take ((unindex1 $ shape arr) - 1) arr --- | Yield all but the first element of the input vector. The vector may not --- be empty. +-- | Yield all but the first element of the input vector. The vector must not be +-- empty. +-- tail :: Elt e => Acc (Vector e) -> Acc (Vector e) -tail = drop 1 +tail arr = backpermute (ilift1 (subtract 1) (shape arr)) (ilift1 (+1)) arr -- | Yield a slit (slice) from the vector. The vector must contain at least --- i + n elements. +-- @i + n@ elements. Denotationally, we have: -- -slit :: Elt e - => Exp Int - -> Exp Int - -> Acc (Vector e) - -> Acc (Vector e) -slit i n = backpermute (index1 n) (ilift1 (+ i)) +-- > slit i n = take n . drop i +-- +slit :: Elt e => Exp Int -> Exp Int -> Acc (Vector e) -> Acc (Vector e) +slit i n = + let i' = the (unit i) + n' = the (unit n) + in backpermute (index1 n') (ilift1 (+ i')) diff --git a/Data/Array/Accelerate/Pretty.hs b/Data/Array/Accelerate/Pretty.hs --- a/Data/Array/Accelerate/Pretty.hs +++ b/Data/Array/Accelerate/Pretty.hs @@ -1,9 +1,14 @@ -{-# LANGUAGE GADTs, FlexibleInstances, TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeSynonymInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Pretty -- Copyright : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee +-- [2009..2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell -- License : BSD3 -- -- Maintainer : Manuel M T Chakravarty @@ -24,18 +29,25 @@ import Text.PrettyPrint -- friends -import Data.Array.Accelerate.Pretty.Print import Data.Array.Accelerate.AST +import Data.Array.Accelerate.Trafo.Base +import Data.Array.Accelerate.Pretty.Print -- |Show instances -- --------------- -instance Show (OpenAcc aenv a) where - show c = render $ prettyAcc 0 noParens c +wide :: Style +wide = style { lineLength = 150 } -instance Show (OpenFun env aenv f) where - show f = render $ prettyFun 0 f +instance Kit acc => Show (acc aenv a) where + show c = renderStyle wide $ prettyAcc 0 noParens c -instance Show (OpenExp env aenv t) where - show e = render $ prettyExp 0 0 noParens e +instance Kit acc => Show (PreOpenAfun acc aenv f) where + show f = renderStyle wide $ prettyPreAfun prettyAcc 0 f + +instance Kit acc => Show (PreOpenFun acc env aenv f) where + show f = renderStyle wide $ prettyPreFun prettyAcc 0 f + +instance Kit acc => Show (PreOpenExp acc env aenv t) where + show e = renderStyle wide $ prettyPreExp prettyAcc 0 0 noParens e 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 @@ -26,7 +26,7 @@ import System.Directory import System.Posix.Process import System.IO -import System.IO.Error hiding (catch) +import System.IO.Error import Text.Printf -- friends @@ -58,7 +58,7 @@ writeDotFile -- fall back to writing the dot file -- writeDotFile :: IO () - writeDotFile = catch writeDotFile' handler + writeDotFile = catchIOError writeDotFile' handler writeDotFile' = do let path = basename ++ ".dot" h <- openFile path WriteMode @@ -80,7 +80,7 @@ withTempFile :: String -> (FilePath -> Handle -> IO a) -> IO a withTempFile pattern f = do - tempDir <- catch getTemporaryDirectory (\_ -> return ".") + tempDir <- catchIOError getTemporaryDirectory (\_ -> return ".") (tempFile, tempH) <- openTempFile tempDir pattern finally (f tempFile tempH) (hClose tempH >> removeFile tempFile) diff --git a/Data/Array/Accelerate/Pretty/HTML.hs b/Data/Array/Accelerate/Pretty/HTML.hs --- a/Data/Array/Accelerate/Pretty/HTML.hs +++ b/Data/Array/Accelerate/Pretty/HTML.hs @@ -1,4 +1,7 @@ -{-# LANGUAGE GADTs, OverloadedStrings, ScopedTypeVariables, NoMonomorphismRestriction #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} -- | -- Module : Data.Array.Accelerate.Pretty.HTML -- Copyright : [2010..2011] Sean Seefried @@ -16,34 +19,38 @@ ) where - -- standard libraries +#if !MIN_VERSION_base(4,6,0) +import Prelude hiding ( catch ) +import System.IO.Error hiding ( catch ) +#else +import System.IO.Error +#endif +import Control.Exception import Data.String import Data.Monoid -import qualified Data.Text as T -import Text.Blaze.Renderer.Utf8 -import Text.Blaze.Html4.Transitional ((!)) -import qualified Text.Blaze.Html4.Transitional as H -import qualified Text.Blaze.Html4.Transitional.Attributes as A - -import System.IO -import System.IO.Error hiding (catch) -import qualified Data.ByteString.Lazy as BS +import Text.Blaze.Html.Renderer.Utf8 +import Text.Blaze.Html4.Transitional ( (!) ) +import qualified Data.Text as T +import qualified Data.ByteString.Lazy as BS +import qualified Text.Blaze.Html4.Transitional as H +import qualified Text.Blaze.Html4.Transitional.Attributes as A -- friends import Data.Array.Accelerate.AST import Data.Array.Accelerate.Pretty.Traverse + combineHtml :: String -> String -> [H.Html] -> H.Html combineHtml cssClass label nodes = do let inner = foldl (>>) (return ()) nodes H.div ! A.class_ ("node " `mappend` fromString cssClass `mappend` " expanded") $ do - H.span ! A.class_ "selector" $ H.text (fromString label) + H.span ! A.class_ "selector" $ H.toMarkup label inner leafHtml :: String -> String -> H.Html leafHtml cssClass label = H.div ! A.class_ ("node " `mappend` fromString cssClass `mappend` " leaf") $ - H.span $ H.text (fromString label) + H.span $ H.toMarkup label htmlLabels :: Labels htmlLabels = Labels { accFormat = "array-node" @@ -68,7 +75,7 @@ H.script ! A.type_ "text/javascript" ! A.src "https://ajax.googleapis.com/ajax/libs/jquery/1.4.4/jquery.min.js" $ mempty H.link ! A.rel "stylesheet" ! A.href "accelerate.css" ! A.type_ "text/css" - H.script ! A.type_ "text/javascript" $ H.text $ + H.script ! A.type_ "text/javascript" $ H.toMarkup $ T.unlines ["function collapse() {" ," var parent=$(this).parent();" ," var that = $(this);" @@ -177,15 +184,13 @@ where writeHtmlFile = do let cssPath = "accelerate.css" - h <- openFile cssPath WriteMode - hPutStr h accelerateCSS - hClose h - let path = basename ++ ".html" - h <- openFile path WriteMode - BS.hPutStr h (renderHtml $ htmlAST acc) + let path = basename ++ ".html" + -- + writeFile cssPath accelerateCSS + BS.writeFile path (renderHtml $ htmlAST acc) putStrLn ("HTML file successfully written to `" ++ path ++ "'\n" ++ "CSS file written to `" ++ cssPath ++ "'") - hClose h + handler :: IOError -> IO () handler e = case True of 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 @@ -1,7 +1,13 @@ -{-# LANGUAGE GADTs, FlexibleInstances, TypeOperators, ScopedTypeVariables, RankNTypes #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} -- | -- Module : Data.Array.Accelerate.Pretty.Print -- Copyright : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee +-- [2009..2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell -- License : BSD3 -- -- Maintainer : Manuel M T Chakravarty @@ -13,17 +19,19 @@ -- * Pretty printing functions PrettyAcc, - prettyPreAcc, prettyAcc, + prettyPreAcc, prettyOpenAcc, prettyPreExp, prettyExp, prettyPreAfun, prettyAfun, prettyPreFun, prettyFun, + prettyPrim, noParens ) where -- standard libraries +import Prelude hiding ( exp ) +import Data.List import Text.PrettyPrint -import Prelude hiding (exp) -- friends import Data.Array.Accelerate.Array.Sugar @@ -40,8 +48,8 @@ -- Pretty print an array expression -- -prettyAcc :: PrettyAcc OpenAcc -prettyAcc alvl wrap (OpenAcc acc) = prettyPreAcc prettyAcc alvl wrap acc +prettyOpenAcc :: PrettyAcc OpenAcc +prettyOpenAcc alvl wrap (OpenAcc acc) = prettyPreAcc prettyOpenAcc alvl wrap acc prettyPreAcc :: forall acc aenv a. @@ -51,11 +59,23 @@ -> PreOpenAcc acc aenv a -> Doc prettyPreAcc pp alvl wrap (Alet acc1 acc2) - = wrap - $ sep [ hang (text "let a" <> int alvl <+> char '=') 2 $ - pp alvl noParens acc1 - , text "in" <+> pp (alvl + 1) noParens acc2 - ] + | not (isAlet acc1') && isAlet acc2' + = wrap $ sep [ text "let" <+> a <+> equals <+> acc1' <+> text "in" + , acc2' ] + -- + | otherwise + = wrap $ sep [ hang (text "let" <+> a <+> equals) 2 acc1' + , text "in" <+> acc2' ] + where + -- TLM: derp, can't unwrap into a PreOpenAcc to pattern match on Alet + -- + isAlet doc = "let" `isPrefixOf` render doc + + acc1' = pp alvl noParens acc1 + acc2' = pp (alvl+1) noParens acc2 + a = char 'a' <> int alvl + + prettyPreAcc _ alvl _ (Avar idx) = text $ 'a' : show (alvl - idxToInt idx - 1) prettyPreAcc pp alvl wrap (Aprj ix arrs) @@ -71,77 +91,87 @@ prettyPreAcc pp alvl wrap (Unit e) = wrap $ prettyArrOp "unit" [prettyPreExp pp 0 alvl parens e] prettyPreAcc pp alvl wrap (Generate sh f) - = wrap + = wrap $ prettyArrOp "generate" [prettyPreExp pp 0 alvl parens sh, parens (prettyPreFun pp alvl f)] +prettyPreAcc pp alvl wrap (Transform sh ix f acc) + = wrap + $ prettyArrOp "transform" [ prettyPreExp pp 0 alvl parens sh + , parens (prettyPreFun pp alvl ix) + , parens (prettyPreFun pp alvl f) + , pp alvl parens acc ] prettyPreAcc pp alvl wrap (Reshape sh acc) = wrap $ prettyArrOp "reshape" [prettyPreExp pp 0 alvl parens sh, pp alvl parens acc] prettyPreAcc pp alvl wrap (Replicate _ty ix acc) - = wrap $ prettyArrOp "replicate" [prettyPreExp pp 0 alvl id ix, pp alvl parens acc] -prettyPreAcc pp alvl wrap (Index _ty acc ix) - = wrap $ sep [pp alvl parens acc, char '!', prettyPreExp pp 0 alvl id ix] + = wrap $ prettyArrOp "replicate" [prettyPreExp pp 0 alvl noParens ix, pp alvl parens acc] +prettyPreAcc pp alvl wrap (Slice _ty acc ix) + = wrap $ sep [pp alvl parens acc, char '!', prettyPreExp pp 0 alvl noParens ix] prettyPreAcc pp alvl wrap (Map f acc) = wrap $ prettyArrOp "map" [parens (prettyPreFun pp alvl f), pp alvl parens acc] prettyPreAcc pp alvl wrap (ZipWith f acc1 acc2) - = wrap + = wrap $ prettyArrOp "zipWith" [parens (prettyPreFun pp alvl f), pp alvl parens acc1, pp alvl parens acc2] prettyPreAcc pp alvl wrap (Fold f e acc) - = wrap + = wrap $ prettyArrOp "fold" [parens (prettyPreFun pp alvl f), prettyPreExp pp 0 alvl parens e, pp alvl parens acc] prettyPreAcc pp alvl wrap (Fold1 f acc) = wrap $ prettyArrOp "fold1" [parens (prettyPreFun pp alvl f), pp alvl parens acc] prettyPreAcc pp alvl wrap (FoldSeg f e acc1 acc2) - = wrap + = wrap $ prettyArrOp "foldSeg" [parens (prettyPreFun pp alvl f), prettyPreExp pp 0 alvl parens e, pp alvl parens acc1, pp alvl parens acc2] prettyPreAcc pp alvl wrap (Fold1Seg f acc1 acc2) - = wrap + = wrap $ prettyArrOp "fold1Seg" [parens (prettyPreFun pp alvl f), pp alvl parens acc1, pp alvl parens acc2] prettyPreAcc pp alvl wrap (Scanl f e acc) - = wrap + = wrap $ prettyArrOp "scanl" [parens (prettyPreFun pp alvl f), prettyPreExp pp 0 alvl parens e, pp alvl parens acc] prettyPreAcc pp alvl wrap (Scanl' f e acc) - = wrap + = wrap $ prettyArrOp "scanl'" [parens (prettyPreFun pp alvl f), prettyPreExp pp 0 alvl parens e, pp alvl parens acc] prettyPreAcc pp alvl wrap (Scanl1 f acc) - = wrap + = wrap $ prettyArrOp "scanl1" [parens (prettyPreFun pp alvl f), pp alvl parens acc] prettyPreAcc pp alvl wrap (Scanr f e acc) - = wrap + = wrap $ prettyArrOp "scanr" [parens (prettyPreFun pp alvl f), prettyPreExp pp 0 alvl parens e, pp alvl parens acc] prettyPreAcc pp alvl wrap (Scanr' f e acc) - = wrap + = wrap $ prettyArrOp "scanr'" [parens (prettyPreFun pp alvl f), prettyPreExp pp 0 alvl parens e, pp alvl parens acc] prettyPreAcc pp alvl wrap (Scanr1 f acc) - = wrap + = wrap $ prettyArrOp "scanr1" [parens (prettyPreFun pp alvl f), pp alvl parens acc] prettyPreAcc pp alvl wrap (Permute f dfts p acc) - = wrap + = wrap $ prettyArrOp "permute" [parens (prettyPreFun pp alvl f), pp alvl parens dfts, parens (prettyPreFun pp alvl p), pp alvl parens acc] prettyPreAcc pp alvl wrap (Backpermute sh p acc) - = wrap + = wrap $ prettyArrOp "backpermute" [prettyPreExp pp 0 alvl parens sh, parens (prettyPreFun pp alvl p), pp alvl parens acc] prettyPreAcc pp alvl wrap (Stencil sten bndy acc) - = wrap + = wrap $ prettyArrOp "stencil" [parens (prettyPreFun pp alvl sten), prettyBoundary acc bndy, pp alvl parens acc] prettyPreAcc pp alvl wrap (Stencil2 sten bndy1 acc1 bndy2 acc2) - = wrap + = wrap $ prettyArrOp "stencil2" [parens (prettyPreFun pp alvl sten), prettyBoundary acc1 bndy1, pp alvl parens acc1, prettyBoundary acc2 bndy2, pp alvl parens acc2] +prettyPreAcc pp alvl wrap (Aforeign ff afun acc) + = wrap $ prettyArrOp "aforeign" [text (strForeign ff), + parens (prettyPreAfun pp alvl afun), + pp alvl parens acc] prettyBoundary :: forall acc aenv dim e. Elt e => {-dummy-}acc aenv (Array dim e) -> Boundary (EltRepr e) -> Doc @@ -155,53 +185,63 @@ -- Pretty print a function over array computations. -- --- At the moment restricted to /closed/ functions. --- -prettyAfun :: Int -> Afun fun -> Doc -prettyAfun = prettyPreAfun prettyAcc +prettyAfun :: Int -> OpenAfun aenv t -> Doc +prettyAfun = prettyPreAfun prettyOpenAcc -prettyPreAfun :: forall acc fun. PrettyAcc acc -> Int -> PreAfun acc fun -> Doc -prettyPreAfun pp _alvl fun = +prettyPreAfun :: forall acc aenv fun. PrettyAcc acc -> Int -> PreOpenAfun acc aenv fun -> Doc +prettyPreAfun pp alvl fun = let (n, bodyDoc) = count n fun in char '\\' <> hsep [text $ 'a' : show idx | idx <- [0..n]] <+> text "->" <+> bodyDoc where count :: Int -> PreOpenAfun acc aenv' fun' -> (Int, Doc) - count lvl (Abody body) = (-1, pp (lvl + 1) noParens body) -- 'lvl+1' ok as functions is closed! + count lvl (Abody body) = (-1, pp (lvl + alvl + 1) noParens body) count lvl (Alam fun') = let (n, body) = count lvl fun' in (1 + n, body) -- Pretty print a function over scalar expressions. -- prettyFun :: Int -> OpenFun env aenv fun -> Doc -prettyFun = prettyPreFun prettyAcc +prettyFun = prettyPreFun prettyOpenAcc -prettyPreFun :: forall acc env aenv fun. PrettyAcc acc -> Int -> PreOpenFun acc env aenv fun -> Doc -prettyPreFun pp alvl fun = +prettyPreFun :: PrettyAcc acc -> Int -> PreOpenFun acc env aenv fun -> Doc +prettyPreFun pp = prettyPreOpenFun pp 0 + +prettyPreOpenFun :: forall acc env aenv fun. PrettyAcc acc -> Int -> Int -> PreOpenFun acc env aenv fun -> Doc +prettyPreOpenFun pp lvl alvl fun = let (n, bodyDoc) = count n fun in - char '\\' <> hsep [text $ 'x' : show idx | idx <- [0..n]] <+> + char '\\' <> hsep [text $ 'x' : show idx | idx <- [lvl..n]] <+> text "->" <+> bodyDoc where count :: Int -> PreOpenFun acc env' aenv' fun' -> (Int, Doc) - count lvl (Body body) = (-1, prettyPreExp pp (lvl + 1) alvl noParens body) - count lvl (Lam fun') = let (n, body) = count lvl fun' in (1 + n, body) + count l (Body body) = (lvl-1, prettyPreExp pp (l + 1) alvl noParens body) + count l (Lam fun') = let (n, body) = count l fun' in (1 + n, body) -- Pretty print an expression. -- -- * Apply the wrapping combinator (3rd argument) to any compound expressions. -- prettyExp :: Int -> Int -> (Doc -> Doc) -> OpenExp env aenv t -> Doc -prettyExp = prettyPreExp prettyAcc +prettyExp = prettyPreExp prettyOpenAcc prettyPreExp :: forall acc t env aenv. PrettyAcc acc -> Int -> Int -> (Doc -> Doc) -> PreOpenExp acc env aenv t -> Doc prettyPreExp pp lvl alvl wrap (Let e1 e2) - = wrap - $ sep [ hang (text "let x" <> int lvl <+> char '=') 2 $ - prettyPreExp pp lvl alvl noParens e1 - , text "in" <+> prettyPreExp pp (lvl + 1) alvl noParens e2 - ] + | not (isLet e1) && isLet e2 + = wrap $ sep [ text "let" <+> x <+> equals <+> e1' <+> text "in" + , e2' ] + -- + | otherwise + = wrap $ sep [ hang (text "let" <+> x <+> equals) 2 e1' + , text "in" <+> e2' ] + where + isLet (Let _ _) = True + isLet _ = False + e1' = prettyPreExp pp lvl alvl noParens e1 + e2' = prettyPreExp pp (lvl+1) alvl noParens e2 + x = char 'x' <> int lvl + prettyPreExp _pp lvl _ _ (Var idx) = text $ 'x' : show (lvl - idxToInt idx - 1) prettyPreExp _pp _ _ _ (Const v) @@ -210,22 +250,41 @@ = prettyTuple pp lvl alvl tup prettyPreExp pp lvl alvl wrap (Prj idx e) = wrap $ char '#' <> prettyTupleIdx idx <+> prettyPreExp pp lvl alvl parens e -prettyPreExp _pp _lvl _alvl wrap IndexNil - = wrap $ text "index Z" +prettyPreExp _pp _lvl _alvl _wrap IndexNil + = char 'Z' prettyPreExp pp lvl alvl wrap (IndexCons t h) - = wrap $ - text "index" <+> - parens (prettyPreExp pp lvl alvl parens t <+> text ":." <+> prettyPreExp pp lvl alvl parens h) + = wrap $ prettyPreExp pp lvl alvl noParens t <+> text ":." <+> prettyPreExp pp lvl alvl noParens h prettyPreExp pp lvl alvl wrap (IndexHead ix) = wrap $ text "indexHead" <+> prettyPreExp pp lvl alvl parens ix prettyPreExp pp lvl alvl wrap (IndexTail ix) = wrap $ text "indexTail" <+> prettyPreExp pp lvl alvl parens ix prettyPreExp _ _ _ wrap (IndexAny) = wrap $ text "indexAny" +prettyPreExp pp lvl alvl wrap (IndexSlice _ slix sh) + = wrap $ text "indexSlice" <+> sep [ prettyPreExp pp lvl alvl parens slix + , prettyPreExp pp lvl alvl parens sh ] +prettyPreExp pp lvl alvl wrap (IndexFull _ slix sl) + = wrap $ text "indexFull" <+> sep [ prettyPreExp pp lvl alvl parens slix + , prettyPreExp pp lvl alvl parens sl ] +prettyPreExp pp lvl alvl wrap (ToIndex sh ix) + = wrap $ text "toIndex" <+> sep [ prettyPreExp pp lvl alvl parens sh + , prettyPreExp pp lvl alvl parens ix ] +prettyPreExp pp lvl alvl wrap (FromIndex sh ix) + = wrap $ text "fromIndex" <+> sep [ prettyPreExp pp lvl alvl parens sh + , prettyPreExp pp lvl alvl parens ix ] prettyPreExp pp lvl alvl wrap (Cond c t e) - = wrap $ sep [prettyPreExp pp lvl alvl parens c <+> char '?', - parens (prettyPreExp pp lvl alvl noParens t <> comma <+> - prettyPreExp pp lvl alvl noParens e)] + = wrap $ sep [ prettyPreExp pp lvl alvl parens c <+> char '?', + tuple [ prettyPreExp pp lvl alvl noParens t + , prettyPreExp pp lvl alvl noParens e ] ] +prettyPreExp pp lvl alvl wrap (Iterate i fun a) + = wrap $ text "iterate" <> brackets (prettyPreExp pp lvl alvl id i) + <+> sep [ wrap (prettyPreExp pp lvl alvl parens a) + , parens (prettyPreOpenFun pp lvl alvl (Lam (Body fun))) ] +prettyPreExp pp lvl alvl wrap (Foreign ff f e) + = wrap $ text "foreign" <+> text (strForeign ff) + <+> prettyPreFun pp alvl f + <+> prettyPreExp pp lvl alvl parens e + prettyPreExp _pp _ _ _ (PrimConst a) = prettyConst a prettyPreExp pp lvl alvl wrap (PrimApp p a) @@ -234,20 +293,24 @@ | otherwise = wrap $ f' <+> prettyPreExp pp lvl alvl parens a - where - -- sometimes the infix function arguments are obstructed by, for example, a - -- scalar let binding. If so, add parentheses and print prefix. + -- sometimes the infix function arguments are obstructed by. If so, add + -- parentheses and print prefix. -- (infixOp, f) = prettyPrim p f' = if infixOp then parens f else f -prettyPreExp pp lvl alvl wrap (IndexScalar idx i) +prettyPreExp pp lvl alvl wrap (Index idx i) = wrap $ cat [pp alvl parens idx, char '!', prettyPreExp pp lvl alvl parens i] +prettyPreExp pp lvl alvl wrap (LinearIndex idx i) + = wrap $ cat [pp alvl parens idx, text "!!", prettyPreExp pp lvl alvl parens i] prettyPreExp pp _lvl alvl wrap (Shape idx) = wrap $ text "shape" <+> pp alvl parens idx prettyPreExp pp lvl alvl wrap (ShapeSize idx) = wrap $ text "shapeSize" <+> parens (prettyPreExp pp lvl alvl parens idx) +prettyPreExp pp lvl alvl wrap (Intersect sh1 sh2) + = wrap $ text "intersect" <+> sep [ prettyPreExp pp lvl alvl parens sh1 + , prettyPreExp pp lvl alvl parens sh2 ] -- Pretty print nested pairs as a proper tuple. -- @@ -256,15 +319,15 @@ -> Int -> Atuple (acc aenv) t -> Doc -prettyAtuple pp alvl = encloseSep lparen rparen comma . collect +prettyAtuple pp alvl = tuple . collect where collect :: Atuple (acc aenv) t' -> [Doc] collect NilAtup = [] - collect (SnocAtup tup a) = collect tup ++ [pp alvl id a] + collect (SnocAtup tup a) = collect tup ++ [pp alvl noParens a] prettyTuple :: forall acc env aenv t. PrettyAcc acc -> Int -> Int -> Tuple (PreOpenExp acc env aenv) t -> Doc -prettyTuple pp lvl alvl = encloseSep lparen rparen comma . collect +prettyTuple pp lvl alvl = tuple . collect where collect :: Tuple (PreOpenExp acc env aenv) t' -> [Doc] collect NilTup = [] @@ -356,7 +419,7 @@ -- TLM: seems to flatten the nesting structure -- prettyArrays :: ArraysR arrs -> arrs -> Doc -prettyArrays arrs = encloseSep lparen rparen comma . collect arrs +prettyArrays arrs = tuple . collect arrs where collect :: ArraysR arrs -> arrs -> [Doc] collect ArraysRunit _ = [] @@ -365,10 +428,9 @@ prettyArray :: forall dim e. Array dim e -> Doc prettyArray arr@(Array sh _) - = parens $ - hang (text "Array") 2 $ - sep [ parens . text $ showShape (toElt sh :: dim) - , dataDoc] + = hang (text "Array") 2 + $ sep [ parens . text $ showShape (toElt sh :: dim) + , dataDoc] where showDoc :: forall a. Show a => a -> Doc showDoc = text . show @@ -384,6 +446,9 @@ noParens :: Doc -> Doc noParens = id +tuple :: [Doc] -> Doc +tuple = encloseSep lparen rparen comma + encloseSep :: Doc -> Doc -> Doc -> [Doc] -> Doc encloseSep left right p ds = case ds of @@ -391,6 +456,7 @@ [d] -> left <> d <> right _ -> left <> sep (punctuate p ds) <> right + -- Auxiliary ops -- @@ -408,3 +474,4 @@ runScalarShow (NonNumScalarType ty) | NonNumDict <- nonNumDict ty = show -} + diff --git a/Data/Array/Accelerate/Pretty/Traverse.hs b/Data/Array/Accelerate/Pretty/Traverse.hs --- a/Data/Array/Accelerate/Pretty/Traverse.hs +++ b/Data/Array/Accelerate/Pretty/Traverse.hs @@ -41,15 +41,17 @@ travAcc' (Alet acc1 acc2) = combine "Alet" [travAcc f c l acc1, travAcc f c l acc2] travAcc' (Avar idx) = leaf ("AVar " `cat` idxToInt idx) travAcc' (Apply afun acc) = combine "Apply" [travAfun f c l afun, travAcc f c l acc] + travAcc' (Aforeign ff afun acc) = combine ("Aforeign " ++ strForeign ff) [travAfun f c l afun, travAcc f c l acc] travAcc' (Acond e acc1 acc2) = combine "Acond" [travExp f c l e, travAcc f c l acc1, travAcc f c l acc2] travAcc' (Atuple tup) = combine "Atuple" [ travAtuple f c l tup ] travAcc' (Aprj idx a) = combine ("Aprj " `cat` tupleIdxToInt idx) [ travAcc f c l a ] travAcc' (Use arr) = combine "Use" [ travArrays f c l (arrays (undefined::a)) arr ] travAcc' (Unit e) = combine "Unit" [ travExp f c l e ] travAcc' (Generate sh fun) = combine "Generate" [ travExp f c l sh, travFun f c l fun] + travAcc' (Transform sh pf vf acc) = combine "Transform" [ travExp f c l sh, travFun f c l pf, travFun f c l vf, travAcc f c l acc ] travAcc' (Reshape sh acc) = combine "Reshape" [ travExp f c l sh, travAcc f c l acc ] travAcc' (Replicate _ ix acc) = combine "Replicate" [ travExp f c l ix, travAcc f c l acc ] - travAcc' (Index _ acc ix) = combine "Index" [ travAcc f c l acc, travExp f c l ix ] + travAcc' (Slice _ acc ix) = combine "Slice" [ travAcc f c l acc, travExp f c l ix ] travAcc' (Map fun acc) = combine "Map" [ travFun f c l fun, travAcc f c l acc ] travAcc' (ZipWith fun acc1 acc2) = combine "ZipWith" [ travFun f c l fun, travAcc f c l acc1, travAcc f c l acc2 ] travAcc' (Fold fun e acc) = combine "Fold" [ travFun f c l fun, travExp f c l e, travAcc f c l acc] @@ -82,22 +84,30 @@ leaf = l (expFormat f) travExp' :: OpenExp env aenv a -> m b - travExp' (Let e1 e2) = combine "Let" [travExp f c l e1, travExp f c l e2] - travExp' (Var idx) = leaf ("Var " `cat` idxToInt idx) - travExp' (Const v) = leaf ("Const " `cat` (toElt v :: a)) - travExp' (Tuple tup) = combine "Tuple" [ travTuple f c l tup ] - travExp' (Prj idx e) = combine ("Prj " `cat` tupleIdxToInt idx) [ travExp f c l e ] - travExp' (IndexNil) = leaf "IndexNil" - travExp' (IndexCons t h) = combine "IndexCons" [ travExp f c l t, travExp f c l h] - travExp' (IndexHead ix) = combine "IndexHead" [ travExp f c l ix ] - travExp' (IndexTail ix) = combine "IndexTail" [ travExp f c l ix ] - travExp' (IndexAny) = leaf "IndexAny" - travExp' (Cond cond thn els) = combine "Cond" [travExp f c l cond, travExp f c l thn, travExp f c l els] - travExp' (PrimConst a) = leaf ("PrimConst " `cat` labelForConst a) - travExp' (PrimApp p a) = combine "PrimApp" [ l (primFunFormat f) (labelForPrimFun p), travExp f c l a ] - travExp' (IndexScalar idx i) = combine "IndexScalar" [ travAcc f c l idx, travExp f c l i] - travExp' (Shape idx) = combine "Shape" [ travAcc f c l idx ] - travExp' (ShapeSize e) = combine "ShapeSize" [ travExp f c l e ] + travExp' (Let e1 e2) = combine "Let" [travExp f c l e1, travExp f c l e2] + travExp' (Var idx) = leaf ("Var " `cat` idxToInt idx) + travExp' (Const v) = leaf ("Const " `cat` (toElt v :: a)) + travExp' (Tuple tup) = combine "Tuple" [ travTuple f c l tup ] + travExp' (Prj idx e) = combine ("Prj " `cat` tupleIdxToInt idx) [ travExp f c l e ] + travExp' (IndexNil) = leaf "IndexNil" + travExp' (IndexCons t h) = combine "IndexCons" [ travExp f c l t, travExp f c l h] + travExp' (IndexHead ix) = combine "IndexHead" [ travExp f c l ix ] + travExp' (IndexTail ix) = combine "IndexTail" [ travExp f c l ix ] + travExp' (IndexAny) = leaf "IndexAny" + travExp' (IndexSlice _ slix sh) = combine "IndexSlice" [ travExp f c l slix, travExp f c l sh ] + travExp' (IndexFull _ slix sl) = combine "IndexFull" [ travExp f c l slix, travExp f c l sl ] + travExp' (ToIndex sh ix) = combine "ToIndex" [ travExp f c l sh, travExp f c l ix ] + travExp' (FromIndex sh ix) = combine "FromIndex" [ travExp f c l sh, travExp f c l ix ] + travExp' (Cond cond thn els) = combine "Cond" [travExp f c l cond, travExp f c l thn, travExp f c l els] + travExp' (Iterate _ fun x) = combine "Iterate" [ travFun f c l (Lam (Body fun)), travExp f c l x ] + travExp' (PrimConst a) = leaf ("PrimConst " `cat` labelForConst a) + travExp' (PrimApp p a) = combine "PrimApp" [ l (primFunFormat f) (labelForPrimFun p), travExp f c l a ] + travExp' (Index idx i) = combine "Index" [ travAcc f c l idx, travExp f c l i] + travExp' (LinearIndex idx i) = combine "LinearIndex" [ travAcc f c l idx, travExp f c l i] + travExp' (Shape idx) = combine "Shape" [ travAcc f c l idx ] + travExp' (ShapeSize e) = combine "ShapeSize" [ travExp f c l e ] + travExp' (Intersect sh1 sh2) = combine "Intersect" [ travExp f c l sh1, travExp f c l sh2 ] + travExp' (Foreign ff fun e) = combine ("Foreign " ++ strForeign ff) [ travFun f c l fun, travExp f c l e ] travAfun :: forall m b aenv fun. Monad m => Labels -> (String -> String -> [m b] -> m b) @@ -240,10 +250,6 @@ labelForConst (PrimMinBound _) = "PrimMinBound" labelForConst (PrimMaxBound _) = "PrimMaxBound" labelForConst (PrimPi _) = "PrimPi" - -tupleIdxToInt :: TupleIdx t e -> Int -tupleIdxToInt ZeroTupIdx = 0 -tupleIdxToInt (SuccTupIdx n) = 1 + tupleIdxToInt n -- Auxiliary ops -- 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 @@ -1,2719 +1,1057 @@ -{-# LANGUAGE CPP, GADTs, TypeOperators, TypeFamilies, ScopedTypeVariables, RankNTypes #-} -{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-} -{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, PatternGuards #-} -{-# OPTIONS_HADDOCK hide #-} --- | --- Module : Data.Array.Accelerate.Smart --- Copyright : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee --- License : BSD3 --- --- Maintainer : Manuel M T Chakravarty --- Stability : experimental --- Portability : non-portable (GHC extensions) --- --- This modules defines the AST of the user-visible embedded language using more --- convenient higher-order abstract syntax (instead of de Bruijn indices). --- Moreover, it defines smart constructors to construct programs. --- - -module Data.Array.Accelerate.Smart ( - - -- * HOAS AST - Acc(..), PreAcc(..), Exp(..), PreExp(..), Boundary(..), Stencil(..), - - -- * HOAS -> de Bruijn conversion - convertAcc, convertAccFun1, - - -- * Smart constructors for literals - constant, - - -- * Smart constructors and destructors for tuples - tup2, tup3, tup4, tup5, tup6, tup7, tup8, tup9, - untup2, untup3, untup4, untup5, untup6, untup7, untup8, untup9, - - atup2, atup3, atup4, atup5, atup6, atup7, atup8, atup9, - unatup2, unatup3, unatup4, unatup5, unatup6, unatup7, unatup8, unatup9, - - -- * Smart constructors for constants - mkMinBound, mkMaxBound, mkPi, - mkSin, mkCos, mkTan, - mkAsin, mkAcos, mkAtan, - 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, mkIDiv, mkMod, - mkBAnd, mkBOr, mkBXor, mkBNot, mkBShiftL, mkBShiftR, mkBRotateL, mkBRotateR, - mkFDiv, mkRecip, mkLt, mkGt, mkLtEq, mkGtEq, mkEq, mkNEq, mkMax, mkMin, - mkLAnd, mkLOr, mkLNot, - - -- * Smart constructors for type coercion functions - mkBoolToInt, mkFromIntegral, - - -- * Auxiliary functions - ($$), ($$$), ($$$$), ($$$$$) - -) where - --- standard library -import Control.Applicative hiding (Const) -import Control.Monad.Fix -import Control.Monad -import Data.HashTable as Hash -import Data.List -import Data.Maybe -import qualified Data.IntMap as IntMap -import Data.Typeable -import System.Mem.StableName -import System.IO.Unsafe (unsafePerformIO) -import Prelude hiding (exp) - --- friends -import Data.Array.Accelerate.Debug -import Data.Array.Accelerate.Type -import Data.Array.Accelerate.Array.Sugar -import qualified Data.Array.Accelerate.Array.Sugar as Sugar -import Data.Array.Accelerate.Tuple hiding (Tuple) -import Data.Array.Accelerate.AST hiding ( - PreOpenAcc(..), OpenAcc(..), Acc, Stencil(..), PreOpenExp(..), OpenExp, PreExp, Exp) -import qualified Data.Array.Accelerate.Tuple as Tuple -import qualified Data.Array.Accelerate.AST as AST -import Data.Array.Accelerate.Pretty () - -#include "accelerate.h" - - --- Configuration (mostly for debugging) --- ------------- - --- Recover the sharing of array computations? --- -recoverAccSharing :: Bool -recoverAccSharing = True - --- Are array computations floated out of expressions irrespective of whether they are shared or --- not? 'True' implies floating them out. (Requires 'recoverAccSharing' to be 'True' as well.) --- -floatOutAccFromExp :: Bool -floatOutAccFromExp = recoverAccSharing && True - --- Recover the sharing of scalar expressions? --- -recoverExpSharing :: Bool -recoverExpSharing = True - - --- Layouts --- ------- - --- A layout of an environment has an entry for each entry of the environment. --- Each entry in the layout holds the deBruijn index that refers to the --- corresponding entry in the environment. --- -data Layout env env' where - EmptyLayout :: Layout env () - PushLayout :: Typeable t - => Layout env env' -> Idx env t -> Layout env (env', t) - --- Project the nth index out of an environment layout. --- --- The first argument provides context information for error messages in the case of failure. --- -prjIdx :: forall t env env'. Typeable t => String -> Int -> Layout env env' -> Idx env t -prjIdx ctxt 0 (PushLayout _ (ix :: Idx env0 t0)) - = case gcast ix of - Just ix' -> ix' - Nothing -> possiblyNestedErr ctxt $ - "Couldn't match expected type `" ++ show (typeOf (undefined::t)) ++ - "' with actual type `" ++ show (typeOf (undefined::t0)) ++ "'" ++ - "\n Type mismatch" -prjIdx ctxt n (PushLayout l _) = prjIdx ctxt (n - 1) l -prjIdx ctxt _ EmptyLayout = possiblyNestedErr ctxt "Environment doesn't contain index" - -possiblyNestedErr :: String -> String -> a -possiblyNestedErr ctxt failreason - = error $ "Fatal error in Smart.prjIdx:" - ++ "\n " ++ failreason ++ " at " ++ ctxt - ++ "\n Possible reason: nested data parallelism — array computation that depends on a" - ++ "\n scalar variable of type 'Exp a'" - --- Add an entry to a layout, incrementing all indices --- -incLayout :: Layout env env' -> Layout (env, t) env' -incLayout EmptyLayout = EmptyLayout -incLayout (PushLayout lyt ix) = PushLayout (incLayout lyt) (SuccIdx ix) - - --- Array computations --- ------------------ - --- 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 occurence. --- -type Level = Int - --- |Array-valued collective computations without a recursive knot --- --- Note [Pipe and sharing recovery] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- The 'Pipe' constructor is special. It is the only form that contains functions over array --- computations and these functions are fixed to be over vanilla 'Acc' types. This enables us to --- perform sharing recovery independently from the context for them. --- -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) -- see comment above on why 'Acc' and not 'acc' - -> (Acc bs -> Acc cs) - -> acc as - -> PreAcc acc exp cs - Acond :: (Arrays as) - => exp Bool - -> acc as - -> acc as - -> PreAcc acc exp as - - Atuple :: (Arrays arrs, IsTuple arrs) - => Tuple.Atuple acc (TupleRepr arrs) - -> PreAcc acc exp arrs - - Aprj :: (Arrays arrs, IsTuple 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, - Typeable (SliceShape slix), Typeable (FullShape slix)) - -- the Typeable constraints shouldn't be necessary as they are implied by - -- 'SliceIx slix' — unfortunately, the (old) type checker doesn't grok that - => exp slix - -> acc (Array (SliceShape slix) e) - -> PreAcc acc exp (Array (FullShape slix) e) - Index :: (Slice slix, Elt e, - Typeable (SliceShape slix), Typeable (FullShape slix)) - -- the Typeable constraints shouldn't be necessary as they are implied by - -- 'SliceIx slix' — unfortunately, the (old) type checker doesn't grok that - => 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 :: Elt e - => (Exp e -> Exp e -> exp e) - -> exp e - -> acc (Vector e) - -> PreAcc acc exp (Vector e) - Scanl' :: Elt e - => (Exp e -> Exp e -> exp e) - -> exp e - -> acc (Vector e) - -> PreAcc acc exp (Vector e, Scalar e) - Scanl1 :: Elt e - => (Exp e -> Exp e -> exp e) - -> acc (Vector e) - -> PreAcc acc exp (Vector e) - Scanr :: Elt e - => (Exp e -> Exp e -> exp e) - -> exp e - -> acc (Vector e) - -> PreAcc acc exp (Vector e) - Scanr' :: Elt e - => (Exp e -> Exp e -> exp e) - -> exp e - -> acc (Vector e) - -> PreAcc acc exp (Vector e, Scalar e) - Scanr1 :: Elt e - => (Exp e -> Exp e -> exp e) - -> acc (Vector e) - -> PreAcc acc exp (Vector 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) - --- |Array-valued collective computations --- -newtype Acc a = Acc (PreAcc Acc Exp a) - -deriving instance Typeable1 Acc - --- |Conversion from HOAS to de Bruijn computation AST --- - - --- |Convert a closed array expression to de Bruijn form while also incorporating sharing --- information. --- -convertAcc :: Arrays arrs => Acc arrs -> AST.Acc arrs -convertAcc = convertOpenAcc 0 [] EmptyLayout - --- |Convert an open array expression to de Bruijn form while also incorporating sharing --- information. --- -convertOpenAcc :: Arrays arrs => Level -> [Level] -> Layout aenv aenv -> Acc arrs -> AST.OpenAcc aenv arrs -convertOpenAcc lvl fvs alyt acc - = let - (sharingAcc, initialEnv) = recoverSharingAcc floatOutAccFromExp lvl fvs acc - in - convertSharingAcc alyt initialEnv sharingAcc - --- |Convert a unary function over array computations --- -convertAccFun1 :: forall a b. (Arrays a, Arrays b) - => (Acc a -> Acc b) - -> AST.Afun (a -> b) -convertAccFun1 f = Alam (Abody openF) - where - lvl = 0 - a = Atag lvl - alyt = EmptyLayout - `PushLayout` - (ZeroIdx :: Idx ((), a) a) - openF = convertOpenAcc (lvl + 1) [lvl] alyt (f (Acc a)) - --- |Convert an array expression with given array environment layout and sharing information into --- de Bruijn form while recovering sharing at the same time (by introducing appropriate let --- bindings). The latter implements the third phase of sharing recovery. --- --- The sharing environment 'env' keeps track of all currently bound sharing variables, keeping them --- in reverse chronological order (outermost variable is at the end of the list). --- -convertSharingAcc :: forall a aenv. Arrays a - => Layout aenv aenv - -> [StableSharingAcc] - -> SharingAcc a - -> AST.OpenAcc aenv a -convertSharingAcc alyt env (AvarSharing sa) - | Just i <- findIndex (matchStableAcc sa) env - = AST.OpenAcc $ AST.Avar (prjIdx (ctxt ++ "; i = " ++ show i) i alyt) - | null env - = error $ "Cyclic definition of a value of type 'Acc' (sa = " ++ - show (hashStableNameHeight sa) ++ ")" - | otherwise - = INTERNAL_ERROR(error) "convertSharingAcc" err - where - ctxt = "shared 'Acc' tree with stable name " ++ show (hashStableNameHeight sa) - err = "inconsistent valuation @ " ++ ctxt ++ ";\n env = " ++ show env -convertSharingAcc alyt env (AletSharing sa@(StableSharingAcc _ boundAcc) bodyAcc) - = AST.OpenAcc - $ let alyt' = incLayout alyt `PushLayout` ZeroIdx - in - AST.Alet (convertSharingAcc alyt env boundAcc) (convertSharingAcc alyt' (sa:env) bodyAcc) -convertSharingAcc alyt env (AccSharing _ preAcc) - = AST.OpenAcc - $ (case preAcc of - Atag i - -> AST.Avar (prjIdx ("de Bruijn conversion tag " ++ show i) i alyt) - Pipe afun1 afun2 acc - -> let boundAcc = convertAccFun1 afun1 `AST.Apply` convertSharingAcc alyt env acc - bodyAcc = convertAccFun1 afun2 `AST.Apply` AST.OpenAcc (AST.Avar AST.ZeroIdx) - in - AST.Alet (AST.OpenAcc boundAcc) (AST.OpenAcc bodyAcc) - Acond b acc1 acc2 - -> AST.Acond (convertExp alyt env b) (convertSharingAcc alyt env acc1) - (convertSharingAcc alyt env acc2) - Atuple arrs - -> AST.Atuple (convertSharingAtuple alyt env arrs) - Aprj ix a - -> AST.Aprj ix (convertSharingAcc alyt env a) - Use array - -> AST.Use (fromArr array) - Unit e - -> AST.Unit (convertExp alyt env e) - Generate sh f - -> AST.Generate (convertExp alyt env sh) (convertFun1 alyt env f) - Reshape e acc - -> AST.Reshape (convertExp alyt env e) (convertSharingAcc alyt env acc) - Replicate ix acc - -> mkReplicate (convertExp alyt env ix) (convertSharingAcc alyt env acc) - Index acc ix - -> mkIndex (convertSharingAcc alyt env acc) (convertExp alyt env ix) - Map f acc - -> AST.Map (convertFun1 alyt env f) (convertSharingAcc alyt env acc) - ZipWith f acc1 acc2 - -> AST.ZipWith (convertFun2 alyt env f) - (convertSharingAcc alyt env acc1) - (convertSharingAcc alyt env acc2) - Fold f e acc - -> AST.Fold (convertFun2 alyt env f) (convertExp alyt env e) - (convertSharingAcc alyt env acc) - Fold1 f acc - -> AST.Fold1 (convertFun2 alyt env f) (convertSharingAcc alyt env acc) - FoldSeg f e acc1 acc2 - -> AST.FoldSeg (convertFun2 alyt env f) (convertExp alyt env e) - (convertSharingAcc alyt env acc1) (convertSharingAcc alyt env acc2) - Fold1Seg f acc1 acc2 - -> AST.Fold1Seg (convertFun2 alyt env f) - (convertSharingAcc alyt env acc1) - (convertSharingAcc alyt env acc2) - Scanl f e acc - -> AST.Scanl (convertFun2 alyt env f) (convertExp alyt env e) - (convertSharingAcc alyt env acc) - Scanl' f e acc - -> AST.Scanl' (convertFun2 alyt env f) - (convertExp alyt env e) - (convertSharingAcc alyt env acc) - Scanl1 f acc - -> AST.Scanl1 (convertFun2 alyt env f) (convertSharingAcc alyt env acc) - Scanr f e acc - -> AST.Scanr (convertFun2 alyt env f) (convertExp alyt env e) - (convertSharingAcc alyt env acc) - Scanr' f e acc - -> AST.Scanr' (convertFun2 alyt env f) - (convertExp alyt env e) - (convertSharingAcc alyt env acc) - Scanr1 f acc - -> AST.Scanr1 (convertFun2 alyt env f) (convertSharingAcc alyt env acc) - Permute f dftAcc perm acc - -> AST.Permute (convertFun2 alyt env f) - (convertSharingAcc alyt env dftAcc) - (convertFun1 alyt env perm) - (convertSharingAcc alyt env acc) - Backpermute newDim perm acc - -> AST.Backpermute (convertExp alyt env newDim) - (convertFun1 alyt env perm) - (convertSharingAcc alyt env acc) - Stencil stencil boundary acc - -> AST.Stencil (convertStencilFun acc alyt env stencil) - (convertBoundary boundary) - (convertSharingAcc alyt env acc) - Stencil2 stencil bndy1 acc1 bndy2 acc2 - -> AST.Stencil2 (convertStencilFun2 acc1 acc2 alyt env stencil) - (convertBoundary bndy1) - (convertSharingAcc alyt env acc1) - (convertBoundary bndy2) - (convertSharingAcc alyt env acc2) - :: AST.PreOpenAcc AST.OpenAcc aenv a) - -convertSharingAtuple - :: forall aenv a. - Layout aenv aenv - -> [StableSharingAcc] - -> Tuple.Atuple SharingAcc a - -> Tuple.Atuple (AST.OpenAcc aenv) a -convertSharingAtuple alyt aenv = cvt - where - cvt :: Tuple.Atuple SharingAcc a' -> Tuple.Atuple (AST.OpenAcc aenv) a' - cvt NilAtup = NilAtup - cvt (SnocAtup t a) = cvt t `SnocAtup` convertSharingAcc alyt aenv a - - --- |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) - - --- 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'. --- - --- |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 -> PreExp acc exp t - -- environment size at defining occurrence - - -- All the same constructors as 'AST.Exp' - Const :: Elt t - => t -> PreExp acc exp t - - Tuple :: (Elt t, IsTuple t) - => Tuple.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) - Cond :: Elt t - => exp Bool -> 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 - IndexScalar :: (Shape sh, Elt t) - => acc (Array sh t) -> exp sh -> 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 - --- |Scalar expressions for plain array computations. --- -newtype Exp t = Exp (PreExp Acc Exp t) - -deriving instance Typeable1 Exp - --- |Conversion from HOAS to de Bruijn expression AST --- - - --- |Convert an open expression with given environment layouts and sharing information into --- de Bruijn form while recovering sharing at the same time (by introducing appropriate let --- bindings). The latter implements the third phase of sharing recovery. --- --- The sharing environments 'env' and 'aenv' keep track of all currently bound sharing variables, --- keeping them in reverse chronological order (outermost variable is at the end of the list). --- -convertSharingExp :: forall t env aenv - . Elt t - => Layout env env -- scalar environment - -> Layout aenv aenv -- array environment - -> [StableSharingExp] -- currently bound sharing variables of expressions - -> [StableSharingAcc] -- currently bound sharing variables of array computations - -> SharingExp t -- expression to be converted - -> AST.OpenExp env aenv t -convertSharingExp lyt alyt env aenv = cvt - where - cvt :: Elt t' => SharingExp t' -> AST.OpenExp env aenv t' - cvt (VarSharing se) - | Just i <- findIndex (matchStableExp se) env - = AST.Var (prjIdx (ctxt ++ "; i = " ++ show i) i lyt) - | null env - = error $ "Cyclic definition of a value of type 'Exp' (sa = " ++ show (hashStableNameHeight se) ++ ")" - | otherwise - = INTERNAL_ERROR(error) "convertSharingExp" err - where - ctxt = "shared 'Exp' tree with stable name " ++ show (hashStableNameHeight se) - err = "inconsistent valuation @ " ++ ctxt ++ ";\n env = " ++ show env - cvt (LetSharing se@(StableSharingExp _ boundExp) bodyExp) - = let lyt' = incLayout lyt `PushLayout` ZeroIdx - in - AST.Let (cvt boundExp) (convertSharingExp lyt' alyt (se:env) aenv bodyExp) - cvt (ExpSharing _ pexp) - = case pexp of - Tag i -> AST.Var (prjIdx ("de Bruijn conversion tag " ++ show i) i lyt) - Const v -> AST.Const (fromElt v) - Tuple tup -> AST.Tuple (convertTuple lyt alyt env aenv tup) - Prj idx e -> AST.Prj idx (cvt e) - IndexNil -> AST.IndexNil - IndexCons ix i -> AST.IndexCons (cvt ix) (cvt i) - IndexHead i -> AST.IndexHead (cvt i) - IndexTail ix -> AST.IndexTail (cvt ix) - IndexAny -> AST.IndexAny - Cond e1 e2 e3 -> AST.Cond (cvt e1) (cvt e2) (cvt e3) - PrimConst c -> AST.PrimConst c - PrimApp p e -> AST.PrimApp p (cvt e) - IndexScalar a e -> AST.IndexScalar (convertSharingAcc alyt aenv a) (cvt e) - Shape a -> AST.Shape (convertSharingAcc alyt aenv a) - ShapeSize e -> AST.ShapeSize (cvt e) - --- |Convert a tuple expression --- -convertTuple :: Layout env env - -> Layout aenv aenv - -> [StableSharingExp] -- currently bound scalar sharing-variables - -> [StableSharingAcc] -- currently bound array sharing-variables - -> Tuple.Tuple SharingExp t - -> Tuple.Tuple (AST.OpenExp env aenv) t -convertTuple _lyt _alyt _env _aenv NilTup = NilTup -convertTuple lyt alyt env aenv (es `SnocTup` e) - = convertTuple lyt alyt env aenv es `SnocTup` convertSharingExp lyt alyt env aenv e - --- |Convert an expression closed wrt to scalar variables --- -convertExp :: Elt t - => Layout aenv aenv -- array environment - -> [StableSharingAcc] -- currently bound array sharing-variables - -> RootExp t -- expression to be converted - -> AST.Exp aenv t -convertExp alyt aenv (EnvExp env exp) = convertSharingExp EmptyLayout alyt env aenv exp -convertExp _ _ _ = INTERNAL_ERROR(error) "convertExp" "not an 'EnvExp'" - --- |Convert a unary functions --- -convertFun1 :: forall a b aenv. (Elt a, Elt b) - => Layout aenv aenv - -> [StableSharingAcc] -- currently bound array sharing-variables - -> (Exp a -> RootExp b) - -> AST.Fun aenv (a -> b) -convertFun1 alyt aenv f = Lam (Body openF) - where - a = Exp $ undefined -- the 'tag' was already embedded in Phase 1 - lyt = EmptyLayout - `PushLayout` - (ZeroIdx :: Idx ((), a) a) - EnvExp env body = f a - openF = convertSharingExp lyt alyt env aenv body - --- |Convert a binary functions --- -convertFun2 :: forall a b c aenv. (Elt a, Elt b, Elt c) - => Layout aenv aenv - -> [StableSharingAcc] -- currently bound array sharing-variables - -> (Exp a -> Exp b -> RootExp c) - -> AST.Fun aenv (a -> b -> c) -convertFun2 alyt aenv f = Lam (Lam (Body openF)) - where - a = Exp $ undefined - b = Exp $ undefined - lyt = EmptyLayout - `PushLayout` - (SuccIdx ZeroIdx :: Idx (((), a), b) a) - `PushLayout` - (ZeroIdx :: Idx (((), a), b) b) - EnvExp env body = f a b - openF = convertSharingExp lyt alyt env aenv body - --- Convert a unary stencil function --- -convertStencilFun :: forall sh a stencil b aenv. (Elt a, Stencil sh a stencil, Elt b) - => SharingAcc (Array sh a) -- just passed to fix the type variables - -> Layout aenv aenv - -> [StableSharingAcc] -- currently bound array sharing-variables - -> (stencil -> RootExp b) - -> AST.Fun aenv (StencilRepr sh stencil -> b) -convertStencilFun _ alyt aenv stencilFun = Lam (Body openStencilFun) - where - stencil = Exp $ undefined :: Exp (StencilRepr sh stencil) - lyt = EmptyLayout - `PushLayout` - (ZeroIdx :: Idx ((), StencilRepr sh stencil) - (StencilRepr sh stencil)) - - EnvExp env body = stencilFun (stencilPrj (undefined::sh) (undefined::a) stencil) - openStencilFun = convertSharingExp lyt alyt env aenv body - --- Convert a binary stencil function --- -convertStencilFun2 :: forall sh a b stencil1 stencil2 c aenv. - (Elt a, Stencil sh a stencil1, - Elt b, Stencil sh b stencil2, - Elt c) - => SharingAcc (Array sh a) -- just passed to fix the type variables - -> SharingAcc (Array sh b) -- just passed to fix the type variables - -> Layout aenv aenv - -> [StableSharingAcc] -- currently bound array sharing-variables - -> (stencil1 -> stencil2 -> RootExp c) - -> AST.Fun aenv (StencilRepr sh stencil1 -> - StencilRepr sh stencil2 -> c) -convertStencilFun2 _ _ alyt aenv stencilFun = Lam (Lam (Body openStencilFun)) - where - stencil1 = Exp $ undefined :: Exp (StencilRepr sh stencil1) - stencil2 = Exp $ undefined :: Exp (StencilRepr sh stencil2) - lyt = EmptyLayout - `PushLayout` - (SuccIdx ZeroIdx :: Idx (((), StencilRepr sh stencil1), - StencilRepr sh stencil2) - (StencilRepr sh stencil1)) - `PushLayout` - (ZeroIdx :: Idx (((), StencilRepr sh stencil1), - StencilRepr sh stencil2) - (StencilRepr sh stencil2)) - - EnvExp env body = stencilFun (stencilPrj (undefined::sh) (undefined::a) stencil1) - (stencilPrj (undefined::sh) (undefined::b) stencil2) - openStencilFun = convertSharingExp lyt alyt env aenv body - - --- Sharing recovery --- ---------------- - --- Sharing recovery proceeds in two phases: --- --- /Phase One: build the occurence map/ --- --- This is a top-down traversal of the AST that computes a map from AST nodes to the number of --- occurences of that AST node in the overall Accelerate program. An occurrences count of two or --- more indicates sharing. --- --- IMPORTANT: To avoid unfolding the sharing, we do not descent into subtrees that we have --- previously encountered. Hence, the complexity is proprtional to the number of nodes in the --- tree /with/ sharing. Consequently, the occurence count is that in the tree with sharing --- as well. --- --- During computation of the occurences, the tree is annotated with stable names on every node --- using 'AccSharing' constructors and all but the first occurence of shared subtrees are pruned --- using 'AvarSharing' constructors (see 'SharingAcc' below). This phase is impure as it is based --- on stable names. --- --- We use a hash table (instead of 'Data.Map') as computing stable names forces us to live in IO --- anyway. Once, the computation of occurence counts is complete, we freeze the hash table into --- a 'Data.Map'. --- --- (Implemented by 'makeOccMap'.) --- --- /Phase Two: determine scopes and inject sharing information/ --- --- This is a bottom-up traversal that determines the scope for every binding to be introduced --- to share a subterm. It uses the occurence map to determine, for every shared subtree, the --- lowest AST node at which the binding for that shared subtree can be placed (using a --- 'AletSharing' constructor)— it's the meet of all the shared subtree occurences. --- --- The second phase is also replacing the first occurence of each shared subtree with a --- 'AvarSharing' node and floats the shared subtree up to its binding point. --- --- (Implemented by 'determineScopes'.) --- --- /Sharing recovery for expressions/ --- --- We recover sharing for each expression (including function bodies) independently of any other --- expression — i.e., we cannot share scalar expressions across array computations. Hence, during --- Phase One, we mark all scalar expression nodes with a stable name and compute one occurence map --- for every scalar expression (including functions) that occurs in an array computation. These --- occurence maps are added to the root of scalar expressions using 'RootExp'. --- --- NB: We do not need to worry sharing recovery will try to float a shared subexpression past a --- binder that occurs in that subexpression. Why? Otherwise, the binder would already occur --- out of scope in the orignal source program. --- --- /Lambda bound variables/ --- --- During sharing recovery, lambda bound variables appear in the form of 'Atag' and 'Tag' data --- constructors. The tag values are determined during Phase One of sharing recovery by computing --- the /level/ of each variable at its binding occurence. The level at the root of the AST is 0 --- and increases by one with each lambda on each path through the AST. - --- Stable names - --- Opaque stable name for AST nodes — used to key the occurence map. --- -data StableASTName c where - StableASTName :: (Typeable1 c, Typeable t) => StableName (c t) -> StableASTName c - -instance Show (StableASTName c) where - show (StableASTName sn) = show $ hashStableName sn - -instance Eq (StableASTName c) where - StableASTName sn1 == StableASTName sn2 - | Just sn1' <- gcast sn1 = sn1' == sn2 - | otherwise = False - -makeStableAST :: c t -> IO (StableName (c t)) -makeStableAST e = e `seq` makeStableName e - --- Stable name for an AST node including the height of the AST representing the array computation. --- -data StableNameHeight t = StableNameHeight (StableName t) Int - -instance Eq (StableNameHeight t) where - (StableNameHeight sn1 _) == (StableNameHeight sn2 _) = sn1 == sn2 - -higherSNH :: StableNameHeight t1 -> StableNameHeight t2 -> Bool -StableNameHeight _ h1 `higherSNH` StableNameHeight _ h2 = h1 > h2 - -hashStableNameHeight :: StableNameHeight t -> Int -hashStableNameHeight (StableNameHeight sn _) = hashStableName sn - --- Mutable occurence map - --- Hash table keyed on the stable names of array computations. --- -type ASTHashTable c v = Hash.HashTable (StableASTName c) v - --- Mutable hashtable version of the occurrence map, which associates each AST node with an --- occurence count and the height of the AST. --- -type OccMapHash c = ASTHashTable c (Int, Int) - --- Create a new hash table keyed on AST nodes. --- -newASTHashTable :: IO (ASTHashTable c v) -newASTHashTable = Hash.new (==) hashStableAST - where - hashStableAST (StableASTName sn) = fromIntegral (hashStableName sn) - --- Enter one AST node occurrence into an occurrence map. Returns 'Just h' if this is a repeated --- occurence and the height of the repeatedly occuring AST is 'h'. --- --- If this is the first occurence, the 'height' *argument* must provide the height of the AST; --- otherwise, the height will be *extracted* from the occurence map. In the latter case, this --- function yields the AST height. --- -enterOcc :: OccMapHash c -> StableASTName c -> Int -> IO (Maybe Int) -enterOcc occMap sa height - = do - entry <- Hash.lookup occMap sa - case entry of - Nothing -> Hash.insert occMap sa (1 , height) >> return Nothing - Just (n, heightS) -> Hash.update occMap sa (n + 1, heightS) >> return (Just heightS) - --- Immutable occurence map - --- Immutable version of the occurence map (storing the occurence count only, not the height). We --- use the 'StableName' hash to index an 'IntMap' and disambiguate 'StableName's with identical --- hashes explicitly, storing them in a list in the 'IntMap'. --- -type OccMap c = IntMap.IntMap [(StableASTName c, Int)] - --- Turn a mutable into an immutable occurence map. --- -freezeOccMap :: OccMapHash c -> IO (OccMap c) -freezeOccMap oc - = do - kvs <- map dropHeight <$> Hash.toList oc - return . IntMap.fromList . map (\kvs -> (key (head kvs), kvs)). groupBy sameKey $ kvs - where - key (StableASTName sn, _) = hashStableName sn - sameKey kv1 kv2 = key kv1 == key kv2 - dropHeight (k, (cnt, _)) = (k, cnt) - --- Look up the occurence map keyed by array computations using a stable name. If a the key does --- not exist in the map, return an occurence count of '1'. --- -lookupWithASTName :: OccMap c -> StableASTName c -> Int -lookupWithASTName oc sa@(StableASTName sn) - = fromMaybe 1 $ IntMap.lookup (hashStableName sn) oc >>= Prelude.lookup sa - --- Look up the occurence map keyed by array computations using a sharing array computation. If an --- the key does not exist in the map, return an occurence count of '1'. --- -lookupWithSharingAcc :: OccMap Acc -> StableSharingAcc -> Int -lookupWithSharingAcc oc (StableSharingAcc (StableNameHeight sn _) _) - = lookupWithASTName oc (StableASTName sn) - --- Look up the occurence map keyed by scalar expressions using a sharing expression. If an --- the key does not exist in the map, return an occurence count of '1'. --- -lookupWithSharingExp :: OccMap Exp -> StableSharingExp -> Int -lookupWithSharingExp oc (StableSharingExp (StableNameHeight sn _) _) - = lookupWithASTName oc (StableASTName sn) - --- Stable 'Acc' nodes - --- Stable name for 'Acc' nodes including the height of the AST. --- -type StableAccName arrs = StableNameHeight (Acc arrs) - --- Interleave sharing annotations into an array computation AST. Subtrees can be marked as being --- represented by variable (binding a shared subtree) using 'AvarSharing' and as being prefixed by --- a let binding (for a shared subtree) using 'AletSharing'. --- -data SharingAcc arrs where - AvarSharing :: Arrays arrs - => StableAccName arrs -> SharingAcc arrs - AletSharing :: StableSharingAcc -> SharingAcc arrs -> SharingAcc arrs - AccSharing :: Arrays arrs - => StableAccName arrs -> PreAcc SharingAcc RootExp arrs -> SharingAcc arrs - --- Stable name for an array computation associated with its sharing-annotated version. --- -data StableSharingAcc where - StableSharingAcc :: Arrays arrs => StableAccName arrs -> SharingAcc arrs -> StableSharingAcc - -instance Show StableSharingAcc where - show (StableSharingAcc sn _) = show $ hashStableNameHeight sn - -instance Eq StableSharingAcc where - StableSharingAcc sn1 _ == StableSharingAcc sn2 _ - | Just sn1' <- gcast sn1 = sn1' == sn2 - | otherwise = False - -higherSSA :: StableSharingAcc -> StableSharingAcc -> Bool -StableSharingAcc sn1 _ `higherSSA` StableSharingAcc sn2 _ = sn1 `higherSNH` sn2 - --- Test whether the given stable names matches an array computation with sharing. --- -matchStableAcc :: Typeable arrs => StableAccName arrs -> StableSharingAcc -> Bool -matchStableAcc sn1 (StableSharingAcc sn2 _) - | Just sn1' <- gcast sn1 = sn1' == sn2 - | otherwise = False - --- Dummy entry for environments to be used for unused variables. --- -noStableAccName :: StableAccName arrs -noStableAccName = unsafePerformIO $ StableNameHeight <$> makeStableName undefined <*> pure 0 - --- Stable 'Exp' nodes - --- Stable name for 'Exp' nodes including the height of the AST. --- -type StableExpName t = StableNameHeight (Exp t) - --- Interleave sharing annotations into a scalar expressions AST in the same manner as 'SharingAcc' --- do for array computations. --- -data SharingExp t where - VarSharing :: Elt t - => StableExpName t -> SharingExp t - LetSharing :: StableSharingExp -> SharingExp t -> SharingExp t - ExpSharing :: Elt t - => StableExpName t -> PreExp SharingAcc SharingExp t -> SharingExp t - --- Expressions rooted in 'Acc' computations. --- --- * Between counting occurences and determining scopes, the root of every expression embedded in an --- 'Acc' is annotated by (1) the tags of free scalar variables and (2) an occurence map for that --- one expression (excluding any subterms that are rooted in embedded 'Acc's.) --- * After determining scopes, the root of every expression is annotated with a sorted environment of --- the 'StableSharingExp's corresponding to its free expression-valued variables. --- -data RootExp t where - OccMapExp :: [Int] -> OccMap Exp -> SharingExp t -> RootExp t - EnvExp :: [StableSharingExp] -> SharingExp t -> RootExp t - --- Stable name for an expression associated with its sharing-annotated version. --- -data StableSharingExp where - StableSharingExp :: Elt t => StableExpName t -> SharingExp t -> StableSharingExp - -instance Show StableSharingExp where - show (StableSharingExp sn _) = show $ hashStableNameHeight sn - -instance Eq StableSharingExp where - StableSharingExp sn1 _ == StableSharingExp sn2 _ - | Just sn1' <- gcast sn1 = sn1' == sn2 - | otherwise = False - -higherSSE :: StableSharingExp -> StableSharingExp -> Bool -StableSharingExp sn1 _ `higherSSE` StableSharingExp sn2 _ = sn1 `higherSNH` sn2 - --- Test whether the given stable names matches an expression with sharing. --- -matchStableExp :: Typeable t => StableExpName t -> StableSharingExp -> Bool -matchStableExp sn1 (StableSharingExp sn2 _) - | Just sn1' <- gcast sn1 = sn1' == sn2 - | otherwise = False - --- Dummy entry for environments to be used for unused variables. --- -noStableExpName :: StableExpName t -noStableExpName = unsafePerformIO $ StableNameHeight <$> makeStableName undefined <*> pure 0 - --- Compute the 'Acc' occurence map, marks all nodes (both 'Acc' and 'Exp' nodes) with stable names, --- and drop repeated occurences of shared 'Acc' and 'Exp' subtrees (Phase One). --- --- We compute a single 'Acc' occurence map for the whole AST, but one 'Exp' occurence map for each --- sub-expression rooted in an 'Acc' operation. This is as we cannot float 'Exp' subtrees across --- 'Acc' operations, but we can float 'Acc' subtrees out of 'Exp' expressions. --- --- Note [Traversing functions and side effects] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- We need to descent into function bodies to build the 'OccMap' with all occurences in the --- function bodies. Due to the side effects in the construction of the occurence map and, more --- importantly, the dependence of the second phase on /global/ occurence information, we may not --- delay the body traversals by putting them under a lambda. Hence, we apply each function, to --- traverse its body and use a /dummy abstraction/ of the result. --- --- For example, given a function 'f', we traverse 'f (Tag 0)', which yields a transformed body 'e'. --- As the result of the traversal of the overall function, we use 'const e'. Hence, it is crucial --- that the 'Tag' supplied during the initial traversal is already the one required by the HOAS to --- de Bruijn conversion in 'convertSharingAcc' — any subsequent application of 'const e' will only --- yield 'e' with the embedded 'Tag 0' of the original application. During sharing recovery, we --- float /all/ free variables ('Atag' and 'Tag') out to construct the initial environment for --- producing de Bruijn indices, which replaces them by 'AvarSharing' or 'VarSharing' nodes. Hence, --- the tag values only serve the purpose of determining the ordering in that initial environment. --- They are /not/ directly used to compute the de Brujin indices. --- -makeOccMap :: Typeable arrs => Level -> Acc arrs -> IO (SharingAcc arrs, OccMapHash Acc) -makeOccMap lvl rootAcc - = do - traceLine "makeOccMap" "Enter" - occMap <- newASTHashTable - (rootAcc', _) <- traverseAcc lvl occMap rootAcc - traceLine "makeOccMap" "Exit" - return (rootAcc', occMap) - where - traverseAcc :: forall arrs. Typeable arrs - => Level -> OccMapHash Acc -> Acc arrs -> IO (SharingAcc arrs, Int) - traverseAcc lvl occMap acc@(Acc pacc) - = mfix $ \ ~(_, height) -> do - { -- Compute stable name and enter it into the occurence map - ; sn <- makeStableAST acc - ; heightIfRepeatedOccurence <- enterOcc occMap (StableASTName sn) height - - ; traceLine (showPreAccOp pacc) $ - case heightIfRepeatedOccurence of - Just height -> "REPEATED occurence (sn = " ++ show (hashStableName sn) ++ - "; height = " ++ show height ++ ")" - Nothing -> "first occurence (sn = " ++ show (hashStableName sn) ++ ")" - - -- Reconstruct the computation in shared form. - -- - -- In case of a repeated occurence, the height comes from the occurence map; otherwise, - -- it is computed by the traversal function passed in 'newAcc'. See also 'enterOcc'. - -- - -- NB: This function can only be used in the case alternatives below; outside of the - -- case we cannot discharge the 'Arrays arrs' constraint. - ; let reconstruct :: Arrays arrs - => IO (PreAcc SharingAcc RootExp arrs, Int) - -> IO (SharingAcc arrs, Int) - reconstruct newAcc - = case heightIfRepeatedOccurence of - Just height | recoverAccSharing - -> return (AvarSharing (StableNameHeight sn height), height) - _ -> do - { (acc, height) <- newAcc - ; return (AccSharing (StableNameHeight sn height) acc, height) - } - - ; case pacc of - Atag i -> reconstruct $ return (Atag i, 0) -- height is 0! - Pipe afun1 afun2 acc -> reconstruct $ travA (Pipe afun1 afun2) acc - Acond e acc1 acc2 -> reconstruct $ do - (e' , h1) <- enterExp lvl occMap e - (acc1', h2) <- traverseAcc lvl occMap acc1 - (acc2', h3) <- traverseAcc lvl occMap acc2 - return (Acond e' acc1' acc2', h1 `max` h2 `max` h3 + 1) - - Atuple tup -> reconstruct $ do - (tup', h) <- travAtup tup - return (Atuple tup', h) - Aprj ix a -> reconstruct $ travA (Aprj ix) a - - Use arr -> reconstruct $ return (Use arr, 1) - Unit e -> reconstruct $ do - (e', h) <- enterExp lvl occMap e - return (Unit e', h + 1) - Generate e f -> reconstruct $ do - (e', h1) <- enterExp lvl occMap e - (f', h2) <- traverseFun1 lvl occMap f - return (Generate e' f', h1 `max` h2 + 1) - Reshape e acc -> reconstruct $ travEA Reshape e acc - Replicate e acc -> reconstruct $ travEA Replicate e acc - Index acc e -> reconstruct $ travEA (flip Index) e acc - Map f acc -> reconstruct $ do - (f' , h1) <- traverseFun1 lvl occMap f - (acc', h2) <- traverseAcc lvl occMap acc - return (Map f' acc', h1 `max` h2 + 1) - ZipWith f acc1 acc2 -> reconstruct $ travF2A2 ZipWith f acc1 acc2 - Fold f e acc -> reconstruct $ travF2EA Fold f e acc - Fold1 f acc -> reconstruct $ travF2A Fold1 f acc - FoldSeg f e acc1 acc2 -> reconstruct $ do - (f' , h1) <- traverseFun2 lvl occMap f - (e' , h2) <- enterExp lvl occMap e - (acc1', h3) <- traverseAcc lvl occMap acc1 - (acc2', h4) <- traverseAcc lvl occMap acc2 - return (FoldSeg f' e' acc1' acc2', - h1 `max` h2 `max` h3 `max` h4 + 1) - Fold1Seg f acc1 acc2 -> reconstruct $ travF2A2 Fold1Seg f acc1 acc2 - Scanl f e acc -> reconstruct $ travF2EA Scanl f e acc - Scanl' f e acc -> reconstruct $ travF2EA Scanl' f e acc - Scanl1 f acc -> reconstruct $ travF2A Scanl1 f acc - Scanr f e acc -> reconstruct $ travF2EA Scanr f e acc - Scanr' f e acc -> reconstruct $ travF2EA Scanr' f e acc - Scanr1 f acc -> reconstruct $ travF2A Scanr1 f acc - Permute c acc1 p acc2 -> reconstruct $ do - (c' , h1) <- traverseFun2 lvl occMap c - (p' , h2) <- traverseFun1 lvl occMap p - (acc1', h3) <- traverseAcc lvl occMap acc1 - (acc2', h4) <- traverseAcc lvl occMap acc2 - return (Permute c' acc1' p' acc2', - h1 `max` h2 `max` h3 `max` h4 + 1) - Backpermute e p acc -> reconstruct $ do - (e' , h1) <- enterExp lvl occMap e - (p' , h2) <- traverseFun1 lvl occMap p - (acc', h3) <- traverseAcc lvl occMap acc - return (Backpermute e' p' acc', h1 `max` h2 `max` h3 + 1) - Stencil s bnd acc -> reconstruct $ do - (s' , h1) <- traverseStencil1 acc lvl occMap s - (acc', h2) <- traverseAcc lvl occMap acc - return (Stencil s' bnd acc', h1 `max` h2 + 1) - Stencil2 s bnd1 acc1 - bnd2 acc2 -> reconstruct $ do - (s' , h1) <- traverseStencil2 acc1 acc2 lvl occMap s - (acc1', h2) <- traverseAcc lvl occMap acc1 - (acc2', h3) <- traverseAcc lvl occMap acc2 - return (Stencil2 s' bnd1 acc1' bnd2 acc2', - h1 `max` h2 `max` h3 + 1) - } - where - travA :: Arrays arrs' - => (SharingAcc arrs' -> PreAcc SharingAcc RootExp arrs) - -> Acc arrs' -> IO (PreAcc SharingAcc RootExp arrs, Int) - travA c acc - = do - (acc', h) <- traverseAcc lvl occMap acc - return (c acc', h + 1) - - travEA :: (Typeable b, Arrays arrs') - => (RootExp b -> SharingAcc arrs' -> PreAcc SharingAcc RootExp arrs) - -> Exp b -> Acc arrs' -> IO (PreAcc SharingAcc RootExp arrs, Int) - travEA c exp acc - = do - (exp', h1) <- enterExp lvl occMap exp - (acc', h2) <- traverseAcc lvl occMap acc - return (c exp' acc', h1 `max` h2 + 1) - - travF2A :: (Elt b, Elt c, Typeable d, Arrays arrs') - => ((Exp b -> Exp c -> RootExp d) -> SharingAcc arrs' - -> PreAcc SharingAcc RootExp arrs) - -> (Exp b -> Exp c -> Exp d) -> Acc arrs' - -> IO (PreAcc SharingAcc RootExp arrs, Int) - travF2A c fun acc - = do - (fun', h1) <- traverseFun2 lvl occMap fun - (acc', h2) <- traverseAcc lvl occMap acc - return (c fun' acc', h1 `max` h2 + 1) - - travF2EA :: (Elt b, Elt c, Typeable d, Typeable e, Arrays arrs') - => ((Exp b -> Exp c -> RootExp d) -> RootExp e - -> SharingAcc arrs' -> PreAcc SharingAcc RootExp arrs) - -> (Exp b -> Exp c -> Exp d) -> Exp e -> Acc arrs' - -> IO (PreAcc SharingAcc RootExp arrs, Int) - travF2EA c fun exp acc - = do - (fun', h1) <- traverseFun2 lvl occMap fun - (exp', h2) <- enterExp lvl occMap exp - (acc', h3) <- traverseAcc lvl occMap acc - return (c fun' exp' acc', h1 `max` h2 `max` h3 + 1) - - travF2A2 :: (Elt b, Elt c, Typeable d, Arrays arrs1, Arrays arrs2) - => ((Exp b -> Exp c -> RootExp d) -> SharingAcc arrs1 - -> SharingAcc arrs2 -> PreAcc SharingAcc RootExp arrs) - -> (Exp b -> Exp c -> Exp d) -> Acc arrs1 -> Acc arrs2 - -> IO (PreAcc SharingAcc RootExp arrs, Int) - travF2A2 c fun acc1 acc2 - = do - (fun' , h1) <- traverseFun2 lvl occMap fun - (acc1', h2) <- traverseAcc lvl occMap acc1 - (acc2', h3) <- traverseAcc lvl occMap acc2 - return (c fun' acc1' acc2', h1 `max` h2 `max` h3 + 1) - - travAtup :: Tuple.Atuple Acc a - -> IO (Tuple.Atuple SharingAcc a, Int) - travAtup NilAtup = return (NilAtup, 1) - travAtup (SnocAtup tup a) = do - (tup', h1) <- travAtup tup - (a', h2) <- traverseAcc lvl occMap a - return (SnocAtup tup' a', h1 `max` h2 + 1) - - traverseFun1 :: (Elt b, Typeable c) - => Level -> OccMapHash Acc -> (Exp b -> Exp c) -> IO (Exp b -> RootExp c, Int) - traverseFun1 lvl occMap f - = do - -- see Note [Traversing functions and side effects] - (body, h) <- enterFun (lvl + 1) [lvl] occMap $ f (Exp $ Tag lvl) - return (const body, h + 1) - - traverseFun2 :: (Elt b, Elt c, Typeable d) - => Level -> OccMapHash Acc -> (Exp b -> Exp c -> Exp d) - -> IO (Exp b -> Exp c -> RootExp d, Int) - traverseFun2 lvl occMap f - = do - -- see Note [Traversing functions and side effects] - (body, h) <- enterFun (lvl + 2) [lvl, lvl + 1] occMap $ f (Exp $ Tag (lvl + 1)) (Exp $ Tag lvl) - return (\_ _ -> body, h + 2) - - traverseStencil1 :: forall sh b c stencil. (Stencil sh b stencil, Typeable c) - => Acc (Array sh b){-dummy-} - -> Level -> OccMapHash Acc -> (stencil -> Exp c) - -> IO (stencil -> RootExp c, Int) - traverseStencil1 _ lvl occMap stencilFun - = do - -- see Note [Traversing functions and side effects] - (body, h) <- enterFun (lvl + 1) [lvl] occMap $ - stencilFun (stencilPrj (undefined::sh) (undefined::b) (Exp $ Tag lvl)) - return (const body, h + 1) - - traverseStencil2 :: forall sh b c d stencil1 stencil2. - (Stencil sh b stencil1, Stencil sh c stencil2, Typeable d) - => Acc (Array sh b){-dummy-} - -> Acc (Array sh c){-dummy-} - -> Level - -> OccMapHash Acc - -> (stencil1 -> stencil2 -> Exp d) - -> IO (stencil1 -> stencil2 -> RootExp d, Int) - traverseStencil2 _ _ lvl occMap stencilFun - = do - -- see Note [Traversing functions and side effects] - (body, h) <- enterFun (lvl + 2) [lvl, lvl + 1] occMap $ - stencilFun (stencilPrj (undefined::sh) (undefined::b) (Exp $ Tag (lvl + 1))) - (stencilPrj (undefined::sh) (undefined::c) (Exp $ Tag lvl)) - return (\_ _ -> body, h + 2) - - -- Enter an 'Exp' subtree from an 'Acc' tree => need a local 'Exp' occurence map - -- - -- First argument is the level (of bound variables) and the second are the tags of newly - -- introduced free scalar variables in this expression. - -- - enterFun :: forall a. Typeable a => Level -> [Int] -> OccMapHash Acc -> Exp a -> IO (RootExp a, Int) - enterFun lvl fvs accOccMap exp - = do - { expOccMap <- newASTHashTable - ; (exp', h) <- traverseExp lvl accOccMap expOccMap exp - ; frozenExpOccMap <- freezeOccMap expOccMap - ; return (OccMapExp fvs frozenExpOccMap exp', h) - } - - -- 'enterFun' without any new free variables. - -- - enterExp :: forall a. Typeable a => Level -> OccMapHash Acc -> Exp a -> IO (RootExp a, Int) - enterExp lvl = enterFun lvl [] - - traverseExp :: forall a. Typeable a => Level -> OccMapHash Acc -> OccMapHash Exp -> Exp a -> IO (SharingExp a, Int) - traverseExp lvl accOccMap expOccMap exp@(Exp pexp) - = mfix $ \ ~(_, height) -> do - { -- Compute stable name and enter it into the occurence map - ; sn <- makeStableAST exp - ; heightIfRepeatedOccurence <- enterOcc expOccMap (StableASTName sn) height - - ; traceLine (showPreExpOp pexp) $ - case heightIfRepeatedOccurence of - Just height -> "REPEATED occurence (sn = " ++ show (hashStableName sn) ++ - "; height = " ++ show height ++ ")" - Nothing -> "first occurence (sn = " ++ show (hashStableName sn) ++ ")" - - - -- Reconstruct the computation in shared form. - -- - -- In case of a repeated occurence, the height comes from the occurence map; otherwise, - -- it is computed by the traversal function passed in 'newExp'. See also 'enterOcc'. - -- - -- NB: This function can only be used in the case alternatives below; outside of the - -- case we cannot discharge the 'Elt a' constraint. - ; let reconstruct :: Elt a - => IO (PreExp SharingAcc SharingExp a, Int) - -> IO (SharingExp a, Int) - reconstruct newExp - = case heightIfRepeatedOccurence of - Just height | recoverExpSharing - -> return (VarSharing (StableNameHeight sn height), height) - _ -> do - { (exp, height) <- newExp - ; return (ExpSharing (StableNameHeight sn height) exp, height) - } - - ; case pexp of - Tag i -> reconstruct $ return (Tag i, 0) -- height is 0! - Const c -> reconstruct $ return (Const c, 1) - Tuple tup -> reconstruct $ do - (tup', h) <- travTup tup - return (Tuple tup', h) - Prj i e -> reconstruct $ travE1 (Prj i) e - IndexNil -> reconstruct $ return (IndexNil, 1) - IndexCons ix i -> reconstruct $ travE2 IndexCons ix i - IndexHead i -> reconstruct $ travE1 IndexHead i - IndexTail ix -> reconstruct $ travE1 IndexTail ix - IndexAny -> reconstruct $ return (IndexAny, 1) - Cond e1 e2 e3 -> reconstruct $ travE3 Cond e1 e2 e3 - PrimConst c -> reconstruct $ return (PrimConst c, 1) - PrimApp p e -> reconstruct $ travE1 (PrimApp p) e - IndexScalar a e -> reconstruct $ travAE IndexScalar a e - Shape a -> reconstruct $ travA Shape a - ShapeSize e -> reconstruct $ travE1 ShapeSize e - } - where - travE1 :: Typeable b => (SharingExp b -> PreExp SharingAcc SharingExp a) -> Exp b - -> IO (PreExp SharingAcc SharingExp a, Int) - travE1 c e - = do - (e', h) <- traverseExp lvl accOccMap expOccMap e - return (c e', h + 1) - - travE2 :: (Typeable b, Typeable c) - => (SharingExp b -> SharingExp c -> PreExp SharingAcc SharingExp a) - -> Exp b -> Exp c - -> IO (PreExp SharingAcc SharingExp a, Int) - travE2 c e1 e2 - = do - (e1', h1) <- traverseExp lvl accOccMap expOccMap e1 - (e2', h2) <- traverseExp lvl accOccMap expOccMap e2 - return (c e1' e2', h1 `max` h2 + 1) - - travE3 :: (Typeable b, Typeable c, Typeable d) - => (SharingExp b -> SharingExp c -> SharingExp d -> PreExp SharingAcc SharingExp a) - -> Exp b -> Exp c -> Exp d - -> IO (PreExp SharingAcc SharingExp a, Int) - travE3 c e1 e2 e3 - = do - (e1', h1) <- traverseExp lvl accOccMap expOccMap e1 - (e2', h2) <- traverseExp lvl accOccMap expOccMap e2 - (e3', h3) <- traverseExp lvl accOccMap expOccMap e3 - return (c e1' e2' e3', h1 `max` h2 `max` h3 + 1) - - travA :: Typeable b => (SharingAcc b -> PreExp SharingAcc SharingExp a) -> Acc b - -> IO (PreExp SharingAcc SharingExp a, Int) - travA c acc - = do - (acc', h) <- traverseAcc lvl accOccMap acc - return (c acc', h + 1) - - travAE :: (Typeable b, Typeable c) - => (SharingAcc b -> SharingExp c -> PreExp SharingAcc SharingExp a) - -> Acc b -> Exp c - -> IO (PreExp SharingAcc SharingExp a, Int) - travAE c acc e - = do - (acc', h1) <- traverseAcc lvl accOccMap acc - (e' , h2) <- traverseExp lvl accOccMap expOccMap e - return (c acc' e', h1 `max` h2 + 1) - - travTup :: Tuple.Tuple Exp tup -> IO (Tuple.Tuple SharingExp tup, Int) - travTup NilTup = return (NilTup, 1) - travTup (SnocTup tup e) = do - (tup', h1) <- travTup tup - (e' , h2) <- traverseExp lvl accOccMap expOccMap e - return (SnocTup tup' e', h1 `max` h2 + 1) - --- Type used to maintain how often each shared subterm, so far, occured during a bottom-up sweep. --- --- Invariants: --- - If one shared term 's' is itself a subterm of another shared term 't', then 's' must occur --- *after* 't' in the 'NodeCounts'. --- - No shared term occurs twice. --- - A term may have a final occurence count of only 1 iff it is either a free variable ('Atag' --- or 'Tag') or an array computation listed out of an expression. --- - All 'Exp' node counts precede all 'Acc' node counts as we don't share 'Exp' nodes across 'Acc' --- nodes. --- --- We determine the subterm property by using the tree height in 'StableNameHeight'. Trees get --- smaller towards the end of a 'NodeCounts' list. The height of free variables ('Atag' or 'Tag') --- is 0, whereas other leaves have height 1. This guarantees that all free variables are at the end --- of the 'NodeCounts' list. --- --- To ensure the invariant is preserved over merging node counts from sibling subterms, the --- function '(+++)' must be used. --- -type NodeCounts = [NodeCount] - -data NodeCount = AccNodeCount StableSharingAcc Int - | ExpNodeCount StableSharingExp Int - deriving Show - --- Empty node counts --- -noNodeCounts :: NodeCounts -noNodeCounts = [] - --- Singleton node counts for 'Acc' --- -accNodeCount :: StableSharingAcc -> Int -> NodeCounts -accNodeCount ssa n = [AccNodeCount ssa n] - --- Singleton node counts for 'Exp' --- -expNodeCount :: StableSharingExp -> Int -> NodeCounts -expNodeCount sse n = [ExpNodeCount sse n] - --- Combine node counts that belong to the same node. --- --- * We assume that the node counts invariant —subterms follow their parents— holds for both --- arguments and guarantee that it still holds for the result. --- * In the same manner, we assume that all 'Exp' node counts precede 'Acc' node counts and --- guarantee that this also hold for the result. --- -(+++) :: NodeCounts -> NodeCounts -> NodeCounts -us +++ vs = foldr insert us vs - where - insert x [] = [x] - insert x@(AccNodeCount sa1 count1) ys@(y@(AccNodeCount sa2 count2) : ys') - | sa1 == sa2 = AccNodeCount (sa1 `pickNoneAvar` sa2) (count1 + count2) : ys' - | sa1 `higherSSA` sa2 = x : ys - | otherwise = y : insert x ys' - insert x@(ExpNodeCount se1 count1) ys@(y@(ExpNodeCount se2 count2) : ys') - | se1 == se2 = ExpNodeCount (se1 `pickNoneVar` se2) (count1 + count2) : ys' - | se1 `higherSSE` se2 = x : ys - | otherwise = y : insert x ys' - insert x@(AccNodeCount _ _) (y@(ExpNodeCount _ _) : ys') - = y : insert x ys' - insert x@(ExpNodeCount _ _) (y@(AccNodeCount _ _) : ys') - = x : insert y ys' - - (StableSharingAcc _ (AvarSharing _)) `pickNoneAvar` sa2 = sa2 - sa1 `pickNoneAvar` _sa2 = sa1 - - (StableSharingExp _ (VarSharing _)) `pickNoneVar` sa2 = sa2 - sa1 `pickNoneVar` _sa2 = sa1 - --- Build an initial environment for the tag values given in the first argument for traversing an --- array expression. The 'StableSharingAcc's for all tags /actually used/ in the expressions are --- in the second argument. (Tags are not used if a bound variable has no usage occurence.) --- --- Bail out if any tag occurs multiple times as this indicates that the sharing of an argument --- variable was not preserved and we cannot build an appropriate initial environment (c.f., comments --- at 'determineScopes'. --- -buildInitialEnvAcc :: [Level] -> [StableSharingAcc] -> [StableSharingAcc] -buildInitialEnvAcc tags sas = map (lookupSA sas) tags - where - lookupSA sas tag1 - = case filter hasTag sas of - [] -> noStableSharing -- tag is not used in the analysed expression - [sa] -> sa -- tag has a unique occurence - sas2 -> INTERNAL_ERROR(error) "buildInitialEnvAcc" - ("Encountered duplicate 'ATag's\n " ++ concat (intersperse ", " (map showSA sas2))) - where - hasTag (StableSharingAcc _ (AccSharing _ (Atag tag2))) = tag1 == tag2 - hasTag sa - = INTERNAL_ERROR(error) "buildInitialEnvAcc" - ("Encountered a node that is not a plain 'Atag'\n " ++ showSA sa) - - noStableSharing :: StableSharingAcc - noStableSharing = StableSharingAcc noStableAccName (undefined :: SharingAcc ()) - - showSA (StableSharingAcc _ (AccSharing sn acc)) = show (hashStableNameHeight sn) ++ ": " ++ - showPreAccOp acc - showSA (StableSharingAcc _ (AvarSharing sn)) = "AvarSharing " ++ show (hashStableNameHeight sn) - showSA (StableSharingAcc _ (AletSharing sa _ )) = "AletSharing " ++ show sa ++ "..." - --- Build an initial environment for the tag values given in the first argument for traversing a --- scalar expression. The 'StableSharingExp's for all tags /actually used/ in the expressions are --- in the second argument. (Tags are not used if a bound variable has no usage occurence.) --- --- Bail out if any tag occurs multiple times as this indicates that the sharing of an argument --- variable was not preserved and we cannot build an appropriate initial environment (c.f., comments --- at 'determineScopes'. --- -buildInitialEnvExp :: [Level] -> [StableSharingExp] -> [StableSharingExp] -buildInitialEnvExp tags ses = map (lookupSE ses) tags - where - lookupSE ses tag1 - = case filter hasTag ses of - [] -> noStableSharing -- tag is not used in the analysed expression - [se] -> se -- tag has a unique occurence - ses2 -> INTERNAL_ERROR(error) "buildInitialEnvExp" - ("Encountered a duplicate 'Tag'\n " ++ concat (intersperse ", " (map showSE ses2))) - where - hasTag (StableSharingExp _ (ExpSharing _ (Tag tag2))) = tag1 == tag2 - hasTag se - = INTERNAL_ERROR(error) "buildInitialEnvExp" - ("Encountered a node that is not a plain 'Tag'\n " ++ showSE se) - - noStableSharing :: StableSharingExp - noStableSharing = StableSharingExp noStableExpName (undefined :: SharingExp ()) - - showSE (StableSharingExp _ (ExpSharing sn exp)) = show (hashStableNameHeight sn) ++ ": " ++ - showPreExpOp exp - showSE (StableSharingExp _ (VarSharing sn)) = "VarSharing " ++ show (hashStableNameHeight sn) - showSE (StableSharingExp _ (LetSharing se _ )) = "LetSharing " ++ show se ++ "..." - --- Determine whether a 'NodeCount' is for an 'Atag' or 'Tag', which represent free variables. --- -isFreeVar :: NodeCount -> Bool -isFreeVar (AccNodeCount (StableSharingAcc _ (AccSharing _ (Atag _))) _) = True -isFreeVar (ExpNodeCount (StableSharingExp _ (ExpSharing _ (Tag _))) _) = True -isFreeVar _ = False - --- Determine the scopes of all variables representing shared subterms (Phase Two) in a bottom-up --- sweep. The first argument determines whether array computations are floated out of expressions --- irrespective of whether they are shared or not — 'True' implies floating them out. --- --- In addition to the AST with sharing information, yield the 'StableSharingAcc's for all free --- variables of 'rootAcc', which are represented by 'Atag' leaves in the tree. They are in order of --- the tag values — i.e., in the same order that they need to appear in an environment to use the --- tag for indexing into that environment. --- --- Precondition: there are only 'AvarSharing' and 'AccSharing' nodes in the argument. --- -determineScopes :: Typeable a - => Bool -> [Level] -> OccMap Acc -> SharingAcc a -> (SharingAcc a, [StableSharingAcc]) -determineScopes floatOutAcc fvs accOccMap rootAcc - = let - (sharingAcc, counts) = scopesAcc rootAcc - unboundTrees = filter (not . isFreeVar) counts - in - if all isFreeVar counts - then - (sharingAcc, buildInitialEnvAcc fvs [sa | AccNodeCount sa _ <- counts]) - else - INTERNAL_ERROR(error) "determineScopes" ("unbound shared subtrees" ++ show unboundTrees) - where - scopesAcc :: forall arrs. SharingAcc arrs -> (SharingAcc arrs, NodeCounts) - scopesAcc (AletSharing _ _) - = INTERNAL_ERROR(error) "determineScopes: scopesAcc" "unexpected 'AletSharing'" - scopesAcc sharingAcc@(AvarSharing sn) - = (sharingAcc, StableSharingAcc sn sharingAcc `accNodeCount` 1) - scopesAcc (AccSharing sn pacc) - = case pacc of - Atag i -> reconstruct (Atag i) noNodeCounts - Pipe afun1 afun2 acc -> travA (Pipe afun1 afun2) acc - -- we are not traversing 'afun1' & 'afun2' — see Note [Pipe and sharing recovery] - Acond e acc1 acc2 -> let - (e' , accCount1) = scopesExpInit e - (acc1', accCount2) = scopesAcc acc1 - (acc2', accCount3) = scopesAcc acc2 - in - reconstruct (Acond e' acc1' acc2') - (accCount1 +++ accCount2 +++ accCount3) - - Atuple tup -> let (tup', accCount) = travAtup tup - in reconstruct (Atuple tup') accCount - Aprj ix a -> travA (Aprj ix) a - - Use arr -> reconstruct (Use arr) noNodeCounts - Unit e -> let - (e', accCount) = scopesExpInit e - in - reconstruct (Unit e') accCount - Generate sh f -> let - (sh', accCount1) = scopesExpInit sh - (f' , accCount2) = scopesFun1 f - in - reconstruct (Generate sh' f') (accCount1 +++ accCount2) - Reshape sh acc -> travEA Reshape sh acc - Replicate n acc -> travEA Replicate n acc - Index acc i -> travEA (flip Index) i acc - Map f acc -> let - (f' , accCount1) = scopesFun1 f - (acc', accCount2) = scopesAcc acc - in - reconstruct (Map f' acc') (accCount1 +++ accCount2) - ZipWith f acc1 acc2 -> travF2A2 ZipWith f acc1 acc2 - Fold f z acc -> travF2EA Fold f z acc - Fold1 f acc -> travF2A Fold1 f acc - FoldSeg f z acc1 acc2 -> let - (f' , accCount1) = scopesFun2 f - (z' , accCount2) = scopesExpInit z - (acc1', accCount3) = scopesAcc acc1 - (acc2', accCount4) = scopesAcc acc2 - in - reconstruct (FoldSeg f' z' acc1' acc2') - (accCount1 +++ accCount2 +++ accCount3 +++ accCount4) - Fold1Seg f acc1 acc2 -> travF2A2 Fold1Seg f acc1 acc2 - Scanl f z acc -> travF2EA Scanl f z acc - Scanl' f z acc -> travF2EA Scanl' f z acc - Scanl1 f acc -> travF2A Scanl1 f acc - Scanr f z acc -> travF2EA Scanr f z acc - Scanr' f z acc -> travF2EA Scanr' f z acc - Scanr1 f acc -> travF2A Scanr1 f acc - Permute fc acc1 fp acc2 -> let - (fc' , accCount1) = scopesFun2 fc - (acc1', accCount2) = scopesAcc acc1 - (fp' , accCount3) = scopesFun1 fp - (acc2', accCount4) = scopesAcc acc2 - in - reconstruct (Permute fc' acc1' fp' acc2') - (accCount1 +++ accCount2 +++ accCount3 +++ accCount4) - Backpermute sh fp acc -> let - (sh' , accCount1) = scopesExpInit sh - (fp' , accCount2) = scopesFun1 fp - (acc', accCount3) = scopesAcc acc - in - reconstruct (Backpermute sh' fp' acc') - (accCount1 +++ accCount2 +++ accCount3) - Stencil st bnd acc -> let - (st' , accCount1) = scopesStencil1 acc st - (acc', accCount2) = scopesAcc acc - in - reconstruct (Stencil st' bnd acc') (accCount1 +++ accCount2) - Stencil2 st bnd1 acc1 bnd2 acc2 - -> let - (st' , accCount1) = scopesStencil2 acc1 acc2 st - (acc1', accCount2) = scopesAcc acc1 - (acc2', accCount3) = scopesAcc acc2 - in - reconstruct (Stencil2 st' bnd1 acc1' bnd2 acc2') - (accCount1 +++ accCount2 +++ accCount3) - where - travEA :: Arrays arrs - => (RootExp e -> SharingAcc arrs' -> PreAcc SharingAcc RootExp arrs) - -> RootExp e - -> SharingAcc arrs' - -> (SharingAcc arrs, NodeCounts) - travEA c e acc = reconstruct (c e' acc') (accCount1 +++ accCount2) - where - (e' , accCount1) = scopesExpInit e - (acc', accCount2) = scopesAcc acc - - travF2A :: (Elt a, Elt b, Arrays arrs) - => ((Exp a -> Exp b -> RootExp c) -> SharingAcc arrs' - -> PreAcc SharingAcc RootExp arrs) - -> (Exp a -> Exp b -> RootExp c) - -> SharingAcc arrs' - -> (SharingAcc arrs, NodeCounts) - travF2A c f acc = reconstruct (c f' acc') (accCount1 +++ accCount2) - where - (f' , accCount1) = scopesFun2 f - (acc', accCount2) = scopesAcc acc - - travF2EA :: (Elt a, Elt b, Arrays arrs) - => ((Exp a -> Exp b -> RootExp c) -> RootExp e - -> SharingAcc arrs' -> PreAcc SharingAcc RootExp arrs) - -> (Exp a -> Exp b -> RootExp c) - -> RootExp e - -> SharingAcc arrs' - -> (SharingAcc arrs, NodeCounts) - travF2EA c f e acc = reconstruct (c f' e' acc') (accCount1 +++ accCount2 +++ accCount3) - where - (f' , accCount1) = scopesFun2 f - (e' , accCount2) = scopesExpInit e - (acc', accCount3) = scopesAcc acc - - travF2A2 :: (Elt a, Elt b, Arrays arrs) - => ((Exp a -> Exp b -> RootExp c) -> SharingAcc arrs1 - -> SharingAcc arrs2 -> PreAcc SharingAcc RootExp arrs) - -> (Exp a -> Exp b -> RootExp c) - -> SharingAcc arrs1 - -> SharingAcc arrs2 - -> (SharingAcc arrs, NodeCounts) - travF2A2 c f acc1 acc2 = reconstruct (c f' acc1' acc2') - (accCount1 +++ accCount2 +++ accCount3) - where - (f' , accCount1) = scopesFun2 f - (acc1', accCount2) = scopesAcc acc1 - (acc2', accCount3) = scopesAcc acc2 - - travAtup :: Tuple.Atuple SharingAcc a - -> (Tuple.Atuple SharingAcc a, NodeCounts) - travAtup NilAtup = (NilAtup, noNodeCounts) - travAtup (SnocAtup tup a) = let (tup', accCountT) = travAtup tup - (a', accCountA) = scopesAcc a - in - (SnocAtup tup' a', accCountT +++ accCountA) - - travA :: Arrays arrs - => (SharingAcc arrs' -> PreAcc SharingAcc RootExp arrs) - -> SharingAcc arrs' - -> (SharingAcc arrs, NodeCounts) - travA c acc = reconstruct (c acc') accCount - where - (acc', accCount) = scopesAcc acc - - -- Occurence count of the currently processed node - accOccCount = let StableNameHeight sn' _ = sn - in - lookupWithASTName accOccMap (StableASTName sn') - - -- Reconstruct the current tree node. - -- - -- * If the current node is being shared ('accOccCount > 1'), replace it by a 'AvarSharing' - -- node and float the shared subtree out wrapped in a 'NodeCounts' value. - -- * If the current node is not shared, reconstruct it in place. - -- * Special case for free variables ('Atag'): Replace the tree by a sharing variable and - -- float the 'Atag' out in a 'NodeCounts' value. This is idependent of the number of - -- occurences. - -- - -- In either case, any completed 'NodeCounts' are injected as bindings using 'AletSharing' - -- node. - -- - reconstruct :: Arrays arrs - => PreAcc SharingAcc RootExp arrs -> NodeCounts - -> (SharingAcc arrs, NodeCounts) - reconstruct newAcc@(Atag _) _subCount - -- free variable => replace by a sharing variable regardless of the number of occ.s - = let thisCount = StableSharingAcc sn (AccSharing sn newAcc) `accNodeCount` 1 - in - tracePure "FREE" (show thisCount) $ - (AvarSharing sn, thisCount) - reconstruct newAcc subCount - -- shared subtree => replace by a sharing variable (if 'recoverAccSharing' enabled) - | accOccCount > 1 && recoverAccSharing - = let allCount = (StableSharingAcc sn sharingAcc `accNodeCount` 1) +++ newCount - in - tracePure ("SHARED" ++ completed) (show allCount) $ - (AvarSharing sn, allCount) - -- neither shared nor free variable => leave it as it is - | otherwise - = tracePure ("Normal" ++ completed) (show newCount) $ - (sharingAcc, newCount) - where - -- Determine the bindings that need to be attached to the current node... - (newCount, bindHere) = filterCompleted subCount - - -- ...and wrap them in 'AletSharing' constructors - lets = foldl (flip (.)) id . map AletSharing $ bindHere - sharingAcc = lets $ AccSharing sn newAcc - - -- trace support - completed | null bindHere = "" - | otherwise = "(" ++ show (length bindHere) ++ " lets)" - - -- Extract *leading* nodes that have a complete node count (i.e., their node count is equal - -- to the number of occurences of that node in the overall expression). - -- - -- Nodes with a completed node count should be let bound at the currently processed node. - -- - -- NB: Only extract leading nodes (i.e., the longest run at the *front* of the list that is - -- complete). Otherwise, we would let-bind subterms before their parents, which leads - -- scope errors. - -- - filterCompleted :: NodeCounts -> (NodeCounts, [StableSharingAcc]) - filterCompleted counts - = let (completed, counts') = break notComplete counts - in (counts', [sa | AccNodeCount sa _ <- completed]) - where - -- a node is not yet complete while the node count 'n' is below the overall number - -- of occurences for that node in the whole program, with the exception that free - -- variables are never complete - notComplete nc@(AccNodeCount sa n) | not . isFreeVar $ nc = lookupWithSharingAcc accOccMap sa > n - notComplete _ = True - - scopesExpInit :: RootExp t -> (RootExp t, NodeCounts) - scopesExpInit (OccMapExp fvs expOccMap exp) - = let - (expWithScopes, nodeCounts) = scopesExp expOccMap exp - (expCounts, accCounts) = break isAccNodeCount nodeCounts - in - (EnvExp (buildInitialEnvExp fvs [se | ExpNodeCount se _ <- expCounts]) expWithScopes, accCounts) - where - isAccNodeCount (AccNodeCount {}) = True - isAccNodeCount _ = False - scopesExpInit _ = INTERNAL_ERROR(error) "scopesExpInit" "not an 'OccMapExp'" - - scopesExp :: forall t. OccMap Exp -> SharingExp t -> (SharingExp t, NodeCounts) - scopesExp _expOccMap (LetSharing _ _) - = INTERNAL_ERROR(error) "determineScopes: scopesExp" "unexpected 'LetSharing'" - scopesExp _expOccMap sharingExp@(VarSharing sn) - = (sharingExp, StableSharingExp sn sharingExp `expNodeCount` 1) - scopesExp expOccMap (ExpSharing sn pexp) - = case pexp of - Tag i -> reconstruct (Tag i) noNodeCounts - Const c -> reconstruct (Const c) noNodeCounts - Tuple tup -> let (tup', accCount) = travTup tup - in - reconstruct (Tuple tup') accCount - Prj i e -> travE1 (Prj i) e - IndexNil -> reconstruct IndexNil noNodeCounts - IndexCons ix i -> travE2 IndexCons ix i - IndexHead i -> travE1 IndexHead i - IndexTail ix -> travE1 IndexTail ix - IndexAny -> reconstruct IndexAny noNodeCounts - Cond e1 e2 e3 -> travE3 Cond e1 e2 e3 - PrimConst c -> reconstruct (PrimConst c) noNodeCounts - PrimApp p e -> travE1 (PrimApp p) e - IndexScalar a e -> travAE IndexScalar a e - Shape a -> travA Shape a - ShapeSize e -> travE1 ShapeSize e - where - travTup :: Tuple.Tuple SharingExp tup -> (Tuple.Tuple SharingExp tup, NodeCounts) - travTup NilTup = (NilTup, noNodeCounts) - travTup (SnocTup tup e) = let - (tup', accCountT) = travTup tup - (e' , accCountE) = scopesExp expOccMap e - in - (SnocTup tup' e', accCountT +++ accCountE) - - travE1 :: (SharingExp a -> PreExp SharingAcc SharingExp t) -> SharingExp a - -> (SharingExp t, NodeCounts) - travE1 c e = reconstruct (c e') accCount - where - (e', accCount) = scopesExp expOccMap e - - travE2 :: (SharingExp a -> SharingExp b -> PreExp SharingAcc SharingExp t) - -> SharingExp a - -> SharingExp b - -> (SharingExp t, NodeCounts) - travE2 c e1 e2 = reconstruct (c e1' e2') (accCount1 +++ accCount2) - where - (e1', accCount1) = scopesExp expOccMap e1 - (e2', accCount2) = scopesExp expOccMap e2 - - travE3 :: (SharingExp a -> SharingExp b -> SharingExp c -> PreExp SharingAcc SharingExp t) - -> SharingExp a - -> SharingExp b - -> SharingExp c - -> (SharingExp t, NodeCounts) - travE3 c e1 e2 e3 = reconstruct (c e1' e2' e3') (accCount1 +++ accCount2 +++ accCount3) - where - (e1', accCount1) = scopesExp expOccMap e1 - (e2', accCount2) = scopesExp expOccMap e2 - (e3', accCount3) = scopesExp expOccMap e3 - - travA :: (SharingAcc a -> PreExp SharingAcc SharingExp t) -> SharingAcc a - -> (SharingExp t, NodeCounts) - travA c acc = maybeFloatOutAcc c acc' accCount - where - (acc', accCount) = scopesAcc acc - - travAE :: (SharingAcc a -> SharingExp b -> PreExp SharingAcc SharingExp t) - -> SharingAcc a - -> SharingExp b - -> (SharingExp t, NodeCounts) - travAE c acc e = maybeFloatOutAcc (flip c e') acc' (accCountA +++ accCountE) - where - (acc', accCountA) = scopesAcc acc - (e' , accCountE) = scopesExp expOccMap e - - maybeFloatOutAcc :: (SharingAcc a -> PreExp SharingAcc SharingExp t) - -> SharingAcc a - -> NodeCounts - -> (SharingExp t, NodeCounts) - maybeFloatOutAcc c acc@(AvarSharing _) accCount -- nothing to float out - = reconstruct (c acc) accCount - maybeFloatOutAcc c acc accCount - | floatOutAcc = reconstruct (c var) ((stableAcc `accNodeCount` 1) +++ accCount) - | otherwise = reconstruct (c acc) accCount - where - (var, stableAcc) = abstract acc id - - abstract :: SharingAcc a -> (SharingAcc a -> SharingAcc a) - -> (SharingAcc a, StableSharingAcc) - abstract (AvarSharing _) _ = INTERNAL_ERROR(error) "sharingAccToVar" "AvarSharing" - abstract (AletSharing sa acc) lets = abstract acc (lets . AletSharing sa) - abstract acc@(AccSharing sn _) lets = (AvarSharing sn, StableSharingAcc sn (lets acc)) - - -- Occurence count of the currently processed node - expOccCount = let StableNameHeight sn' _ = sn - in - lookupWithASTName expOccMap (StableASTName sn') - - -- Reconstruct the current tree node. - -- - -- * If the current node is being shared ('expOccCount > 1'), replace it by a 'VarSharing' - -- node and float the shared subtree out wrapped in a 'NodeCounts' value. - -- * If the current node is not shared, reconstruct it in place. - -- * Special case for free variables ('Tag'): Replace the tree by a sharing variable and - -- float the 'Tag' out in a 'NodeCounts' value. This is idependent of the number of - -- occurences. - -- - -- In either case, any completed 'NodeCounts' are injected as bindings using 'LetSharing' - -- node. - -- - reconstruct :: PreExp SharingAcc SharingExp t -> NodeCounts - -> (SharingExp t, NodeCounts) - reconstruct newExp@(Tag _) _subCount - -- free variable => replace by a sharing variable regardless of the number of occ.s - = let thisCount = StableSharingExp sn (ExpSharing sn newExp) `expNodeCount` 1 - in - tracePure "FREE" (show thisCount) $ - (VarSharing sn, thisCount) - reconstruct newExp subCount - -- shared subtree => replace by a sharing variable (if 'recoverExpSharing' enabled) - | expOccCount > 1 && recoverExpSharing - = let allCount = (StableSharingExp sn sharingExp `expNodeCount` 1) +++ newCount - in - tracePure ("SHARED" ++ completed) (show allCount) $ - (VarSharing sn, allCount) - -- neither shared nor free variable => leave it as it is - | otherwise - = tracePure ("Normal" ++ completed) (show newCount) $ - (sharingExp, newCount) - where - -- Determine the bindings that need to be attached to the current node... - (newCount, bindHere) = filterCompleted subCount - - -- ...and wrap them in 'LetSharing' constructors - lets = foldl (flip (.)) id . map LetSharing $ bindHere - sharingExp = lets $ ExpSharing sn newExp - - -- trace support - completed | null bindHere = "" - | otherwise = " (" ++ show (length bindHere) ++ " lets)" - - -- Extract *leading* nodes that have a complete node count (i.e., their node count is equal - -- to the number of occurences of that node in the overall expression). - -- - -- Nodes with a completed node count should be let bound at the currently processed node. - -- - -- NB: Only extract leading nodes (i.e., the longest run at the *front* of the list that is - -- complete). Otherwise, we would let-bind subterms before their parents, which leads - -- scope errors. - -- - filterCompleted :: NodeCounts -> (NodeCounts, [StableSharingExp]) - filterCompleted counts - = let (completed, counts') = break notComplete counts - in (counts', [sa | ExpNodeCount sa _ <- completed]) - where - -- a node is not yet complete while the node count 'n' is below the overall number - -- of occurences for that node in the whole program, with the exception that free - -- variables are never complete - notComplete nc@(ExpNodeCount sa n) | not . isFreeVar $ nc = lookupWithSharingExp expOccMap sa > n - notComplete _ = True - - -- The lambda bound variable is at this point already irrelevant; for details, see - -- Note [Traversing functions and side effects] - -- - scopesFun1 :: Elt e1 => (Exp e1 -> RootExp e2) -> (Exp e1 -> RootExp e2, NodeCounts) - scopesFun1 f = (const body, counts) - where - (body, counts) = scopesExpInit (f undefined) - - -- The lambda bound variable is at this point already irrelevant; for details, see - -- Note [Traversing functions and side effects] - -- - scopesFun2 :: (Elt e1, Elt e2) - => (Exp e1 -> Exp e2 -> RootExp e3) - -> (Exp e1 -> Exp e2 -> RootExp e3, NodeCounts) - scopesFun2 f = (\_ _ -> body, counts) - where - (body, counts) = scopesExpInit (f undefined undefined) - - -- The lambda bound variable is at this point already irrelevant; for details, see - -- Note [Traversing functions and side effects] - -- - scopesStencil1 :: forall sh e1 e2 stencil. Stencil sh e1 stencil - => SharingAcc (Array sh e1){-dummy-} - -> (stencil -> RootExp e2) - -> (stencil -> RootExp e2, NodeCounts) - scopesStencil1 _ stencilFun = (const body, counts) - where - (body, counts) = scopesExpInit (stencilFun undefined) - - -- The lambda bound variable is at this point already irrelevant; for details, see - -- Note [Traversing functions and side effects] - -- - scopesStencil2 :: forall sh e1 e2 e3 stencil1 stencil2. - (Stencil sh e1 stencil1, Stencil sh e2 stencil2) - => SharingAcc (Array sh e1){-dummy-} - -> SharingAcc (Array sh e2){-dummy-} - -> (stencil1 -> stencil2 -> RootExp e3) - -> (stencil1 -> stencil2 -> RootExp e3, NodeCounts) - scopesStencil2 _ _ stencilFun = (\_ _ -> body, counts) - where - (body, counts) = scopesExpInit (stencilFun undefined undefined) - --- |Recover sharing information and annotate the HOAS AST with variable and let binding --- annotations. The first argument determines whether array computations are floated out of --- expressions irrespective of whether they are shared or not — 'True' implies floating them out. --- --- Also returns the 'StableSharingAcc's of all 'Atag' leaves in environment order — they represent --- the free variables of the AST. --- --- NB: Strictly speaking, this function is not deterministic, as it uses stable pointers to --- determine the sharing of subterms. The stable pointer API does not guarantee its --- completeness; i.e., it may miss some equalities, which implies that we may fail to discover --- some sharing. However, sharing does not affect the denotational meaning of an array --- computation; hence, we do not compromise denotational correctness. --- --- There is one caveat: We currently rely on the 'Atag' and 'Tag' leaves representing free --- variables to be shared if any of them is used more than once. If one is duplicated, the --- 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.) --- -recoverSharingAcc :: Typeable a => Bool -> Level -> [Level] -> Acc a -> (SharingAcc a, [StableSharingAcc]) -{-# NOINLINE recoverSharingAcc #-} -recoverSharingAcc floatOutAcc lvl fvs acc - = let (acc', occMap) = - unsafePerformIO $ do -- to enable stable pointers; it's safe as explained above - { (acc', occMap) <- makeOccMap lvl acc - - ; occMapList <- Hash.toList occMap - ; traceChunk "OccMap" $ - show occMapList - - ; frozenOccMap <- freezeOccMap occMap - ; return (acc', frozenOccMap) - } - in - determineScopes floatOutAcc fvs occMap acc' - - --- Pretty printing --- --------------- - -instance Arrays arrs => Show (Acc arrs) where - show = show . convertAcc - -instance Elt a => Show (Exp a) where - show = show . convertExp EmptyLayout [] . EnvExp undefined . toSharingExp - where - toSharingExp :: Exp b -> SharingExp b - toSharingExp (Exp pexp) - = case pexp of - Tag i -> ExpSharing undefined $ Tag i - Const v -> ExpSharing undefined $ Const v - Tuple tup -> ExpSharing undefined $ Tuple (toSharingTup tup) - Prj idx e -> ExpSharing undefined $ Prj idx (toSharingExp e) - IndexNil -> ExpSharing undefined $ IndexNil - IndexCons ix i -> ExpSharing undefined $ IndexCons (toSharingExp ix) (toSharingExp i) - IndexHead ix -> ExpSharing undefined $ IndexHead (toSharingExp ix) - IndexTail ix -> ExpSharing undefined $ IndexTail (toSharingExp ix) - IndexAny -> ExpSharing undefined $ IndexAny - Cond e1 e2 e3 -> ExpSharing undefined $ Cond (toSharingExp e1) (toSharingExp e2) - (toSharingExp e3) - PrimConst c -> ExpSharing undefined $ PrimConst c - PrimApp p e -> ExpSharing undefined $ PrimApp p (toSharingExp e) - IndexScalar a e -> ExpSharing undefined $ IndexScalar (fst $ recoverSharingAcc False 0 [] a) - (toSharingExp e) - Shape a -> ExpSharing undefined $ Shape (fst $ recoverSharingAcc False 0 [] a) - ShapeSize e -> ExpSharing undefined $ ShapeSize (toSharingExp e) - - toSharingTup :: Tuple.Tuple Exp tup -> Tuple.Tuple SharingExp tup - toSharingTup NilTup = NilTup - toSharingTup (SnocTup tup e) = SnocTup (toSharingTup tup) (toSharingExp e) - --- for debugging -showPreAccOp :: forall acc exp arrs. PreAcc acc exp arrs -> String -showPreAccOp (Atag i) = "Atag " ++ show i -showPreAccOp (Pipe _ _ _) = "Pipe" -showPreAccOp (Acond _ _ _) = "Acond" -showPreAccOp (Atuple _) = "Atuple" -showPreAccOp (Aprj _ _) = "Aprj" -showPreAccOp (Use a) = "Use " ++ showArrays a -showPreAccOp (Unit _) = "Unit" -showPreAccOp (Generate _ _) = "Generate" -showPreAccOp (Reshape _ _) = "Reshape" -showPreAccOp (Replicate _ _) = "Replicate" -showPreAccOp (Index _ _) = "Index" -showPreAccOp (Map _ _) = "Map" -showPreAccOp (ZipWith _ _ _) = "ZipWith" -showPreAccOp (Fold _ _ _) = "Fold" -showPreAccOp (Fold1 _ _) = "Fold1" -showPreAccOp (FoldSeg _ _ _ _) = "FoldSeg" -showPreAccOp (Fold1Seg _ _ _) = "Fold1Seg" -showPreAccOp (Scanl _ _ _) = "Scanl" -showPreAccOp (Scanl' _ _ _) = "Scanl'" -showPreAccOp (Scanl1 _ _) = "Scanl1" -showPreAccOp (Scanr _ _ _) = "Scanr" -showPreAccOp (Scanr' _ _ _) = "Scanr'" -showPreAccOp (Scanr1 _ _) = "Scanr1" -showPreAccOp (Permute _ _ _ _) = "Permute" -showPreAccOp (Backpermute _ _ _) = "Backpermute" -showPreAccOp (Stencil _ _ _) = "Stencil" -showPreAccOp (Stencil2 _ _ _ _ _) = "Stencil2" - -showArrays :: forall arrs. Arrays arrs => arrs -> String -showArrays = display . collect (arrays (undefined::arrs)) . fromArr - where - collect :: ArraysR a -> a -> [String] - collect ArraysRunit _ = [] - collect ArraysRarray arr = [showShortendArr arr] - collect (ArraysRpair r1 r2) (a1, a2) = collect r1 a1 ++ collect r2 a2 - -- - display [] = [] - display [x] = x - display xs = "(" ++ concat (intersperse ", " xs) ++ ")" - - -showShortendArr :: Elt e => Array sh e -> String -showShortendArr arr - = show (take cutoff l) ++ if length l > cutoff then ".." else "" - where - l = Sugar.toList arr - cutoff = 5 - -_showSharingAccOp :: SharingAcc arrs -> String -_showSharingAccOp (AvarSharing sn) = "AVAR " ++ show (hashStableNameHeight sn) -_showSharingAccOp (AletSharing _ acc) = "ALET " ++ _showSharingAccOp acc -_showSharingAccOp (AccSharing _ acc) = showPreAccOp acc - --- for debugging -showPreExpOp :: PreExp acc exp t -> String -showPreExpOp (Tag _) = "Tag" -showPreExpOp (Const c) = "Const " ++ show c -showPreExpOp (Tuple _) = "Tuple" -showPreExpOp (Prj _ _) = "Prj" -showPreExpOp IndexNil = "IndexNil" -showPreExpOp (IndexCons _ _) = "IndexCons" -showPreExpOp (IndexHead _) = "IndexHead" -showPreExpOp (IndexTail _) = "IndexTail" -showPreExpOp IndexAny = "IndexAny" -showPreExpOp (Cond _ _ _) = "Cons" -showPreExpOp (PrimConst _) = "PrimConst" -showPreExpOp (PrimApp _ _) = "PrimApp" -showPreExpOp (IndexScalar _ _) = "IndexScalar" -showPreExpOp (Shape _) = "Shape" -showPreExpOp (ShapeSize _) = "ShapeSize" - --- Smart constructors to construct representation AST forms --- -------------------------------------------------------- - -mkIndex :: forall slix e aenv. (Slice slix, Elt e) - => AST.OpenAcc aenv (Array (FullShape slix) e) - -> AST.Exp aenv slix - -> AST.PreOpenAcc AST.OpenAcc aenv (Array (SliceShape slix) e) -mkIndex arr e - = AST.Index (sliceIndex slix) arr e - where - slix = undefined :: slix - -mkReplicate :: forall slix e aenv. (Slice slix, Elt e) - => AST.Exp aenv slix - -> AST.OpenAcc aenv (Array (SliceShape slix) e) - -> AST.PreOpenAcc AST.OpenAcc aenv (Array (FullShape slix) e) -mkReplicate e arr - = AST.Replicate (sliceIndex slix) e arr - where - slix = undefined :: slix - --- Smart constructors and destructors for array tuples --- - -atup2 :: (Arrays a, Arrays b) => (Acc a, Acc b) -> Acc (a, b) -atup2 (x1, x2) = Acc $ Atuple (NilAtup `SnocAtup` x1 `SnocAtup` x2) - -atup3 :: (Arrays a, Arrays b, Arrays c) => (Acc a, Acc b, Acc c) -> Acc (a, b, c) -atup3 (x1, x2, x3) = Acc $ Atuple (NilAtup `SnocAtup` x1 `SnocAtup` x2 `SnocAtup` x3) - -atup4 :: (Arrays a, Arrays b, Arrays c, Arrays d) - => (Acc a, Acc b, Acc c, Acc d) -> Acc (a, b, c, d) -atup4 (x1, x2, x3, x4) - = Acc $ Atuple (NilAtup `SnocAtup` x1 `SnocAtup` x2 `SnocAtup` x3 `SnocAtup` x4) - -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 (x1, x2, x3, x4, x5) - = Acc $ Atuple $ - NilAtup `SnocAtup` x1 `SnocAtup` x2 `SnocAtup` x3 `SnocAtup` x4 `SnocAtup` x5 - -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 (x1, x2, x3, x4, x5, x6) - = Acc $ Atuple $ - NilAtup `SnocAtup` x1 `SnocAtup` x2 `SnocAtup` x3 - `SnocAtup` x4 `SnocAtup` x5 `SnocAtup` x6 - -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 (x1, x2, x3, x4, x5, x6, x7) - = Acc $ Atuple $ - NilAtup `SnocAtup` x1 `SnocAtup` x2 `SnocAtup` x3 - `SnocAtup` x4 `SnocAtup` x5 `SnocAtup` x6 `SnocAtup` x7 - -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 (x1, x2, x3, x4, x5, x6, x7, x8) - = Acc $ Atuple $ - NilAtup `SnocAtup` x1 `SnocAtup` x2 `SnocAtup` x3 `SnocAtup` x4 - `SnocAtup` x5 `SnocAtup` x6 `SnocAtup` x7 `SnocAtup` x8 - -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 (x1, x2, x3, x4, x5, x6, x7, x8, x9) - = Acc $ Atuple $ - NilAtup `SnocAtup` x1 `SnocAtup` x2 `SnocAtup` x3 `SnocAtup` x4 - `SnocAtup` x5 `SnocAtup` x6 `SnocAtup` x7 `SnocAtup` x8 `SnocAtup` x9 - -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 ) - - --- 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 :: Elt s => TupleIdx (t, s) s -tix0 = ZeroTupIdx -tix1 :: Elt s => TupleIdx ((t, s), s1) s -tix1 = SuccTupIdx tix0 -tix2 :: Elt s => TupleIdx (((t, s), s1), s2) s -tix2 = SuccTupIdx tix1 -tix3 :: Elt s => TupleIdx ((((t, s), s1), s2), s3) s -tix3 = SuccTupIdx tix2 -tix4 :: Elt s => TupleIdx (((((t, s), s1), s2), s3), s4) s -tix4 = SuccTupIdx tix3 -tix5 :: Elt s => TupleIdx ((((((t, s), s1), s2), s3), s4), s5) s -tix5 = SuccTupIdx tix4 -tix6 :: Elt s => TupleIdx (((((((t, s), s1), s2), s3), s4), s5), s6) s -tix6 = SuccTupIdx tix5 -tix7 :: Elt s => TupleIdx ((((((((t, s), s1), s2), s3), s4), s5), s6), s7) s -tix7 = SuccTupIdx tix6 -tix8 :: Elt s => TupleIdx (((((((((t, s), s1), s2), s3), s4), s5), s6), s7), s8) s -tix8 = SuccTupIdx tix7 - - --- Smart constructor for literals --- - --- |Constant scalar expression --- -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 (x1, x2) = Exp $ Tuple (NilTup `SnocTup` x1 `SnocTup` x2) - -tup3 :: (Elt a, Elt b, Elt c) => (Exp a, Exp b, Exp c) -> Exp (a, b, c) -tup3 (x1, x2, x3) = Exp $ Tuple (NilTup `SnocTup` x1 `SnocTup` x2 `SnocTup` x3) - -tup4 :: (Elt a, Elt b, Elt c, Elt d) - => (Exp a, Exp b, Exp c, Exp d) -> Exp (a, b, c, d) -tup4 (x1, x2, x3, x4) - = Exp $ Tuple (NilTup `SnocTup` x1 `SnocTup` x2 `SnocTup` x3 `SnocTup` x4) - -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 (x1, x2, x3, x4, x5) - = Exp $ Tuple $ - NilTup `SnocTup` x1 `SnocTup` x2 `SnocTup` x3 `SnocTup` x4 `SnocTup` x5 - -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 (x1, x2, x3, x4, x5, x6) - = Exp $ Tuple $ - NilTup `SnocTup` x1 `SnocTup` x2 `SnocTup` x3 `SnocTup` x4 `SnocTup` x5 `SnocTup` x6 - -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 (x1, x2, x3, x4, x5, x6, x7) - = Exp $ Tuple $ - NilTup `SnocTup` x1 `SnocTup` x2 `SnocTup` x3 - `SnocTup` x4 `SnocTup` x5 `SnocTup` x6 `SnocTup` x7 - -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 (x1, x2, x3, x4, x5, x6, x7, x8) - = Exp $ Tuple $ - NilTup `SnocTup` x1 `SnocTup` x2 `SnocTup` x3 `SnocTup` x4 - `SnocTup` x5 `SnocTup` x6 `SnocTup` x7 `SnocTup` x8 - -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 (x1, x2, x3, x4, x5, x6, x7, x8, x9) - = Exp $ Tuple $ - NilTup `SnocTup` x1 `SnocTup` x2 `SnocTup` x3 `SnocTup` x4 - `SnocTup` x5 `SnocTup` x6 `SnocTup` x7 `SnocTup` x8 `SnocTup` x9 - -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) - --- 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 - -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 & Bits - -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) - -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) - -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) - --- 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) - --- FIXME: add missing operations from Floating, RealFrac & RealFloat - --- Relational and equality operators - -mkLt :: (Elt t, IsScalar t) => Exp t -> Exp t -> Exp Bool -mkLt x y = Exp $ PrimLt scalarType `PrimApp` tup2 (x, y) - -mkGt :: (Elt t, IsScalar t) => Exp t -> Exp t -> Exp Bool -mkGt x y = Exp $ PrimGt scalarType `PrimApp` tup2 (x, y) - -mkLtEq :: (Elt t, IsScalar t) => Exp t -> Exp t -> Exp Bool -mkLtEq x y = Exp $ PrimLtEq scalarType `PrimApp` tup2 (x, y) - -mkGtEq :: (Elt t, IsScalar t) => Exp t -> Exp t -> Exp Bool -mkGtEq x y = Exp $ PrimGtEq scalarType `PrimApp` tup2 (x, y) - -mkEq :: (Elt t, IsScalar t) => Exp t -> Exp t -> Exp Bool -mkEq x y = Exp $ PrimEq scalarType `PrimApp` tup2 (x, y) - -mkNEq :: (Elt t, IsScalar t) => Exp t -> Exp t -> Exp Bool -mkNEq x y = Exp $ PrimNEq scalarType `PrimApp` tup2 (x, y) - -mkMax :: (Elt t, IsScalar t) => Exp t -> Exp t -> Exp t -mkMax x y = Exp $ PrimMax scalarType `PrimApp` tup2 (x, y) - -mkMin :: (Elt t, IsScalar t) => Exp t -> Exp t -> Exp t -mkMin x y = Exp $ PrimMin scalarType `PrimApp` tup2 (x, y) - --- Logical operators - -mkLAnd :: Exp Bool -> Exp Bool -> Exp Bool -mkLAnd x y = Exp $ PrimLAnd `PrimApp` tup2 (x, y) - -mkLOr :: Exp Bool -> Exp Bool -> Exp Bool -mkLOr x y = Exp $ PrimLOr `PrimApp` tup2 (x, y) - -mkLNot :: Exp Bool -> Exp Bool -mkLNot x = Exp $ PrimLNot `PrimApp` x - --- FIXME: Character conversions - --- FIXME: Numeric conversions - -mkFromIntegral :: (Elt a, Elt b, IsIntegral a, IsNum b) => Exp a -> Exp b -mkFromIntegral x = Exp $ PrimFromIntegral integralType numType `PrimApp` x - --- FIXME: Other conversions - -mkBoolToInt :: Exp Bool -> Exp Int -mkBoolToInt b = Exp $ PrimBoolToInt `PrimApp` b - - --- Auxiliary functions --- -------------------- - -infixr 0 $$ -($$) :: (b -> a) -> (c -> d -> b) -> c -> d -> a -(f $$ g) x y = f (g x y) - -infixr 0 $$$ -($$$) :: (b -> a) -> (c -> d -> e -> b) -> c -> d -> e -> a -(f $$$ g) x y z = f (g x y z) - -infixr 0 $$$$ -($$$$) :: (b -> a) -> (c -> d -> e -> f -> b) -> c -> d -> e -> f -> a -(f $$$$ g) x y z u = f (g x y z u) - -infixr 0 $$$$$ -($$$$$) :: (b -> a) -> (c -> d -> e -> f -> g -> b) -> c -> d -> e -> f -> g-> a -(f $$$$$ g) x y z u v = f (g x y z u v) +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_HADDOCK hide #-} +-- | +-- Module : Data.Array.Accelerate.Smart +-- Copyright : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee +-- [2009..2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Manuel M T Chakravarty +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- +-- This modules defines the AST of the user-visible embedded language using more +-- convenient higher-order abstract syntax (instead of de Bruijn indices). +-- Moreover, it defines smart constructors to construct programs. +-- + +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, + untup2, untup3, untup4, untup5, untup6, untup7, untup8, untup9, + + atup2, atup3, atup4, atup5, atup6, atup7, atup8, atup9, + unatup2, unatup3, unatup4, unatup5, unatup6, unatup7, unatup8, unatup9, + + -- * Smart constructors for constants + mkMinBound, mkMaxBound, mkPi, + mkSin, mkCos, mkTan, + mkAsin, mkAcos, mkAtan, + 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, mkIDiv, mkMod, + mkBAnd, mkBOr, mkBXor, mkBNot, mkBShiftL, mkBShiftR, mkBRotateL, mkBRotateR, + mkFDiv, mkRecip, mkLt, mkGt, mkLtEq, mkGtEq, mkEq, mkNEq, mkMax, mkMin, + mkLAnd, mkLOr, mkLNot, + + -- * Smart constructors for type coercion functions + mkBoolToInt, mkFromIntegral, + + -- * 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.Tuple hiding ( Tuple ) +import Data.Array.Accelerate.AST hiding ( + PreOpenAcc(..), OpenAcc(..), Acc, Stencil(..), PreOpenExp(..), OpenExp, PreExp, Exp, + showPreAccOp, showPreExpOp ) +import qualified Data.Array.Accelerate.AST as AST +import qualified Data.Array.Accelerate.Tuple as Tuple + + +-- Array computations +-- ------------------ + +-- 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 +-- +-- Note [Pipe and sharing recovery] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- The 'Pipe' constructor is special. It is the only form that contains functions over array +-- computations and these functions are fixed to be over vanilla 'Acc' types. This enables us to +-- perform sharing recovery independently from the context for them. +-- +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) -- see comment above on why 'Acc' and not 'acc' + -> (Acc bs -> Acc cs) + -> acc as + -> PreAcc acc exp cs + + Aforeign :: (Arrays arrs, Arrays a, Foreign f) + => f arrs a + -> (Acc arrs -> Acc a) + -> acc arrs + -> PreAcc acc exp a + + Acond :: (Arrays as) + => exp Bool + -> acc as + -> acc as + -> PreAcc acc exp as + + Atuple :: (Arrays arrs, IsTuple arrs) + => Tuple.Atuple acc (TupleRepr arrs) + -> PreAcc acc exp arrs + + Aprj :: (Arrays arrs, IsTuple 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, + Typeable (SliceShape slix), Typeable (FullShape slix)) + -- the Typeable constraints shouldn't be necessary as they are implied by + -- 'SliceIx slix' — unfortunately, the (old) type checker doesn't grok that + => exp slix + -> acc (Array (SliceShape slix) e) + -> PreAcc acc exp (Array (FullShape slix) e) + + Slice :: (Slice slix, Elt e, + Typeable (SliceShape slix), Typeable (FullShape slix)) + -- the Typeable constraints shouldn't be necessary as they are implied by + -- 'SliceIx slix' — unfortunately, the (old) type checker doesn't grok that + => 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 :: Elt e + => (Exp e -> Exp e -> exp e) + -> exp e + -> acc (Vector e) + -> PreAcc acc exp (Vector e) + + Scanl' :: Elt e + => (Exp e -> Exp e -> exp e) + -> exp e + -> acc (Vector e) + -> PreAcc acc exp (Vector e, Scalar e) + + Scanl1 :: Elt e + => (Exp e -> Exp e -> exp e) + -> acc (Vector e) + -> PreAcc acc exp (Vector e) + + Scanr :: Elt e + => (Exp e -> Exp e -> exp e) + -> exp e + -> acc (Vector e) + -> PreAcc acc exp (Vector e) + + Scanr' :: Elt e + => (Exp e -> Exp e -> exp e) + -> exp e + -> acc (Vector e) + -> PreAcc acc exp (Vector e, Scalar e) + + Scanr1 :: Elt e + => (Exp e -> Exp e -> exp e) + -> acc (Vector e) + -> PreAcc acc exp (Vector 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) + +-- |Array-valued collective computations +-- +newtype Acc a = Acc (PreAcc Acc Exp a) + +deriving instance Typeable1 Acc + + +-- 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'. +-- + +-- | 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 -> PreExp acc exp t + -- environment size at defining occurrence + + -- All the same constructors as 'AST.Exp' + Const :: Elt t + => t -> PreExp acc exp t + + Tuple :: (Elt t, IsTuple t) + => Tuple.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 + 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 + Foreign :: (Elt x, Elt y, Foreign f) + => f x y + -> (Exp x -> Exp y) -- RCE: Using Exp instead of exp to aid in sharing recovery. + -> exp x -> PreExp acc exp y + +-- | Scalar expressions for plain array computations. +-- +newtype Exp t = Exp (PreExp Acc Exp t) + +deriving instance Typeable1 Exp + + +-- Smart constructors and destructors for array tuples +-- --------------------------------------------------- + +atup2 :: (Arrays a, Arrays b) => (Acc a, Acc b) -> Acc (a, b) +atup2 (x1, x2) = Acc $ Atuple (NilAtup `SnocAtup` x1 `SnocAtup` x2) + +atup3 :: (Arrays a, Arrays b, Arrays c) => (Acc a, Acc b, Acc c) -> Acc (a, b, c) +atup3 (x1, x2, x3) = Acc $ Atuple (NilAtup `SnocAtup` x1 `SnocAtup` x2 `SnocAtup` x3) + +atup4 :: (Arrays a, Arrays b, Arrays c, Arrays d) + => (Acc a, Acc b, Acc c, Acc d) -> Acc (a, b, c, d) +atup4 (x1, x2, x3, x4) + = Acc $ Atuple (NilAtup `SnocAtup` x1 `SnocAtup` x2 `SnocAtup` x3 `SnocAtup` x4) + +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 (x1, x2, x3, x4, x5) + = Acc $ Atuple $ + NilAtup `SnocAtup` x1 `SnocAtup` x2 `SnocAtup` x3 `SnocAtup` x4 `SnocAtup` x5 + +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 (x1, x2, x3, x4, x5, x6) + = Acc $ Atuple $ + NilAtup `SnocAtup` x1 `SnocAtup` x2 `SnocAtup` x3 + `SnocAtup` x4 `SnocAtup` x5 `SnocAtup` x6 + +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 (x1, x2, x3, x4, x5, x6, x7) + = Acc $ Atuple $ + NilAtup `SnocAtup` x1 `SnocAtup` x2 `SnocAtup` x3 + `SnocAtup` x4 `SnocAtup` x5 `SnocAtup` x6 `SnocAtup` x7 + +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 (x1, x2, x3, x4, x5, x6, x7, x8) + = Acc $ Atuple $ + NilAtup `SnocAtup` x1 `SnocAtup` x2 `SnocAtup` x3 `SnocAtup` x4 + `SnocAtup` x5 `SnocAtup` x6 `SnocAtup` x7 `SnocAtup` x8 + +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 (x1, x2, x3, x4, x5, x6, x7, x8, x9) + = Acc $ Atuple $ + NilAtup `SnocAtup` x1 `SnocAtup` x2 `SnocAtup` x3 `SnocAtup` x4 + `SnocAtup` x5 `SnocAtup` x6 `SnocAtup` x7 `SnocAtup` x8 `SnocAtup` x9 + +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 ) + + +-- 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 :: Elt s => TupleIdx (t, s) s +tix0 = ZeroTupIdx +tix1 :: Elt s => TupleIdx ((t, s), s1) s +tix1 = SuccTupIdx tix0 +tix2 :: Elt s => TupleIdx (((t, s), s1), s2) s +tix2 = SuccTupIdx tix1 +tix3 :: Elt s => TupleIdx ((((t, s), s1), s2), s3) s +tix3 = SuccTupIdx tix2 +tix4 :: Elt s => TupleIdx (((((t, s), s1), s2), s3), s4) s +tix4 = SuccTupIdx tix3 +tix5 :: Elt s => TupleIdx ((((((t, s), s1), s2), s3), s4), s5) s +tix5 = SuccTupIdx tix4 +tix6 :: Elt s => TupleIdx (((((((t, s), s1), s2), s3), s4), s5), s6) s +tix6 = SuccTupIdx tix5 +tix7 :: Elt s => TupleIdx ((((((((t, s), s1), s2), s3), s4), s5), s6), s7) s +tix7 = SuccTupIdx tix6 +tix8 :: Elt s => TupleIdx (((((((((t, s), s1), s2), s3), s4), s5), s6), s7), s8) s +tix8 = SuccTupIdx tix7 + + +-- 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 (x1, x2) = Exp $ Tuple (NilTup `SnocTup` x1 `SnocTup` x2) + +tup3 :: (Elt a, Elt b, Elt c) => (Exp a, Exp b, Exp c) -> Exp (a, b, c) +tup3 (x1, x2, x3) = Exp $ Tuple (NilTup `SnocTup` x1 `SnocTup` x2 `SnocTup` x3) + +tup4 :: (Elt a, Elt b, Elt c, Elt d) + => (Exp a, Exp b, Exp c, Exp d) -> Exp (a, b, c, d) +tup4 (x1, x2, x3, x4) + = Exp $ Tuple (NilTup `SnocTup` x1 `SnocTup` x2 `SnocTup` x3 `SnocTup` x4) + +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 (x1, x2, x3, x4, x5) + = Exp $ Tuple $ + NilTup `SnocTup` x1 `SnocTup` x2 `SnocTup` x3 `SnocTup` x4 `SnocTup` x5 + +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 (x1, x2, x3, x4, x5, x6) + = Exp $ Tuple $ + NilTup `SnocTup` x1 `SnocTup` x2 `SnocTup` x3 `SnocTup` x4 `SnocTup` x5 `SnocTup` x6 + +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 (x1, x2, x3, x4, x5, x6, x7) + = Exp $ Tuple $ + NilTup `SnocTup` x1 `SnocTup` x2 `SnocTup` x3 + `SnocTup` x4 `SnocTup` x5 `SnocTup` x6 `SnocTup` x7 + +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 (x1, x2, x3, x4, x5, x6, x7, x8) + = Exp $ Tuple $ + NilTup `SnocTup` x1 `SnocTup` x2 `SnocTup` x3 `SnocTup` x4 + `SnocTup` x5 `SnocTup` x6 `SnocTup` x7 `SnocTup` x8 + +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 (x1, x2, x3, x4, x5, x6, x7, x8, x9) + = Exp $ Tuple $ + NilTup `SnocTup` x1 `SnocTup` x2 `SnocTup` x3 `SnocTup` x4 + `SnocTup` x5 `SnocTup` x6 `SnocTup` x7 `SnocTup` x8 `SnocTup` x9 + +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) + +-- 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 + +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 & Bits + +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) + +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) + +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) + +-- 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) + +-- FIXME: add missing operations from Floating, RealFrac & RealFloat + +-- Relational and equality operators + +mkLt :: (Elt t, IsScalar t) => Exp t -> Exp t -> Exp Bool +mkLt x y = Exp $ PrimLt scalarType `PrimApp` tup2 (x, y) + +mkGt :: (Elt t, IsScalar t) => Exp t -> Exp t -> Exp Bool +mkGt x y = Exp $ PrimGt scalarType `PrimApp` tup2 (x, y) + +mkLtEq :: (Elt t, IsScalar t) => Exp t -> Exp t -> Exp Bool +mkLtEq x y = Exp $ PrimLtEq scalarType `PrimApp` tup2 (x, y) + +mkGtEq :: (Elt t, IsScalar t) => Exp t -> Exp t -> Exp Bool +mkGtEq x y = Exp $ PrimGtEq scalarType `PrimApp` tup2 (x, y) + +mkEq :: (Elt t, IsScalar t) => Exp t -> Exp t -> Exp Bool +mkEq x y = Exp $ PrimEq scalarType `PrimApp` tup2 (x, y) + +mkNEq :: (Elt t, IsScalar t) => Exp t -> Exp t -> Exp Bool +mkNEq x y = Exp $ PrimNEq scalarType `PrimApp` tup2 (x, y) + +mkMax :: (Elt t, IsScalar t) => Exp t -> Exp t -> Exp t +mkMax x y = Exp $ PrimMax scalarType `PrimApp` tup2 (x, y) + +mkMin :: (Elt t, IsScalar t) => Exp t -> Exp t -> Exp t +mkMin x y = Exp $ PrimMin scalarType `PrimApp` tup2 (x, y) + +-- Logical operators + +mkLAnd :: Exp Bool -> Exp Bool -> Exp Bool +mkLAnd x y = Exp $ PrimLAnd `PrimApp` tup2 (x, y) + +mkLOr :: Exp Bool -> Exp Bool -> Exp Bool +mkLOr x y = Exp $ PrimLOr `PrimApp` tup2 (x, y) + +mkLNot :: Exp Bool -> Exp Bool +mkLNot x = Exp $ PrimLNot `PrimApp` x + +-- FIXME: Character conversions + +-- FIXME: Numeric conversions + +mkFromIntegral :: (Elt a, Elt b, IsIntegral a, IsNum b) => Exp a -> Exp b +mkFromIntegral x = Exp $ PrimFromIntegral integralType numType `PrimApp` x + +-- FIXME: Other conversions + +mkBoolToInt :: Exp Bool -> Exp Int +mkBoolToInt b = Exp $ PrimBoolToInt `PrimApp` b + + +-- Auxiliary functions +-- -------------------- + +infixr 0 $$ +($$) :: (b -> a) -> (c -> d -> b) -> c -> d -> a +(f $$ g) x y = f (g x y) + +infixr 0 $$$ +($$$) :: (b -> a) -> (c -> d -> e -> b) -> c -> d -> e -> a +(f $$$ g) x y z = f (g x y z) + +infixr 0 $$$$ +($$$$) :: (b -> a) -> (c -> d -> e -> f -> b) -> c -> d -> e -> f -> a +(f $$$$ g) x y z u = f (g x y z u) + +infixr 0 $$$$$ +($$$$$) :: (b -> a) -> (c -> d -> e -> f -> g -> b) -> c -> d -> e -> f -> g-> a +(f $$$$$ g) x y z u v = f (g x y z u v) + + +-- Debugging +-- --------- + +showPreAccOp :: forall acc exp arrs. PreAcc acc exp arrs -> String +showPreAccOp (Atag i) = "Atag " ++ show i +showPreAccOp (Use a) = "Use " ++ showArrays a +showPreAccOp Pipe{} = "Pipe" +showPreAccOp Acond{} = "Acond" +showPreAccOp Atuple{} = "Atuple" +showPreAccOp Aprj{} = "Aprj" +showPreAccOp Unit{} = "Unit" +showPreAccOp Generate{} = "Generate" +showPreAccOp Reshape{} = "Reshape" +showPreAccOp Replicate{} = "Replicate" +showPreAccOp Slice{} = "Slice" +showPreAccOp Map{} = "Map" +showPreAccOp ZipWith{} = "ZipWith" +showPreAccOp Fold{} = "Fold" +showPreAccOp Fold1{} = "Fold1" +showPreAccOp FoldSeg{} = "FoldSeg" +showPreAccOp Fold1Seg{} = "Fold1Seg" +showPreAccOp Scanl{} = "Scanl" +showPreAccOp Scanl'{} = "Scanl'" +showPreAccOp Scanl1{} = "Scanl1" +showPreAccOp Scanr{} = "Scanr" +showPreAccOp Scanr'{} = "Scanr'" +showPreAccOp Scanr1{} = "Scanr1" +showPreAccOp Permute{} = "Permute" +showPreAccOp Backpermute{} = "Backpermute" +showPreAccOp Stencil{} = "Stencil" +showPreAccOp Stencil2{} = "Stencil2" +showPreAccOp Aforeign{} = "Aforeign" + +showArrays :: forall arrs. Arrays arrs => arrs -> String +showArrays = display . collect (arrays (undefined::arrs)) . fromArr + where + collect :: ArraysR a -> a -> [String] + collect ArraysRunit _ = [] + collect ArraysRarray arr = [showShortendArr arr] + collect (ArraysRpair r1 r2) (a1, a2) = collect r1 a1 ++ collect r2 a2 + -- + display [] = [] + display [x] = x + display xs = "(" ++ intercalate ", " xs ++ ")" + + +showShortendArr :: Elt e => Array sh e -> String +showShortendArr arr + = show (take cutoff l) ++ if length l > cutoff then ".." else "" + where + l = toList arr + cutoff = 5 + + +showPreExpOp :: PreExp acc exp t -> String +showPreExpOp (Const c) = "Const " ++ show c +showPreExpOp Tag{} = "Tag" +showPreExpOp Tuple{} = "Tuple" +showPreExpOp Prj{} = "Prj" +showPreExpOp IndexNil = "IndexNil" +showPreExpOp IndexCons{} = "IndexCons" +showPreExpOp IndexHead{} = "IndexHead" +showPreExpOp IndexTail{} = "IndexTail" +showPreExpOp IndexAny = "IndexAny" +showPreExpOp ToIndex{} = "ToIndex" +showPreExpOp FromIndex{} = "FromIndex" +showPreExpOp Cond{} = "Cond" +showPreExpOp PrimConst{} = "PrimConst" +showPreExpOp PrimApp{} = "PrimApp" +showPreExpOp Index{} = "Index" +showPreExpOp LinearIndex{} = "LinearIndex" +showPreExpOp Shape{} = "Shape" +showPreExpOp ShapeSize{} = "ShapeSize" +showPreExpOp Foreign{} = "Foreign" + diff --git a/Data/Array/Accelerate/Trafo.hs b/Data/Array/Accelerate/Trafo.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/Trafo.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_HADDOCK hide #-} +-- | +-- Module : Data.Array.Accelerate.Trafo +-- Copyright : [2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Manuel M T Chakravarty +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.Trafo ( + + -- * HOAS -> de Bruijn conversion + Phase(..), phases, + + convertAcc, convertAccWith, + convertAccFun1, convertAccFun1With, + + -- * Fusion + module Data.Array.Accelerate.Trafo.Fusion, + + -- * Substitution + rebuildAcc, + module Data.Array.Accelerate.Trafo.Substitution, + +) where + +import System.IO.Unsafe + +import Data.Array.Accelerate.Smart +import Data.Array.Accelerate.Debug +import Data.Array.Accelerate.Pretty ( ) -- show instances +import Data.Array.Accelerate.Array.Sugar ( Arrays, Elt ) +import Data.Array.Accelerate.Trafo.Base +import Data.Array.Accelerate.Trafo.Fusion hiding ( convertAcc, convertAfun ) +import Data.Array.Accelerate.Trafo.Substitution +import qualified Data.Array.Accelerate.AST as AST +import qualified Data.Array.Accelerate.Trafo.Fusion as Fusion +import qualified Data.Array.Accelerate.Trafo.Rewrite as Rewrite +import qualified Data.Array.Accelerate.Trafo.Simplify as Rewrite +import qualified Data.Array.Accelerate.Trafo.Sharing as Sharing + + +-- Configuration +-- ------------- + +data Phase = Phase + { + -- | Recover sharing of array computations? + recoverAccSharing :: Bool + + -- | Recover sharing of scalar expressions? + , recoverExpSharing :: Bool + + -- | Are array computations floated out of expressions irrespective of + -- whether they are shared or not? Requires 'recoverAccSharing'. + , floatOutAccFromExp :: Bool + + -- | Fuse array computations? This also implies simplifying scalar + -- expressions. NOTE: currently always enabled. + , enableAccFusion :: Bool + + -- | Convert segment length arrays into segment offset arrays? + , convertOffsetOfSegment :: Bool + } + + +-- | The default method of converting from HOAS to de Bruijn; incorporating +-- sharing recovery and fusion optimisation. +-- +phases :: Phase +phases = Phase + { recoverAccSharing = True + , recoverExpSharing = True + , floatOutAccFromExp = True + , enableAccFusion = True + , convertOffsetOfSegment = False + } + + +-- HOAS -> de Bruijn conversion +-- ---------------------------- + +-- | Convert a closed array expression to de Bruijn form while also +-- incorporating sharing observation and array fusion. +-- +convertAcc :: Arrays arrs => Acc arrs -> DelayedAcc arrs +convertAcc = convertAccWith phases + +convertAccWith :: Arrays arrs => Phase -> Acc arrs -> DelayedAcc arrs +convertAccWith ok acc + = Fusion.convertAcc -- `when` enableAccFusion + $ Rewrite.convertSegments `when` convertOffsetOfSegment + $ Sharing.convertAcc (recoverAccSharing ok) (recoverExpSharing ok) (floatOutAccFromExp ok) acc + where + when f phase + | phase ok = f + | otherwise = id + + +-- | Convert a unary function over array computations, incorporating sharing +-- observation and array fusion +-- +convertAccFun1 :: (Arrays a, Arrays b) => (Acc a -> Acc b) -> DelayedAfun (a -> b) +convertAccFun1 = convertAccFun1With phases + +convertAccFun1With :: (Arrays a, Arrays b) => Phase -> (Acc a -> Acc b) -> DelayedAfun (a -> b) +convertAccFun1With ok acc + = Fusion.convertAfun -- `when` enableAccFusion + $ Rewrite.convertSegmentsAfun `when` convertOffsetOfSegment + $ Sharing.convertAccFun1 (recoverAccSharing ok) (recoverExpSharing ok) (floatOutAccFromExp ok) acc + where + when f phase + | phase ok = f + | otherwise = id + + +-- | Convert a closed scalar expression, incorporating sharing observation and +-- optimisation. +-- +convertExp :: Elt e => Exp e -> AST.Exp () e +convertExp + = Rewrite.simplify + . Sharing.convertExp (recoverExpSharing phases) + + +-- | Convert closed scalar functions, incorporating sharing observation and +-- optimisation. +-- +convertFun1 :: (Elt a, Elt b) => (Exp a -> Exp b) -> AST.Fun () (a -> b) +convertFun1 + = Rewrite.simplify + . Sharing.convertFun1 (recoverExpSharing phases) + +convertFun2 :: (Elt a, Elt b, Elt c) => (Exp a -> Exp b -> Exp c) -> AST.Fun () (a -> b -> c) +convertFun2 + = Rewrite.simplify + . Sharing.convertFun2 (recoverExpSharing phases) + + +-- Pretty printing +-- --------------- + +instance Arrays arrs => Show (Acc arrs) where + show = withSimplStats . show . convertAcc + +instance (Arrays a, Arrays b) => Show (Acc a -> Acc b) where + show = withSimplStats . show . convertAccFun1 + +instance Elt e => Show (Exp e) where + show = withSimplStats . show . convertExp + +instance (Elt a, Elt b) => Show (Exp a -> Exp b) where + show = withSimplStats . show . convertFun1 + +instance (Elt a, Elt b, Elt c) => Show (Exp a -> Exp b -> Exp c) where + show = withSimplStats . show . convertFun2 + + +-- Debugging +-- --------- + +-- Attach simplifier statistics to the tail of the given string. Since the +-- statistics rely on fully evaluating the expression this is difficult to do +-- generally (without an additional deepseq), but easy enough for our show +-- instances. +-- +-- For now, we just reset the statistics at the beginning of a conversion, and +-- leave it to a backend to choose an appropriate moment to dump the summary. +-- +withSimplStats :: String -> String +#ifdef ACCELERATE_DEBUG +withSimplStats x = unsafePerformIO $ do + enabled <- queryFlag dump_simpl_stats + if not enabled + then return x + else do resetSimplCount + stats <- length x `seq` simplCount + traceMessage dump_simpl_stats (show stats) + return x +#else +withSimplStats x = x +#endif + diff --git a/Data/Array/Accelerate/Trafo/Algebra.hs b/Data/Array/Accelerate/Trafo/Algebra.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/Trafo/Algebra.hs @@ -0,0 +1,605 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} +-- | +-- Module : Data.Array.Accelerate.Trafo.Algebra +-- Copyright : [2012..2013] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Manuel M T Chakravarty +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- +-- Algebraic simplifications of scalar expressions, including constant folding +-- and using algebraic properties of particular operator-operand combinations. +-- + +module Data.Array.Accelerate.Trafo.Algebra ( + + evalPrimApp + +) where + +import Prelude hiding ( exp ) +import Data.Maybe ( fromMaybe ) +import Data.Bits +import Data.Char +import Text.PrettyPrint +import qualified Prelude as P + +-- friends +import Data.Array.Accelerate.AST +import Data.Array.Accelerate.Type +import Data.Array.Accelerate.Tuple +import Data.Array.Accelerate.Pretty.Print ( prettyPrim ) +import Data.Array.Accelerate.Array.Sugar ( Elt, toElt, fromElt ) +import Data.Array.Accelerate.Analysis.Match +import Data.Array.Accelerate.Trafo.Base + +import qualified Data.Array.Accelerate.Debug as Stats + + +-- Propagate constant expressions, which are either constant valued expressions +-- or constant let bindings. Be careful not to follow self-cycles. +-- +propagate + :: forall acc env aenv exp. Kit acc + => Gamma acc env env aenv + -> PreOpenExp acc env aenv exp + -> Maybe exp +propagate env = cvtE + where + cvtE :: PreOpenExp acc env aenv e -> Maybe e + cvtE exp = case exp of + Const c -> Just (toElt c) + PrimConst c -> Just (evalPrimConst c) + Prj ix (Var v) | Tuple t <- prjExp v env -> cvtT ix t + Prj ix e | Just c <- cvtE e -> cvtP ix (fromTuple c) + Var ix + | e <- prjExp ix env + , Nothing <- match exp e -> cvtE e + -- + _ -> Nothing + + cvtP :: TupleIdx t e -> t -> Maybe e + cvtP ZeroTupIdx (_, v) = Just v + cvtP (SuccTupIdx idx) (tup, _) = cvtP idx tup + + cvtT :: TupleIdx t e -> Tuple (PreOpenExp acc env aenv) t -> Maybe e + cvtT ZeroTupIdx (SnocTup _ e) = cvtE e + cvtT (SuccTupIdx idx) (SnocTup tup _) = cvtT idx tup + cvtT _ _ = error "hey what's the head angle on that thing?" + + +-- Attempt to evaluate primitive function applications +-- +evalPrimApp + :: forall acc env aenv a r. (Kit acc, Elt a, Elt r) + => Gamma acc env env aenv + -> PrimFun (a -> r) + -> PreOpenExp acc env aenv a + -> PreOpenExp acc env aenv r +evalPrimApp env f x + -- First attempt to move constant values towards the left + | Just r <- commutes f x env = evalPrimApp env f r +-- | Just r <- associates f x = r + + -- Now attempt to evaluate any expressions + | otherwise + = fromMaybe (PrimApp f x) + $ case f of + PrimAdd ty -> evalAdd ty x env + PrimSub ty -> evalSub ty x env + PrimMul ty -> evalMul ty x env + PrimNeg ty -> evalNeg ty x env + PrimAbs ty -> evalAbs ty x env + PrimSig ty -> evalSig ty x env + PrimQuot ty -> evalQuot ty x env + PrimRem ty -> evalRem ty x env + PrimIDiv ty -> evalIDiv ty x env + PrimMod ty -> evalMod ty x env + PrimBAnd ty -> evalBAnd ty x env + PrimBOr ty -> evalBOr ty x env + PrimBXor ty -> evalBXor ty x env + PrimBNot ty -> evalBNot ty x env + PrimBShiftL ty -> evalBShiftL ty x env + PrimBShiftR ty -> evalBShiftR ty x env + PrimBRotateL ty -> evalBRotateL ty x env + PrimBRotateR ty -> evalBRotateR ty x env + PrimFDiv ty -> evalFDiv ty x env + PrimRecip ty -> evalRecip ty x env + PrimSin ty -> evalSin ty x env + PrimCos ty -> evalCos ty x env + PrimTan ty -> evalTan ty x env + PrimAsin ty -> evalAsin ty x env + PrimAcos ty -> evalAcos ty x env + PrimAtan ty -> evalAtan ty x env + PrimAsinh ty -> evalAsinh ty x env + PrimAcosh ty -> evalAcosh ty x env + PrimAtanh ty -> evalAtanh ty x env + PrimExpFloating ty -> evalExpFloating ty x env + PrimSqrt ty -> evalSqrt ty x env + PrimLog ty -> evalLog ty x env + PrimFPow ty -> evalFPow ty x env + PrimLogBase ty -> evalLogBase ty x env + PrimAtan2 ty -> evalAtan2 ty x env + PrimTruncate ta tb -> evalTruncate ta tb x env + PrimRound ta tb -> evalRound ta tb x env + PrimFloor ta tb -> evalFloor ta tb x env + PrimCeiling ta tb -> evalCeiling ta tb x env + PrimLt ty -> evalLt ty x env + PrimGt ty -> evalGt ty x env + PrimLtEq ty -> evalLtEq ty x env + PrimGtEq ty -> evalGtEq ty x env + PrimEq ty -> evalEq ty x env + PrimNEq ty -> evalNEq ty x env + PrimMax ty -> evalMax ty x env + PrimMin ty -> evalMin ty x env + PrimLAnd -> evalLAnd x env + PrimLOr -> evalLOr x env + PrimLNot -> evalLNot x env + PrimOrd -> evalOrd x env + PrimChr -> evalChr x env + PrimBoolToInt -> evalBoolToInt x env + PrimFromIntegral ta tb -> evalFromIntegral ta tb x env + + +-- Discriminate binary functions that commute, and if so return the operands in +-- a stable ordering. If only one of the arguments is a constant, this is placed +-- to the left of the operator. Returning Nothing indicates no change is made. +-- +commutes + :: forall acc env aenv a r. (Kit acc, Elt a, Elt r) + => PrimFun (a -> r) + -> PreOpenExp acc env aenv a + -> Gamma acc env env aenv + -> Maybe (PreOpenExp acc env aenv a) +commutes f x env = case f of + PrimAdd _ -> swizzle x + PrimMul _ -> swizzle x + PrimBAnd _ -> swizzle x + PrimBOr _ -> swizzle x + PrimBXor _ -> swizzle x + PrimEq _ -> swizzle x + PrimNEq _ -> swizzle x + PrimMax _ -> swizzle x + PrimMin _ -> swizzle x + PrimLAnd -> swizzle x + PrimLOr -> swizzle x + _ -> Nothing + where + swizzle :: PreOpenExp acc env aenv (b,b) -> Maybe (PreOpenExp acc env aenv (b,b)) + swizzle (Tuple (NilTup `SnocTup` a `SnocTup` b)) + | Nothing <- propagate env a + , Just _ <- propagate env b + = Stats.ruleFired (pprFun "commutes" f) + $ Just $ Tuple (NilTup `SnocTup` b `SnocTup` a) + +-- TLM: changing the ordering here when neither term can be reduced can be +-- disadvantageous: for example in (x &&* y), the user might have put a +-- simpler condition first that is designed to fail fast. +-- +-- | Nothing <- propagate env a +-- , Nothing <- propagate env b +-- , hashOpenExp a > hashOpenExp b +-- = Just $ Tuple (NilTup `SnocTup` b `SnocTup` a) + + swizzle _ + = Nothing + + +{-- +-- Determine if successive applications of a binary operator will associate, and +-- if so move them to the left. That is: +-- +-- a + (b + c) --> (a + b) + c +-- +-- Returning Nothing indicates no change is made. +-- +-- TLM: we might get into trouble here, as we've lost track of where the user +-- has explicitly put parenthesis. +-- +-- TLM: BROKEN!! does not correctly change the sign of expressions when flipping +-- (-x+y) or (-y+x). +-- +associates + :: (Elt a, Elt r) + => PrimFun (a -> r) + -> PreOpenExp acc env aenv a + -> Maybe (PreOpenExp acc env aenv r) +associates fun exp = case fun of + PrimAdd _ -> swizzle fun exp [PrimAdd ty, PrimSub ty] + PrimSub _ -> swizzle fun exp [PrimAdd ty, PrimSub ty] + PrimLAnd -> swizzle fun exp [fun] + PrimLOr -> swizzle fun exp [fun] + _ -> swizzle fun exp [fun] + where + -- TODO: check the list of ops is complete (and correct) + ty = undefined + ops = [ PrimMul ty, PrimFDiv ty, PrimAdd ty, PrimSub ty, PrimBAnd ty, PrimBOr ty, PrimBXor ty ] + + swizzle :: (Elt a, Elt r) => PrimFun (a -> r) -> PreOpenExp acc env aenv a -> [PrimFun (a -> r)] -> Maybe (PreOpenExp acc env aenv r) + swizzle f x lvl + | Just REFL <- matches f ops + , Just (a,bc) <- untup2 x + , PrimApp g y <- bc + , Just REFL <- matches g lvl + , Just (b,c) <- untup2 y + = Stats.ruleFired (pprFun "associates" f) + $ Just $ PrimApp g (tup2 (PrimApp f (tup2 (a,b)), c)) + + swizzle _ _ _ + = Nothing + + matches :: (Elt s, Elt t) => PrimFun (s -> a) -> [PrimFun (t -> a)] -> Maybe (s :=: t) + matches _ [] = Nothing + matches f (x:xs) + | Just REFL <- matchPrimFun' f x + = Just REFL + + | otherwise + = matches f xs +--} + + +-- Helper functions +-- ---------------- + +type a :-> b = forall acc env aenv. Kit acc => PreOpenExp acc env aenv a -> Gamma acc env env aenv -> Maybe (PreOpenExp acc env aenv b) + +eval1 :: Elt b => (a -> b) -> a :-> b +eval1 f x env + | Just a <- propagate env x = Stats.substitution "constant fold" . Just $ Const (fromElt (f a)) + | otherwise = Nothing + +eval2 :: Elt c => (a -> b -> c) -> (a,b) :-> c +eval2 f (untup2 -> Just (x,y)) env + | Just a <- propagate env x + , Just b <- propagate env y + = Stats.substitution "constant fold" + $ Just $ Const (fromElt (f a b)) + +eval2 _ _ _ + = Nothing + +-- tup2 :: (Elt a, Elt b) => (PreOpenExp acc env aenv a, PreOpenExp acc env aenv b) -> PreOpenExp acc env aenv (a, b) +-- tup2 (a,b) = Tuple (NilTup `SnocTup` a `SnocTup` b) + +untup2 :: PreOpenExp acc env aenv (a, b) -> Maybe (PreOpenExp acc env aenv a, PreOpenExp acc env aenv b) +untup2 exp + | Tuple (NilTup `SnocTup` a `SnocTup` b) <- exp = Just (a, b) + | otherwise = Nothing + + +pprFun :: String -> PrimFun f -> String +pprFun rule f = show $ text rule <+> snd (prettyPrim f) + + +-- Methods of Num +-- -------------- + +evalAdd :: Elt a => NumType a -> (a,a) :-> a +evalAdd (IntegralNumType ty) | IntegralDict <- integralDict ty = evalAdd' +evalAdd (FloatingNumType ty) | FloatingDict <- floatingDict ty = evalAdd' + +evalAdd' :: (Elt a, Eq a, Num a) => (a,a) :-> a +evalAdd' (untup2 -> Just (x,y)) env + | Just a <- propagate env x + , a == 0 + = Stats.ruleFired "x+0" $ Just y + +evalAdd' arg env + = eval2 (+) arg env + + +evalSub :: Elt a => NumType a -> (a,a) :-> a +evalSub ty@(IntegralNumType ty') | IntegralDict <- integralDict ty' = evalSub' ty +evalSub ty@(FloatingNumType ty') | FloatingDict <- floatingDict ty' = evalSub' ty + +evalSub' :: forall a. (Elt a, Eq a, Num a) => NumType a -> (a,a) :-> a +evalSub' ty (untup2 -> Just (x,y)) env + | Just b <- propagate env y + , b == 0 + = Stats.ruleFired "x-0" $ Just x + + | Nothing <- propagate env x + , Just b <- propagate env y + = Stats.ruleFired "-y+x" + $ Just $ evalPrimApp env (PrimAdd ty) (Tuple $ NilTup `SnocTup` Const (fromElt (-b)) `SnocTup` x) + + | Just REFL <- match x y + = Stats.ruleFired "x-x" + $ Just $ Const (fromElt (0::a)) + +evalSub' _ arg env + = eval2 (-) arg env + + +evalMul :: Elt a => NumType a -> (a,a) :-> a +evalMul (IntegralNumType ty) | IntegralDict <- integralDict ty = evalMul' +evalMul (FloatingNumType ty) | FloatingDict <- floatingDict ty = evalMul' + +evalMul' :: (Elt a, Eq a, Num a) => (a,a) :-> a +evalMul' (untup2 -> Just (x,y)) env + | Just a <- propagate env x + , Nothing <- propagate env y + = case a of + 0 -> Stats.ruleFired "x*0" $ Just x + 1 -> Stats.ruleFired "x*1" $ Just y + _ -> Nothing + +evalMul' arg env + = eval2 (*) arg env + +evalNeg :: Elt a => NumType a -> a :-> a +evalNeg (IntegralNumType ty) | IntegralDict <- integralDict ty = eval1 negate +evalNeg (FloatingNumType ty) | FloatingDict <- floatingDict ty = eval1 negate + +evalAbs :: Elt a => NumType a -> a :-> a +evalAbs (IntegralNumType ty) | IntegralDict <- integralDict ty = eval1 abs +evalAbs (FloatingNumType ty) | FloatingDict <- floatingDict ty = eval1 abs + +evalSig :: Elt a => NumType a -> a :-> a +evalSig (IntegralNumType ty) | IntegralDict <- integralDict ty = eval1 signum +evalSig (FloatingNumType ty) | FloatingDict <- floatingDict ty = eval1 signum + + +-- Methods of Integral & Bits +-- -------------------------- + +evalQuot :: Elt a => IntegralType a -> (a,a) :-> a +evalQuot ty | IntegralDict <- integralDict ty = eval2 quot + +evalRem :: Elt a => IntegralType a -> (a,a) :-> a +evalRem ty | IntegralDict <- integralDict ty = eval2 rem + +evalIDiv :: Elt a => IntegralType a -> (a,a) :-> a +evalIDiv ty | IntegralDict <- integralDict ty = evalIDiv' + +evalIDiv' :: (Elt a, Integral a, Eq a) => (a,a) :-> a +evalIDiv' (untup2 -> Just (x,y)) env + | Just 1 <- propagate env y + = Stats.ruleFired "x`div`1" $ Just x + +evalIDiv' arg env + = eval2 div arg env + +evalMod :: Elt a => IntegralType a -> (a,a) :-> a +evalMod ty | IntegralDict <- integralDict ty = eval2 mod + +evalBAnd :: Elt a => IntegralType a -> (a,a) :-> a +evalBAnd ty | IntegralDict <- integralDict ty = eval2 (.&.) + +evalBOr :: Elt a => IntegralType a -> (a,a) :-> a +evalBOr ty | IntegralDict <- integralDict ty = eval2 (.|.) + +evalBXor :: Elt a => IntegralType a -> (a,a) :-> a +evalBXor ty | IntegralDict <- integralDict ty = eval2 xor + +evalBNot :: Elt a => IntegralType a -> a :-> a +evalBNot ty | IntegralDict <- integralDict ty = eval1 complement + +evalBShiftL :: Elt a => IntegralType a -> (a,Int) :-> a +evalBShiftL _ (untup2 -> Just (x,i)) env + | Just 0 <- propagate env i + = Stats.ruleFired "x `shiftL` 0" $ Just x + +evalBShiftL ty arg env + | IntegralDict <- integralDict ty = eval2 shiftL arg env + +evalBShiftR :: Elt a => IntegralType a -> (a,Int) :-> a +evalBShiftR _ (untup2 -> Just (x,i)) env + | Just 0 <- propagate env i + = Stats.ruleFired "x `shiftR` 0" $ Just x + +evalBShiftR ty arg env + | IntegralDict <- integralDict ty = eval2 shiftR arg env + +evalBRotateL :: Elt a => IntegralType a -> (a,Int) :-> a +evalBRotateL _ (untup2 -> Just (x,i)) env + | Just 0 <- propagate env i + = Stats.ruleFired "x `rotateL` 0" $ Just x +evalBRotateL ty arg env + | IntegralDict <- integralDict ty = eval2 rotateL arg env + +evalBRotateR :: Elt a => IntegralType a -> (a,Int) :-> a +evalBRotateR _ (untup2 -> Just (x,i)) env + | Just 0 <- propagate env i + = Stats.ruleFired "x `rotateR` 0" $ Just x +evalBRotateR ty arg env + | IntegralDict <- integralDict ty = eval2 rotateR arg env + + +-- Methods of Fractional & Floating +-- -------------------------------- + +evalFDiv :: Elt a => FloatingType a -> (a,a) :-> a +evalFDiv ty | FloatingDict <- floatingDict ty = evalFDiv' + +evalFDiv' :: (Elt a, Fractional a, Eq a) => (a,a) :-> a +evalFDiv' (untup2 -> Just (x,y)) env + | Just 1 <- propagate env y + = Stats.ruleFired "x/1" $ Just x + +evalFDiv' arg env + = eval2 (/) arg env + + +evalRecip :: Elt a => FloatingType a -> a :-> a +evalRecip ty | FloatingDict <- floatingDict ty = eval1 recip + +evalSin :: Elt a => FloatingType a -> a :-> a +evalSin ty | FloatingDict <- floatingDict ty = eval1 sin + +evalCos :: Elt a => FloatingType a -> a :-> a +evalCos ty | FloatingDict <- floatingDict ty = eval1 cos + +evalTan :: Elt a => FloatingType a -> a :-> a +evalTan ty | FloatingDict <- floatingDict ty = eval1 tan + +evalAsin :: Elt a => FloatingType a -> a :-> a +evalAsin ty | FloatingDict <- floatingDict ty = eval1 asin + +evalAcos :: Elt a => FloatingType a -> a :-> a +evalAcos ty | FloatingDict <- floatingDict ty = eval1 acos + +evalAtan :: Elt a => FloatingType a -> a :-> a +evalAtan ty | FloatingDict <- floatingDict ty = eval1 atan + +evalAsinh :: Elt a => FloatingType a -> a :-> a +evalAsinh ty | FloatingDict <- floatingDict ty = eval1 asinh + +evalAcosh :: Elt a => FloatingType a -> a :-> a +evalAcosh ty | FloatingDict <- floatingDict ty = eval1 acosh + +evalAtanh :: Elt a => FloatingType a -> a :-> a +evalAtanh ty | FloatingDict <- floatingDict ty = eval1 atanh + +evalExpFloating :: Elt a => FloatingType a -> a :-> a +evalExpFloating ty | FloatingDict <- floatingDict ty = eval1 P.exp + +evalSqrt :: Elt a => FloatingType a -> a :-> a +evalSqrt ty | FloatingDict <- floatingDict ty = eval1 sqrt + +evalLog :: Elt a => FloatingType a -> a :-> a +evalLog ty | FloatingDict <- floatingDict ty = eval1 log + +evalFPow :: Elt a => FloatingType a -> (a,a) :-> a +evalFPow ty | FloatingDict <- floatingDict ty = eval2 (**) + +evalLogBase :: Elt a => FloatingType a -> (a,a) :-> a +evalLogBase ty | FloatingDict <- floatingDict ty = eval2 logBase + +evalAtan2 :: Elt a => FloatingType a -> (a,a) :-> a +evalAtan2 ty | FloatingDict <- floatingDict ty = eval2 atan2 + +evalTruncate :: (Elt a, Elt b) => FloatingType a -> IntegralType b -> a :-> b +evalTruncate ta tb + | FloatingDict <- floatingDict ta + , IntegralDict <- integralDict tb = eval1 truncate + +evalRound :: (Elt a, Elt b) => FloatingType a -> IntegralType b -> a :-> b +evalRound ta tb + | FloatingDict <- floatingDict ta + , IntegralDict <- integralDict tb = eval1 round + +evalFloor :: (Elt a, Elt b) => FloatingType a -> IntegralType b -> a :-> b +evalFloor ta tb + | FloatingDict <- floatingDict ta + , IntegralDict <- integralDict tb = eval1 floor + +evalCeiling :: (Elt a, Elt b) => FloatingType a -> IntegralType b -> a :-> b +evalCeiling ta tb + | FloatingDict <- floatingDict ta + , IntegralDict <- integralDict tb = eval1 ceiling + + +-- Relational & Equality +-- --------------------- + +evalLt :: ScalarType a -> (a,a) :-> Bool +evalLt (NumScalarType (IntegralNumType ty)) | IntegralDict <- integralDict ty = eval2 (<) +evalLt (NumScalarType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = eval2 (<) +evalLt (NonNumScalarType ty) | NonNumDict <- nonNumDict ty = eval2 (<) + +evalGt :: ScalarType a -> (a,a) :-> Bool +evalGt (NumScalarType (IntegralNumType ty)) | IntegralDict <- integralDict ty = eval2 (>) +evalGt (NumScalarType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = eval2 (>) +evalGt (NonNumScalarType ty) | NonNumDict <- nonNumDict ty = eval2 (>) + +evalLtEq :: ScalarType a -> (a,a) :-> Bool +evalLtEq (NumScalarType (IntegralNumType ty)) | IntegralDict <- integralDict ty = eval2 (<=) +evalLtEq (NumScalarType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = eval2 (<=) +evalLtEq (NonNumScalarType ty) | NonNumDict <- nonNumDict ty = eval2 (<=) + +evalGtEq :: ScalarType a -> (a,a) :-> Bool +evalGtEq (NumScalarType (IntegralNumType ty)) | IntegralDict <- integralDict ty = eval2 (>=) +evalGtEq (NumScalarType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = eval2 (>=) +evalGtEq (NonNumScalarType ty) | NonNumDict <- nonNumDict ty = eval2 (>=) + +evalEq :: ScalarType a -> (a,a) :-> Bool +evalEq (NumScalarType (IntegralNumType ty)) | IntegralDict <- integralDict ty = eval2 (==) +evalEq (NumScalarType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = eval2 (==) +evalEq (NonNumScalarType ty) | NonNumDict <- nonNumDict ty = eval2 (==) + +evalNEq :: ScalarType a -> (a,a) :-> Bool +evalNEq (NumScalarType (IntegralNumType ty)) | IntegralDict <- integralDict ty = eval2 (/=) +evalNEq (NumScalarType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = eval2 (/=) +evalNEq (NonNumScalarType ty) | NonNumDict <- nonNumDict ty = eval2 (/=) + +evalMax :: Elt a => ScalarType a -> (a,a) :-> a +evalMax (NumScalarType (IntegralNumType ty)) | IntegralDict <- integralDict ty = eval2 max +evalMax (NumScalarType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = eval2 max +evalMax (NonNumScalarType ty) | NonNumDict <- nonNumDict ty = eval2 max + +evalMin :: Elt a => ScalarType a -> (a,a) :-> a +evalMin (NumScalarType (IntegralNumType ty)) | IntegralDict <- integralDict ty = eval2 min +evalMin (NumScalarType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = eval2 min +evalMin (NonNumScalarType ty) | NonNumDict <- nonNumDict ty = eval2 min + + +-- Logical operators +-- ----------------- + +evalLAnd :: (Bool,Bool) :-> Bool +evalLAnd (untup2 -> Just (x,y)) env + | Just a <- propagate env x + = Just $ if a then Stats.ruleFired "True &&" y + else Stats.ruleFired "False &&" $ Const (fromElt False) + +evalLAnd _ _ + = Nothing + +evalLOr :: (Bool,Bool) :-> Bool +evalLOr (untup2 -> Just (x,y)) env + | Just a <- propagate env x + = Just $ if a then Stats.ruleFired "True ||" $ Const (fromElt True) + else Stats.ruleFired "False ||" y + +evalLOr _ _ + = Nothing + +evalLNot :: Bool :-> Bool +evalLNot = eval1 not + +evalOrd :: Char :-> Int +evalOrd = eval1 ord + +evalChr :: Int :-> Char +evalChr = eval1 chr + +evalBoolToInt :: Bool :-> Int +evalBoolToInt = eval1 fromEnum + +evalFromIntegral :: Elt b => IntegralType a -> NumType b -> a :-> b +evalFromIntegral ta (IntegralNumType tb) + | IntegralDict <- integralDict ta + , IntegralDict <- integralDict tb = eval1 fromIntegral + +evalFromIntegral ta (FloatingNumType tb) + | IntegralDict <- integralDict ta + , FloatingDict <- floatingDict tb = eval1 fromIntegral + + +-- Scalar primitives +-- ----------------- + +evalPrimConst :: PrimConst a -> a +evalPrimConst (PrimMinBound ty) = evalMinBound ty +evalPrimConst (PrimMaxBound ty) = evalMaxBound ty +evalPrimConst (PrimPi ty) = evalPi ty + +evalMinBound :: BoundedType a -> a +evalMinBound (IntegralBoundedType ty) | IntegralDict <- integralDict ty = minBound +evalMinBound (NonNumBoundedType ty) | NonNumDict <- nonNumDict ty = minBound + +evalMaxBound :: BoundedType a -> a +evalMaxBound (IntegralBoundedType ty) | IntegralDict <- integralDict ty = maxBound +evalMaxBound (NonNumBoundedType ty) | NonNumDict <- nonNumDict ty = maxBound + +evalPi :: FloatingType a -> a +evalPi ty | FloatingDict <- floatingDict ty = pi + diff --git a/Data/Array/Accelerate/Trafo/Base.hs b/Data/Array/Accelerate/Trafo/Base.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/Trafo/Base.hs @@ -0,0 +1,220 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE IncoherentInstances #-} +{-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +-- | +-- Module : Data.Array.Accelerate.Trafo.Base +-- Copyright : [2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Manuel M T Chakravarty +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.Trafo.Base ( + + -- Toolkit + Kit(..), Match(..), (:=:)(REFL), + avarIn, kmap, + + -- Delayed Arrays + DelayedAcc, DelayedOpenAcc(..), + DelayedAfun, DelayedOpenAfun, + DelayedExp, DelayedFun, DelayedOpenExp, DelayedOpenFun, + + -- Environments + Gamma(..), incExp, prjExp, lookupExp, + +) where + +-- standard library +import Prelude hiding ( until ) +import Data.Hashable +import Text.PrettyPrint + +-- friends +import Data.Array.Accelerate.AST +import Data.Array.Accelerate.Array.Sugar ( Array, Arrays, Shape, Elt ) +import Data.Array.Accelerate.Analysis.Match +import Data.Array.Accelerate.Trafo.Substitution +import Data.Array.Accelerate.Pretty.Print + +#include "accelerate.h" + + +-- Toolkit +-- ======= + +-- The bat utility belt of operations required to manipulate terms parameterised +-- by the recursive closure. +-- +class Kit acc where + inject :: PreOpenAcc acc aenv a -> acc aenv a + extract :: acc aenv a -> PreOpenAcc acc aenv a + -- + rebuildAcc :: RebuildAcc acc + matchAcc :: MatchAcc acc + hashAcc :: HashAcc acc + prettyAcc :: PrettyAcc acc + +instance Kit OpenAcc where + inject = OpenAcc + extract (OpenAcc pacc) = pacc + + rebuildAcc = rebuildOpenAcc + matchAcc = matchOpenAcc + hashAcc = hashOpenAcc + prettyAcc = prettyOpenAcc + +avarIn :: (Kit acc, Arrays arrs) => Idx aenv arrs -> acc aenv arrs +avarIn = inject . Avar + +kmap :: Kit acc => (PreOpenAcc acc aenv a -> PreOpenAcc acc aenv b) -> acc aenv a -> acc aenv b +kmap f = inject . f . extract + + +-- A class for testing the equality of terms homogeneously, returning a witness +-- to the existentially quantified terms in the positive case. +-- +class Match f where + match :: f s -> f t -> Maybe (s :=: t) + +instance Match (Idx env) where + match = matchIdx + +instance Kit acc => Match (PreOpenExp acc env aenv) where + match = matchPreOpenExp matchAcc hashAcc + +instance Kit acc => Match (PreOpenFun acc env aenv) where + match = matchPreOpenFun matchAcc hashAcc + +instance Kit acc => Match (PreOpenAcc acc aenv) where + match = matchPreOpenAcc matchAcc hashAcc + +instance Kit acc => Match (acc aenv) where -- overlapping, undecidable, incoherent + match = matchAcc + + +-- Delayed Arrays +-- ============== + +-- The type of delayed arrays. This representation is used to annotate the AST +-- in the recursive knot to distinguish standard AST terms from operand arrays +-- that should be embedded into their consumers. +-- +type DelayedAcc = DelayedOpenAcc () +type DelayedAfun = PreOpenAfun DelayedOpenAcc () + +type DelayedExp = DelayedOpenExp () +type DelayedFun = DelayedOpenFun () +type DelayedOpenAfun = PreOpenAfun DelayedOpenAcc +type DelayedOpenExp = PreOpenExp DelayedOpenAcc +type DelayedOpenFun = PreOpenFun DelayedOpenAcc + +data DelayedOpenAcc aenv a where + Manifest :: PreOpenAcc DelayedOpenAcc aenv a -> DelayedOpenAcc aenv a + + Delayed :: (Shape sh, Elt e) => + { extentD :: PreExp DelayedOpenAcc aenv sh + , indexD :: PreFun DelayedOpenAcc aenv (sh -> e) + , linearIndexD :: PreFun DelayedOpenAcc aenv (Int -> e) + } -> DelayedOpenAcc aenv (Array sh e) + +instance Kit DelayedOpenAcc where + inject = Manifest + extract = error "DelayedAcc.extract" + -- + rebuildAcc = rebuildDelayed + matchAcc = matchDelayed + hashAcc = hashDelayed + prettyAcc = prettyDelayed + + +hashDelayed :: HashAcc DelayedOpenAcc +hashDelayed (Manifest pacc) = hash "Manifest" `hashWithSalt` hashPreOpenAcc hashAcc pacc +hashDelayed Delayed{..} = hash "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) + = matchPreOpenAcc matchAcc hashAcc pacc1 pacc2 + +matchDelayed (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 _ _ + = Nothing + +rebuildDelayed :: RebuildAcc DelayedOpenAcc +rebuildDelayed v acc = case acc of + Manifest pacc -> Manifest (rebuildA rebuildDelayed v pacc) + Delayed{..} -> Delayed (rebuildEA rebuildDelayed v extentD) + (rebuildFA rebuildDelayed v indexD) + (rebuildFA rebuildDelayed v linearIndexD) + + +-- Note: If we detect that the delayed array is simply accessing an array +-- variable, then just print the variable name. That is: +-- +-- > let a0 = <...> in map f (Delayed (shape a0) (\x0 -> a0!x0)) +-- +-- becomes +-- +-- > let a0 = <...> in map f a0 +-- +prettyDelayed :: PrettyAcc DelayedOpenAcc +prettyDelayed alvl wrap acc = case acc of + Manifest pacc -> prettyPreAcc prettyDelayed alvl wrap pacc + Delayed sh f _ + | Shape a <- sh + , Just REFL <- match f (Lam (Body (Index a (Var ZeroIdx)))) + -> prettyDelayed alvl wrap a + + | otherwise + -> wrap $ hang (text "Delayed") 2 + $ sep [ prettyPreExp prettyDelayed 0 alvl parens sh + , parens (prettyPreFun prettyDelayed alvl f) + ] + + +-- Environments +-- ============ + +-- An environment that holds let-bound scalar expressions. The second +-- environment variable env' is used to project out the corresponding +-- index when looking up in the environment congruent expressions. +-- +data Gamma acc env env' aenv where + EmptyExp :: Gamma acc env env' aenv + + PushExp :: Gamma acc env env' aenv + -> PreOpenExp acc env aenv t + -> Gamma acc env (env', t) aenv + +incExp :: Gamma acc env env' aenv -> Gamma acc (env, s) env' aenv +incExp EmptyExp = EmptyExp +incExp (PushExp env e) = incExp env `PushExp` weakenE SuccIdx e + +prjExp :: Idx env' t -> Gamma acc env env' aenv -> PreOpenExp acc env aenv t +prjExp ZeroIdx (PushExp _ v) = v +prjExp (SuccIdx ix) (PushExp env _) = prjExp ix env +prjExp _ _ = INTERNAL_ERROR(error) "prjExp" "inconsistent valuation" + +lookupExp :: Kit acc => Gamma acc env env' aenv -> PreOpenExp acc env aenv t -> Maybe (Idx env' t) +lookupExp EmptyExp _ = Nothing +lookupExp (PushExp env e) x + | Just REFL <- match e x = Just ZeroIdx + | otherwise = SuccIdx `fmap` lookupExp env x + diff --git a/Data/Array/Accelerate/Trafo/Fusion.hs b/Data/Array/Accelerate/Trafo/Fusion.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/Trafo/Fusion.hs @@ -0,0 +1,1248 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE IncoherentInstances #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} +-- | +-- Module : Data.Array.Accelerate.Trafo.Fusion +-- Copyright : [2012..2013] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Manuel M T Chakravarty +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- +-- This module implements producer/producer and consumer/producer fusion as a +-- term rewriting of the Accelerate AST. +-- +-- The function 'quench' perform the source-to-source fusion transformation, +-- while 'anneal' additionally makes the representation of embedded producers +-- explicit by representing the AST as a 'DelayedAcc' of manifest and delayed +-- nodes. +-- + +module Data.Array.Accelerate.Trafo.Fusion ( + + -- ** Types + DelayedAcc, DelayedOpenAcc(..), + DelayedAfun, DelayedOpenAfun, + DelayedExp, DelayedFun, DelayedOpenExp, DelayedOpenFun, + + -- ** Conversion + convertAcc, convertAfun, + +) where + +-- standard library +import Prelude hiding ( exp, until ) + +-- friends +import Data.Array.Accelerate.AST +import Data.Array.Accelerate.Trafo.Base +import Data.Array.Accelerate.Trafo.Shrink +import Data.Array.Accelerate.Trafo.Simplify +import Data.Array.Accelerate.Trafo.Substitution +import Data.Array.Accelerate.Array.Representation ( SliceIndex(..) ) +import Data.Array.Accelerate.Array.Sugar ( Array, Arrays(..), ArraysR(..), ArrRepr', Elt, EltRepr, Shape ) +import Data.Array.Accelerate.Tuple + +import qualified Data.Array.Accelerate.Debug as Stats +#ifdef ACCELERATE_DEBUG +import System.IO.Unsafe -- for debugging +#endif + +#include "accelerate.h" + + +-- Delayed Array Fusion +-- ==================== + +-- | Apply the fusion transformation to a closed de Bruijn AST +-- +convertAcc :: Arrays arrs => Acc arrs -> DelayedAcc arrs +convertAcc = withSimplStats . quenchAcc . annealAcc + +-- | Apply the fusion transformation to a function of array arguments +-- +convertAfun :: Afun f -> DelayedAfun f +convertAfun = withSimplStats . quenchAfun . annealAfun + +withSimplStats :: a -> a +#ifdef ACCELERATE_DEBUG +withSimplStats x = unsafePerformIO Stats.resetSimplCount `seq` x +#else +withSimplStats x = x +#endif + + +-- | An optional second phase of the fusion transformation that makes the +-- representation of fused consumer/producer terms explicit. Note that quenching +-- happens after annealing. +-- +-- TODO: integrate this with the first phase? +-- +quenchAcc :: Arrays arrs => OpenAcc aenv arrs -> DelayedOpenAcc aenv arrs +quenchAcc = cvtA + where + -- Convert array computations into an embeddable delayed representation. + -- This is essentially the reverse of 'compute'. + -- + embed :: (Shape sh, Elt e) => OpenAcc aenv (Array sh e) -> DelayedOpenAcc aenv (Array sh e) + embed (OpenAcc pacc) = + case pacc of + Avar v + -> Delayed (arrayShape v) (indexArray v) (linearIndex v) + + Generate (cvtE -> sh) (cvtF -> f) + -> Delayed sh f (f `compose` fromIndex sh) + + Map (cvtF -> f) (embed -> Delayed{..}) + -> Delayed extentD (f `compose` indexD) (f `compose` linearIndexD) + + Backpermute (cvtE -> sh) (cvtF -> p) (embed -> Delayed{..}) + -> let p' = indexD `compose` p + in Delayed sh p'(p' `compose` fromIndex sh) + + Transform (cvtE -> sh) (cvtF -> p) (cvtF -> f) (embed -> Delayed{..}) + -> let f' = f `compose` indexD `compose` p + in Delayed sh f' (f' `compose` fromIndex sh) + + _ -> INTERNAL_ERROR(error) "quench" "tried to consume a non-embeddable term" + + fusionError = INTERNAL_ERROR(error) "quench" "unexpected fusible materials" + + -- Convert array programs as manifest terms. + -- + cvtA :: OpenAcc aenv a -> DelayedOpenAcc aenv a + cvtA (OpenAcc pacc) = Manifest $ + case pacc of + -- Non-fusible terms + -- ----------------- + Avar ix -> Avar ix + Use arr -> Use arr + Unit e -> Unit (cvtE e) + Alet bnd body -> Alet (cvtA bnd) (cvtA body) + Acond p t e -> Acond (cvtE p) (cvtA t) (cvtA e) + Atuple tup -> Atuple (cvtAT tup) + Aprj ix tup -> Aprj ix (cvtA tup) + Apply f a -> Apply (cvtAF f) (cvtA a) + Aforeign ff f a -> Aforeign ff (cvtAF f) (cvtA a) + + -- Producers + -- --------- + -- + -- Some producers might still exist as a manifest array. Typically + -- this is because they are the last stage of the computation, or the + -- result of a let-binding to be used multiple times. The input array + -- here should be an array variable, else something went wrong. + -- + Map f a -> Map (cvtF f) (embed a) + Generate sh f -> Generate (cvtE sh) (cvtF f) + Transform sh p f a -> Transform (cvtE sh) (cvtF p) (cvtF f) (embed a) + Backpermute sh p a -> backpermute (cvtE sh) (cvtF p) (embed a) a + + Reshape{} -> fusionError + Replicate{} -> fusionError + Slice{} -> fusionError + ZipWith{} -> fusionError + + -- Consumers + -- --------- + -- + -- Embed producers directly into the representation. For stencils we + -- make an exception. Since these consumers access elements of the + -- argument array multiple times, we are careful not to duplicate work + -- and instead force the argument to be a manifest array. + -- + Fold f z a -> Fold (cvtF f) (cvtE z) (embed a) + Fold1 f a -> Fold1 (cvtF f) (embed a) + FoldSeg f z a s -> FoldSeg (cvtF f) (cvtE z) (embed a) (embed s) + Fold1Seg f a s -> Fold1Seg (cvtF f) (embed a) (embed s) + Scanl f z a -> Scanl (cvtF f) (cvtE z) (embed a) + Scanl1 f a -> Scanl1 (cvtF f) (embed a) + Scanl' f z a -> Scanl' (cvtF f) (cvtE z) (embed a) + Scanr f z a -> Scanr (cvtF f) (cvtE z) (embed a) + Scanr1 f a -> Scanr1 (cvtF f) (embed a) + Scanr' f z a -> Scanr' (cvtF f) (cvtE z) (embed a) + Permute f d p a -> Permute (cvtF f) (cvtA d) (cvtF p) (embed 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) + + -- A backwards permutation at this stage might be further simplified as a + -- reshape operation, which can be executed in constant time without + -- actually executing any array operations. + -- + -- This requires that the argument of reshape be a manifest array, which is + -- an exception to the rule of having all array inputs in delayed form. + -- + backpermute sh p a x + | OpenAcc (Avar v) <- x + , Just REFL <- match p (simplify $ reindex (arrayShape v) sh) + = Reshape sh (Manifest (Avar v)) + + | otherwise + = Backpermute sh p a + + cvtAT :: Atuple (OpenAcc aenv) a -> Atuple (DelayedOpenAcc aenv) a + cvtAT NilAtup = NilAtup + cvtAT (SnocAtup t a) = cvtAT t `SnocAtup` cvtA a + + cvtAF :: OpenAfun aenv f -> PreOpenAfun DelayedOpenAcc aenv f + cvtAF (Alam f) = Alam (cvtAF f) + cvtAF (Abody b) = Abody (cvtA b) + + -- Conversions for closed scalar functions and expressions + -- + cvtF :: OpenFun env aenv f -> DelayedOpenFun env aenv f + cvtF (Lam f) = Lam (cvtF f) + cvtF (Body b) = Body (cvtE b) + + cvtE :: OpenExp env aenv t -> DelayedOpenExp env aenv t + cvtE exp = + case exp of + Let bnd body -> Let (cvtE bnd) (cvtE body) + Var ix -> Var ix + Const c -> Const c + Tuple tup -> Tuple (cvtT tup) + Prj ix t -> Prj ix (cvtE t) + IndexNil -> IndexNil + IndexCons sh sz -> IndexCons (cvtE sh) (cvtE sz) + IndexHead sh -> IndexHead (cvtE sh) + IndexTail sh -> IndexTail (cvtE sh) + IndexAny -> IndexAny + IndexSlice x ix sh -> IndexSlice x (cvtE ix) (cvtE sh) + IndexFull x ix sl -> IndexFull x (cvtE ix) (cvtE sl) + ToIndex sh ix -> ToIndex (cvtE sh) (cvtE ix) + FromIndex sh ix -> FromIndex (cvtE sh) (cvtE ix) + Cond p t e -> Cond (cvtE p) (cvtE t) (cvtE e) + Iterate n f x -> Iterate (cvtE n) (cvtE f) (cvtE x) + PrimConst c -> PrimConst c + PrimApp f x -> PrimApp f (cvtE x) + Index a sh -> Index (cvtA a) (cvtE sh) + LinearIndex a i -> LinearIndex (cvtA a) (cvtE i) + Shape a -> Shape (cvtA a) + ShapeSize sh -> ShapeSize (cvtE sh) + Intersect s t -> Intersect (cvtE s) (cvtE t) + Foreign ff f e -> Foreign ff (cvtF f) (cvtE e) + + cvtT :: Tuple (OpenExp env aenv) t -> Tuple (DelayedOpenExp env aenv) t + cvtT NilTup = NilTup + cvtT (SnocTup t e) = cvtT t `SnocTup` cvtE e + + +quenchAfun :: OpenAfun aenv f -> DelayedOpenAfun aenv f +quenchAfun (Alam f) = Alam (quenchAfun f) +quenchAfun (Abody b) = Abody (quenchAcc b) + + +-- | Apply the fusion transformation to the AST to combine and simplify terms. +-- This combines producer/producer terms and makes consumer/producer nodes +-- adjacent. +-- +annealAcc :: Arrays arrs => OpenAcc aenv arrs -> OpenAcc aenv arrs +annealAcc = computeAcc . delayAcc + where + delayAcc :: Arrays a => OpenAcc aenv a -> Delayed OpenAcc aenv a + delayAcc (OpenAcc pacc) = delayPreAcc delayAcc elimAcc pacc + + countAcc :: UsesOfAcc OpenAcc + countAcc ok idx (OpenAcc pacc) = usesOfPreAcc ok countAcc idx pacc + + -- When does the cost of re-computation outweigh that of memory access? For + -- the moment only do the substitution on a single use of the bound array + -- into the use site, but it is likely advantageous to be far more + -- aggressive here. SEE: [Sharing vs. Fusion] + -- + elimAcc :: Idx aenv s -> OpenAcc aenv t -> Bool + elimAcc v acc = countAcc False v acc <= lIMIT + where + lIMIT = 1 + + +annealAfun :: OpenAfun aenv f -> OpenAfun aenv f +annealAfun (Alam f) = Alam (annealAfun f) +annealAfun (Abody b) = Abody (annealAcc b) + + +-- | Recast terms into the internal fusion delayed array representation to be +-- forged into combined terms. Using the reduced internal form limits the number +-- of combinations that need to be considered. +-- +type DelayAcc acc = forall aenv arrs. Arrays arrs => acc aenv arrs -> Delayed acc aenv arrs +type ElimAcc acc = forall aenv s t. Idx aenv s -> acc aenv t -> Bool + +{-# SPECIALISE + delayPreAcc :: Arrays a + => DelayAcc OpenAcc + -> ElimAcc OpenAcc + -> PreOpenAcc OpenAcc aenv a + -> Delayed OpenAcc aenv a + #-} + +delayPreAcc + :: forall acc aenv arrs. (Kit acc, Arrays arrs) + => DelayAcc acc + -> ElimAcc acc + -> PreOpenAcc acc aenv arrs + -> Delayed acc aenv arrs +delayPreAcc delayAcc elimAcc pacc = + case pacc of + + -- Non-fusible terms + -- ----------------- + -- + -- Solid and semi-solid terms that we generally do not which to fuse, such + -- as control flow (|?), array introduction (use, unit), array tupling and + -- projection, and foreign function operations. Generally we also do not + -- want to fuse past array let bindings, as this would imply work + -- duplication. SEE: [Sharing vs. Fusion] + -- + Alet bnd body -> aletD delayAcc elimAcc bnd body + Acond p at ae -> acondD delayAcc (cvtE p) at ae + Aprj ix tup -> aprjD delayAcc ix tup + Atuple tup -> done $ Atuple (cvtAT tup) + Apply f a -> done $ Apply (cvtAF f) (cvtA a) + Aforeign ff f a -> done $ Aforeign ff (cvtAF f) (cvtA a) + + -- Array injection + Avar v -> done $ Avar v + Use arrs -> done $ Use arrs + Unit e -> done $ Unit (cvtE e) + + -- Producers + -- --------- + -- + -- The class of operations that given a set of zero or more input arrays, + -- produce a _single_ element for the output array by manipulating a + -- _single_ element from each input array. These can be further classified + -- as value (map, zipWith) or index space (backpermute, slice, replicate) + -- transformations. + -- + -- The critical feature is that each element of the output is produced + -- independently of all others, and so we can aggressively fuse arbitrary + -- sequences of these operations. + -- + Generate sh f -> generateD (cvtE sh) (cvtF f) + + Map f a -> fuse (into mapD (cvtF f)) a + ZipWith f a b -> fuse2 (into zipWithD (cvtF f)) a b + Transform sh p f a -> fuse (into3 transformD (cvtE sh) (cvtF p) (cvtF f)) a + + Backpermute sl p a -> fuse (into2 backpermuteD (cvtE sl) (cvtF p)) a + Slice slix a sl -> fuse (into (sliceD slix) (cvtE sl)) a + Replicate slix sh a -> fuse (into (replicateD slix) (cvtE sh)) a + Reshape sl a -> fuse (into reshapeD (cvtE sl)) a + + -- Consumers + -- --------- + -- + -- Operations where each element of the output array depends on multiple + -- elements of the input array. To implement these operations efficiently in + -- parallel, we need to know how elements of the array depend on each other: + -- a parallel scan is implemented very differently from a parallel fold, for + -- example. + -- + -- In order to avoid obfuscating this crucial information required for + -- parallel implementation, fusion is separated into to phases: + -- producer/producer, implemented above, and consumer/producer, which is + -- implemented below. This will place producers adjacent to the consumer + -- node, so that the producer can be directly embedded into the consumer + -- during the code generation phase. + -- + Fold f z a -> embed (into2 Fold (cvtF f) (cvtE z)) a + Fold1 f a -> embed (into Fold1 (cvtF f)) a + FoldSeg f z a s -> embed2 (into2 FoldSeg (cvtF f) (cvtE z)) a s + Fold1Seg f a s -> embed2 (into Fold1Seg (cvtF f)) a s + Scanl f z a -> embed (into2 Scanl (cvtF f) (cvtE z)) a + Scanl1 f a -> embed (into Scanl1 (cvtF f)) a + Scanl' f z a -> embed (into2 Scanl' (cvtF f) (cvtE z)) a + Scanr f z a -> embed (into2 Scanr (cvtF f) (cvtE z)) a + 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 -> embed (into (stencil x) (cvtF f)) a + Stencil2 f x a y b -> embed2 (into (stencil2 x y) (cvtF f)) a b + + where + cvtA :: Arrays a => acc aenv' a -> acc aenv' a + cvtA = computeAcc . delayAcc + + cvtAT :: Atuple (acc aenv') a -> Atuple (acc aenv') a + cvtAT NilAtup = NilAtup + cvtAT (SnocAtup tup a) = cvtAT tup `SnocAtup` cvtA a + + cvtAF :: PreOpenAfun acc aenv' f -> PreOpenAfun acc aenv' f + cvtAF (Alam f) = Alam (cvtAF f) + cvtAF (Abody a) = Abody (cvtA a) + + -- 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 + + -- Conversions for closed scalar functions and expressions, with + -- pre-simplification. We don't bother traversing array-valued terms in + -- scalar expressions, as these are guaranteed to only be array variables. + -- + cvtF :: PreFun acc aenv t -> PreFun acc aenv t + cvtF = cvtF' . simplify + + cvtE :: PreExp acc aenv t -> PreExp acc aenv t + cvtE = cvtE' . simplify + + -- Conversions for scalar functions and expressions without + -- pre-simplification. Hence we can operate on open expressions. + -- + cvtF' :: PreOpenFun acc env aenv' t -> PreOpenFun acc env aenv' t + cvtF' (Lam f) = Lam (cvtF' f) + cvtF' (Body b) = Body (cvtE' b) + + cvtE' :: PreOpenExp acc env aenv' t -> PreOpenExp acc env aenv' t + cvtE' exp = + case exp of + Let bnd body -> Let (cvtE' bnd) (cvtE' body) + Var ix -> Var ix + Const c -> Const c + Tuple tup -> Tuple (cvtT tup) + Prj tup ix -> Prj tup (cvtE' ix) + IndexNil -> IndexNil + IndexCons sh sz -> IndexCons (cvtE' sh) (cvtE' sz) + IndexHead sh -> IndexHead (cvtE' sh) + IndexTail sh -> IndexTail (cvtE' sh) + IndexAny -> IndexAny + IndexSlice x ix sh -> IndexSlice x (cvtE' ix) (cvtE' sh) + IndexFull x ix sl -> IndexFull x (cvtE' ix) (cvtE' sl) + ToIndex sh ix -> ToIndex (cvtE' sh) (cvtE' ix) + FromIndex sh ix -> FromIndex (cvtE' sh) (cvtE' ix) + Cond p t e -> Cond (cvtE' p) (cvtE' t) (cvtE' e) + Iterate n f x -> Iterate (cvtE' n) (cvtE' f) (cvtE' x) + PrimConst c -> PrimConst c + PrimApp f x -> PrimApp f (cvtE' x) + Index a sh -> Index a (cvtE' sh) + LinearIndex a i -> LinearIndex a (cvtE' i) + Shape a -> Shape a + ShapeSize sh -> ShapeSize (cvtE' sh) + Intersect s t -> Intersect (cvtE' s) (cvtE' t) + Foreign ff f e -> Foreign ff (cvtF' f) (cvtE' e) + + cvtT :: Tuple (PreOpenExp acc env aenv') t -> Tuple (PreOpenExp acc env aenv') t + cvtT NilTup = NilTup + cvtT (SnocTup tup e) = cvtT tup `SnocTup` cvtE' e + + -- Helpers to embed and fuse delayed terms + -- + into :: Sink f => (f env' a -> b) -> f env a -> Extend acc env env' -> b + into op a env = op (sink env a) + + into2 :: (Sink f1, Sink f2) + => (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 + -> Delayed acc aenv bs + fuse op (delayAcc -> Term env cc) = Term env (op env cc) + + fuse2 :: (Arrays as, Arrays bs) + => (forall aenv'. Extend acc aenv aenv' -> Cunctation acc aenv' as -> Cunctation acc aenv' bs -> Cunctation acc aenv' cs) + -> acc aenv as + -> acc aenv bs + -> Delayed acc aenv cs + fuse2 op a1 a0 + | Term env1 cc1 <- delayAcc a1 + , Term env0 cc0 <- delayAcc (sink env1 a0) + , env <- env1 `join` env0 + = Term env (op env (sink env0 cc1) cc0) + + embed :: (Arrays as, Arrays bs) + => (forall aenv'. Extend acc aenv aenv' -> acc aenv' as -> PreOpenAcc acc aenv' bs) + -> acc aenv as + -> Delayed acc aenv bs + embed op (delayAcc -> Term env cc) = case cc of + Done v -> Term (env `PushEnv` op env (avarIn v)) (Done ZeroIdx) + Step sh p f v -> Term (env `PushEnv` op env (computeAcc (Term BaseEnv (Step sh p f v)))) (Done ZeroIdx) + Yield sh f -> Term (env `PushEnv` op env (computeAcc (Term BaseEnv (Yield sh f)))) (Done ZeroIdx) + + embed2 :: forall aenv as bs cs. (Arrays as, Arrays bs, Arrays cs) + => (forall aenv'. Extend acc aenv aenv' -> acc aenv' as -> acc aenv' bs -> PreOpenAcc acc aenv' cs) + -> acc aenv as + -> acc aenv bs + -> Delayed acc aenv cs + embed2 op (delayAcc -> Term env1 cc1) a0 = case cc1 of + Done v -> inner env1 v a0 + Step sh p f v -> inner (env1 `PushEnv` compute (Term BaseEnv (Step sh p f v))) ZeroIdx a0 + Yield sh f -> inner (env1 `PushEnv` compute (Term BaseEnv (Yield sh f))) ZeroIdx a0 + where + inner :: Extend acc aenv aenv' -> Idx aenv' as -> acc aenv bs -> Delayed acc aenv cs + inner env1 v1 (delayAcc . sink env1 -> Term env0 cc0) = case cc0 of + Done v0 -> let env = env1 `join` env0 in Term (env `PushEnv` op env (avarIn (sink env0 v1)) (avarIn v0)) (Done ZeroIdx) + Step sh p f v -> let env = env1 `join` env0 in Term (env `PushEnv` op env (avarIn (sink env0 v1)) (computeAcc (Term BaseEnv (Step sh p f v)))) (Done ZeroIdx) + Yield sh f -> let env = env1 `join` env0 in Term (env `PushEnv` op env (avarIn (sink env0 v1)) (computeAcc (Term BaseEnv (Yield sh f)))) (Done ZeroIdx) + + +-- Internal representation +-- ======================= + +-- Note: [Representing delayed array] +-- +-- During the fusion transformation we represent terms as a pair consisting of +-- a collection of supplementary environment bindings and a description of how +-- to construct the array. +-- +-- It is critical to separate these two. To create a real AST node we need both +-- the environment and array term, but analysis of how to fuse terms requires +-- only the array description. If the additional bindings are bundled as part of +-- the representation, the existentially quantified extended environment type +-- will be untouchable. This is problematic because the terms of the two arrays +-- are defined with respect to this existentially quantified type, and there is +-- no way to directly combine these two environments: +-- +-- join :: Extend env env1 -> Extend env env2 -> Extend env ??? +-- +-- And hence, no way to combine the terms of the delayed representation. +-- +-- The only way to bring terms into the same scope is to operate via the +-- manifest terms. This entails a great deal of conversion between delayed and +-- AST terms, but is certainly possible. +-- +-- However, because of the limited scope into which this existential type is +-- available, we ultimately perform this process many times. In fact, complexity +-- of the fusion algorithm for an AST of N terms becomes O(r^n), where r is the +-- number of different rules we have for combining terms. +-- +data Delayed acc aenv a where + Term :: Extend acc aenv aenv' + -> Cunctation acc aenv' a + -> Delayed acc aenv a + + +-- Cunctation (n): the action or an instance of delaying; a tardy action. +-- +-- This describes the ways in which the fusion transformation represents +-- intermediate arrays. The fusion process operates by recasting producer array +-- computations in terms of a set of scalar functions used to construct an +-- element at each index, and fusing successive producers by combining these +-- scalar functions. +-- +data Cunctation acc aenv a where + + -- The base case is just a real (manifest) array term. No fusion happens here. + -- Note that the array is referenced by an index into the extended + -- environment, making the term non-recursive. + -- + Done :: Arrays a + => Idx aenv a + -> Cunctation acc aenv a + + -- We can represent an array by its shape and a function to compute an element + -- at each index. + -- + Yield :: (Shape sh, Elt e) + => PreExp acc aenv sh + -> PreFun acc aenv (sh -> e) + -> Cunctation acc aenv (Array sh e) + + -- A more restrictive form than 'Yield' may afford greater opportunities for + -- optimisation by a backend. This more structured form applies an index and + -- value transform to an input array. Note that the transform is applied to an + -- array stored as an environment index, so that the term is non-recursive and + -- it is always possible to embed into a collective operation. + -- + Step :: (Shape sh, Shape sh', Elt a, Elt b) + => PreExp acc aenv sh' + -> PreFun acc aenv (sh' -> sh) + -> PreFun acc aenv (a -> b) + -> Idx aenv (Array sh a) + -> Cunctation acc aenv (Array sh' b) + + +-- Convert a real AST node into the internal representation +-- +done :: Arrays a => PreOpenAcc acc aenv a -> Delayed acc aenv a +done pacc + | Avar v <- pacc = Term BaseEnv (Done v) + | otherwise = Term (BaseEnv `PushEnv` pacc) (Done ZeroIdx) + + +-- Recast a cunctation into a mapping from indices to elements. +-- +yield :: Kit acc + => Cunctation acc aenv (Array sh e) + -> Cunctation acc aenv (Array sh e) +yield cc = + case cc of + Yield{} -> cc + Step sh p f v -> Yield sh (f `compose` indexArray v `compose` p) + Done v + | ArraysRarray <- accType' cc -> Yield (arrayShape v) (indexArray v) + | otherwise -> error "yield: impossible case" + + +-- Recast a cunctation into transformation step form. Not possible if the source +-- was in the Yield formulation. +-- +step :: Kit acc + => Cunctation acc aenv (Array sh e) + -> Maybe (Cunctation acc aenv (Array sh e)) +step cc = + case cc of + Yield{} -> Nothing + Step{} -> Just cc + Done v + | ArraysRarray <- accType' cc -> Just $ Step (arrayShape v) identity identity v + | otherwise -> error "step: impossible case" + + +-- Get the shape of a delayed array +-- +shape :: Kit acc => Cunctation acc aenv (Array sh e) -> PreExp acc aenv sh +shape cc + | Just (Step sh _ _ _) <- step cc = sh + | Yield sh _ <- yield cc = sh + + +-- Reified type of a delayed array representation. This way we don't require +-- additional class constraints on 'step' and 'yield'. +-- +accType' :: forall acc aenv a. Arrays a => Cunctation acc aenv a -> ArraysR (ArrRepr' a) +accType' _ = arrays' (undefined :: a) + + +-- Environment manipulation +-- ======================== + +-- NOTE: [Extend] +-- +-- As part of the fusion transformation we often need to lift out array valued +-- inputs to be let-bound at a higher point. We can't add these directly to the +-- output array term because these would interfere with further fusion steps. +-- +-- The Extend type is a heterogeneous snoc-list of array terms that witnesses +-- how the array environment is extend by binding these additional terms. +-- +data Extend acc aenv aenv' where + BaseEnv :: Extend acc aenv aenv + + PushEnv :: Arrays a + => Extend acc aenv aenv' -> PreOpenAcc acc aenv' a -> Extend acc aenv (aenv', a) + + +-- Append two environment witnesses +-- +join :: Extend acc env env' -> Extend acc env' env'' -> Extend acc env env'' +join x BaseEnv = x +join x (PushEnv as a) = x `join` as `PushEnv` a + +-- Bring into scope all of the array terms in the Extend environment list. This +-- converts a term in the inner environment (aenv') into the outer (aenv). +-- +bind :: (Kit acc, Arrays a) + => Extend acc aenv aenv' + -> PreOpenAcc acc aenv' a + -> PreOpenAcc acc aenv a +bind BaseEnv = id +bind (PushEnv env a) = bind env . Alet (inject a) . inject + + +-- prjExtend :: Kit acc => Extend acc env env' -> Idx env' t -> PreOpenAcc acc env' t +-- prjExtend (PushEnv _ v) ZeroIdx = weakenA rebuildAcc SuccIdx v +-- prjExtend (PushEnv env _) (SuccIdx idx) = weakenA rebuildAcc SuccIdx $ prjExtend env idx +-- prjExtend _ _ = INTERNAL_ERROR(error) "prjExtend" "inconsistent valuation" + + +-- Sink a term from one array environment into another, where additional +-- bindings have come into scope according to the witness and no old things have +-- vanished. +-- +class Sink f where + sink :: Extend acc env env' -> f env t -> f env' t + +instance Sink Idx where + sink BaseEnv = Stats.substitution "sink" id + sink (PushEnv e _) = SuccIdx . sink e + +instance Kit acc => Sink (PreOpenExp acc env) where + sink env = weakenEA rebuildAcc (sink env) + +instance Kit acc => Sink (PreOpenFun acc env) where + sink env = weakenFA rebuildAcc (sink env) + +instance Kit acc => Sink (PreOpenAcc acc) where + sink env = weakenA rebuildAcc (sink env) + +instance Kit acc => Sink acc where -- overlapping, undecidable, incoherent + sink env = rebuildAcc (Avar . sink env) + +instance Kit acc => Sink (Cunctation acc) where + sink env cc = case cc of + Done v -> Done (sink env v) + Step sh p f v -> Step (sink env sh) (sink env p) (sink env f) (sink env v) + Yield sh f -> Yield (sink env sh) (sink env f) + + +class Sink1 f where + sink1 :: Extend acc env env' -> f (env,s) t -> f (env',s) t + +instance Sink1 Idx where + sink1 BaseEnv = Stats.substitution "sink1" id + sink1 (PushEnv e _) = split . sink1 e + where + split :: Idx (env,s) t -> Idx ((env,u),s) t + split ZeroIdx = ZeroIdx + split (SuccIdx ix) = SuccIdx (SuccIdx ix) + +instance Kit acc => Sink1 (PreOpenExp acc env) where + sink1 env = weakenEA rebuildAcc (sink1 env) + +instance Kit acc => Sink1 (PreOpenFun acc env) where + sink1 env = weakenFA rebuildAcc (sink1 env) + +instance Kit acc => Sink1 (PreOpenAcc acc) where + sink1 env = weakenA rebuildAcc (sink1 env) + +instance Kit acc => Sink1 acc where -- overlapping, undecidable, incoherent + sink1 env = rebuildAcc (Avar . sink1 env) + + + +-- Array fusion of a de Bruijn computation AST +-- =========================================== + +-- Array computations +-- ------------------ + +-- Recast the internal representation of delayed arrays into a real AST node. +-- Use the most specific version of a combinator whenever possible. +-- +compute :: (Kit acc, Arrays arrs) => Delayed acc aenv arrs -> PreOpenAcc acc aenv arrs +compute (Term env cc) + = bind env + $ case cc of + Done v -> Avar v + Yield (simplify -> sh) (simplify -> f) -> Generate sh f + Step (simplify -> sh) (simplify -> p) (simplify -> f) v + | Just REFL <- identShape + , Just REFL <- isIdentity p + , Just REFL <- isIdentity f -> Avar v + | Just REFL <- identShape + , Just REFL <- isIdentity p -> Map f acc + | Just REFL <- isIdentity f -> Backpermute sh p acc + | otherwise -> Transform sh p f acc + where + identShape = match sh (arrayShape v) + acc = avarIn v + + +-- Evaluate a delayed computation and tie the recursive knot +-- +computeAcc :: (Kit acc, Arrays arrs) => Delayed acc aenv arrs -> acc aenv arrs +computeAcc = inject . compute + + +-- Representation of a generator as a delayed array +-- +generateD :: (Shape sh, Elt e) + => PreExp acc aenv sh + -> PreFun acc aenv (sh -> e) + -> Delayed acc aenv (Array sh e) +generateD sh f + = Stats.ruleFired "generateD" + $ Term BaseEnv (Yield sh f) + + +-- Fuse a unary function into a delayed array. +-- +mapD :: (Kit acc, Elt b) + => PreFun acc aenv (a -> b) + -> Cunctation acc aenv (Array sh a) + -> Cunctation acc aenv (Array sh b) +mapD f = Stats.ruleFired "mapD" . go + where + go (step -> Just (Step sh ix g v)) = Step sh ix (f `compose` g) v + go (yield -> Yield sh g) = Yield sh (f `compose` g) + + +-- Fuse an index space transformation function that specifies where elements in +-- the destination array read there data from in the source array. +-- +backpermuteD + :: (Kit acc, Shape sh') + => PreExp acc aenv sh' + -> PreFun acc aenv (sh' -> sh) + -> Cunctation acc aenv (Array sh e) + -> Cunctation acc aenv (Array sh' e) +backpermuteD sh' p = Stats.ruleFired "backpermuteD" . go + where + go (step -> Just (Step _ q f v)) = Step sh' (q `compose` p) f v + go (yield -> Yield _ g) = Yield sh' (g `compose` p) + + +-- Transform as a combined map and backwards permutation +-- +transformD + :: (Kit acc, Shape sh', Elt b) + => PreExp acc aenv sh' + -> PreFun acc aenv (sh' -> sh) + -> PreFun acc aenv (a -> b) + -> Cunctation acc aenv (Array sh a) + -> Cunctation acc aenv (Array sh' b) +transformD sh' p f + = Stats.ruleFired "transformD" + . backpermuteD sh' p + . mapD f + + +-- Replicate as a backwards permutation +-- +-- TODO: If we have a pattern such as `replicate sh (map f xs)` then in some +-- cases it might be beneficial to not fuse these terms, if `f` is +-- expensive and/or `sh` is large. +-- +replicateD + :: (Kit acc, Shape sh, Shape sl, Elt slix, Elt e) + => SliceIndex (EltRepr slix) (EltRepr sl) co (EltRepr sh) + -> PreExp acc aenv slix + -> Cunctation acc aenv (Array sl e) + -> Cunctation acc aenv (Array sh e) +replicateD sliceIndex slix cc + = Stats.ruleFired "replicateD" + $ backpermuteD (IndexFull sliceIndex slix (shape cc)) (extend sliceIndex slix) cc + + +-- Dimensional slice as a backwards permutation +-- +sliceD + :: (Kit acc, Shape sh, Shape sl, Elt slix, Elt e) + => SliceIndex (EltRepr slix) (EltRepr sl) co (EltRepr sh) + -> PreExp acc aenv slix + -> Cunctation acc aenv (Array sh e) + -> Cunctation acc aenv (Array sl e) +sliceD sliceIndex slix cc + = Stats.ruleFired "sliceD" + $ backpermuteD (IndexSlice sliceIndex slix (shape cc)) (restrict sliceIndex slix) cc + + +-- Reshape an array +-- +-- For delayed arrays this is implemented as an index space transformation. +-- However for manifest arrays this can be done in constant time. However, if +-- the reshaped array is later consumed, for example in foldAll, this won't be +-- fused into the consumer. At this point always convert into a delayed +-- representation, and attempt to recover the reshape operation in the final +-- quenching phase. +-- +-- TLM: there was a runtime check to ensure the old and new shapes contained the +-- same number of elements: this has been lost for the delayed cases! +-- +reshapeD + :: (Kit acc, Shape sh, Shape sl) + => PreExp acc aenv sl + -> Cunctation acc aenv (Array sh e) + -> Cunctation acc aenv (Array sl e) +reshapeD sl cc + = Stats.ruleFired "reshapeD" + $ backpermuteD sl (reindex (shape cc) sl) cc + + +-- Combine two arrays element-wise with a binary function to produce a delayed +-- array. +-- +zipWithD :: (Kit acc, Shape sh, Elt a, Elt b, Elt c) + => PreFun acc aenv (a -> b -> c) + -> Cunctation acc aenv (Array sh a) + -> Cunctation acc aenv (Array sh b) + -> Cunctation acc aenv (Array sh c) +zipWithD f cc1 cc0 + -- Two stepper functions identically accessing the same array can be kept in + -- stepping form. This might yield a simpler final term. + -- + | Just (Step sh1 p1 f1 v1) <- step cc1 + , Just (Step sh0 p0 f0 v0) <- step cc0 + , Just REFL <- match v1 v0 + , Just REFL <- match p1 p0 + = Stats.ruleFired "zipWithD/step" + $ Step (sh1 `Intersect` sh0) p0 (combine f f1 f0) v0 + + -- Otherwise transform both delayed terms into (index -> value) mappings and + -- combine the two indexing functions that way. + -- + | Yield sh1 f1 <- yield cc1 + , Yield sh0 f0 <- yield cc0 + = Stats.ruleFired "zipWithD" + $ Yield (sh1 `Intersect` sh0) (combine f f1 f0) + + where + combine :: forall acc aenv a b c e. (Elt a, Elt b, Elt c) + => PreFun acc aenv (a -> b -> c) + -> PreFun acc aenv (e -> a) + -> PreFun acc aenv (e -> b) + -> PreFun acc aenv (e -> c) + combine c ixa ixb + | Lam (Lam (Body c')) <- weakenFE SuccIdx c :: PreOpenFun acc ((),e) aenv (a -> b -> c) + , Lam (Body ixa') <- ixa -- else the skolem 'e' will escape + , Lam (Body ixb') <- ixb + = Lam $ Body $ Let ixa' $ Let (weakenE SuccIdx ixb') c' + + +-- NOTE: [Sharing vs. Fusion] +-- +-- The approach to array fusion is similar to that the first generation of Repa. +-- It was discovered that the most immediately pressing problem with delayed +-- arrays in Repa-1 was that it did not preserve sharing of collective +-- operations, leading to excessive recomputation and severe repercussions on +-- performance if the user did not explicitly intervene. +-- +-- However, as we have explicit sharing information in the term tree, so it is +-- straightforward to respect sharing by not fusing let-bindings, as that +-- introduces work duplication. However, sometimes we can be cleverer. +-- +-- let-floating: +-- ------------- +-- +-- If the binding is of manifest data, we can instead move the let-binding to a +-- different point in the program and then continue to fuse into the body. This +-- is done by adding the bound term to the Extend environment. In essence this +-- is covering a different occurrence of the same problem Extend was introduced +-- to handle: let bindings of manifest data unnecessarily get in the way of the +-- fusion process. For example: +-- +-- map f (zipWith g xs (map h xs)) +-- +-- after sharing recovery results in: +-- +-- map f (let a0 = xs in zipWith g a0 (map h a0)) +-- +-- Without allowing the binding for a0 to float outwards, `map f` will not be +-- fused into the rest of the program. +-- +-- let-elimination: +-- ---------------- +-- +-- Array binding points appear in the program because the array data _or_ shape +-- was accessed multiple times in the source program. In general we want to fuse +-- arbitrary sequences of array _data_, irrespective of how the shape component +-- is used. For example, reverse is defined in the prelude as: +-- +-- reverse xs = let len = unindex1 (shape xs) +-- pf i = len - i - 1 +-- in +-- backpermute (shape xs) (ilift1 pf) xs +-- +-- Sharing recovery introduces a let-binding for the input `xs` since it is used +-- thrice in the definition, which impedes subsequent fusion. However the actual +-- array data is only accessed once, with the remaining two uses querying the +-- array shape. Since the delayed terms contain the shape of the array they +-- represent as a scalar term, if the data component otherwise satisfies the +-- rules for fusing terms, as it does in this example, we can eliminate the +-- let-binding by pushing the scalar shape and value generation terms directly +-- into the body. +-- +-- Let-elimination can also be used to _introduce_ work duplication, which may +-- be beneficial if we can estimate that the cost of recomputation is less than +-- the cost of completely evaluating the array and subsequently retrieving the +-- data from memory. +-- +aletD :: forall acc aenv arrs brrs. (Kit acc, Arrays arrs, Arrays brrs) + => DelayAcc acc + -> ElimAcc acc + -> acc aenv arrs + -> acc (aenv,arrs) brrs + -> Delayed acc aenv brrs +aletD delayAcc elimAcc (delayAcc -> Term env1 cc1) acc0 + + -- let-floating + -- ------------ + -- + -- Immediately inline the variable referring to the bound expression into the + -- body, instead of adding to the environments and creating an indirection + -- that must be later eliminated by shrinking. + -- + | Done v1 <- cc1 + , Term env0 cc0 <- delayAcc $ rebuildAcc (subTop (Avar v1) . sink1 env1) acc0 + = Stats.ruleFired "aletD/float" + $ Term (env1 `join` env0) cc0 + + -- Handle the remaining cases in a separate function. It turns out that this + -- is important so we aren't excessively sinking/delaying terms. + -- + | otherwise + , Term env0 cc0 <- delayAcc $ sink1 env1 acc0 + = case cc1 of + Step{} -> aletD' env1 cc1 env0 cc0 + Yield{} -> aletD' env1 cc1 env0 cc0 + + where + subTop :: forall aenv s t. Arrays t => PreOpenAcc acc aenv s -> Idx (aenv,s) t -> PreOpenAcc acc aenv t + subTop t ZeroIdx = t + subTop _ (SuccIdx idx) = Avar idx + + -- The second part of let-elimination. Splitting into two steps exposes the + -- extra type variables, and ensures we don't do extra work for the + -- let-floating case (which can lead to a complexity blowup.) + -- + aletD' :: forall aenv aenv' aenv'' sh e brrs. (Kit acc, Shape sh, Elt e, Arrays brrs) + => Extend acc aenv aenv' + -> Cunctation acc aenv' (Array sh e) + -> Extend acc (aenv', Array sh e) aenv'' + -> Cunctation acc aenv'' brrs + -> Delayed acc aenv brrs + aletD' env1 cc1 env0 cc0 + | not shouldInline = Term (env1 `PushEnv` bnd `join` env0) cc0 + + | Stats.ruleFired "aletD/eliminate" False + = undefined + + | Done v1 <- cc1 = eliminate (arrayShape v1) (indexArray v1) + | Step sh1 p1 f1 v1 <- cc1 = eliminate sh1 (f1 `compose` indexArray v1 `compose` p1) + | Yield sh1 f1 <- cc1 = eliminate sh1 f1 + where + -- The main terms, remade manifest. We need to do this so that eliminating + -- terms considers not just the main term but any of the environment terms + -- (in Extend). This problem occurred in the Canny example program. + -- + shouldInline = elimAcc ZeroIdx body + body = computeAcc (Term env0 cc0) + bnd = compute (Term BaseEnv cc1) + + eliminate :: PreExp acc aenv' sh + -> PreFun acc aenv' (sh -> e) + -> Delayed acc aenv brrs + eliminate sh1 f1 + | sh1' <- weakenEA rebuildAcc SuccIdx sh1 + , f1' <- weakenFA rebuildAcc SuccIdx f1 + , Term env0' cc0' <- delayAcc $ rebuildAcc (subTop bnd) $ kmap (replaceA sh1' f1' ZeroIdx) body + = Term (env1 `join` env0') cc0' + + -- As part of let-elimination, we need to replace uses of array variables in + -- scalar expressions with an equivalent expression that generates the + -- result directly + -- + -- TODO: when we inline bindings we ought to let bind at the first + -- occurrence and use a variable at all subsequent locations. At the + -- moment we are just hoping CSE in the simplifier phase does good + -- things, but that is limited in what it looks for. + -- + replaceE :: forall env aenv sh e t. (Kit acc, Shape sh, Elt e) + => PreOpenExp acc env aenv sh -> PreOpenFun acc env aenv (sh -> e) -> Idx aenv (Array sh e) + -> PreOpenExp acc env aenv t + -> PreOpenExp acc env aenv t + replaceE sh' f' avar exp = + case exp of + Let x y -> Let (cvtE x) (replaceE (weakenE SuccIdx sh') (weakenFE SuccIdx f') avar y) + Var i -> Var i + Foreign ff f e -> Foreign ff f (cvtE e) + Const c -> Const c + Tuple t -> Tuple (cvtT t) + Prj ix e -> Prj ix (cvtE e) + IndexNil -> IndexNil + IndexCons sl sz -> IndexCons (cvtE sl) (cvtE sz) + IndexHead sh -> IndexHead (cvtE sh) + IndexTail sz -> IndexTail (cvtE sz) + IndexAny -> IndexAny + IndexSlice x ix sh -> IndexSlice x (cvtE ix) (cvtE sh) + IndexFull x ix sl -> IndexFull x (cvtE ix) (cvtE sl) + ToIndex sh ix -> ToIndex (cvtE sh) (cvtE ix) + FromIndex sh i -> FromIndex (cvtE sh) (cvtE i) + Cond p t e -> Cond (cvtE p) (cvtE t) (cvtE e) + Iterate n f x -> Iterate (cvtE n) (replaceE (weakenE SuccIdx sh') (weakenFE SuccIdx f') avar f) (cvtE x) + PrimConst c -> PrimConst c + PrimApp g x -> PrimApp g (cvtE x) + ShapeSize sh -> ShapeSize (cvtE sh) + Intersect sh sl -> Intersect (cvtE sh) (cvtE sl) + Shape a + | Just REFL <- match a a' -> Stats.substitution "replaceE/shape" sh' + | otherwise -> exp + + Index a sh + | Just REFL <- match a a' + , Lam (Body b) <- f' -> Stats.substitution "replaceE/!" $ Let sh b + | otherwise -> Index a (cvtE sh) + + LinearIndex a i + | Just REFL <- match a a' + , Lam (Body b) <- f' -> Stats.substitution "replaceE/!!" $ Let (Let i (FromIndex (weakenE SuccIdx sh') (Var ZeroIdx))) b + | otherwise -> LinearIndex a (cvtE i) + + where + a' = avarIn avar + + cvtE :: PreOpenExp acc env aenv s -> PreOpenExp acc env aenv s + cvtE = replaceE sh' f' avar + + cvtT :: Tuple (PreOpenExp acc env aenv) s -> Tuple (PreOpenExp acc env aenv) s + cvtT NilTup = NilTup + cvtT (SnocTup t e) = cvtT t `SnocTup` cvtE e + + replaceF :: forall env aenv sh e t. (Kit acc, Shape sh, Elt e) + => PreOpenExp acc env aenv sh -> PreOpenFun acc env aenv (sh -> e) -> Idx aenv (Array sh e) + -> PreOpenFun acc env aenv t + -> PreOpenFun acc env aenv t + replaceF sh' f' avar fun = + case fun of + Body e -> Body (replaceE sh' f' avar e) + Lam f -> Lam (replaceF (weakenE SuccIdx sh') (weakenFE SuccIdx f') avar f) + + replaceA :: forall aenv sh e a. (Kit acc, Shape sh, Elt e) + => PreExp acc aenv sh -> PreFun acc aenv (sh -> e) -> Idx aenv (Array sh e) + -> PreOpenAcc acc aenv a + -> PreOpenAcc acc aenv a + replaceA sh' f' avar pacc = + case pacc of + Avar v + | Just REFL <- match v avar -> Avar avar + | otherwise -> Avar v + + Alet bnd body -> + let sh'' = weakenEA rebuildAcc SuccIdx sh' + f'' = weakenFA rebuildAcc SuccIdx f' + in + Alet (cvtA bnd) (kmap (replaceA sh'' f'' (SuccIdx avar)) body) + + Use arrs -> Use arrs + Unit e -> Unit (cvtE e) + Acond p at ae -> Acond (cvtE p) (cvtA at) (cvtA ae) + Aprj ix tup -> Aprj ix (cvtA tup) + Atuple tup -> Atuple (cvtAT tup) + Apply f a -> Apply f (cvtA a) -- no sharing between f and a + Aforeign ff f a -> Aforeign ff f (cvtA a) -- no sharing between f and a + Generate sh f -> Generate (cvtE sh) (cvtF f) + Map f a -> Map (cvtF f) (cvtA a) + ZipWith f a b -> ZipWith (cvtF f) (cvtA a) (cvtA b) + Backpermute sh p a -> Backpermute (cvtE sh) (cvtF p) (cvtA a) + Transform sh p f a -> Transform (cvtE sh) (cvtF p) (cvtF f) (cvtA a) + Slice slix a sl -> Slice slix (cvtA a) (cvtE sl) + Replicate slix sh a -> Replicate slix (cvtE sh) (cvtA a) + Reshape sl a -> Reshape (cvtE sl) (cvtA a) + Fold f z a -> Fold (cvtF f) (cvtE z) (cvtA a) + Fold1 f a -> Fold1 (cvtF f) (cvtA a) + FoldSeg f z a s -> FoldSeg (cvtF f) (cvtE z) (cvtA a) (cvtA s) + Fold1Seg f a s -> Fold1Seg (cvtF f) (cvtA a) (cvtA s) + Scanl f z a -> Scanl (cvtF f) (cvtE z) (cvtA a) + Scanl1 f a -> Scanl1 (cvtF f) (cvtA a) + Scanl' f z a -> Scanl' (cvtF f) (cvtE z) (cvtA a) + Scanr f z a -> Scanr (cvtF f) (cvtE z) (cvtA a) + 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) + + where + cvtA :: acc aenv s -> acc aenv s + cvtA = kmap (replaceA sh' f' avar) + + cvtE :: PreExp acc aenv s -> PreExp acc aenv s + cvtE = replaceE sh' f' avar + + cvtF :: PreFun acc aenv s -> PreFun acc aenv s + cvtF = replaceF sh' f' avar + + cvtAT :: Atuple (acc aenv) s -> Atuple (acc aenv) s + cvtAT NilAtup = NilAtup + cvtAT (SnocAtup tup a) = cvtAT tup `SnocAtup` cvtA a + + +-- Array conditionals, in particular eliminate branches when the predicate +-- reduces to a known constant. +-- +-- Note that we take the raw unprocessed terms as input. If instead we had the +-- terms for each branch in the delayed representation, this would require that +-- each term has been sunk into a common environment, which implies the +-- conditional has been pushed underneath the intersection of bound terms for +-- both branches. This would result in redundant work processing the bindings +-- for the branch not taken. +-- +acondD :: (Kit acc, Arrays arrs) + => DelayAcc acc + -> PreExp acc aenv Bool + -> acc aenv arrs + -> acc aenv arrs + -> Delayed acc aenv arrs +acondD delayAcc p t e + | Const ((),True) <- p = Stats.knownBranch "True" $ delayAcc t + | Const ((),False) <- p = Stats.knownBranch "False" $ delayAcc e + | Just REFL <- match t e = Stats.knownBranch "redundant" $ delayAcc e + | otherwise = done $ Acond p (computeAcc (delayAcc t)) + (computeAcc (delayAcc e)) + + +-- Array tuple projection. Whenever possible we want to peek underneath the +-- tuple structure and continue the fusion process. +-- +aprjD :: forall acc aenv arrs a. (Kit acc, IsTuple arrs, Arrays arrs, Arrays a) + => DelayAcc acc + -> TupleIdx (TupleRepr arrs) a + -> acc aenv arrs + -> Delayed acc aenv a +aprjD delayAcc ix a + | Atuple tup <- extract a = Stats.ruleFired "aprj/Atuple" . delayAcc $ aprjAT ix tup + | otherwise = done $ Aprj ix (cvtA a) + where + cvtA :: acc aenv arrs -> acc aenv arrs + cvtA = computeAcc . delayAcc + + aprjAT :: TupleIdx atup a -> Atuple (acc aenv) atup -> acc aenv a + aprjAT ZeroTupIdx (SnocAtup _ a) = a + aprjAT (SuccTupIdx ix) (SnocAtup t _) = aprjAT ix t + + +-- Scalar expressions +-- ------------------ + +isIdentity :: PreFun acc aenv (a -> b) -> Maybe (a :=: b) +isIdentity f + | Lam (Body (Var ZeroIdx)) <- f = Just REFL + | otherwise = Nothing + +identity :: Elt a => PreOpenFun acc env aenv (a -> a) +identity = Lam (Body (Var ZeroIdx)) + +toIndex :: Shape sh => PreOpenExp acc env aenv sh -> PreOpenFun acc env aenv (sh -> Int) +toIndex sh = Lam (Body (ToIndex (weakenE SuccIdx sh) (Var ZeroIdx))) + +fromIndex :: Shape sh => PreOpenExp acc env aenv sh -> PreOpenFun acc env aenv (Int -> sh) +fromIndex sh = Lam (Body (FromIndex (weakenE SuccIdx sh) (Var ZeroIdx))) + +reindex :: (Kit acc, Shape sh, Shape sh') + => PreOpenExp acc env aenv sh' + -> PreOpenExp acc env aenv sh + -> PreOpenFun acc env aenv (sh -> sh') +reindex sh' sh + | Just REFL <- match sh sh' = identity + | otherwise = fromIndex sh' `compose` toIndex sh + +extend :: (Shape sh, Shape sl, Elt slix) + => SliceIndex (EltRepr slix) (EltRepr sl) co (EltRepr sh) + -> PreExp acc aenv slix + -> PreFun acc aenv (sh -> sl) +extend sliceIndex slix = Lam (Body (IndexSlice sliceIndex (weakenE SuccIdx slix) (Var ZeroIdx))) + +restrict :: (Shape sh, Shape sl, Elt slix) + => SliceIndex (EltRepr slix) (EltRepr sl) co (EltRepr sh) + -> PreExp acc aenv slix + -> PreFun acc aenv (sl -> sh) +restrict sliceIndex slix = Lam (Body (IndexFull sliceIndex (weakenE SuccIdx slix) (Var ZeroIdx))) + +arrayShape :: (Kit acc, Shape sh, Elt e) => Idx aenv (Array sh e) -> PreExp acc aenv sh +arrayShape = Shape . avarIn + +indexArray :: (Kit acc, Shape sh, Elt e) => Idx aenv (Array sh e) -> PreFun acc aenv (sh -> e) +indexArray v = Lam (Body (Index (avarIn v) (Var ZeroIdx))) + +linearIndex :: (Kit acc, Shape sh, Elt e) => Idx aenv (Array sh e) -> PreFun acc aenv (Int -> e) +linearIndex v = Lam (Body (LinearIndex (avarIn v) (Var ZeroIdx))) + diff --git a/Data/Array/Accelerate/Trafo/Rewrite.hs b/Data/Array/Accelerate/Trafo/Rewrite.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/Trafo/Rewrite.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | +-- Module : Data.Array.Accelerate.Trafo.Rewrite +-- Copyright : [2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Manuel M T Chakravarty +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.Trafo.Rewrite + where + +-- friends +import Data.Array.Accelerate.AST +import Data.Array.Accelerate.Type +import Data.Array.Accelerate.Tuple +import Data.Array.Accelerate.Trafo.Substitution +import Data.Array.Accelerate.Array.Sugar ( Arrays, Segments, Elt, fromElt ) + + +-- Convert segment length arrays passed to segmented operations into offset +-- index style. This is achieved by wrapping the segmented array argument in a +-- left prefix-sum, so you must only ever apply this once. +-- +convertSegments :: OpenAcc aenv a -> OpenAcc aenv a +convertSegments = cvtA + where + cvtT :: Atuple (OpenAcc aenv) t -> Atuple (OpenAcc aenv) t + cvtT atup = case atup of + NilAtup -> NilAtup + SnocAtup t a -> cvtT t `SnocAtup` cvtA a + + cvtAfun :: OpenAfun aenv t -> OpenAfun aenv t + cvtAfun = convertSegmentsAfun + + cvtE :: Elt t => Exp aenv t -> Exp aenv t + cvtE = id + + cvtF :: Fun aenv t -> Fun aenv t + cvtF = id + + a0 :: Arrays a => OpenAcc (aenv, a) a + a0 = OpenAcc (Avar ZeroIdx) + + segments :: (Elt i, IsIntegral i) => OpenAcc aenv (Segments i) -> OpenAcc aenv (Segments i) + segments s = OpenAcc $ Scanl plus zero (cvtA s) + + zero :: forall aenv i. (Elt i, IsIntegral i) => PreOpenExp OpenAcc () aenv i + zero = Const (fromElt (0::i)) + + plus :: (Elt i, IsIntegral i) => PreOpenFun OpenAcc () aenv (i -> i -> i) + plus = Lam (Lam (Body (PrimAdd numType + `PrimApp` + Tuple (NilTup `SnocTup` Var (SuccIdx ZeroIdx) + `SnocTup` Var ZeroIdx)))) + + cvtA :: OpenAcc aenv a -> OpenAcc aenv a + cvtA (OpenAcc pacc) = OpenAcc $ case pacc of + Alet bnd body -> Alet (cvtA bnd) (cvtA body) + Avar ix -> Avar ix + Atuple tup -> Atuple (cvtT tup) + Aprj tup a -> Aprj tup (cvtA a) + Apply f a -> Apply (cvtAfun f) (cvtA a) + Aforeign ff afun acc -> Aforeign ff (cvtAfun afun) (cvtA acc) + Acond p t e -> Acond (cvtE p) (cvtA t) (cvtA e) + Use a -> Use a + Unit e -> Unit (cvtE e) + Reshape e a -> Reshape (cvtE e) (cvtA a) + Generate e f -> Generate (cvtE e) (cvtF f) + Transform sh ix f a -> Transform (cvtE sh) (cvtF ix) (cvtF f) (cvtA a) + Replicate sl slix a -> Replicate sl (cvtE slix) (cvtA a) + Slice sl a slix -> Slice sl (cvtA a) (cvtE slix) + Map f a -> Map (cvtF f) (cvtA a) + ZipWith f a1 a2 -> ZipWith (cvtF f) (cvtA a1) (cvtA a2) + Fold f z a -> Fold (cvtF f) (cvtE z) (cvtA a) + Fold1 f a -> Fold1 (cvtF f) (cvtA a) + Scanl f z a -> Scanl (cvtF f) (cvtE z) (cvtA a) + Scanl' f z a -> Scanl' (cvtF f) (cvtE z) (cvtA a) + Scanl1 f a -> Scanl1 (cvtF f) (cvtA a) + Scanr f z a -> Scanr (cvtF f) (cvtE z) (cvtA a) + Scanr' f z a -> Scanr' (cvtF f) (cvtE z) (cvtA a) + Scanr1 f a -> Scanr1 (cvtF f) (cvtA a) + Permute f1 a1 f2 a2 -> Permute (cvtF f1) (cvtA a1) (cvtF f2) (cvtA a2) + Backpermute sh f a -> Backpermute (cvtE sh) (cvtF f) (cvtA a) + Stencil f b a -> Stencil (cvtF f) b (cvtA a) + Stencil2 f b1 a1 b2 a2 -> Stencil2 (cvtF f) b1 (cvtA a1) b2 (cvtA a2) + + -- Things we are interested in, whoo! + FoldSeg f z a s -> Alet (segments s) (OpenAcc (FoldSeg (cvtF f') (cvtE z') (cvtA a') a0)) + where f' = weakenFA rebuildOpenAcc SuccIdx f + z' = weakenEA rebuildOpenAcc SuccIdx z + a' = rebuildOpenAcc (Avar . SuccIdx) a + + Fold1Seg f a s -> Alet (segments s) (OpenAcc (Fold1Seg (cvtF f') (cvtA a') a0)) + where f' = weakenFA rebuildOpenAcc SuccIdx f + a' = rebuildOpenAcc (Avar . SuccIdx) a + + +convertSegmentsAfun :: OpenAfun aenv t -> OpenAfun aenv t +convertSegmentsAfun afun = + case afun of + Abody b -> Abody (convertSegments b) + Alam f -> Alam (convertSegmentsAfun f) + diff --git a/Data/Array/Accelerate/Trafo/Sharing.hs b/Data/Array/Accelerate/Trafo/Sharing.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/Trafo/Sharing.hs @@ -0,0 +1,2034 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# OPTIONS_HADDOCK hide #-} +-- | +-- Module : Data.Array.Accelerate.Trafo.Sharing +-- Copyright : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee +-- [2009..2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Manuel M T Chakravarty +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- +-- This module implements HOAS to de Bruijn conversion of array expressions +-- while incorporating sharing information. +-- + +module Data.Array.Accelerate.Trafo.Sharing ( + + -- * HOAS -> de Bruijn conversion + convertAcc, convertAccFun1, + convertExp, convertFun1, convertFun2, + +) where + +-- standard library +import Control.Applicative hiding ( Const ) +import Control.Monad.Fix +import Data.List +import Data.Maybe +import Data.Hashable +import Data.Typeable +import qualified Data.HashTable.IO as Hash +import qualified Data.IntMap as IntMap +import System.IO.Unsafe ( unsafePerformIO ) +import System.Mem.StableName + +-- friends +import Data.Array.Accelerate.Smart +import Data.Array.Accelerate.Array.Sugar as Sugar +import Data.Array.Accelerate.Tuple hiding ( Tuple ) +import Data.Array.Accelerate.AST hiding ( + PreOpenAcc(..), OpenAcc(..), Acc, Stencil(..), PreOpenExp(..), OpenExp, PreExp, Exp, + showPreAccOp, showPreExpOp ) +import qualified Data.Array.Accelerate.AST as AST +import qualified Data.Array.Accelerate.Tuple as Tuple +import qualified Data.Array.Accelerate.Debug as Debug + +#include "accelerate.h" + + +-- Configuration +-- ------------- + +-- Perhaps the configuration should be passed as a reader monad or some such, +-- but that's a little inconvenient. +-- +data Config = Config + { + recoverAccSharing :: Bool -- ^ Recover sharing of array computations ? + , recoverExpSharing :: Bool -- ^ Recover sharing of scalar expressions ? + , floatOutAcc :: Bool -- ^ Always float array computations out of expressions ? + } + + +-- Layouts +-- ------- + +-- A layout of an environment has an entry for each entry of the environment. +-- Each entry in the layout holds the de Bruijn index that refers to the +-- corresponding entry in the environment. +-- +data Layout env env' where + EmptyLayout :: Layout env () + PushLayout :: Typeable t + => Layout env env' -> Idx env t -> Layout env (env', t) + +-- Project the nth index out of an environment layout. +-- +-- The first argument provides context information for error messages in the case of failure. +-- +prjIdx :: forall t env env'. Typeable t => String -> Int -> Layout env env' -> Idx env t +prjIdx ctxt 0 (PushLayout _ (ix :: Idx env0 t0)) + = flip fromMaybe (gcast ix) + $ possiblyNestedErr ctxt $ + "Couldn't match expected type `" ++ show (typeOf (undefined::t)) ++ + "' with actual type `" ++ show (typeOf (undefined::t0)) ++ "'" ++ + "\n Type mismatch" +prjIdx ctxt n (PushLayout l _) = prjIdx ctxt (n - 1) l +prjIdx ctxt _ EmptyLayout = possiblyNestedErr ctxt "Environment doesn't contain index" + +possiblyNestedErr :: String -> String -> a +possiblyNestedErr ctxt failreason + = error $ "Fatal error in Sharing.prjIdx:" + ++ "\n " ++ failreason ++ " at " ++ ctxt + ++ "\n Possible reason: nested data parallelism — array computation that depends on a" + ++ "\n scalar variable of type 'Exp a'" + +-- Add an entry to a layout, incrementing all indices +-- +incLayout :: Layout env env' -> Layout (env, t) env' +incLayout EmptyLayout = EmptyLayout +incLayout (PushLayout lyt ix) = PushLayout (incLayout lyt) (SuccIdx ix) + + + +-- Conversion from HOAS to de Bruijn computation AST +-- ================================================= + +-- Array computations +-- ------------------ + +-- | Convert a closed array expression to de Bruijn form while also incorporating sharing +-- information. +-- +convertAcc + :: Arrays arrs + => Bool -- ^ recover sharing of array computations ? + -> Bool -- ^ recover sharing of scalar expressions ? + -> Bool -- ^ always float array computations out of expressions? + -> Acc arrs + -> AST.Acc arrs +convertAcc shareAcc shareExp floatAcc acc + = let config = Config shareAcc shareExp (shareAcc && floatAcc) + in + convertOpenAcc config 0 [] EmptyLayout acc + +-- | Convert a unary function over array computations +-- +convertAccFun1 + :: forall a b. (Arrays a, Arrays b) + => Bool -- ^ recover sharing of array computations ? + -> Bool -- ^ recover sharing of scalar expressions ? + -> Bool -- ^ always float array computations out of expressions? + -> (Acc a -> Acc b) + -> AST.Afun (a -> b) +convertAccFun1 shareAcc shareExp floatAcc f + = let config = Config shareAcc shareExp (shareAcc && floatAcc) + + lvl = 0 + a = Atag lvl + alyt = EmptyLayout + `PushLayout` + (ZeroIdx :: Idx ((), a) a) + openF = convertOpenAcc config (lvl + 1) [lvl] alyt (f (Acc a)) + in + Alam (Abody openF) + +-- | Convert an open array expression to de Bruijn form while also incorporating sharing +-- information. +-- +convertOpenAcc + :: Arrays arrs + => Config + -> Level + -> [Level] + -> Layout aenv aenv + -> Acc arrs + -> AST.OpenAcc aenv arrs +convertOpenAcc config lvl fvs alyt acc + = let (sharingAcc, initialEnv) = recoverSharingAcc config lvl fvs acc + in + convertSharingAcc config alyt initialEnv sharingAcc + +-- | Convert an array expression with given array environment layout and sharing information into +-- de Bruijn form while recovering sharing at the same time (by introducing appropriate let +-- bindings). The latter implements the third phase of sharing recovery. +-- +-- The sharing environment 'env' keeps track of all currently bound sharing variables, keeping them +-- in reverse chronological order (outermost variable is at the end of the list). +-- +convertSharingAcc + :: forall aenv arrs. Arrays arrs + => Config + -> Layout aenv aenv + -> [StableSharingAcc] + -> SharingAcc arrs + -> AST.OpenAcc aenv arrs +convertSharingAcc _ alyt aenv (AvarSharing sa) + | Just i <- findIndex (matchStableAcc sa) aenv + = AST.OpenAcc $ AST.Avar (prjIdx (ctxt ++ "; i = " ++ show i) i alyt) + | null aenv + = error $ "Cyclic definition of a value of type 'Acc' (sa = " ++ + show (hashStableNameHeight sa) ++ ")" + | otherwise + = INTERNAL_ERROR(error) "convertSharingAcc" err + where + ctxt = "shared 'Acc' tree with stable name " ++ show (hashStableNameHeight sa) + err = "inconsistent valuation @ " ++ ctxt ++ ";\n aenv = " ++ show aenv + +convertSharingAcc config alyt aenv (AletSharing sa@(StableSharingAcc _ boundAcc) bodyAcc) + = AST.OpenAcc + $ let alyt' = incLayout alyt `PushLayout` ZeroIdx + in + AST.Alet (convertSharingAcc config alyt aenv boundAcc) + (convertSharingAcc config alyt' (sa:aenv) bodyAcc) + +convertSharingAcc config alyt aenv (AccSharing _ preAcc) + = AST.OpenAcc + $ let cvtA :: Arrays a => SharingAcc a -> AST.OpenAcc aenv a + cvtA = convertSharingAcc config alyt aenv + + cvtE :: Elt t => RootExp t -> AST.Exp aenv t + cvtE = convertRootExp config alyt aenv + + cvtF1 :: (Elt a, Elt b) => (Exp a -> RootExp b) -> AST.Fun aenv (a -> b) + cvtF1 = convertSharingFun1 config alyt aenv + + cvtF2 :: (Elt a, Elt b, Elt c) => (Exp a -> Exp b -> RootExp c) -> AST.Fun aenv (a -> b -> c) + cvtF2 = convertSharingFun2 config alyt aenv + in + case preAcc of + + Atag i + -> AST.Avar (prjIdx ("de Bruijn conversion tag " ++ show i) i alyt) + + Pipe afun1 afun2 acc + -> let a = recoverAccSharing config + e = recoverExpSharing config + f = floatOutAcc config + boundAcc = convertAccFun1 a e f afun1 `AST.Apply` convertSharingAcc config alyt aenv acc + bodyAcc = convertAccFun1 a e f afun2 `AST.Apply` AST.OpenAcc (AST.Avar AST.ZeroIdx) + in + AST.Alet (AST.OpenAcc boundAcc) (AST.OpenAcc bodyAcc) + + Aforeign ff afun acc + -> let a = recoverAccSharing config + e = recoverExpSharing config + f = floatOutAcc config + in + AST.Aforeign ff (convertAccFun1 a e f afun) (cvtA acc) + + Acond b acc1 acc2 -> AST.Acond (cvtE b) (cvtA acc1) (cvtA acc2) + Atuple arrs -> AST.Atuple (convertSharingAtuple config alyt aenv arrs) + Aprj ix a -> AST.Aprj ix (cvtA a) + Use array -> AST.Use (fromArr array) + Unit e -> AST.Unit (cvtE e) + Generate sh f -> AST.Generate (cvtE sh) (cvtF1 f) + Reshape e acc -> AST.Reshape (cvtE e) (cvtA acc) + Replicate ix acc -> mkReplicate (cvtE ix) (cvtA acc) + Slice acc ix -> mkIndex (cvtA acc) (cvtE ix) + Map f acc -> AST.Map (cvtF1 f) (cvtA acc) + ZipWith f acc1 acc2 -> AST.ZipWith (cvtF2 f) (cvtA acc1) (cvtA acc2) + Fold f e acc -> AST.Fold (cvtF2 f) (cvtE e) (cvtA acc) + Fold1 f acc -> AST.Fold1 (cvtF2 f) (cvtA acc) + FoldSeg f e acc1 acc2 -> AST.FoldSeg (cvtF2 f) (cvtE e) (cvtA acc1) (cvtA acc2) + Fold1Seg f acc1 acc2 -> AST.Fold1Seg (cvtF2 f) (cvtA acc1) (cvtA acc2) + Scanl f e acc -> AST.Scanl (cvtF2 f) (cvtE e) (cvtA acc) + Scanl' f e acc -> AST.Scanl' (cvtF2 f) (cvtE e) (cvtA acc) + Scanl1 f acc -> AST.Scanl1 (cvtF2 f) (cvtA acc) + Scanr f e acc -> AST.Scanr (cvtF2 f) (cvtE e) (cvtA acc) + Scanr' f e acc -> AST.Scanr' (cvtF2 f) (cvtE e) (cvtA acc) + Scanr1 f acc -> AST.Scanr1 (cvtF2 f) (cvtA acc) + Permute f dftAcc perm acc -> AST.Permute (cvtF2 f) (cvtA dftAcc) (cvtF1 perm) (cvtA acc) + 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) + (cvtA acc) + Stencil2 stencil bndy1 acc1 bndy2 acc2 + -> AST.Stencil2 (convertSharingStencilFun2 config acc1 acc2 alyt aenv stencil) + (convertBoundary bndy1) + (cvtA acc1) + (convertBoundary bndy2) + (cvtA acc2) + +convertSharingAtuple + :: forall aenv a. + Config + -> Layout aenv aenv + -> [StableSharingAcc] + -> Tuple.Atuple SharingAcc a + -> Tuple.Atuple (AST.OpenAcc aenv) a +convertSharingAtuple config alyt aenv = cvt + where + cvt :: Tuple.Atuple SharingAcc a' -> Tuple.Atuple (AST.OpenAcc aenv) a' + cvt NilAtup = NilAtup + cvt (SnocAtup t a) = cvt t `SnocAtup` convertSharingAcc config alyt aenv a + + +-- | 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) + + +-- Smart constructors to represent AST forms +-- +mkIndex :: forall slix e aenv. (Slice slix, Elt e) + => AST.OpenAcc aenv (Array (FullShape slix) e) + -> AST.Exp aenv slix + -> AST.PreOpenAcc AST.OpenAcc aenv (Array (SliceShape slix) e) +mkIndex = AST.Slice (sliceIndex slix) + where + slix = undefined :: slix + +mkReplicate :: forall slix e aenv. (Slice slix, Elt e) + => AST.Exp aenv slix + -> AST.OpenAcc aenv (Array (SliceShape slix) e) + -> AST.PreOpenAcc AST.OpenAcc aenv (Array (FullShape slix) e) +mkReplicate = AST.Replicate (sliceIndex slix) + where + slix = undefined :: slix + + + +-- Scalar expressions +-- ------------------ + +-- | Convert a closed scalar expression to de Bruijn form while incorporating +-- sharing information. +-- +convertExp + :: Elt e + => Bool -- ^ recover sharing of scalar expressions ? + -> Exp e -- ^ expression to be converted + -> AST.Exp () e +convertExp shareExp exp + = let config = Config False shareExp False + in + convertOpenExp config 0 [] EmptyLayout exp + +-- | Convert a closed scalar function of one parameter to de Bruijn form while +-- incorporating sharing information +-- +convertFun1 + :: (Elt a, Elt b) + => Bool + -> (Exp a -> Exp b) + -> AST.Fun () (a -> b) +convertFun1 shareExp f + = let config = Config False shareExp False + + lvl = 0 + x = Exp (Tag lvl) + lyt = EmptyLayout `PushLayout` ZeroIdx + body = convertOpenExp config (lvl+1) [lvl] lyt (f x) + in + Lam (Body body) + +-- | Convert a closed scalar function of two parameters to de Bruijn form while +-- incorporating sharing information +-- +convertFun2 + :: (Elt a, Elt b, Elt c) + => Bool + -> (Exp a -> Exp b -> Exp c) + -> AST.Fun () (a -> b -> c) +convertFun2 shareExp f + = let config = Config False shareExp False + + lvl = 0 + x = Exp (Tag (lvl+1)) + y = Exp (Tag lvl) + lyt = EmptyLayout `PushLayout` SuccIdx ZeroIdx + `PushLayout` ZeroIdx + body = convertOpenExp config (lvl+2) [lvl, lvl+1] lyt (f x y) + in + Lam (Lam (Body body)) + +convertOpenExp + :: Elt e + => Config + -> Level -- level of currently bound scalar variables + -> [Level] -- tags of bound scalar variables + -> Layout env env + -> Exp e + -> AST.OpenExp env () e +convertOpenExp config lvl fvar lyt exp + = let (sharingExp, initialEnv) = recoverSharingExp config lvl fvar exp + in + convertSharingExp config lyt EmptyLayout initialEnv [] sharingExp + + +-- | Convert an open expression with given environment layouts and sharing information into +-- de Bruijn form while recovering sharing at the same time (by introducing appropriate let +-- bindings). The latter implements the third phase of sharing recovery. +-- +-- The sharing environments 'env' and 'aenv' keep track of all currently bound sharing variables, +-- keeping them in reverse chronological order (outermost variable is at the end of the list). +-- +convertSharingExp + :: forall t env aenv. Elt t + => Config + -> Layout env env -- scalar environment + -> Layout aenv aenv -- array environment + -> [StableSharingExp] -- currently bound sharing variables of expressions + -> [StableSharingAcc] -- currently bound sharing variables of array computations + -> SharingExp t -- expression to be converted + -> AST.OpenExp env aenv t +convertSharingExp config lyt alyt env aenv = cvt + where + cvt :: Elt t' => SharingExp t' -> AST.OpenExp env aenv t' + cvt (VarSharing se) + | Just i <- findIndex (matchStableExp se) env + = AST.Var (prjIdx (ctxt ++ "; i = " ++ show i) i lyt) + | null env + = error $ "Cyclic definition of a value of type 'Exp' (sa = " ++ show (hashStableNameHeight se) ++ ")" + | otherwise + = INTERNAL_ERROR(error) "convertSharingExp" err + where + ctxt = "shared 'Exp' tree with stable name " ++ show (hashStableNameHeight se) + err = "inconsistent valuation @ " ++ ctxt ++ ";\n env = " ++ show env + cvt (LetSharing se@(StableSharingExp _ boundExp) bodyExp) + = let lyt' = incLayout lyt `PushLayout` ZeroIdx + in + AST.Let (cvt boundExp) (convertSharingExp config lyt' alyt (se:env) aenv bodyExp) + cvt (ExpSharing _ pexp) + = case pexp of + Tag i -> AST.Var (prjIdx ("de Bruijn conversion tag " ++ show i) i lyt) + Const v -> AST.Const (fromElt v) + Tuple tup -> AST.Tuple (cvtT tup) + Prj idx e -> AST.Prj idx (cvt e) + IndexNil -> AST.IndexNil + IndexCons ix i -> AST.IndexCons (cvt ix) (cvt i) + IndexHead i -> AST.IndexHead (cvt i) + IndexTail ix -> AST.IndexTail (cvt ix) + IndexAny -> AST.IndexAny + ToIndex sh ix -> AST.ToIndex (cvt sh) (cvt ix) + FromIndex sh e -> AST.FromIndex (cvt sh) (cvt e) + Cond e1 e2 e3 -> AST.Cond (cvt e1) (cvt e2) (cvt e3) + PrimConst c -> AST.PrimConst c + PrimApp f e -> cvtPrimFun f (cvt e) + Index a e -> AST.Index (cvtA a) (cvt e) + LinearIndex a i -> AST.LinearIndex (cvtA a) (cvt i) + Shape a -> AST.Shape (cvtA a) + ShapeSize e -> AST.ShapeSize (cvt e) + Foreign ff f e -> AST.Foreign ff (convertFun1 (recoverExpSharing config) f) (cvt e) + + cvtA :: Arrays a => SharingAcc a -> AST.OpenAcc aenv a + cvtA = convertSharingAcc config alyt aenv + + cvtT :: Tuple.Tuple SharingExp tup -> Tuple.Tuple (AST.OpenExp env aenv) tup + cvtT = convertSharingTuple config lyt alyt env aenv + + -- Push primitive function applications down through let bindings so that + -- they are adjacent to their arguments. It looks a bit nicer this way. + -- + cvtPrimFun :: (Elt a, Elt r) + => AST.PrimFun (a -> r) -> AST.OpenExp env' aenv' a -> AST.OpenExp env' aenv' r + cvtPrimFun f e = case e of + AST.Let bnd body -> AST.Let bnd (cvtPrimFun f body) + x -> AST.PrimApp f x + +-- | Convert a tuple expression +-- +convertSharingTuple + :: Config + -> Layout env env + -> Layout aenv aenv + -> [StableSharingExp] -- currently bound scalar sharing-variables + -> [StableSharingAcc] -- currently bound array sharing-variables + -> Tuple.Tuple SharingExp t + -> Tuple.Tuple (AST.OpenExp env aenv) t +convertSharingTuple config lyt alyt env aenv tup = + case tup of + NilTup -> NilTup + SnocTup t e -> convertSharingTuple config lyt alyt env aenv t + `SnocTup` convertSharingExp config lyt alyt env aenv e + +-- | Convert a scalar expression, which is closed with respect to scalar variables +-- +convertRootExp + :: Elt t + => Config + -> Layout aenv aenv -- array environment + -> [StableSharingAcc] -- currently bound array sharing-variables + -> RootExp t -- expression to be converted + -> AST.Exp aenv t +convertRootExp config alyt aenv exp + = case exp of + EnvExp env exp -> convertSharingExp config EmptyLayout alyt env aenv exp + _ -> INTERNAL_ERROR(error) "convertRootExp" "not an 'EnvExp'" + +-- | Convert a unary functions +-- +convertSharingFun1 + :: forall a b aenv. (Elt a, Elt b) + => Config + -> Layout aenv aenv + -> [StableSharingAcc] -- currently bound array sharing-variables + -> (Exp a -> RootExp b) + -> AST.Fun aenv (a -> b) +convertSharingFun1 config alyt aenv f = Lam (Body openF) + where + a = Exp undefined -- the 'tag' was already embedded in Phase 1 + lyt = EmptyLayout + `PushLayout` + (ZeroIdx :: Idx ((), a) a) + EnvExp env body = f a + openF = convertSharingExp config lyt alyt env aenv body + +-- | Convert a binary functions +-- +convertSharingFun2 + :: forall a b c aenv. (Elt a, Elt b, Elt c) + => Config + -> Layout aenv aenv + -> [StableSharingAcc] -- currently bound array sharing-variables + -> (Exp a -> Exp b -> RootExp c) + -> AST.Fun aenv (a -> b -> c) +convertSharingFun2 config alyt aenv f = Lam (Lam (Body openF)) + where + a = Exp undefined + b = Exp undefined + lyt = EmptyLayout + `PushLayout` + (SuccIdx ZeroIdx :: Idx (((), a), b) a) + `PushLayout` + (ZeroIdx :: Idx (((), a), b) b) + EnvExp env body = f a b + openF = convertSharingExp config lyt alyt env aenv body + +-- | Convert a unary stencil function +-- +convertSharingStencilFun1 + :: forall sh a stencil b aenv. (Elt a, Stencil sh a stencil, Elt b) + => Config + -> SharingAcc (Array sh a) -- just passed to fix the type variables + -> Layout aenv aenv + -> [StableSharingAcc] -- currently bound array sharing-variables + -> (stencil -> RootExp b) + -> AST.Fun aenv (StencilRepr sh stencil -> b) +convertSharingStencilFun1 config _ alyt aenv stencilFun = Lam (Body openStencilFun) + where + stencil = Exp undefined :: Exp (StencilRepr sh stencil) + lyt = EmptyLayout + `PushLayout` + (ZeroIdx :: Idx ((), StencilRepr sh stencil) + (StencilRepr sh stencil)) + + EnvExp env body = stencilFun (stencilPrj (undefined::sh) (undefined::a) stencil) + openStencilFun = convertSharingExp config lyt alyt env aenv body + +-- | Convert a binary stencil function +-- +convertSharingStencilFun2 + :: forall sh a b stencil1 stencil2 c aenv. + (Elt a, Stencil sh a stencil1, + Elt b, Stencil sh b stencil2, + Elt c) + => Config + -> SharingAcc (Array sh a) -- just passed to fix the type variables + -> SharingAcc (Array sh b) -- just passed to fix the type variables + -> Layout aenv aenv + -> [StableSharingAcc] -- currently bound array sharing-variables + -> (stencil1 -> stencil2 -> RootExp c) + -> AST.Fun aenv (StencilRepr sh stencil1 -> StencilRepr sh stencil2 -> c) +convertSharingStencilFun2 config _ _ alyt aenv stencilFun = Lam (Lam (Body openStencilFun)) + where + stencil1 = Exp undefined :: Exp (StencilRepr sh stencil1) + stencil2 = Exp undefined :: Exp (StencilRepr sh stencil2) + lyt = EmptyLayout + `PushLayout` + (SuccIdx ZeroIdx :: Idx (((), StencilRepr sh stencil1), + StencilRepr sh stencil2) + (StencilRepr sh stencil1)) + `PushLayout` + (ZeroIdx :: Idx (((), StencilRepr sh stencil1), + StencilRepr sh stencil2) + (StencilRepr sh stencil2)) + + EnvExp env body = stencilFun (stencilPrj (undefined::sh) (undefined::a) stencil1) + (stencilPrj (undefined::sh) (undefined::b) stencil2) + openStencilFun = convertSharingExp config lyt alyt env aenv body + + +-- Sharing recovery +-- ================ + +-- Sharing recovery proceeds in two phases: +-- +-- /Phase One: build the occurrence map/ +-- +-- This is a top-down traversal of the AST that computes a map from AST nodes to the number of +-- occurrences of that AST node in the overall Accelerate program. An occurrences count of two or +-- more indicates sharing. +-- +-- IMPORTANT: To avoid unfolding the sharing, we do not descent into subtrees that we have +-- previously encountered. Hence, the complexity is proportional to the number of nodes in the +-- tree /with/ sharing. Consequently, the occurrence count is that in the tree with sharing +-- as well. +-- +-- During computation of the occurrences, the tree is annotated with stable names on every node +-- using 'AccSharing' constructors and all but the first occurrence of shared subtrees are pruned +-- using 'AvarSharing' constructors (see 'SharingAcc' below). This phase is impure as it is based +-- on stable names. +-- +-- We use a hash table (instead of 'Data.Map') as computing stable names forces us to live in IO +-- anyway. Once, the computation of occurrence counts is complete, we freeze the hash table into +-- a 'Data.Map'. +-- +-- (Implemented by 'makeOccMap*'.) +-- +-- /Phase Two: determine scopes and inject sharing information/ +-- +-- This is a bottom-up traversal that determines the scope for every binding to be introduced +-- to share a subterm. It uses the occurrence map to determine, for every shared subtree, the +-- lowest AST node at which the binding for that shared subtree can be placed (using a +-- 'AletSharing' constructor)— it's the meet of all the shared subtree occurrences. +-- +-- The second phase is also replacing the first occurrence of each shared subtree with a +-- 'AvarSharing' node and floats the shared subtree up to its binding point. +-- +-- (Implemented by 'determineScopes*'.) +-- +-- /Sharing recovery for expressions/ +-- +-- We recover sharing for each expression (including function bodies) independently of any other +-- expression — i.e., we cannot share scalar expressions across array computations. Hence, during +-- Phase One, we mark all scalar expression nodes with a stable name and compute one occurrence map +-- for every scalar expression (including functions) that occurs in an array computation. These +-- occurrence maps are added to the root of scalar expressions using 'RootExp'. +-- +-- NB: We do not need to worry sharing recovery will try to float a shared subexpression past a +-- binder that occurs in that subexpression. Why? Otherwise, the binder would already occur +-- out of scope in the original source program. +-- +-- /Lambda bound variables/ +-- +-- During sharing recovery, lambda bound variables appear in the form of 'Atag' and 'Tag' data +-- constructors. The tag values are determined during Phase One of sharing recovery by computing +-- the /level/ of each variable at its binding occurrence. The level at the root of the AST is 0 +-- and increases by one with each lambda on each path through the AST. + +-- Stable names +-- ------------ + +-- Opaque stable name for AST nodes — used to key the occurrence map. +-- +data StableASTName c where + StableASTName :: (Typeable1 c, Typeable t) => StableName (c t) -> StableASTName c + +instance Show (StableASTName c) where + show (StableASTName sn) = show $ hashStableName sn + +instance Eq (StableASTName c) where + StableASTName sn1 == StableASTName sn2 + | Just sn1' <- gcast sn1 = sn1' == sn2 + | otherwise = False + +instance Hashable (StableASTName c) where + hashWithSalt s (StableASTName sn) = hashWithSalt s sn + +makeStableAST :: c t -> IO (StableName (c t)) +makeStableAST e = e `seq` makeStableName e + +-- Stable name for an AST node including the height of the AST representing the array computation. +-- +data StableNameHeight t = StableNameHeight (StableName t) Int + +instance Eq (StableNameHeight t) where + (StableNameHeight sn1 _) == (StableNameHeight sn2 _) = sn1 == sn2 + +higherSNH :: StableNameHeight t1 -> StableNameHeight t2 -> Bool +StableNameHeight _ h1 `higherSNH` StableNameHeight _ h2 = h1 > h2 + +hashStableNameHeight :: StableNameHeight t -> Int +hashStableNameHeight (StableNameHeight sn _) = hashStableName sn + +-- Mutable occurrence map +-- ---------------------- + +-- Hash table keyed on the stable names of array computations. +-- +type HashTable key val = Hash.BasicHashTable key val +type ASTHashTable c v = HashTable (StableASTName c) v + +-- Mutable hashtable version of the occurrence map, which associates each AST node with an +-- occurrence count and the height of the AST. +-- +type OccMapHash c = ASTHashTable c (Int, Int) + +-- Create a new hash table keyed on AST nodes. +-- +newASTHashTable :: IO (ASTHashTable c v) +newASTHashTable = Hash.new + +-- Enter one AST node occurrence into an occurrence map. Returns 'Just h' if this is a repeated +-- occurrence and the height of the repeatedly occurring AST is 'h'. +-- +-- If this is the first occurrence, the 'height' *argument* must provide the height of the AST; +-- otherwise, the height will be *extracted* from the occurrence map. In the latter case, this +-- function yields the AST height. +-- +enterOcc :: OccMapHash c -> StableASTName c -> Int -> IO (Maybe Int) +enterOcc occMap sa height + = do + entry <- Hash.lookup occMap sa + case entry of + Nothing -> Hash.insert occMap sa (1 , height) >> return Nothing + Just (n, heightS) -> Hash.insert occMap sa (n + 1, heightS) >> return (Just heightS) + +-- Immutable occurrence map +-- ------------------------ + +-- Immutable version of the occurrence map (storing the occurrence count only, not the height). We +-- use the 'StableName' hash to index an 'IntMap' and disambiguate 'StableName's with identical +-- hashes explicitly, storing them in a list in the 'IntMap'. +-- +type OccMap c = IntMap.IntMap [(StableASTName c, Int)] + +-- Turn a mutable into an immutable occurrence map. +-- +freezeOccMap :: OccMapHash c -> IO (OccMap c) +freezeOccMap oc + = do + ocl <- Hash.toList oc + traceChunk "OccMap" (show ocl) + + return . IntMap.fromList + . map (\kvs -> (key (head kvs), kvs)) + . groupBy sameKey + . map dropHeight + $ ocl + where + key (StableASTName sn, _) = hashStableName sn + sameKey kv1 kv2 = key kv1 == key kv2 + dropHeight (k, (cnt, _)) = (k, cnt) + +-- Look up the occurrence map keyed by array computations using a stable name. If the key does +-- not exist in the map, return an occurrence count of '1'. +-- +lookupWithASTName :: OccMap c -> StableASTName c -> Int +lookupWithASTName oc sa@(StableASTName sn) + = fromMaybe 1 $ IntMap.lookup (hashStableName sn) oc >>= Prelude.lookup sa + +-- Look up the occurrence map keyed by array computations using a sharing array computation. If an +-- the key does not exist in the map, return an occurrence count of '1'. +-- +lookupWithSharingAcc :: OccMap Acc -> StableSharingAcc -> Int +lookupWithSharingAcc oc (StableSharingAcc (StableNameHeight sn _) _) + = lookupWithASTName oc (StableASTName sn) + +-- Look up the occurrence map keyed by scalar expressions using a sharing expression. If an +-- the key does not exist in the map, return an occurrence count of '1'. +-- +lookupWithSharingExp :: OccMap Exp -> StableSharingExp -> Int +lookupWithSharingExp oc (StableSharingExp (StableNameHeight sn _) _) + = lookupWithASTName oc (StableASTName sn) + +-- Stable 'Acc' nodes +-- ------------------ + +-- Stable name for 'Acc' nodes including the height of the AST. +-- +type StableAccName arrs = StableNameHeight (Acc arrs) + +-- Interleave sharing annotations into an array computation AST. Subtrees can be marked as being +-- represented by variable (binding a shared subtree) using 'AvarSharing' and as being prefixed by +-- a let binding (for a shared subtree) using 'AletSharing'. +-- +data SharingAcc arrs where + AvarSharing :: Arrays arrs + => StableAccName arrs -> SharingAcc arrs + AletSharing :: StableSharingAcc -> SharingAcc arrs -> SharingAcc arrs + AccSharing :: Arrays arrs + => StableAccName arrs -> PreAcc SharingAcc RootExp arrs -> SharingAcc arrs + +-- Stable name for an array computation associated with its sharing-annotated version. +-- +data StableSharingAcc where + StableSharingAcc :: Arrays arrs + => StableAccName arrs + -> SharingAcc arrs + -> StableSharingAcc + +instance Show StableSharingAcc where + show (StableSharingAcc sn _) = show $ hashStableNameHeight sn + +instance Eq StableSharingAcc where + StableSharingAcc sn1 _ == StableSharingAcc sn2 _ + | Just sn1' <- gcast sn1 = sn1' == sn2 + | otherwise = False + +higherSSA :: StableSharingAcc -> StableSharingAcc -> Bool +StableSharingAcc sn1 _ `higherSSA` StableSharingAcc sn2 _ = sn1 `higherSNH` sn2 + +-- Test whether the given stable names matches an array computation with sharing. +-- +matchStableAcc :: Typeable arrs => StableAccName arrs -> StableSharingAcc -> Bool +matchStableAcc sn1 (StableSharingAcc sn2 _) + | Just sn1' <- gcast sn1 = sn1' == sn2 + | otherwise = False + +-- Dummy entry for environments to be used for unused variables. +-- +noStableAccName :: StableAccName arrs +noStableAccName = unsafePerformIO $ StableNameHeight <$> makeStableName undefined <*> pure 0 + +-- Stable 'Exp' nodes +-- ------------------ + +-- Stable name for 'Exp' nodes including the height of the AST. +-- +type StableExpName t = StableNameHeight (Exp t) + +-- Interleave sharing annotations into a scalar expressions AST in the same manner as 'SharingAcc' +-- do for array computations. +-- +data SharingExp t where + VarSharing :: Elt t + => StableExpName t -> SharingExp t + LetSharing :: StableSharingExp -> SharingExp t -> SharingExp t + ExpSharing :: Elt t + => StableExpName t -> PreExp SharingAcc SharingExp t -> SharingExp t + +-- Expressions rooted in 'Acc' computations. +-- +-- * Between counting occurrences and determining scopes, the root of every expression embedded in an +-- 'Acc' is annotated by (1) the tags of free scalar variables and (2) an occurrence map for that +-- one expression (excluding any subterms that are rooted in embedded 'Acc's.) +-- * After determining scopes, the root of every expression is annotated with a sorted environment of +-- the 'StableSharingExp's corresponding to its free expression-valued variables. +-- +data RootExp t where + OccMapExp :: [Int] -> OccMap Exp -> SharingExp t -> RootExp t + EnvExp :: [StableSharingExp] -> SharingExp t -> RootExp t + +-- Stable name for an expression associated with its sharing-annotated version. +-- +data StableSharingExp where + StableSharingExp :: Elt t => StableExpName t -> SharingExp t -> StableSharingExp + +instance Show StableSharingExp where + show (StableSharingExp sn _) = show $ hashStableNameHeight sn + +instance Eq StableSharingExp where + StableSharingExp sn1 _ == StableSharingExp sn2 _ + | Just sn1' <- gcast sn1 = sn1' == sn2 + | otherwise = False + +higherSSE :: StableSharingExp -> StableSharingExp -> Bool +StableSharingExp sn1 _ `higherSSE` StableSharingExp sn2 _ = sn1 `higherSNH` sn2 + +-- Test whether the given stable names matches an expression with sharing. +-- +matchStableExp :: Typeable t => StableExpName t -> StableSharingExp -> Bool +matchStableExp sn1 (StableSharingExp sn2 _) + | Just sn1' <- gcast sn1 = sn1' == sn2 + | otherwise = False + +-- Dummy entry for environments to be used for unused variables. +-- +noStableExpName :: StableExpName t +noStableExpName = unsafePerformIO $ StableNameHeight <$> makeStableName undefined <*> pure 0 + + +-- Occurrence counting +-- =================== + +-- Compute the 'Acc' occurrence map, marks all nodes (both 'Acc' and 'Exp' nodes) with stable names, +-- and drop repeated occurrences of shared 'Acc' and 'Exp' subtrees (Phase One). +-- +-- We compute a single 'Acc' occurrence map for the whole AST, but one 'Exp' occurrence map for each +-- sub-expression rooted in an 'Acc' operation. This is as we cannot float 'Exp' subtrees across +-- 'Acc' operations, but we can float 'Acc' subtrees out of 'Exp' expressions. +-- +-- Note [Traversing functions and side effects] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- We need to descent into function bodies to build the 'OccMap' with all occurrences in the +-- function bodies. Due to the side effects in the construction of the occurrence map and, more +-- importantly, the dependence of the second phase on /global/ occurrence information, we may not +-- delay the body traversals by putting them under a lambda. Hence, we apply each function, to +-- traverse its body and use a /dummy abstraction/ of the result. +-- +-- For example, given a function 'f', we traverse 'f (Tag 0)', which yields a transformed body 'e'. +-- As the result of the traversal of the overall function, we use 'const e'. Hence, it is crucial +-- that the 'Tag' supplied during the initial traversal is already the one required by the HOAS to +-- de Bruijn conversion in 'convertSharingAcc' — any subsequent application of 'const e' will only +-- yield 'e' with the embedded 'Tag 0' of the original application. During sharing recovery, we +-- float /all/ free variables ('Atag' and 'Tag') out to construct the initial environment for +-- producing de Bruijn indices, which replaces them by 'AvarSharing' or 'VarSharing' nodes. Hence, +-- the tag values only serve the purpose of determining the ordering in that initial environment. +-- They are /not/ directly used to compute the de Brujin indices. +-- +makeOccMapAcc + :: Typeable arrs + => Config + -> Level + -> Acc arrs + -> IO (SharingAcc arrs, OccMap Acc) +makeOccMapAcc config lvl acc = do + traceLine "makeOccMapAcc" "Enter" + accOccMap <- newASTHashTable + (acc', _) <- makeOccMapSharingAcc config accOccMap lvl acc + frozenAccOccMap <- freezeOccMap accOccMap + traceLine "makeOccMapAcc" "Exit" + return (acc', frozenAccOccMap) + + +makeOccMapSharingAcc + :: Typeable arrs + => Config + -> OccMapHash Acc + -> Level + -> Acc arrs + -> IO (SharingAcc arrs, Int) +makeOccMapSharingAcc config accOccMap = traverseAcc + where + traverseFun1 :: (Elt a, Typeable b) => Level -> (Exp a -> Exp b) -> IO (Exp a -> RootExp b, Int) + traverseFun1 = makeOccMapFun1 config accOccMap + + traverseFun2 :: (Elt a, Elt b, Typeable c) + => Level + -> (Exp a -> Exp b -> Exp c) + -> IO (Exp a -> Exp b -> RootExp c, Int) + traverseFun2 = makeOccMapFun2 config accOccMap + + traverseExp :: Typeable e => Level -> Exp e -> IO (RootExp e, Int) + traverseExp = makeOccMapExp config accOccMap + + traverseAcc :: forall arrs. Typeable arrs => Level -> Acc arrs -> IO (SharingAcc arrs, Int) + traverseAcc lvl acc@(Acc pacc) + = mfix $ \ ~(_, height) -> do + -- Compute stable name and enter it into the occurrence map + -- + sn <- makeStableAST acc + heightIfRepeatedOccurrence <- enterOcc accOccMap (StableASTName sn) height + + traceLine (showPreAccOp pacc) $ do + let hash = show (hashStableName sn) + case heightIfRepeatedOccurrence of + Just height -> "REPEATED occurrence (sn = " ++ hash ++ "; height = " ++ show height ++ ")" + Nothing -> "first occurrence (sn = " ++ hash ++ ")" + + -- Reconstruct the computation in shared form. + -- + -- In case of a repeated occurrence, the height comes from the occurrence map; otherwise + -- it is computed by the traversal function passed in 'newAcc'. See also 'enterOcc'. + -- + -- NB: This function can only be used in the case alternatives below; outside of the + -- case we cannot discharge the 'Arrays arrs' constraint. + -- + let reconstruct :: Arrays arrs + => IO (PreAcc SharingAcc RootExp arrs, Int) + -> IO (SharingAcc arrs, Int) + reconstruct newAcc + = case heightIfRepeatedOccurrence of + Just height | recoverAccSharing config + -> return (AvarSharing (StableNameHeight sn height), height) + _ -> do (acc, height) <- newAcc + return (AccSharing (StableNameHeight sn height) acc, height) + + case pacc of + Atag i -> reconstruct $ return (Atag i, 0) -- height is 0! + Pipe afun1 afun2 acc -> reconstruct $ travA (Pipe afun1 afun2) acc + Aforeign ff afun acc -> reconstruct $ travA (Aforeign ff afun) acc + Acond e acc1 acc2 -> reconstruct $ do + (e' , h1) <- traverseExp lvl e + (acc1', h2) <- traverseAcc lvl acc1 + (acc2', h3) <- traverseAcc lvl acc2 + return (Acond e' acc1' acc2', h1 `max` h2 `max` h3 + 1) + + Atuple tup -> reconstruct $ do + (tup', h) <- travAtup tup + return (Atuple tup', h) + Aprj ix a -> reconstruct $ travA (Aprj ix) a + + Use arr -> reconstruct $ return (Use arr, 1) + Unit e -> reconstruct $ do + (e', h) <- traverseExp lvl e + return (Unit e', h + 1) + Generate e f -> reconstruct $ do + (e', h1) <- traverseExp lvl e + (f', h2) <- traverseFun1 lvl f + return (Generate e' f', h1 `max` h2 + 1) + Reshape e acc -> reconstruct $ travEA Reshape e acc + Replicate e acc -> reconstruct $ travEA Replicate e acc + Slice acc e -> reconstruct $ travEA (flip Slice) e acc + Map f acc -> reconstruct $ do + (f' , h1) <- traverseFun1 lvl f + (acc', h2) <- traverseAcc lvl acc + return (Map f' acc', h1 `max` h2 + 1) + ZipWith f acc1 acc2 -> reconstruct $ travF2A2 ZipWith f acc1 acc2 + Fold f e acc -> reconstruct $ travF2EA Fold f e acc + Fold1 f acc -> reconstruct $ travF2A Fold1 f acc + FoldSeg f e acc1 acc2 -> reconstruct $ do + (f' , h1) <- traverseFun2 lvl f + (e' , h2) <- traverseExp lvl e + (acc1', h3) <- traverseAcc lvl acc1 + (acc2', h4) <- traverseAcc lvl acc2 + return (FoldSeg f' e' acc1' acc2', + h1 `max` h2 `max` h3 `max` h4 + 1) + Fold1Seg f acc1 acc2 -> reconstruct $ travF2A2 Fold1Seg f acc1 acc2 + Scanl f e acc -> reconstruct $ travF2EA Scanl f e acc + Scanl' f e acc -> reconstruct $ travF2EA Scanl' f e acc + Scanl1 f acc -> reconstruct $ travF2A Scanl1 f acc + Scanr f e acc -> reconstruct $ travF2EA Scanr f e acc + Scanr' f e acc -> reconstruct $ travF2EA Scanr' f e acc + Scanr1 f acc -> reconstruct $ travF2A Scanr1 f acc + Permute c acc1 p acc2 -> reconstruct $ do + (c' , h1) <- traverseFun2 lvl c + (p' , h2) <- traverseFun1 lvl p + (acc1', h3) <- traverseAcc lvl acc1 + (acc2', h4) <- traverseAcc lvl acc2 + return (Permute c' acc1' p' acc2', + h1 `max` h2 `max` h3 `max` h4 + 1) + Backpermute e p acc -> reconstruct $ do + (e' , h1) <- traverseExp lvl e + (p' , h2) <- traverseFun1 lvl p + (acc', h3) <- traverseAcc lvl acc + 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) + 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) + + where + travA :: Arrays arrs' + => (SharingAcc arrs' -> PreAcc SharingAcc RootExp arrs) + -> Acc arrs' -> IO (PreAcc SharingAcc RootExp arrs, Int) + travA c acc + = do + (acc', h) <- traverseAcc lvl acc + return (c acc', h + 1) + + travEA :: (Typeable b, Arrays arrs') + => (RootExp b -> SharingAcc arrs' -> PreAcc SharingAcc RootExp arrs) + -> Exp b -> Acc arrs' -> IO (PreAcc SharingAcc RootExp arrs, Int) + travEA c exp acc + = do + (exp', h1) <- traverseExp lvl exp + (acc', h2) <- traverseAcc lvl acc + return (c exp' acc', h1 `max` h2 + 1) + + travF2A :: (Elt b, Elt c, Typeable d, Arrays arrs') + => ((Exp b -> Exp c -> RootExp d) -> SharingAcc arrs' + -> PreAcc SharingAcc RootExp arrs) + -> (Exp b -> Exp c -> Exp d) -> Acc arrs' + -> IO (PreAcc SharingAcc RootExp arrs, Int) + travF2A c fun acc + = do + (fun', h1) <- traverseFun2 lvl fun + (acc', h2) <- traverseAcc lvl acc + return (c fun' acc', h1 `max` h2 + 1) + + travF2EA :: (Elt b, Elt c, Typeable d, Typeable e, Arrays arrs') + => ((Exp b -> Exp c -> RootExp d) -> RootExp e -> SharingAcc arrs' -> PreAcc SharingAcc RootExp arrs) + -> (Exp b -> Exp c -> Exp d) -> Exp e -> Acc arrs' + -> IO (PreAcc SharingAcc RootExp arrs, Int) + travF2EA c fun exp acc + = do + (fun', h1) <- traverseFun2 lvl fun + (exp', h2) <- traverseExp lvl exp + (acc', h3) <- traverseAcc lvl acc + return (c fun' exp' acc', h1 `max` h2 `max` h3 + 1) + + travF2A2 :: (Elt b, Elt c, Typeable d, Arrays arrs1, Arrays arrs2) + => ((Exp b -> Exp c -> RootExp d) -> SharingAcc arrs1 -> SharingAcc arrs2 -> PreAcc SharingAcc RootExp arrs) + -> (Exp b -> Exp c -> Exp d) -> Acc arrs1 -> Acc arrs2 + -> IO (PreAcc SharingAcc RootExp arrs, Int) + travF2A2 c fun acc1 acc2 + = do + (fun' , h1) <- traverseFun2 lvl fun + (acc1', h2) <- traverseAcc lvl acc1 + (acc2', h3) <- traverseAcc lvl acc2 + return (c fun' acc1' acc2', h1 `max` h2 `max` h3 + 1) + + travAtup :: Tuple.Atuple Acc a + -> IO (Tuple.Atuple SharingAcc a, Int) + travAtup NilAtup = return (NilAtup, 1) + travAtup (SnocAtup tup a) = do + (tup', h1) <- travAtup tup + (a', h2) <- traverseAcc lvl a + return (SnocAtup tup' a', h1 `max` h2 + 1) + + +-- Generate occupancy information for scalar functions and expressions. Helper +-- functions wrapping around 'makeOccMapRootExp' with more specific types. +-- +-- See Note [Traversing functions and side effects] +-- +makeOccMapExp + :: Typeable e + => Config + -> OccMapHash Acc + -> Level + -> Exp e + -> IO (RootExp e, Int) +makeOccMapExp config accOccMap lvl = makeOccMapRootExp config accOccMap lvl [] + +makeOccMapFun1 + :: (Elt a, Typeable b) + => Config + -> OccMapHash Acc + -> Level + -> (Exp a -> Exp b) + -> IO (Exp a -> RootExp b, Int) +makeOccMapFun1 config accOccMap lvl f = do + let x = Exp (Tag lvl) + -- + (body, height) <- makeOccMapRootExp config accOccMap (lvl+1) [lvl] (f x) + return (const body, height) + +makeOccMapFun2 + :: (Elt a, Elt b, Typeable c) + => Config + -> OccMapHash Acc + -> Level + -> (Exp a -> Exp b -> Exp c) + -> IO (Exp a -> Exp b -> RootExp c, Int) +makeOccMapFun2 config accOccMap lvl f = do + let x = Exp (Tag (lvl+1)) + y = Exp (Tag lvl) + -- + (body, height) <- makeOccMapRootExp config accOccMap (lvl+2) [lvl, lvl+1] (f x y) + return (\_ _ -> body, height) + +makeOccMapStencil1 + :: forall sh a b stencil. (Stencil sh a stencil, Typeable b) + => Config + -> OccMapHash Acc + -> Acc (Array sh a) {- dummy -} + -> Level + -> (stencil -> Exp b) + -> IO (stencil -> RootExp b, Int) +makeOccMapStencil1 config accOccMap _ lvl stencil = do + let x = Exp (Tag lvl) + f = stencil . stencilPrj (undefined::sh) (undefined::a) + -- + (body, height) <- makeOccMapRootExp config accOccMap (lvl+1) [lvl] (f x) + return (const body, height) + +makeOccMapStencil2 + :: forall sh a b c stencil1 stencil2. (Stencil sh a stencil1, Stencil sh b stencil2, Typeable c) + => Config + -> OccMapHash Acc + -> Acc (Array sh a) {- dummy -} + -> Acc (Array sh b) {- dummy -} + -> Level + -> (stencil1 -> stencil2 -> Exp c) + -> IO (stencil1 -> stencil2 -> RootExp c, Int) +makeOccMapStencil2 config accOccMap _ _ lvl stencil = do + let x = Exp (Tag (lvl+1)) + y = Exp (Tag lvl) + f a b = stencil (stencilPrj (undefined::sh) (undefined::a) a) + (stencilPrj (undefined::sh) (undefined::b) b) + -- + (body, height) <- makeOccMapRootExp config accOccMap (lvl+2) [lvl, lvl+1] (f x y) + return (\_ _ -> body, height) + + +-- Generate sharing information for expressions embedded in Acc computations. +-- Expressions are annotated with: +-- +-- 1) the tags of free scalar variables (for scalar functions) +-- 2) a local occurrence map for that expression. +-- +makeOccMapRootExp + :: Typeable e + => Config + -> OccMapHash Acc + -> Level -- The level of currently bound scalar variables + -> [Int] -- The tags of newly introduced free scalar variables in this expression + -> Exp e + -> IO (RootExp e, Int) +makeOccMapRootExp config accOccMap lvl fvs exp = do + traceLine "makeOccMapRootExp" "Enter" + expOccMap <- newASTHashTable + (exp', height) <- makeOccMapSharingExp config accOccMap expOccMap lvl exp + frozenExpOccMap <- freezeOccMap expOccMap + traceLine "makeOccMapRootExp" "Exit" + return (OccMapExp fvs frozenExpOccMap exp', height) + + +-- Generate sharing information for an open scalar expression. +-- +makeOccMapSharingExp + :: Typeable e + => Config + -> OccMapHash Acc + -> OccMapHash Exp + -> Level -- The level of currently bound variables + -> Exp e + -> IO (SharingExp e, Int) +makeOccMapSharingExp config accOccMap expOccMap = travE + where + travE :: forall a. Typeable a => Level -> Exp a -> IO (SharingExp a, Int) + travE lvl exp@(Exp pexp) + = mfix $ \ ~(_, height) -> do + -- Compute stable name and enter it into the occurrence map + -- + sn <- makeStableAST exp + heightIfRepeatedOccurrence <- enterOcc expOccMap (StableASTName sn) height + + traceLine (showPreExpOp pexp) $ do + let hash = show (hashStableName sn) + case heightIfRepeatedOccurrence of + Just height -> "REPEATED occurrence (sn = " ++ hash ++ "; height = " ++ show height ++ ")" + Nothing -> "first occurrence (sn = " ++ hash ++ ")" + + -- Reconstruct the computation in shared form. + -- + -- In case of a repeated occurrence, the height comes from the occurrence map; otherwise + -- it is computed by the traversal function passed in 'newExp'. See also 'enterOcc'. + -- + -- NB: This function can only be used in the case alternatives below; outside of the + -- case we cannot discharge the 'Elt a' constraint. + -- + let reconstruct :: Elt a + => IO (PreExp SharingAcc SharingExp a, Int) + -> IO (SharingExp a, Int) + reconstruct newExp + = case heightIfRepeatedOccurrence of + Just height | recoverExpSharing config + -> return (VarSharing (StableNameHeight sn height), height) + _ -> do (exp, height) <- newExp + return (ExpSharing (StableNameHeight sn height) exp, height) + + case pexp of + Tag i -> reconstruct $ return (Tag i, 0) -- height is 0! + Const c -> reconstruct $ return (Const c, 1) + Tuple tup -> reconstruct $ do + (tup', h) <- travTup tup + return (Tuple tup', h) + Prj i e -> reconstruct $ travE1 (Prj i) e + IndexNil -> reconstruct $ return (IndexNil, 1) + IndexCons ix i -> reconstruct $ travE2 IndexCons ix i + IndexHead i -> reconstruct $ travE1 IndexHead i + IndexTail ix -> reconstruct $ travE1 IndexTail ix + IndexAny -> reconstruct $ return (IndexAny, 1) + ToIndex sh ix -> reconstruct $ travE2 ToIndex sh ix + FromIndex sh e -> reconstruct $ travE2 FromIndex sh e + Cond e1 e2 e3 -> reconstruct $ travE3 Cond e1 e2 e3 + PrimConst c -> reconstruct $ return (PrimConst c, 1) + PrimApp p e -> reconstruct $ travE1 (PrimApp p) e + Index a e -> reconstruct $ travAE Index a e + LinearIndex a i -> reconstruct $ travAE LinearIndex a i + Shape a -> reconstruct $ travA Shape a + ShapeSize e -> reconstruct $ travE1 ShapeSize e + Foreign ff f e -> reconstruct $ do + (e', h) <- travE lvl e + return (Foreign ff f e', h+1) + + where + traverseAcc :: Typeable arrs => Level -> Acc arrs -> IO (SharingAcc arrs, Int) + traverseAcc = makeOccMapSharingAcc config accOccMap + + travE1 :: Typeable b => (SharingExp b -> PreExp SharingAcc SharingExp a) -> Exp b + -> IO (PreExp SharingAcc SharingExp a, Int) + travE1 c e + = do + (e', h) <- travE lvl e + return (c e', h + 1) + + travE2 :: (Typeable b, Typeable c) + => (SharingExp b -> SharingExp c -> PreExp SharingAcc SharingExp a) + -> Exp b -> Exp c + -> IO (PreExp SharingAcc SharingExp a, Int) + travE2 c e1 e2 + = do + (e1', h1) <- travE lvl e1 + (e2', h2) <- travE lvl e2 + return (c e1' e2', h1 `max` h2 + 1) + + travE3 :: (Typeable b, Typeable c, Typeable d) + => (SharingExp b -> SharingExp c -> SharingExp d -> PreExp SharingAcc SharingExp a) + -> Exp b -> Exp c -> Exp d + -> IO (PreExp SharingAcc SharingExp a, Int) + travE3 c e1 e2 e3 + = do + (e1', h1) <- travE lvl e1 + (e2', h2) <- travE lvl e2 + (e3', h3) <- travE lvl e3 + return (c e1' e2' e3', h1 `max` h2 `max` h3 + 1) + + travA :: Typeable b => (SharingAcc b -> PreExp SharingAcc SharingExp a) -> Acc b + -> IO (PreExp SharingAcc SharingExp a, Int) + travA c acc + = do + (acc', h) <- traverseAcc lvl acc + return (c acc', h + 1) + + travAE :: (Typeable b, Typeable c) + => (SharingAcc b -> SharingExp c -> PreExp SharingAcc SharingExp a) + -> Acc b -> Exp c + -> IO (PreExp SharingAcc SharingExp a, Int) + travAE c acc e + = do + (acc', h1) <- traverseAcc lvl acc + (e' , h2) <- travE lvl e + return (c acc' e', h1 `max` h2 + 1) + + travTup :: Tuple.Tuple Exp tup -> IO (Tuple.Tuple SharingExp tup, Int) + travTup NilTup = return (NilTup, 1) + travTup (SnocTup tup e) = do + (tup', h1) <- travTup tup + (e' , h2) <- travE lvl e + return (SnocTup tup' e', h1 `max` h2 + 1) + + +-- Type used to maintain how often each shared subterm, so far, occurred during a bottom-up sweep. +-- +-- Invariants: +-- - If one shared term 's' is itself a subterm of another shared term 't', then 's' must occur +-- *after* 't' in the 'NodeCounts'. +-- - No shared term occurs twice. +-- - A term may have a final occurrence count of only 1 iff it is either a free variable ('Atag' +-- or 'Tag') or an array computation lifted out of an expression. +-- - All 'Exp' node counts precede all 'Acc' node counts as we don't share 'Exp' nodes across 'Acc' +-- nodes. +-- +-- We determine the subterm property by using the tree height in 'StableNameHeight'. Trees get +-- smaller towards the end of a 'NodeCounts' list. The height of free variables ('Atag' or 'Tag') +-- is 0, whereas other leaves have height 1. This guarantees that all free variables are at the end +-- of the 'NodeCounts' list. +-- +-- To ensure the invariant is preserved over merging node counts from sibling subterms, the +-- function '(+++)' must be used. +-- +type NodeCounts = [NodeCount] + +data NodeCount = AccNodeCount StableSharingAcc Int + | ExpNodeCount StableSharingExp Int + deriving Show + +-- Empty node counts +-- +noNodeCounts :: NodeCounts +noNodeCounts = [] + +-- Singleton node counts for 'Acc' +-- +accNodeCount :: StableSharingAcc -> Int -> NodeCounts +accNodeCount ssa n = [AccNodeCount ssa n] + +-- Singleton node counts for 'Exp' +-- +expNodeCount :: StableSharingExp -> Int -> NodeCounts +expNodeCount sse n = [ExpNodeCount sse n] + +-- Combine node counts that belong to the same node. +-- +-- * We assume that the node counts invariant —subterms follow their parents— holds for both +-- arguments and guarantee that it still holds for the result. +-- * In the same manner, we assume that all 'Exp' node counts precede 'Acc' node counts and +-- guarantee that this also hold for the result. +-- +(+++) :: NodeCounts -> NodeCounts -> NodeCounts +us +++ vs = foldr insert us vs + where + insert x [] = [x] + insert x@(AccNodeCount sa1 count1) ys@(y@(AccNodeCount sa2 count2) : ys') + | sa1 == sa2 = AccNodeCount (sa1 `pickNoneAvar` sa2) (count1 + count2) : ys' + | sa1 `higherSSA` sa2 = x : ys + | otherwise = y : insert x ys' + insert x@(ExpNodeCount se1 count1) ys@(y@(ExpNodeCount se2 count2) : ys') + | se1 == se2 = ExpNodeCount (se1 `pickNoneVar` se2) (count1 + count2) : ys' + | se1 `higherSSE` se2 = x : ys + | otherwise = y : insert x ys' + insert x@(AccNodeCount _ _) (y@(ExpNodeCount _ _) : ys') + = y : insert x ys' + insert x@(ExpNodeCount _ _) (y@(AccNodeCount _ _) : ys') + = x : insert y ys' + + (StableSharingAcc _ (AvarSharing _)) `pickNoneAvar` sa2 = sa2 + sa1 `pickNoneAvar` _sa2 = sa1 + + (StableSharingExp _ (VarSharing _)) `pickNoneVar` sa2 = sa2 + sa1 `pickNoneVar` _sa2 = sa1 + +-- Build an initial environment for the tag values given in the first argument for traversing an +-- array expression. The 'StableSharingAcc's for all tags /actually used/ in the expressions are +-- in the second argument. (Tags are not used if a bound variable has no usage occurrence.) +-- +-- Bail out if any tag occurs multiple times as this indicates that the sharing of an argument +-- variable was not preserved and we cannot build an appropriate initial environment (c.f., comments +-- at 'determineScopesAcc'. +-- +buildInitialEnvAcc :: [Level] -> [StableSharingAcc] -> [StableSharingAcc] +buildInitialEnvAcc tags sas = map (lookupSA sas) tags + where + lookupSA sas tag1 + = case filter hasTag sas of + [] -> noStableSharing -- tag is not used in the analysed expression + [sa] -> sa -- tag has a unique occurrence + sas2 -> INTERNAL_ERROR(error) "buildInitialEnvAcc" + $ "Encountered duplicate 'ATag's\n " ++ intercalate ", " (map showSA sas2) + where + hasTag (StableSharingAcc _ (AccSharing _ (Atag tag2))) = tag1 == tag2 + hasTag sa + = INTERNAL_ERROR(error) "buildInitialEnvAcc" + $ "Encountered a node that is not a plain 'Atag'\n " ++ showSA sa + + noStableSharing :: StableSharingAcc + noStableSharing = StableSharingAcc noStableAccName (undefined :: SharingAcc ()) + + showSA (StableSharingAcc _ (AccSharing sn acc)) = show (hashStableNameHeight sn) ++ ": " ++ + showPreAccOp acc + showSA (StableSharingAcc _ (AvarSharing sn)) = "AvarSharing " ++ show (hashStableNameHeight sn) + showSA (StableSharingAcc _ (AletSharing sa _ )) = "AletSharing " ++ show sa ++ "..." + +-- Build an initial environment for the tag values given in the first argument for traversing a +-- scalar expression. The 'StableSharingExp's for all tags /actually used/ in the expressions are +-- in the second argument. (Tags are not used if a bound variable has no usage occurrence.) +-- +-- Bail out if any tag occurs multiple times as this indicates that the sharing of an argument +-- variable was not preserved and we cannot build an appropriate initial environment (c.f., comments +-- at 'determineScopesAcc'. +-- +buildInitialEnvExp :: [Level] -> [StableSharingExp] -> [StableSharingExp] +buildInitialEnvExp tags ses = map (lookupSE ses) tags + where + lookupSE ses tag1 + = case filter hasTag ses of + [] -> noStableSharing -- tag is not used in the analysed expression + [se] -> se -- tag has a unique occurrence + ses2 -> INTERNAL_ERROR(error) "buildInitialEnvExp" + ("Encountered a duplicate 'Tag'\n " ++ intercalate ", " (map showSE ses2)) + where + hasTag (StableSharingExp _ (ExpSharing _ (Tag tag2))) = tag1 == tag2 + hasTag se + = INTERNAL_ERROR(error) "buildInitialEnvExp" + ("Encountered a node that is not a plain 'Tag'\n " ++ showSE se) + + noStableSharing :: StableSharingExp + noStableSharing = StableSharingExp noStableExpName (undefined :: SharingExp ()) + + showSE (StableSharingExp _ (ExpSharing sn exp)) = show (hashStableNameHeight sn) ++ ": " ++ + showPreExpOp exp + showSE (StableSharingExp _ (VarSharing sn)) = "VarSharing " ++ show (hashStableNameHeight sn) + showSE (StableSharingExp _ (LetSharing se _ )) = "LetSharing " ++ show se ++ "..." + +-- Determine whether a 'NodeCount' is for an 'Atag' or 'Tag', which represent free variables. +-- +isFreeVar :: NodeCount -> Bool +isFreeVar (AccNodeCount (StableSharingAcc _ (AccSharing _ (Atag _))) _) = True +isFreeVar (ExpNodeCount (StableSharingExp _ (ExpSharing _ (Tag _))) _) = True +isFreeVar _ = False + + +-- Determine scope of shared subterms +-- ================================== + +-- Determine the scopes of all variables representing shared subterms (Phase Two) in a bottom-up +-- sweep. The first argument determines whether array computations are floated out of expressions +-- irrespective of whether they are shared or not — 'True' implies floating them out. +-- +-- In addition to the AST with sharing information, yield the 'StableSharingAcc's for all free +-- variables of 'rootAcc', which are represented by 'Atag' leaves in the tree. They are in order of +-- the tag values — i.e., in the same order that they need to appear in an environment to use the +-- tag for indexing into that environment. +-- +-- Precondition: there are only 'AvarSharing' and 'AccSharing' nodes in the argument. +-- +determineScopesAcc + :: Typeable a + => Config + -> [Level] + -> OccMap Acc + -> SharingAcc a + -> (SharingAcc a, [StableSharingAcc]) +determineScopesAcc config fvs accOccMap rootAcc + = let (sharingAcc, counts) = determineScopesSharingAcc config accOccMap rootAcc + unboundTrees = filter (not . isFreeVar) counts + in + if all isFreeVar counts + then (sharingAcc, buildInitialEnvAcc fvs [sa | AccNodeCount sa _ <- counts]) + else INTERNAL_ERROR(error) "determineScopesAcc" ("unbound shared subtrees" ++ show unboundTrees) + + +determineScopesSharingAcc + :: Config + -> OccMap Acc + -> SharingAcc a + -> (SharingAcc a, NodeCounts) +determineScopesSharingAcc config accOccMap = scopesAcc + where + scopesAcc :: forall arrs. SharingAcc arrs -> (SharingAcc arrs, NodeCounts) + scopesAcc (AletSharing _ _) + = INTERNAL_ERROR(error) "determineScopesSharingAcc: scopesAcc" "unexpected 'AletSharing'" + + scopesAcc sharingAcc@(AvarSharing sn) + = (sharingAcc, StableSharingAcc sn sharingAcc `accNodeCount` 1) + + scopesAcc (AccSharing sn pacc) + = case pacc of + Atag i -> reconstruct (Atag i) noNodeCounts + Pipe afun1 afun2 acc -> travA (Pipe afun1 afun2) acc + -- we are not traversing 'afun1' & 'afun2' — see Note [Pipe and sharing recovery] + Aforeign ff afun acc -> let + (acc', accCount) = scopesAcc acc + in + reconstruct (Aforeign ff afun acc') accCount + Acond e acc1 acc2 -> let + (e' , accCount1) = scopesExp e + (acc1', accCount2) = scopesAcc acc1 + (acc2', accCount3) = scopesAcc acc2 + in + reconstruct (Acond e' acc1' acc2') + (accCount1 +++ accCount2 +++ accCount3) + + Atuple tup -> let (tup', accCount) = travAtup tup + in reconstruct (Atuple tup') accCount + Aprj ix a -> travA (Aprj ix) a + + Use arr -> reconstruct (Use arr) noNodeCounts + Unit e -> let + (e', accCount) = scopesExp e + in + reconstruct (Unit e') accCount + Generate sh f -> let + (sh', accCount1) = scopesExp sh + (f' , accCount2) = scopesFun1 f + in + reconstruct (Generate sh' f') (accCount1 +++ accCount2) + Reshape sh acc -> travEA Reshape sh acc + Replicate n acc -> travEA Replicate n acc + Slice acc i -> travEA (flip Slice) i acc + Map f acc -> let + (f' , accCount1) = scopesFun1 f + (acc', accCount2) = scopesAcc acc + in + reconstruct (Map f' acc') (accCount1 +++ accCount2) + ZipWith f acc1 acc2 -> travF2A2 ZipWith f acc1 acc2 + Fold f z acc -> travF2EA Fold f z acc + Fold1 f acc -> travF2A Fold1 f acc + FoldSeg f z acc1 acc2 -> let + (f' , accCount1) = scopesFun2 f + (z' , accCount2) = scopesExp z + (acc1', accCount3) = scopesAcc acc1 + (acc2', accCount4) = scopesAcc acc2 + in + reconstruct (FoldSeg f' z' acc1' acc2') + (accCount1 +++ accCount2 +++ accCount3 +++ accCount4) + Fold1Seg f acc1 acc2 -> travF2A2 Fold1Seg f acc1 acc2 + Scanl f z acc -> travF2EA Scanl f z acc + Scanl' f z acc -> travF2EA Scanl' f z acc + Scanl1 f acc -> travF2A Scanl1 f acc + Scanr f z acc -> travF2EA Scanr f z acc + Scanr' f z acc -> travF2EA Scanr' f z acc + Scanr1 f acc -> travF2A Scanr1 f acc + Permute fc acc1 fp acc2 -> let + (fc' , accCount1) = scopesFun2 fc + (acc1', accCount2) = scopesAcc acc1 + (fp' , accCount3) = scopesFun1 fp + (acc2', accCount4) = scopesAcc acc2 + in + reconstruct (Permute fc' acc1' fp' acc2') + (accCount1 +++ accCount2 +++ accCount3 +++ accCount4) + Backpermute sh fp acc -> let + (sh' , accCount1) = scopesExp sh + (fp' , accCount2) = scopesFun1 fp + (acc', accCount3) = scopesAcc acc + in + reconstruct (Backpermute sh' fp' acc') + (accCount1 +++ accCount2 +++ accCount3) + Stencil st bnd acc -> let + (st' , accCount1) = scopesStencil1 acc st + (acc', accCount2) = scopesAcc acc + in + reconstruct (Stencil st' bnd acc') (accCount1 +++ accCount2) + Stencil2 st bnd1 acc1 bnd2 acc2 + -> let + (st' , accCount1) = scopesStencil2 acc1 acc2 st + (acc1', accCount2) = scopesAcc acc1 + (acc2', accCount3) = scopesAcc acc2 + in + reconstruct (Stencil2 st' bnd1 acc1' bnd2 acc2') + (accCount1 +++ accCount2 +++ accCount3) + where + travEA :: Arrays arrs + => (RootExp e -> SharingAcc arrs' -> PreAcc SharingAcc RootExp arrs) + -> RootExp e + -> SharingAcc arrs' + -> (SharingAcc arrs, NodeCounts) + travEA c e acc = reconstruct (c e' acc') (accCount1 +++ accCount2) + where + (e' , accCount1) = scopesExp e + (acc', accCount2) = scopesAcc acc + + travF2A :: (Elt a, Elt b, Arrays arrs) + => ((Exp a -> Exp b -> RootExp c) -> SharingAcc arrs' + -> PreAcc SharingAcc RootExp arrs) + -> (Exp a -> Exp b -> RootExp c) + -> SharingAcc arrs' + -> (SharingAcc arrs, NodeCounts) + travF2A c f acc = reconstruct (c f' acc') (accCount1 +++ accCount2) + where + (f' , accCount1) = scopesFun2 f + (acc', accCount2) = scopesAcc acc + + travF2EA :: (Elt a, Elt b, Arrays arrs) + => ((Exp a -> Exp b -> RootExp c) -> RootExp e + -> SharingAcc arrs' -> PreAcc SharingAcc RootExp arrs) + -> (Exp a -> Exp b -> RootExp c) + -> RootExp e + -> SharingAcc arrs' + -> (SharingAcc arrs, NodeCounts) + travF2EA c f e acc = reconstruct (c f' e' acc') (accCount1 +++ accCount2 +++ accCount3) + where + (f' , accCount1) = scopesFun2 f + (e' , accCount2) = scopesExp e + (acc', accCount3) = scopesAcc acc + + travF2A2 :: (Elt a, Elt b, Arrays arrs) + => ((Exp a -> Exp b -> RootExp c) -> SharingAcc arrs1 + -> SharingAcc arrs2 -> PreAcc SharingAcc RootExp arrs) + -> (Exp a -> Exp b -> RootExp c) + -> SharingAcc arrs1 + -> SharingAcc arrs2 + -> (SharingAcc arrs, NodeCounts) + travF2A2 c f acc1 acc2 = reconstruct (c f' acc1' acc2') + (accCount1 +++ accCount2 +++ accCount3) + where + (f' , accCount1) = scopesFun2 f + (acc1', accCount2) = scopesAcc acc1 + (acc2', accCount3) = scopesAcc acc2 + + travAtup :: Tuple.Atuple SharingAcc a + -> (Tuple.Atuple SharingAcc a, NodeCounts) + travAtup NilAtup = (NilAtup, noNodeCounts) + travAtup (SnocAtup tup a) = let (tup', accCountT) = travAtup tup + (a', accCountA) = scopesAcc a + in + (SnocAtup tup' a', accCountT +++ accCountA) + + travA :: Arrays arrs + => (SharingAcc arrs' -> PreAcc SharingAcc RootExp arrs) + -> SharingAcc arrs' + -> (SharingAcc arrs, NodeCounts) + travA c acc = reconstruct (c acc') accCount + where + (acc', accCount) = scopesAcc acc + + -- Occurrence count of the currently processed node + accOccCount = let StableNameHeight sn' _ = sn + in + lookupWithASTName accOccMap (StableASTName sn') + + -- Reconstruct the current tree node. + -- + -- * If the current node is being shared ('accOccCount > 1'), replace it by a 'AvarSharing' + -- node and float the shared subtree out wrapped in a 'NodeCounts' value. + -- * If the current node is not shared, reconstruct it in place. + -- * Special case for free variables ('Atag'): Replace the tree by a sharing variable and + -- float the 'Atag' out in a 'NodeCounts' value. This is independent of the number of + -- occurrences. + -- + -- In either case, any completed 'NodeCounts' are injected as bindings using 'AletSharing' + -- node. + -- + reconstruct :: Arrays arrs + => PreAcc SharingAcc RootExp arrs -> NodeCounts + -> (SharingAcc arrs, NodeCounts) + reconstruct newAcc@(Atag _) _subCount + -- free variable => replace by a sharing variable regardless of the number of + -- occurrences + = let thisCount = StableSharingAcc sn (AccSharing sn newAcc) `accNodeCount` 1 + in + tracePure "FREE" (show thisCount) + (AvarSharing sn, thisCount) + reconstruct newAcc subCount + -- shared subtree => replace by a sharing variable (if 'recoverAccSharing' enabled) + | accOccCount > 1 && recoverAccSharing config + = let allCount = (StableSharingAcc sn sharingAcc `accNodeCount` 1) +++ newCount + in + tracePure ("SHARED" ++ completed) (show allCount) + (AvarSharing sn, allCount) + -- neither shared nor free variable => leave it as it is + | otherwise + = tracePure ("Normal" ++ completed) (show newCount) + (sharingAcc, newCount) + where + -- Determine the bindings that need to be attached to the current node... + (newCount, bindHere) = filterCompleted subCount + + -- ...and wrap them in 'AletSharing' constructors + lets = foldl (flip (.)) id . map AletSharing $ bindHere + sharingAcc = lets $ AccSharing sn newAcc + + -- trace support + completed | null bindHere = "" + | otherwise = "(" ++ show (length bindHere) ++ " lets)" + + -- Extract *leading* nodes that have a complete node count (i.e., their node count is equal + -- to the number of occurrences of that node in the overall expression). + -- + -- Nodes with a completed node count should be let bound at the currently processed node. + -- + -- NB: Only extract leading nodes (i.e., the longest run at the *front* of the list that is + -- complete). Otherwise, we would let-bind subterms before their parents, which leads + -- scope errors. + -- + filterCompleted :: NodeCounts -> (NodeCounts, [StableSharingAcc]) + filterCompleted counts + = let (completed, counts') = break notComplete counts + in (counts', [sa | AccNodeCount sa _ <- completed]) + where + -- a node is not yet complete while the node count 'n' is below the overall number + -- of occurrences for that node in the whole program, with the exception that free + -- variables are never complete + notComplete nc@(AccNodeCount sa n) | not . isFreeVar $ nc = lookupWithSharingAcc accOccMap sa > n + notComplete _ = True + + scopesExp :: RootExp t -> (RootExp t, NodeCounts) + scopesExp = determineScopesExp config accOccMap + + -- The lambda bound variable is at this point already irrelevant; for details, see + -- Note [Traversing functions and side effects] + -- + scopesFun1 :: Elt e1 => (Exp e1 -> RootExp e2) -> (Exp e1 -> RootExp e2, NodeCounts) + scopesFun1 f = (const body, counts) + where + (body, counts) = scopesExp (f undefined) + + -- The lambda bound variable is at this point already irrelevant; for details, see + -- Note [Traversing functions and side effects] + -- + scopesFun2 :: (Elt e1, Elt e2) + => (Exp e1 -> Exp e2 -> RootExp e3) + -> (Exp e1 -> Exp e2 -> RootExp e3, NodeCounts) + scopesFun2 f = (\_ _ -> body, counts) + where + (body, counts) = scopesExp (f undefined undefined) + + -- The lambda bound variable is at this point already irrelevant; for details, see + -- Note [Traversing functions and side effects] + -- + scopesStencil1 :: forall sh e1 e2 stencil. Stencil sh e1 stencil + => SharingAcc (Array sh e1){-dummy-} + -> (stencil -> RootExp e2) + -> (stencil -> RootExp e2, NodeCounts) + scopesStencil1 _ stencilFun = (const body, counts) + where + (body, counts) = scopesExp (stencilFun undefined) + + -- The lambda bound variable is at this point already irrelevant; for details, see + -- Note [Traversing functions and side effects] + -- + scopesStencil2 :: forall sh e1 e2 e3 stencil1 stencil2. + (Stencil sh e1 stencil1, Stencil sh e2 stencil2) + => SharingAcc (Array sh e1){-dummy-} + -> SharingAcc (Array sh e2){-dummy-} + -> (stencil1 -> stencil2 -> RootExp e3) + -> (stencil1 -> stencil2 -> RootExp e3, NodeCounts) + scopesStencil2 _ _ stencilFun = (\_ _ -> body, counts) + where + (body, counts) = scopesExp (stencilFun undefined undefined) + + +determineScopesExp + :: Config + -> OccMap Acc + -> RootExp t + -> (RootExp t, NodeCounts) -- Root (closed) expression plus Acc node counts +determineScopesExp config accOccMap (OccMapExp fvs expOccMap exp) + = let + (expWithScopes, nodeCounts) = determineScopesSharingExp config accOccMap expOccMap exp + (expCounts, accCounts) = break isAccNodeCount nodeCounts + + isAccNodeCount AccNodeCount{} = True + isAccNodeCount _ = False + in + (EnvExp (buildInitialEnvExp fvs [se | ExpNodeCount se _ <- expCounts]) expWithScopes, accCounts) + +determineScopesExp _ _ _ = INTERNAL_ERROR(error) "determineScopesExp" "not an 'OccMapExp'" + + +determineScopesSharingExp + :: Config + -> OccMap Acc + -> OccMap Exp + -> SharingExp t + -> (SharingExp t, NodeCounts) +determineScopesSharingExp config accOccMap expOccMap = scopesExp + where + scopesAcc :: SharingAcc a -> (SharingAcc a, NodeCounts) + scopesAcc = determineScopesSharingAcc config accOccMap + + scopesExp :: forall t. SharingExp t -> (SharingExp t, NodeCounts) + scopesExp (LetSharing _ _) + = INTERNAL_ERROR(error) "determineScopesSharingExp: scopesExp" "unexpected 'LetSharing'" + + scopesExp sharingExp@(VarSharing sn) + = (sharingExp, StableSharingExp sn sharingExp `expNodeCount` 1) + + scopesExp (ExpSharing sn pexp) + = case pexp of + Tag i -> reconstruct (Tag i) noNodeCounts + Const c -> reconstruct (Const c) noNodeCounts + Tuple tup -> let (tup', accCount) = travTup tup + in + reconstruct (Tuple tup') accCount + Prj i e -> travE1 (Prj i) e + IndexNil -> reconstruct IndexNil noNodeCounts + IndexCons ix i -> travE2 IndexCons ix i + IndexHead i -> travE1 IndexHead i + IndexTail ix -> travE1 IndexTail ix + IndexAny -> reconstruct IndexAny noNodeCounts + ToIndex sh ix -> travE2 ToIndex sh ix + FromIndex sh e -> travE2 FromIndex sh e + Cond e1 e2 e3 -> travE3 Cond e1 e2 e3 + PrimConst c -> reconstruct (PrimConst c) noNodeCounts + PrimApp p e -> travE1 (PrimApp p) e + Index a e -> travAE Index a e + LinearIndex a e -> travAE LinearIndex a e + Shape a -> travA Shape a + ShapeSize e -> travE1 ShapeSize e + Foreign ff f e -> travE1 (Foreign ff f) e + where + travTup :: Tuple.Tuple SharingExp tup -> (Tuple.Tuple SharingExp tup, NodeCounts) + travTup NilTup = (NilTup, noNodeCounts) + travTup (SnocTup tup e) = let + (tup', accCountT) = travTup tup + (e' , accCountE) = scopesExp e + in + (SnocTup tup' e', accCountT +++ accCountE) + + travE1 :: (SharingExp a -> PreExp SharingAcc SharingExp t) -> SharingExp a + -> (SharingExp t, NodeCounts) + travE1 c e = reconstruct (c e') accCount + where + (e', accCount) = scopesExp e + + travE2 :: (SharingExp a -> SharingExp b -> PreExp SharingAcc SharingExp t) + -> SharingExp a + -> SharingExp b + -> (SharingExp t, NodeCounts) + travE2 c e1 e2 = reconstruct (c e1' e2') (accCount1 +++ accCount2) + where + (e1', accCount1) = scopesExp e1 + (e2', accCount2) = scopesExp e2 + + travE3 :: (SharingExp a -> SharingExp b -> SharingExp c -> PreExp SharingAcc SharingExp t) + -> SharingExp a + -> SharingExp b + -> SharingExp c + -> (SharingExp t, NodeCounts) + travE3 c e1 e2 e3 = reconstruct (c e1' e2' e3') (accCount1 +++ accCount2 +++ accCount3) + where + (e1', accCount1) = scopesExp e1 + (e2', accCount2) = scopesExp e2 + (e3', accCount3) = scopesExp e3 + + travA :: (SharingAcc a -> PreExp SharingAcc SharingExp t) -> SharingAcc a + -> (SharingExp t, NodeCounts) + travA c acc = maybeFloatOutAcc c acc' accCount + where + (acc', accCount) = scopesAcc acc + + travAE :: (SharingAcc a -> SharingExp b -> PreExp SharingAcc SharingExp t) + -> SharingAcc a + -> SharingExp b + -> (SharingExp t, NodeCounts) + travAE c acc e = maybeFloatOutAcc (`c` e') acc' (accCountA +++ accCountE) + where + (acc', accCountA) = scopesAcc acc + (e' , accCountE) = scopesExp e + + maybeFloatOutAcc :: (SharingAcc a -> PreExp SharingAcc SharingExp t) + -> SharingAcc a + -> NodeCounts + -> (SharingExp t, NodeCounts) + maybeFloatOutAcc c acc@(AvarSharing _) accCount -- nothing to float out + = reconstruct (c acc) accCount + maybeFloatOutAcc c acc accCount + | floatOutAcc config = reconstruct (c var) ((stableAcc `accNodeCount` 1) +++ accCount) + | otherwise = reconstruct (c acc) accCount + where + (var, stableAcc) = abstract acc id + + abstract :: SharingAcc a -> (SharingAcc a -> SharingAcc a) + -> (SharingAcc a, StableSharingAcc) + abstract (AvarSharing _) _ = INTERNAL_ERROR(error) "sharingAccToVar" "AvarSharing" + abstract (AletSharing sa acc) lets = abstract acc (lets . AletSharing sa) + abstract acc@(AccSharing sn _) lets = (AvarSharing sn, StableSharingAcc sn (lets acc)) + + -- Occurrence count of the currently processed node + expOccCount = let StableNameHeight sn' _ = sn + in + lookupWithASTName expOccMap (StableASTName sn') + + -- Reconstruct the current tree node. + -- + -- * If the current node is being shared ('expOccCount > 1'), replace it by a 'VarSharing' + -- node and float the shared subtree out wrapped in a 'NodeCounts' value. + -- * If the current node is not shared, reconstruct it in place. + -- * Special case for free variables ('Tag'): Replace the tree by a sharing variable and + -- float the 'Tag' out in a 'NodeCounts' value. This is independent of the number of + -- occurrences. + -- + -- In either case, any completed 'NodeCounts' are injected as bindings using 'LetSharing' + -- node. + -- + reconstruct :: PreExp SharingAcc SharingExp t -> NodeCounts + -> (SharingExp t, NodeCounts) + reconstruct newExp@(Tag _) _subCount + -- free variable => replace by a sharing variable regardless of the number of + -- occurrences + = let thisCount = StableSharingExp sn (ExpSharing sn newExp) `expNodeCount` 1 + in + tracePure "FREE" (show thisCount) + (VarSharing sn, thisCount) + reconstruct newExp subCount + -- shared subtree => replace by a sharing variable (if 'recoverExpSharing' enabled) + | expOccCount > 1 && recoverExpSharing config + = let allCount = (StableSharingExp sn sharingExp `expNodeCount` 1) +++ newCount + in + tracePure ("SHARED" ++ completed) (show allCount) + (VarSharing sn, allCount) + -- neither shared nor free variable => leave it as it is + | otherwise + = tracePure ("Normal" ++ completed) (show newCount) + (sharingExp, newCount) + where + -- Determine the bindings that need to be attached to the current node... + (newCount, bindHere) = filterCompleted subCount + + -- ...and wrap them in 'LetSharing' constructors + lets = foldl (flip (.)) id . map LetSharing $ bindHere + sharingExp = lets $ ExpSharing sn newExp + + -- trace support + completed | null bindHere = "" + | otherwise = "(" ++ show (length bindHere) ++ " lets)" + + -- Extract *leading* nodes that have a complete node count (i.e., their node count is equal + -- to the number of occurrences of that node in the overall expression). + -- + -- Nodes with a completed node count should be let bound at the currently processed node. + -- + -- NB: Only extract leading nodes (i.e., the longest run at the *front* of the list that is + -- complete). Otherwise, we would let-bind subterms before their parents, which leads + -- scope errors. + -- + filterCompleted :: NodeCounts -> (NodeCounts, [StableSharingExp]) + filterCompleted counts + = let (completed, counts') = break notComplete counts + in (counts', [sa | ExpNodeCount sa _ <- completed]) + where + -- a node is not yet complete while the node count 'n' is below the overall number + -- of occurrences for that node in the whole program, with the exception that free + -- variables are never complete + notComplete nc@(ExpNodeCount sa n) | not . isFreeVar $ nc = lookupWithSharingExp expOccMap sa > n + notComplete _ = True + + +-- |Recover sharing information and annotate the HOAS AST with variable and let binding +-- annotations. The first argument determines whether array computations are floated out of +-- expressions irrespective of whether they are shared or not — 'True' implies floating them out. +-- +-- Also returns the 'StableSharingAcc's of all 'Atag' leaves in environment order — they represent +-- the free variables of the AST. +-- +-- NB: Strictly speaking, this function is not deterministic, as it uses stable pointers to +-- determine the sharing of subterms. The stable pointer API does not guarantee its +-- completeness; i.e., it may miss some equalities, which implies that we may fail to discover +-- some sharing. However, sharing does not affect the denotational meaning of an array +-- computation; hence, we do not compromise denotational correctness. +-- +-- There is one caveat: We currently rely on the 'Atag' and 'Tag' leaves representing free +-- variables to be shared if any of them is used more than once. If one is duplicated, the +-- 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.) +-- +recoverSharingAcc + :: Typeable a + => Config + -> Level -- The level of currently bound array variables + -> [Level] -- The tags of newly introduced free array variables + -> Acc a + -> (SharingAcc a, [StableSharingAcc]) +{-# NOINLINE recoverSharingAcc #-} +recoverSharingAcc config alvl avars acc + = let (acc', occMap) + = unsafePerformIO -- to enable stable pointers; this is safe as explained above + $ makeOccMapAcc config alvl acc + in + determineScopesAcc config avars occMap acc' + + +recoverSharingExp + :: Typeable e + => Config + -> Level -- The level of currently bound scalar variables + -> [Level] -- The tags of newly introduced free scalar variables + -> Exp e + -> (SharingExp e, [StableSharingExp]) +{-# NOINLINE recoverSharingExp #-} +recoverSharingExp config lvl fvar exp + = let + (rootExp, accOccMap) = unsafePerformIO $ do + accOccMap <- newASTHashTable + (exp', _) <- makeOccMapRootExp config accOccMap lvl fvar exp + frozenAccOccMap <- freezeOccMap accOccMap + + return (exp', frozenAccOccMap) + + (EnvExp sse sharingExp, _) = + determineScopesExp config accOccMap rootExp + in + (sharingExp, sse) + + +-- Debugging +-- --------- + +traceLine :: String -> String -> IO () +traceLine header msg + = Debug.traceMessage Debug.dump_sharing + $ header ++ ": " ++ msg + +traceChunk :: String -> String -> IO () +traceChunk header msg + = Debug.traceMessage Debug.dump_sharing + $ header ++ "\n " ++ msg + +tracePure :: String -> String -> a -> a +tracePure header msg + = Debug.tracePure Debug.dump_sharing + $ header ++ ": " ++ msg + + +_showSharingAccOp :: SharingAcc arrs -> String +_showSharingAccOp (AvarSharing sn) = "AVAR " ++ show (hashStableNameHeight sn) +_showSharingAccOp (AletSharing _ acc) = "ALET " ++ _showSharingAccOp acc +_showSharingAccOp (AccSharing _ acc) = showPreAccOp acc + diff --git a/Data/Array/Accelerate/Trafo/Shrink.hs b/Data/Array/Accelerate/Trafo/Shrink.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/Trafo/Shrink.hs @@ -0,0 +1,404 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} +-- | +-- Module : Data.Array.Accelerate.Trafo.Shrink +-- Copyright : [2012..2013] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Manuel M T Chakravarty +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- +-- The shrinking substitution arises as a restriction of beta-reduction to cases +-- where the bound variable is used zero (dead-code elimination) or one (linear +-- inlining) times. By simplifying terms, the shrinking reduction can expose +-- opportunities for further optimisation. +-- +-- TODO: replace with a linear shrinking algorithm; e.g. +-- +-- * Andrew Appel & Trevor Jim, "Shrinking lambda expressions in linear time". +-- +-- * Nick Benton, Andrew Kennedy, Sam Lindley and Claudio Russo, "Shrinking +-- Reductions in SML.NET" +-- + +module Data.Array.Accelerate.Trafo.Shrink ( + + -- Shrinking + Shrink(..), + ShrinkAcc, shrinkPreAcc, basicReduceAcc, + + -- Occurrence counting + UsesOfAcc, usesOfPreAcc, usesOfExp, + +) where + +-- friends +import Data.Array.Accelerate.AST +import Data.Array.Accelerate.Tuple +import Data.Array.Accelerate.Trafo.Base +import Data.Array.Accelerate.Array.Sugar ( Arrays ) +import Data.Array.Accelerate.Trafo.Substitution + +import qualified Data.Array.Accelerate.Debug as Stats + +-- standard library +import Prelude hiding ( exp ) +import Data.Monoid +import Control.Applicative hiding ( Const ) + + +class Shrink f where + shrink :: f -> f + shrink' :: f -> (Bool, f) + + shrink = snd . shrink' + +instance Shrink (PreOpenExp acc env aenv e) where + shrink' = shrinkExp + +instance Shrink (PreOpenFun acc env aenv f) where + shrink' = shrinkFun + + +-- Shrinking +-- ========= + +-- The shrinking substitution for scalar expressions. This is a restricted +-- instance of beta-reduction to cases where the bound variable is used zero +-- (dead-code elimination) or one (linear inlining) times. +-- +shrinkExp :: PreOpenExp acc env aenv t -> (Bool, PreOpenExp acc env aenv t) +shrinkExp = Stats.substitution "shrink exp" . first getAny . shrinkE + where + -- If the bound variable is used at most this many times, it will be inlined + -- into the body. In cases where it is not used at all, this is equivalent + -- to dead-code elimination. + -- + lIMIT = 1 + + shrinkE :: PreOpenExp acc env aenv t -> (Any, PreOpenExp acc env aenv t) + shrinkE exp = case exp of + Let bnd body + | Var _ <- bnd -> Stats.inline "Var" . yes $ shrinkE (inline body bnd) + | uses <= lIMIT -> Stats.betaReduce msg . yes $ shrinkE (inline (snd body') (snd bnd')) + | otherwise -> Let <$> bnd' <*> body' + where + bnd' = shrinkE bnd + body' = shrinkE body + uses = usesOfExp ZeroIdx (snd body') + + msg = case uses of + 0 -> "dead exp" + _ -> "inline exp" -- forced inlining when lIMIT > 1 + -- + Var idx -> pure (Var idx) + Const c -> pure (Const c) + Tuple t -> Tuple <$> shrinkT t + Prj tup e -> Prj tup <$> shrinkE e + IndexNil -> pure IndexNil + IndexCons sl sz -> IndexCons <$> shrinkE sl <*> shrinkE sz + IndexHead sh -> IndexHead <$> shrinkE sh + IndexTail sh -> IndexTail <$> shrinkE sh + IndexSlice x ix sh -> IndexSlice x <$> shrinkE ix <*> shrinkE sh + IndexFull x ix sl -> IndexFull x <$> shrinkE ix <*> shrinkE sl + IndexAny -> pure IndexAny + ToIndex sh ix -> ToIndex <$> shrinkE sh <*> shrinkE ix + FromIndex sh i -> FromIndex <$> shrinkE sh <*> shrinkE i + Cond p t e -> Cond <$> shrinkE p <*> shrinkE t <*> shrinkE e + Iterate n f x -> Iterate <$> shrinkE n <*> shrinkE f <*> shrinkE x + PrimConst c -> pure (PrimConst c) + PrimApp f x -> PrimApp f <$> shrinkE x + Index a sh -> Index a <$> shrinkE sh + LinearIndex a i -> LinearIndex a <$> shrinkE i + Shape a -> pure (Shape a) + ShapeSize sh -> ShapeSize <$> shrinkE sh + Intersect sh sz -> Intersect <$> shrinkE sh <*> shrinkE sz + Foreign ff f e -> Foreign ff <$> shrinkF f <*> shrinkE e + + shrinkT :: Tuple (PreOpenExp acc env aenv) t -> (Any, Tuple (PreOpenExp acc env aenv) t) + shrinkT NilTup = pure NilTup + shrinkT (SnocTup t e) = SnocTup <$> shrinkT t <*> shrinkE e + + shrinkF :: PreOpenFun acc env aenv t -> (Any, PreOpenFun acc env aenv t) + shrinkF = first Any . shrinkFun + + first :: (a -> a') -> (a,b) -> (a',b) + first f (x,y) = (f x, y) + + yes :: (Any, x) -> (Any, x) + yes (_, x) = (Any True, x) + +shrinkFun :: PreOpenFun acc env aenv f -> (Bool, PreOpenFun acc env aenv f) +shrinkFun (Lam f) = Lam <$> shrinkFun f +shrinkFun (Body b) = Body <$> shrinkExp b + + +-- The shrinking substitution for array computations. This is further limited to +-- dead-code elimination only, primarily because linear inlining may inline +-- array computations into scalar expressions, which is generally not desirable. +-- +type ShrinkAcc acc = forall aenv a. acc aenv a -> acc aenv a +type ReduceAcc acc = forall aenv s t. acc aenv s -> acc (aenv,s) t -> Maybe (PreOpenAcc acc aenv t) + +shrinkPreAcc + :: forall acc aenv arrs. ShrinkAcc acc -> ReduceAcc acc + -> PreOpenAcc acc aenv arrs + -> PreOpenAcc acc aenv arrs +shrinkPreAcc shrinkAcc reduceAcc = Stats.substitution "shrink acc" shrinkA + where + shrinkA :: PreOpenAcc acc aenv' a -> PreOpenAcc acc aenv' a + shrinkA pacc = case pacc of + Alet bnd body + | Just reduct <- reduceAcc bnd' body' -> shrinkA reduct + | otherwise -> Alet bnd' body' + where + bnd' = shrinkAcc bnd + body' = shrinkAcc body + -- + Avar ix -> Avar ix + Atuple tup -> Atuple (shrinkAT tup) + Aprj tup a -> Aprj tup (shrinkAcc a) + Apply f a -> Apply (shrinkAF f) (shrinkAcc a) + Aforeign ff af a -> Aforeign ff af (shrinkAcc a) + Acond p t e -> Acond (shrinkE p) (shrinkAcc t) (shrinkAcc e) + Use a -> Use a + Unit e -> Unit (shrinkE e) + Reshape e a -> Reshape (shrinkE e) (shrinkAcc a) + Generate e f -> Generate (shrinkE e) (shrinkF f) + Transform sh ix f a -> Transform (shrinkE sh) (shrinkF ix) (shrinkF f) (shrinkAcc a) + Replicate sl slix a -> Replicate sl (shrinkE slix) (shrinkAcc a) + Slice sl a slix -> Slice sl (shrinkAcc a) (shrinkE slix) + Map f a -> Map (shrinkF f) (shrinkAcc a) + ZipWith f a1 a2 -> ZipWith (shrinkF f) (shrinkAcc a1) (shrinkAcc a2) + Fold f z a -> Fold (shrinkF f) (shrinkE z) (shrinkAcc a) + Fold1 f a -> Fold1 (shrinkF f) (shrinkAcc a) + FoldSeg f z a b -> FoldSeg (shrinkF f) (shrinkE z) (shrinkAcc a) (shrinkAcc b) + Fold1Seg f a b -> Fold1Seg (shrinkF f) (shrinkAcc a) (shrinkAcc b) + Scanl f z a -> Scanl (shrinkF f) (shrinkE z) (shrinkAcc a) + Scanl' f z a -> Scanl' (shrinkF f) (shrinkE z) (shrinkAcc a) + Scanl1 f a -> Scanl1 (shrinkF f) (shrinkAcc a) + Scanr f z a -> Scanr (shrinkF f) (shrinkE z) (shrinkAcc a) + Scanr' f z a -> Scanr' (shrinkF f) (shrinkE z) (shrinkAcc a) + Scanr1 f a -> Scanr1 (shrinkF f) (shrinkAcc a) + Permute f1 a1 f2 a2 -> Permute (shrinkF f1) (shrinkAcc a1) (shrinkF f2) (shrinkAcc a2) + Backpermute sh f a -> Backpermute (shrinkE sh) (shrinkF f) (shrinkAcc a) + Stencil f b a -> Stencil (shrinkF f) b (shrinkAcc a) + Stencil2 f b1 a1 b2 a2 -> Stencil2 (shrinkF f) b1 (shrinkAcc a1) b2 (shrinkAcc a2) + + shrinkE :: PreOpenExp acc env aenv' t -> PreOpenExp acc env aenv' t + shrinkE exp = case exp of + Let bnd body -> Let (shrinkE bnd) (shrinkE body) + Var idx -> Var idx + Const c -> Const c + Tuple t -> Tuple (shrinkT t) + Prj tup e -> Prj tup (shrinkE e) + IndexNil -> IndexNil + IndexCons sl sz -> IndexCons (shrinkE sl) (shrinkE sz) + IndexHead sh -> IndexHead (shrinkE sh) + IndexTail sh -> IndexTail (shrinkE sh) + IndexSlice x ix sh -> IndexSlice x (shrinkE ix) (shrinkE sh) + IndexFull x ix sl -> IndexFull x (shrinkE ix) (shrinkE sl) + IndexAny -> IndexAny + ToIndex sh ix -> ToIndex (shrinkE sh) (shrinkE ix) + FromIndex sh i -> FromIndex (shrinkE sh) (shrinkE i) + Cond p t e -> Cond (shrinkE p) (shrinkE t) (shrinkE e) + Iterate n f x -> Iterate (shrinkE n) (shrinkE f) (shrinkE x) + PrimConst c -> PrimConst c + PrimApp f x -> PrimApp f (shrinkE x) + Index a sh -> Index (shrinkAcc a) (shrinkE sh) + LinearIndex a i -> LinearIndex (shrinkAcc a) (shrinkE i) + Shape a -> Shape (shrinkAcc a) + ShapeSize sh -> ShapeSize (shrinkE sh) + Intersect sh sz -> Intersect (shrinkE sh) (shrinkE sz) + Foreign ff f e -> Foreign ff (shrinkF f) (shrinkE e) + + shrinkF :: PreOpenFun acc env aenv' f -> PreOpenFun acc env aenv' f + shrinkF (Lam f) = Lam (shrinkF f) + shrinkF (Body b) = Body (shrinkE b) + + shrinkT :: Tuple (PreOpenExp acc env aenv') t -> Tuple (PreOpenExp acc env aenv') t + shrinkT NilTup = NilTup + shrinkT (SnocTup t e) = shrinkT t `SnocTup` shrinkE e + + shrinkAT :: Atuple (acc aenv') t -> Atuple (acc aenv') t + shrinkAT NilAtup = NilAtup + shrinkAT (SnocAtup t a) = shrinkAT t `SnocAtup` shrinkAcc a + + shrinkAF :: PreOpenAfun acc aenv' f -> PreOpenAfun acc aenv' f + shrinkAF (Alam f) = Alam (shrinkAF f) + shrinkAF (Abody a) = Abody (shrinkAcc a) + + +-- A somewhat hacky example implementation of the reduction step. It requires a +-- function to open the recursive closure of an array term. +-- +basicReduceAcc + :: Kit acc + => (forall aenv a. acc aenv a -> PreOpenAcc acc aenv a) + -> UsesOfAcc acc + -> ReduceAcc acc +basicReduceAcc unwrapAcc countAcc (unwrapAcc -> bnd) body@(unwrapAcc -> pbody) + | Avar _ <- bnd = Stats.inline "Avar" . Just $ rebuildA rebuildAcc (subTop bnd) pbody + | uses <= lIMIT = Stats.betaReduce msg . Just $ rebuildA rebuildAcc (subTop bnd) pbody + | otherwise = Nothing + where + -- If the bound variable is used at most this many times, it will be inlined + -- into the body. Since this implies an array computation could be inlined + -- into a scalar expression, we limit the shrinking reduction for array + -- computations to dead-code elimination only. + -- + lIMIT = 0 + + uses = countAcc True ZeroIdx body + msg = case uses of + 0 -> "dead acc" + _ -> "inline acc" -- forced inlining when lIMIT > 1 + + subTop :: Arrays t => PreOpenAcc acc aenv s -> Idx (aenv,s) t -> PreOpenAcc acc aenv t + subTop t ZeroIdx = t + subTop _ (SuccIdx idx) = Avar idx + + +-- Occurrence Counting +-- =================== + +-- Count the number of occurrences an in-scope scalar expression bound at the +-- given variable index recursively in a term. +-- +usesOfExp :: forall acc env aenv s t. Idx env s -> PreOpenExp acc env aenv t -> Int +usesOfExp idx = countE + where + countE :: PreOpenExp acc env aenv e -> Int + countE exp = case exp of + Var this + | Just REFL <- match this idx -> 1 + | otherwise -> 0 + -- + Let bnd body -> countE bnd + usesOfExp (SuccIdx idx) body + Const _ -> 0 + Tuple t -> countT t + Prj _ e -> countE e + IndexNil -> 0 + IndexCons sl sz -> countE sl + countE sz + IndexHead sh -> countE sh + IndexTail sh -> countE sh + IndexSlice _ ix sh -> countE ix + countE sh + IndexFull _ ix sl -> countE ix + countE sl + IndexAny -> 0 + ToIndex sh ix -> countE sh + countE ix + FromIndex sh i -> countE sh + countE i + Cond p t e -> countE p + countE t `max` countE e + Iterate n f x -> countE n + countE x + usesOfExp (SuccIdx idx) f + PrimConst _ -> 0 + PrimApp _ x -> countE x + Index _ sh -> countE sh + LinearIndex _ i -> countE i + Shape _ -> 0 + ShapeSize sh -> countE sh + Intersect sh sz -> countE sh + countE sz + Foreign _ _ e -> countE e + + countT :: Tuple (PreOpenExp acc env aenv) e -> Int + countT NilTup = 0 + countT (SnocTup t e) = countT t + countE e + + +-- Count the number of occurrences of the array term bound at the given +-- environment index. If the first argument is 'True' then it includes in the +-- total uses of the variable for 'Shape' information, otherwise not. +-- +type UsesOfAcc acc = forall aenv s t. Bool -> Idx aenv s -> acc aenv t -> Int + +usesOfPreAcc + :: forall acc aenv s t. Kit acc + => Bool + -> UsesOfAcc acc + -> Idx aenv s + -> PreOpenAcc acc aenv t + -> Int +usesOfPreAcc withShape countAcc idx = countP + where + countP :: PreOpenAcc acc aenv a -> Int + countP pacc = case pacc of + Avar this + | Just REFL <- match this idx -> 1 + | otherwise -> 0 + -- + Alet bnd body -> countA bnd + countAcc withShape (SuccIdx idx) body + Atuple tup -> countAT tup + Aprj _ a -> countA a -- special case discount? + Apply _ a -> countA a + Aforeign _ _ a -> countA a + Acond p t e -> countE p + countA t `max` countA e + Use _ -> 0 + Unit e -> countE e + Reshape e a -> countE e + countA a + Generate e f -> countE e + countF f + Transform sh ix f a -> countE sh + countF ix + countF f + countA a + Replicate _ sh a -> countE sh + countA a + Slice _ a sl -> countE sl + countA a + Map f a -> countF f + countA a + ZipWith f a1 a2 -> countF f + countA a1 + countA a2 + Fold f z a -> countF f + countE z + countA a + Fold1 f a -> countF f + countA a + FoldSeg f z a s -> countF f + countE z + countA a + countA s + Fold1Seg f a s -> countF f + countA a + countA s + Scanl f z a -> countF f + countE z + countA a + Scanl' f z a -> countF f + countE z + countA a + Scanl1 f a -> countF f + countA a + Scanr f z a -> countF f + countE z + countA a + Scanr' f z a -> countF f + countE z + countA a + Scanr1 f a -> countF f + countA a + Permute f1 a1 f2 a2 -> countF f1 + countA a1 + countF f2 + countA a2 + Backpermute sh f a -> countE sh + countF f + countA a + Stencil f _ a -> countF f + countA a + Stencil2 f _ a1 _ a2 -> countF f + countA a1 + countA a2 + + countA :: acc aenv a -> Int + countA = countAcc withShape idx + + countE :: PreOpenExp acc env aenv e -> Int + countE exp = case exp of + Let bnd body -> countE bnd + countE body + Var _ -> 0 + Const _ -> 0 + Tuple t -> countT t + Prj _ e -> countE e + IndexNil -> 0 + IndexCons sl sz -> countE sl + countE sz + IndexHead sh -> countE sh + IndexTail sh -> countE sh + IndexSlice _ ix sh -> countE ix + countE sh + IndexFull _ ix sl -> countE ix + countE sl + IndexAny -> 0 + ToIndex sh ix -> countE sh + countE ix + FromIndex sh i -> countE sh + countE i + Cond p t e -> countE p + countE t + countE e + Iterate n f x -> countE n + countE x + countE f + PrimConst _ -> 0 + PrimApp _ x -> countE x + Index a sh -> countA a + countE sh + LinearIndex a i -> countA a + countE i + ShapeSize sh -> countE sh + Intersect sh sz -> countE sh + countE sz + Shape a + | withShape -> countA a + | otherwise -> 0 + Foreign _ _ e -> countE e + + countF :: PreOpenFun acc env aenv f -> Int + countF (Lam f) = countF f + countF (Body b) = countE b + + countT :: Tuple (PreOpenExp acc env aenv) e -> Int + countT NilTup = 0 + countT (SnocTup t e) = countT t + countE e + + countAT :: Atuple (acc aenv) a -> Int + countAT NilAtup = 0 + countAT (SnocAtup t a) = countAT t + countA a + diff --git a/Data/Array/Accelerate/Trafo/Simplify.hs b/Data/Array/Accelerate/Trafo/Simplify.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/Trafo/Simplify.hs @@ -0,0 +1,387 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} +-- | +-- Module : Data.Array.Accelerate.Trafo.Simplify +-- Copyright : [2012..2013] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Manuel M T Chakravarty +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.Trafo.Simplify ( + + Simplify(..), + +) where + +-- standard library +import Prelude hiding ( exp, iterate ) +import Data.Maybe +import Data.Monoid +import Data.Typeable +import Control.Applicative hiding ( Const ) + +-- friends +import Data.Array.Accelerate.AST hiding ( prj ) +import Data.Array.Accelerate.Type +import Data.Array.Accelerate.Tuple +import Data.Array.Accelerate.Analysis.Match +import Data.Array.Accelerate.Trafo.Base +import Data.Array.Accelerate.Trafo.Algebra +import Data.Array.Accelerate.Trafo.Shrink +import Data.Array.Accelerate.Trafo.Substitution +import Data.Array.Accelerate.Analysis.Shape +import Data.Array.Accelerate.Array.Sugar ( Elt, Shape, Slice, toElt, fromElt, (:.)(..) ) + +import Data.Array.Accelerate.Pretty.Print +import qualified Data.Array.Accelerate.Debug as Stats + +#include "accelerate.h" + + +class Simplify f where + simplify :: f -> f + +instance Kit acc => Simplify (PreFun acc aenv f) where + simplify = simplifyFun + +instance Kit acc => Simplify (PreExp acc aenv e) where + simplify = simplifyExp + + +-- Scalar optimisations +-- ==================== + +-- Common subexpression elimination finds computations that are performed at +-- least twice on a given execution path and eliminates the second and later +-- occurrences, replacing them with uses of saved values. This implements a +-- simplified version of that idea, where we look for the expressions of the +-- form: +-- +-- let x = e1 in e2 +-- +-- and replace all occurrences of e1 in e2 with x. This is not full redundancy +-- elimination, but good enough to catch some cases, and in particular those +-- likely to be introduced by scalar composition of terms in the fusion process. +-- +-- While it may seem that common subexpression elimination is always worthwhile, +-- as it reduces the number of arithmetic operations performed, this is not +-- necessarily advantageous. The simplest case in which it may not be desirable +-- is if it causes a register to be occupied for a long time in order to hold +-- the shared expression's value, which hence reduces the number of registers +-- available for other uses. Even worse is if the value has to be spilled to +-- memory because there are insufficient registers available. We sidestep this +-- tricky and target-dependent issue by, for now, simply ignoring it. +-- +localCSE :: (Kit acc, Elt a, Elt b) + => Gamma acc env env aenv + -> PreOpenExp acc env aenv a + -> PreOpenExp acc (env,a) aenv b + -> Maybe (PreOpenExp acc env aenv b) +localCSE env bnd body + | Just ix <- lookupExp env bnd = Stats.ruleFired "CSE" . Just $ inline body (Var ix) + | otherwise = Nothing + + +-- Compared to regular Haskell, the scalar expression language of Accelerate is +-- rather limited in order to meet the restrictions of what can be efficiently +-- implemented on specialised hardware, such as GPUs. For example, to avoid +-- excessive SIMD divergence, we do not support any form of recursion or +-- iteration in scalar expressions. This harmonises well with the stratified +-- design of the Accelerate language: collective array operations comprise many +-- scalar computations that are executed in parallel, so for simplicity of +-- scheduling these operations we would like some assurance that each scalar +-- computation takes approximately the same time to execute as all others. +-- +-- However, some computations are naturally expressed in terms of iteration. For +-- some problems, we can instead use generative techniques to implement the +-- program by defining a single step of a recurrence relation as an Accelerate +-- collective operation and using standard Haskell to unroll the loop a _fixed_ +-- number of times. +-- +-- However, this is outrageously slow because the intermediate values are +-- written to memory at the end of every iteration. Luckily the fusion process +-- will eliminate this intermediate memory traffic by combining the 'n' +-- collective operations into a single operation with 'n' instances of the loop +-- body. However, doing this we uncover an embarrassing secret: C compilers do +-- not compile C code, they compile _idiomatic_ C code. +-- +-- This process recovers the iteration structure that was lost in the process of +-- fusing the collective operations. This allows a backend to generate explicit +-- loops in its target language. +-- +recoverLoops + :: (Kit acc, Elt b) + => Gamma acc env env aenv + -> PreOpenExp acc env aenv a + -> PreOpenExp acc (env,a) aenv b + -> Maybe (PreOpenExp acc env aenv b) +recoverLoops _ bnd e3 + -- To introduce scaler loops, we look for expressions of the form: + -- + -- let x = + -- let y = e1 in e2 + -- in e3 + -- + -- and if e2 and e3 are congruent, replace with: + -- + -- iterate[2] (\y -> e2) e1 + -- + | Let e1 e2 <- bnd + , Just REFL <- matchEnvTop e2 e3 + , Just REFL <- match e2 e3 + = Stats.ruleFired "loop recovery/intro" . Just + $ Iterate (constant 2) e2 e1 + + -- To merge expressions into a loop body, look for the pattern: + -- + -- let x = iterate[n] f e1 + -- in e3 + -- + -- and if e3 matches the loop body, replace the let binding with the bare + -- iteration with the trip count increased by one. + -- + | Iterate n f e1 <- bnd + , Just REFL <- match f e3 + = Stats.ruleFired "loop recovery/merge" . Just + $ Iterate (constant 1 `plus` n) f e1 + + | otherwise + = Nothing + + where + plus :: PreOpenExp acc env aenv Int -> PreOpenExp acc env aenv Int -> PreOpenExp acc env aenv Int + plus x y = PrimApp (PrimAdd numType) $ Tuple $ NilTup `SnocTup` x `SnocTup` y + + constant :: Int -> PreOpenExp acc env aenv Int + constant i = Const ((),i) + + matchEnvTop :: (Elt s, Elt t) + => PreOpenExp acc (env,s) aenv f + -> PreOpenExp acc (env,t) aenv g + -> Maybe (s :=: t) + matchEnvTop _ _ = gcast REFL + + +-- Walk a scalar expression applying simplifications to terms bottom-up. +-- +-- TODO: Look for particular patterns of expressions that can be replaced by +-- something equivalent and simpler. In particular, indexing operations +-- introduced by the fusion transformation. This would benefit from a +-- rewrite rule schema. +-- +simplifyOpenExp + :: forall acc env aenv e. Kit acc + => Gamma acc env env aenv + -> PreOpenExp acc env aenv e + -> (Bool, PreOpenExp acc env aenv e) +simplifyOpenExp env = first getAny . cvtE + where + cvtE :: PreOpenExp acc env aenv t -> (Any, PreOpenExp acc env aenv t) + cvtE exp = case exp of + Let bnd body + | Just reduct <- localCSE env (snd bnd') (snd body') -> yes . snd $ cvtE reduct + | Just reduct <- recoverLoops env (snd bnd') (snd body') -> yes . snd $ cvtE reduct + | otherwise -> Let <$> bnd' <*> body' + where + bnd' = cvtE bnd + env' = PushExp env (snd bnd') + body' = cvtE' (incExp env') body + + Var ix -> pure $ Var ix + Const c -> pure $ Const c + Tuple tup -> Tuple <$> cvtT tup + Prj ix t -> prj ix (cvtE t) + IndexNil -> pure IndexNil + IndexAny -> pure IndexAny + IndexCons sh sz -> indexCons (cvtE sh) (cvtE sz) + IndexHead sh -> indexHead (cvtE sh) + IndexTail sh -> indexTail (cvtE sh) + IndexSlice x ix sh -> IndexSlice x <$> cvtE ix <*> cvtE sh + IndexFull x ix sl -> IndexFull x <$> cvtE ix <*> cvtE sl + ToIndex sh ix -> ToIndex <$> cvtE sh <*> cvtE ix + FromIndex sh ix -> FromIndex <$> cvtE sh <*> cvtE ix + Cond p t e -> cond (cvtE p) (cvtE t) (cvtE e) + Iterate n f x -> Iterate <$> cvtE n <*> cvtE' (incExp env `PushExp` Var ZeroIdx) f <*> cvtE x + PrimConst c -> pure $ PrimConst c + PrimApp f x -> evalPrimApp env f <$> cvtE x + Index a sh -> Index a <$> cvtE sh + LinearIndex a i -> LinearIndex a <$> cvtE i + Shape a -> pure $ Shape a + ShapeSize sh -> ShapeSize <$> cvtE sh + Intersect s t -> cvtE s `intersect` cvtE t + Foreign ff f e -> Foreign ff <$> first Any (simplifyOpenFun EmptyExp f) <*> cvtE e + + cvtT :: Tuple (PreOpenExp acc env aenv) t -> (Any, Tuple (PreOpenExp acc env aenv) t) + cvtT NilTup = pure NilTup + cvtT (SnocTup t e) = SnocTup <$> cvtT t <*> cvtE e + + cvtE' :: Gamma acc env' env' aenv -> PreOpenExp acc env' aenv e' -> (Any, PreOpenExp acc env' aenv e') + cvtE' env' = first Any . simplifyOpenExp env' + + -- If the head terms of a shape intersection match, avoid the intersection + -- test and return the shape. + -- + intersect :: Shape t + => (Any, PreOpenExp acc env aenv t) + -> (Any, PreOpenExp acc env aenv t) + -> (Any, PreOpenExp acc env aenv t) + intersect sh1@(_,sh1') sh2@(_,sh2') + | Just REFL <- match sh1' sh2' = Stats.ruleFired "intersect" (yes sh1') + | otherwise = Intersect <$> sh1 <*> sh2 + + -- Simplify conditional expressions, in particular by eliminating branches + -- when the predicate is a known constant. + -- + cond :: forall t. Elt t + => (Any, PreOpenExp acc env aenv Bool) + -> (Any, PreOpenExp acc env aenv t) + -> (Any, PreOpenExp acc env aenv t) + -> (Any, PreOpenExp acc env aenv t) + cond p@(_,p') t@(_,t') e@(_,e') + | Const ((),True) <- p' = Stats.knownBranch "True" (yes t') + | Const ((),False) <- p' = Stats.knownBranch "False" (yes e') + | Just REFL <- match t' e' = Stats.knownBranch "redundant" (yes e') + | otherwise = Cond <$> p <*> t <*> e + + -- If we are projecting elements from a tuple structure or tuple of constant + -- valued tuple, pick out the appropriate component directly. + -- + prj :: forall s t. (Elt s, Elt t, IsTuple t) + => TupleIdx (TupleRepr t) s + -> (Any, PreOpenExp acc env aenv t) + -> (Any, PreOpenExp acc env aenv s) + prj ix exp@(_,exp') + | Tuple t <- exp' = Stats.inline "prj/Tuple" . yes $ prjT ix t + | Const c <- exp' = Stats.inline "prj/Const" . yes $ prjC ix (fromTuple (toElt c :: t)) + | Let a b <- exp' = Stats.ruleFired "prj/Let" $ cvtE (Let a (Prj ix b)) + | otherwise = Prj ix <$> exp + where + prjT :: TupleIdx tup s -> Tuple (PreOpenExp acc env aenv) tup -> PreOpenExp acc env aenv s + prjT ZeroTupIdx (SnocTup _ e) = e + prjT (SuccTupIdx idx) (SnocTup t _) = prjT idx t + prjT _ _ = error "DO MORE OF WHAT MAKES YOU HAPPY" + + prjC :: TupleIdx tup s -> tup -> PreOpenExp acc env aenv s + prjC ZeroTupIdx (_, v) = Const (fromElt v) + prjC (SuccTupIdx idx) (tup, _) = prjC idx tup + + -- Shape manipulations + -- + indexCons :: (Slice sl, Elt sz) + => (Any, PreOpenExp acc env aenv sl) + -> (Any, PreOpenExp acc env aenv sz) + -> (Any, PreOpenExp acc env aenv (sl :. sz)) + indexCons (_,sl') (_,sz') + | Just REFL <- match sl' IndexNil + , IndexHead sh <- sz' + , expDim sz' == 1 -- no type information that this is a 1D shape, hence gcast next + , Just sh' <- gcast sh + = yes sh' + + indexCons sl sz + = IndexCons <$> sl <*> sz + + indexHead :: (Slice sl, Elt sz) => (Any, PreOpenExp acc env aenv (sl :. sz)) -> (Any, PreOpenExp acc env aenv sz) + indexHead (_, IndexCons _ sz) = yes sz + indexHead sh = IndexHead <$> sh + + indexTail :: (Slice sl, Elt sz) => (Any, PreOpenExp acc env aenv (sl :. sz)) -> (Any, PreOpenExp acc env aenv sl) + indexTail (_, IndexCons sl _) = yes sl + indexTail sh = IndexTail <$> sh + + first :: (a -> a') -> (a,b) -> (a',b) + first f (x,y) = (f x, y) + + yes :: x -> (Any, x) + yes x = (Any True, x) + + +-- Simplification for open functions +-- +simplifyOpenFun + :: Kit acc + => Gamma acc env env aenv + -> PreOpenFun acc env aenv f + -> (Bool, PreOpenFun acc env aenv f) +simplifyOpenFun env (Body e) = Body <$> simplifyOpenExp env e +simplifyOpenFun env (Lam f) = Lam <$> simplifyOpenFun env' f + where + env' = incExp env `PushExp` Var ZeroIdx + + +-- Simplify closed expressions and functions. The process is applied repeatedly +-- until no more changes are made. +-- +simplifyExp :: Kit acc => PreExp acc aenv t -> PreExp acc aenv t +simplifyExp = iterate (show . prettyPreExp prettyAcc 0 0 noParens) (simplifyOpenExp EmptyExp) + +simplifyFun :: Kit acc => PreFun acc aenv f -> PreFun acc aenv f +simplifyFun = iterate (show . prettyPreFun prettyAcc 0) (simplifyOpenFun EmptyExp) + + +-- NOTE: [Simplifier iterations] +-- +-- Run the simplification pass _before_ the shrinking step. There are cases +-- where it is better to run shrinking first, and then simplification would +-- complete in a single step, but the converse is also true. However, as +-- shrinking can remove some structure of the let bindings, which might be +-- useful for the transformations (e.g. loop recovery) we want to maintain this +-- information for at least the first pass. +-- +-- We always apply the simplification step once. Following this, we iterate +-- shrinking and simplification until the expression no longer changes. Both +-- shrink and simplify return a boolean indicating whether any work was done; we +-- stop as soon as either returns false. +-- +-- With internal checks on, we also issue a warning if the iteration limit is +-- reached, but it was still possible to make changes to the expression. +-- +{-# SPECIALISE iterate :: (Exp aenv t -> String) -> (Exp aenv t -> (Bool, Exp aenv t)) -> Exp aenv t -> Exp aenv t #-} +{-# SPECIALISE iterate :: (Fun aenv t -> String) -> (Fun aenv t -> (Bool, Fun aenv t)) -> Fun aenv t -> Fun aenv t #-} + +iterate + :: forall f a. (Match f, Shrink (f a)) + => (f a -> String) + -> (f a -> (Bool, f a)) + -> f a + -> f a +iterate ppr f = fix 0 . setup . simplify' + where + -- The maximum number of simplifier iterations. To be conservative and avoid + -- excessive run times, we set this value very low. + -- + lIMIT = 1 + + simplify' = Stats.simplifierDone . f + setup (_,x) = msg x x + + fix :: Int -> f a -> f a + fix !i !x0 + | i >= lIMIT = INTERNAL_CHECK(warning) "iterate" "iteration limit reached" (x0 ==^ f x0) x0 + | not shrunk = x1 + | not simplified = x2 + | otherwise = fix (i+1) x2 + where + (shrunk, x1) = trace $ shrink' x0 + (simplified, x2) = trace $ simplify' x1 + + -- debugging support + -- + u ==^ (_,v) = isJust (match u v) + + trace v@(changed,x) + | changed = msg x v + | otherwise = v + + msg :: f a -> x -> x + msg x next = Stats.tracePure Stats.dump_simpl_iterations (unlines [ "simplifier done", ppr x ]) next + diff --git a/Data/Array/Accelerate/Trafo/Substitution.hs b/Data/Array/Accelerate/Trafo/Substitution.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/Trafo/Substitution.hs @@ -0,0 +1,420 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_HADDOCK hide #-} +-- | +-- Module : Data.Array.Accelerate.Trafo.Substitution +-- Copyright : [2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Manuel M T Chakravarty +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.Trafo.Substitution ( + + -- ** Renaming & Substitution + inline, substitute, compose, + + -- ** Weakening + (:>), + weakenA, weakenEA, weakenFA, + weakenE, weakenFE, + + -- ** Rebuilding terms + RebuildAcc, + rebuildA, rebuildAfun, rebuildOpenAcc, + rebuildE, rebuildEA, + rebuildFA, rebuildFE, + +) where + +import Prelude hiding ( exp ) + +import Data.Array.Accelerate.AST +import Data.Array.Accelerate.Tuple +import Data.Array.Accelerate.Array.Sugar ( Elt, Arrays ) + +import qualified Data.Array.Accelerate.Debug as Stats + + +-- NOTE: [Renaming and Substitution] +-- +-- To do things like renaming and substitution, we need some operation on +-- variables that we push structurally through terms, applying to each variable. +-- We have a type preserving but environment changing operation: +-- +-- v :: forall t. Idx env t -> f env' aenv t +-- +-- The crafty bit is that 'f' might represent variables (for renaming) or terms +-- (for substitutions). The demonic forall, --- which is to say that the +-- quantifier is in a position which gives us obligation, not opportunity --- +-- forces us to respect type: when pattern matching detects the variable we care +-- about, happily we discover that it has the type we must respect. The demon is +-- not so free to mess with us as one might fear at first. +-- +-- We then lift this to an operation which traverses terms and rebuild them +-- after applying 'v' to the variables: +-- +-- rebuild v :: OpenExp env aenv t -> OpenExp env' aenv t +-- +-- The Syntactic class tells us what we need to know about 'f' if we want to be +-- able to rebuild terms. In essence, the crucial functionality is to propagate +-- a class of operations on variables that is closed under shifting. +-- +infixr `compose` +infixr `substitute` + +-- | Replace the first variable with the given expression. The environment +-- shrinks. +-- +inline :: Elt t + => PreOpenExp acc (env, s) aenv t + -> PreOpenExp acc env aenv s + -> PreOpenExp acc env aenv t +inline f g = Stats.substitution "inline" $ rebuildE (subTop g) f + where + subTop :: Elt t => PreOpenExp acc env aenv s -> Idx (env, s) t -> PreOpenExp acc env aenv t + subTop s ZeroIdx = s + subTop _ (SuccIdx ix) = Var ix + +-- | Replace an expression that uses the top environment variable with another. +-- The result of the first is let bound into the second. +-- +substitute :: (Elt b, Elt c) + => PreOpenExp acc (env, b) aenv c + -> PreOpenExp acc (env, a) aenv b + -> PreOpenExp acc (env, a) aenv c +substitute f g + | Stats.substitution "substitute" False = undefined + + | Var ZeroIdx <- g = f -- don't rebind an identity function + | otherwise = Let g $ rebuildE split f + where + split :: Elt c => Idx (env,b) c -> PreOpenExp acc ((env,a),b) aenv c + split ZeroIdx = Var ZeroIdx + split (SuccIdx ix) = Var (SuccIdx (SuccIdx ix)) + + +-- | Composition of unary functions. +-- +compose :: Elt c + => PreOpenFun acc env aenv (b -> c) + -> PreOpenFun acc env aenv (a -> b) + -> PreOpenFun acc env aenv (a -> c) +compose (Lam (Body f)) (Lam (Body g)) = Stats.substitution "compose" . Lam . Body $ substitute f g +compose _ _ = error "compose: impossible evaluation" + + +-- NOTE: [Weakening] +-- +-- Weakening is something we usually take for granted: every time you learn a +-- new word, old sentences still make sense. If a conclusion is justified by a +-- hypothesis, it is still justified if you add more hypotheses. Similarly, a +-- term remains in scope if you bind more (fresh) variables. Weakening is the +-- operation of shifting things from one scope to a larger scope in which new +-- things have become meaningful, but no old things have vanished. +-- +-- When we use a named representation (or HOAS) we get weakening for free. But +-- in the de Bruijn representation weakening takes work: you have to shift all +-- variable references to make room for the new bindings. +-- + +-- The type of shifting terms from one context into another +-- +type env :> env' = forall t'. Idx env t' -> Idx env' t' + +weakenA :: RebuildAcc acc -> aenv :> aenv' -> PreOpenAcc acc aenv a -> PreOpenAcc acc aenv' a +weakenA k v = Stats.substitution "weakenA" . rebuildA k (Avar . v) + +weakenEA :: RebuildAcc acc -> aenv :> aenv' -> PreOpenExp acc env aenv t -> PreOpenExp acc env aenv' t +weakenEA k v = Stats.substitution "weakenEA" . rebuildEA k (Avar . v) + +weakenFA :: RebuildAcc acc -> aenv :> aenv' -> PreOpenFun acc env aenv f -> PreOpenFun acc env aenv' f +weakenFA k v = Stats.substitution "weakenFA" . rebuildFA k (Avar . v) + + +weakenE :: env :> env' -> PreOpenExp acc env aenv t -> PreOpenExp acc env' aenv t +weakenE v = Stats.substitution "weakenE" . rebuildE (Var . v) + +weakenFE :: env :> env' -> PreOpenFun acc env aenv f -> PreOpenFun acc env' aenv f +weakenFE v = Stats.substitution "weakenFE" . rebuildFE (Var . v) + + +{-# RULES +"weakenA/weakenA" forall a (k :: RebuildAcc acc) (v1 :: env' :> env'') (v2 :: env :> env'). + weakenA k v1 (weakenA k v2 a) = weakenA k (v1 . v2) a + +"weakenEA/weakenEA" forall a (k :: RebuildAcc acc) (v1 :: env' :> env'') (v2 :: env :> env'). + weakenEA k v1 (weakenEA k v2 a) = weakenEA k (v1 . v2) a + +"weakenFA/weakenFA" forall a (k :: RebuildAcc acc) (v1 :: env' :> env'') (v2 :: env :> env'). + weakenFA k v1 (weakenFA k v2 a) = weakenFA k (v1 . v2) a + +"weakenE/weakenE" forall e (v1 :: env' :> env'') (v2 :: env :> env'). + weakenE v1 (weakenE v2 e) = weakenE (v1 . v2) e + +"weakenFE/weakenFE" forall e (v1 :: env' :> env'') (v2 :: env :> env'). + weakenFE v1 (weakenFE v2 e) = weakenFE (v1 . v2) e + #-} + +-- Simultaneous Substitution =================================================== +-- + +-- Scalar expressions +-- ------------------ + +-- SEE: [Renaming and Substitution] +-- SEE: [Weakening] +-- +class SyntacticExp f where + varIn :: Elt t => Idx env t -> f acc env aenv t + expOut :: Elt t => f acc env aenv t -> PreOpenExp acc env aenv t + weakenExp :: Elt t => f acc env aenv t -> f acc (env, s) aenv t + +newtype IdxE (acc :: * -> * -> *) env aenv t = IE { unIE :: Idx env t } + +instance SyntacticExp IdxE where + varIn = IE + expOut = Var . unIE + weakenExp = IE . SuccIdx . unIE + +instance SyntacticExp PreOpenExp where + varIn = Var + expOut = id + weakenExp = rebuildE (weakenExp . IE) + + +shiftE + :: (SyntacticExp f, Elt t) + => (forall t'. Elt t' => Idx env t' -> f acc env' aenv t') + -> Idx (env, s) t + -> f acc (env', s) aenv t +shiftE _ ZeroIdx = varIn ZeroIdx +shiftE v (SuccIdx ix) = weakenExp (v ix) + +rebuildE + :: SyntacticExp f + => (forall t'. Elt t' => Idx env t' -> f acc env' aenv t') + -> PreOpenExp acc env aenv t + -> PreOpenExp acc env' aenv t +rebuildE v exp = + case exp of + Let a b -> Let (rebuildE v a) (rebuildE (shiftE v) b) + Var ix -> expOut (v ix) + Const c -> Const c + Tuple tup -> Tuple (rebuildTE v tup) + Prj tup e -> Prj tup (rebuildE v e) + IndexNil -> IndexNil + IndexCons sh sz -> IndexCons (rebuildE v sh) (rebuildE v sz) + IndexHead sh -> IndexHead (rebuildE v sh) + IndexTail sh -> IndexTail (rebuildE v sh) + IndexAny -> IndexAny + IndexSlice x ix sh -> IndexSlice x (rebuildE v ix) (rebuildE v sh) + IndexFull x ix sl -> IndexFull x (rebuildE v ix) (rebuildE v sl) + ToIndex sh ix -> ToIndex (rebuildE v sh) (rebuildE v ix) + FromIndex sh ix -> FromIndex (rebuildE v sh) (rebuildE v ix) + Cond p t e -> Cond (rebuildE v p) (rebuildE v t) (rebuildE v e) + Iterate n f x -> Iterate (rebuildE v n) (rebuildE (shiftE v) f) (rebuildE v x) + PrimConst c -> PrimConst c + PrimApp f x -> PrimApp f (rebuildE v x) + Index a sh -> Index a (rebuildE v sh) + LinearIndex a i -> LinearIndex a (rebuildE v i) + Shape a -> Shape a + ShapeSize sh -> ShapeSize (rebuildE v sh) + Intersect s t -> Intersect (rebuildE v s) (rebuildE v t) + Foreign ff f e -> Foreign ff f (rebuildE v e) + +rebuildTE + :: SyntacticExp f + => (forall t'. Elt t' => Idx env t' -> f acc env' aenv t') + -> Tuple (PreOpenExp acc env aenv) t + -> Tuple (PreOpenExp acc env' aenv) t +rebuildTE v tup = + case tup of + NilTup -> NilTup + SnocTup t e -> rebuildTE v t `SnocTup` rebuildE v e + +rebuildFE + :: SyntacticExp f + => (forall t'. Elt t' => Idx env t' -> f acc env' aenv t') + -> PreOpenFun acc env aenv t + -> PreOpenFun acc env' aenv t +rebuildFE v fun = + case fun of + Body e -> Body (rebuildE v e) + Lam f -> Lam (rebuildFE (shiftE v) f) + + +-- Array expressions +-- ----------------- + +type RebuildAcc acc = + forall aenv aenv' f a. SyntacticAcc f + => (forall a'. Arrays a' => Idx aenv a' -> f acc aenv' a') + -> acc aenv a + -> acc aenv' a + +class SyntacticAcc f where + avarIn :: Arrays t => Idx aenv t -> f acc aenv t + accOut :: Arrays t => f acc aenv t -> PreOpenAcc acc aenv t + weakenAcc :: Arrays t => RebuildAcc acc -> f acc aenv t -> f acc (aenv, s) t + +newtype IdxA (acc :: * -> * -> *) aenv t = IA { unIA :: Idx aenv t } + +instance SyntacticAcc IdxA where + avarIn = IA + accOut = Avar . unIA + weakenAcc _ = IA . SuccIdx . unIA + +instance SyntacticAcc PreOpenAcc where + avarIn = Avar + accOut = id + weakenAcc k = rebuildA k (weakenAcc k . IA) + + +rebuildOpenAcc + :: SyntacticAcc f + => (forall t'. Arrays t' => Idx aenv t' -> f OpenAcc aenv' t') + -> OpenAcc aenv t + -> OpenAcc aenv' t +rebuildOpenAcc v (OpenAcc acc) = OpenAcc (rebuildA rebuildOpenAcc v acc) + + +shiftA + :: (SyntacticAcc f, Arrays t) + => RebuildAcc acc + -> (forall t'. Arrays t' => Idx aenv t' -> f acc aenv' t') + -> Idx (aenv, s) t + -> f acc (aenv', s) t +shiftA _ _ ZeroIdx = avarIn ZeroIdx +shiftA k v (SuccIdx ix) = weakenAcc k (v ix) + +rebuildA + :: SyntacticAcc f + => RebuildAcc acc + -> (forall t'. Arrays t' => Idx aenv t' -> f acc aenv' t') + -> PreOpenAcc acc aenv t + -> PreOpenAcc acc aenv' t +rebuildA rebuild v acc = + case acc of + Alet a b -> Alet (rebuild v a) (rebuild (shiftA rebuild v) b) + Avar ix -> accOut (v ix) + Atuple tup -> Atuple (rebuildATA rebuild v tup) + Aprj tup a -> Aprj tup (rebuild v a) + Apply f a -> Apply f (rebuild v a) + Aforeign ff afun as -> Aforeign ff afun (rebuild v as) + Acond p t e -> Acond (rebuildEA rebuild v p) (rebuild v t) (rebuild v e) + Use a -> Use a + Unit e -> Unit (rebuildEA rebuild v e) + Reshape e a -> Reshape (rebuildEA rebuild v e) (rebuild v a) + Generate e f -> Generate (rebuildEA rebuild v e) (rebuildFA rebuild v f) + Transform sh ix f a -> Transform (rebuildEA rebuild v sh) (rebuildFA rebuild v ix) (rebuildFA rebuild v f) (rebuild v a) + Replicate sl slix a -> Replicate sl (rebuildEA rebuild v slix) (rebuild v a) + Slice sl a slix -> Slice sl (rebuild v a) (rebuildEA rebuild v slix) + Map f a -> Map (rebuildFA rebuild v f) (rebuild v a) + ZipWith f a1 a2 -> ZipWith (rebuildFA rebuild v f) (rebuild v a1) (rebuild v a2) + Fold f z a -> Fold (rebuildFA rebuild v f) (rebuildEA rebuild v z) (rebuild v a) + Fold1 f a -> Fold1 (rebuildFA rebuild v f) (rebuild v a) + FoldSeg f z a s -> FoldSeg (rebuildFA rebuild v f) (rebuildEA rebuild v z) (rebuild v a) (rebuild v s) + Fold1Seg f a s -> Fold1Seg (rebuildFA rebuild v f) (rebuild v a) (rebuild v s) + Scanl f z a -> Scanl (rebuildFA rebuild v f) (rebuildEA rebuild v z) (rebuild v a) + Scanl' f z a -> Scanl' (rebuildFA rebuild v f) (rebuildEA rebuild v z) (rebuild v a) + Scanl1 f a -> Scanl1 (rebuildFA rebuild v f) (rebuild v a) + Scanr f z a -> Scanr (rebuildFA rebuild v f) (rebuildEA rebuild v z) (rebuild v a) + Scanr' f z a -> Scanr' (rebuildFA rebuild v f) (rebuildEA rebuild v z) (rebuild v a) + Scanr1 f a -> Scanr1 (rebuildFA rebuild v f) (rebuild v a) + Permute f1 a1 f2 a2 -> Permute (rebuildFA rebuild v f1) (rebuild v a1) (rebuildFA rebuild v f2) (rebuild v a2) + Backpermute sh f a -> Backpermute (rebuildEA rebuild v sh) (rebuildFA rebuild v f) (rebuild v a) + Stencil f b a -> Stencil (rebuildFA rebuild v f) b (rebuild v a) + Stencil2 f b1 a1 b2 a2 + -> Stencil2 (rebuildFA rebuild v f) b1 (rebuild v a1) b2 (rebuild v a2) + + +-- Rebuilding array computations +-- + +rebuildAfun + :: SyntacticAcc f + => RebuildAcc acc + -> (forall t'. Arrays t' => Idx aenv t' -> f acc aenv' t') + -> PreOpenAfun acc aenv t + -> PreOpenAfun acc aenv' t +rebuildAfun k v afun = + case afun of + Abody b -> Abody (k v b) + Alam f -> Alam (rebuildAfun k (shiftA k v) f) + +rebuildATA + :: SyntacticAcc f + => RebuildAcc acc + -> (forall t'. Arrays t' => Idx aenv t' -> f acc aenv' t') + -> Atuple (acc aenv) t + -> Atuple (acc aenv') t +rebuildATA k v atup = + case atup of + NilAtup -> NilAtup + SnocAtup t a -> rebuildATA k v t `SnocAtup` k v a + + +-- Rebuilding scalar expressions +-- + +rebuildEA + :: SyntacticAcc f + => RebuildAcc acc + -> (forall t'. Arrays t' => Idx aenv t' -> f acc aenv' t') + -> PreOpenExp acc env aenv t + -> PreOpenExp acc env aenv' t +rebuildEA k v exp = + case exp of + Let a b -> Let (rebuildEA k v a) (rebuildEA k v b) + Var ix -> Var ix + Const c -> Const c + Tuple tup -> Tuple (rebuildTA k v tup) + Prj tup e -> Prj tup (rebuildEA k v e) + IndexNil -> IndexNil + IndexCons sh sz -> IndexCons (rebuildEA k v sh) (rebuildEA k v sz) + IndexHead sh -> IndexHead (rebuildEA k v sh) + IndexTail sh -> IndexTail (rebuildEA k v sh) + IndexAny -> IndexAny + IndexSlice x ix sh -> IndexSlice x (rebuildEA k v ix) (rebuildEA k v sh) + IndexFull x ix sl -> IndexFull x (rebuildEA k v ix) (rebuildEA k v sl) + ToIndex sh ix -> ToIndex (rebuildEA k v sh) (rebuildEA k v ix) + FromIndex sh ix -> FromIndex (rebuildEA k v sh) (rebuildEA k v ix) + Cond p t e -> Cond (rebuildEA k v p) (rebuildEA k v t) (rebuildEA k v e) + Iterate n f x -> Iterate (rebuildEA k v n) (rebuildEA k v f) (rebuildEA k v x) + PrimConst c -> PrimConst c + PrimApp f x -> PrimApp f (rebuildEA k v x) + Index a sh -> Index (k v a) (rebuildEA k v sh) + LinearIndex a i -> LinearIndex (k v a) (rebuildEA k v i) + Shape a -> Shape (k v a) + ShapeSize sh -> ShapeSize (rebuildEA k v sh) + Intersect s t -> Intersect (rebuildEA k v s) (rebuildEA k v t) + Foreign ff f e -> Foreign ff f (rebuildEA k v e) + +rebuildTA + :: SyntacticAcc f + => RebuildAcc acc + -> (forall t'. Arrays t' => Idx aenv t' -> f acc aenv' t') + -> Tuple (PreOpenExp acc env aenv) t + -> Tuple (PreOpenExp acc env aenv') t +rebuildTA k v tup = + case tup of + NilTup -> NilTup + SnocTup t e -> rebuildTA k v t `SnocTup` rebuildEA k v e + +rebuildFA + :: SyntacticAcc f + => RebuildAcc acc + -> (forall t'. Arrays t' => Idx aenv t' -> f acc aenv' t') + -> PreOpenFun acc env aenv t + -> PreOpenFun acc env aenv' t +rebuildFA k v fun = + case fun of + Body e -> Body (rebuildEA k v e) + Lam f -> Lam (rebuildFA k v f) + diff --git a/Data/Array/Accelerate/Tuple.hs b/Data/Array/Accelerate/Tuple.hs --- a/Data/Array/Accelerate/Tuple.hs +++ b/Data/Array/Accelerate/Tuple.hs @@ -2,7 +2,8 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Tuple --- Copyright : [2009..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell +-- Copyright : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee +-- [2009..2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell -- License : BSD3 -- -- Maintainer : Manuel M T Chakravarty @@ -38,6 +39,8 @@ -- TLM: It is irritating that we need a separate data type for tuples of scalars -- vs. arrays, purely to carry the class constraint. -- +-- | Tuples of Arrays. Note that this carries the `Arrays` class +-- constraint rather than `Elt` in the case of tuples of scalars. data Atuple c t where NilAtup :: Atuple c () SnocAtup :: Arrays a => Atuple c s -> c a -> Atuple c (s, a) 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 @@ -4,6 +4,7 @@ -- | -- Module : Data.Array.Accelerate.Type -- Copyright : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee +-- [2009..2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell -- License : BSD3 -- -- Maintainer : Manuel M T Chakravarty @@ -216,6 +217,11 @@ 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 -- @@ -590,7 +596,6 @@ UnitTuple :: TupleType () SingleTuple :: ScalarType a -> TupleType a PairTuple :: TupleType a -> TupleType b -> TupleType (a, b) - -- Stencil support -- --------------- diff --git a/accelerate.cabal b/accelerate.cabal --- a/accelerate.cabal +++ b/accelerate.cabal @@ -1,60 +1,138 @@ Name: accelerate -Version: 0.12.2.0 +Version: 0.13.0.0 Cabal-version: >= 1.6 -Tested-with: GHC >= 7.0.3 +Tested-with: GHC >= 7.4.2 Build-type: Simple Synopsis: An embedded language for accelerated array processing -Description: This library defines an embedded language for - regular, multi-dimensional array computations with - multiple backends to facilitate high-performance - implementations. Currently, there are two backends: - (1) an interpreter that serves as a reference - implementation of the intended semantics of the - language and (2) a CUDA backend generating code for - CUDA-capable NVIDIA GPUs. - . - To use the CUDA backend, you need to have CUDA version 3.x - installed. The CUDA backend currently doesn't support 'Char' - and 'Bool' arrays. - . - An experimental OpenCL backend is available at - and an experimental multicore CPU backend building on the Repa array library - is available at . - . - Known bugs: - . - * New in 0.12.1.0: CUDA backend support for Char and Bool; bug fixes - * New in 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 fluid flow simulator (both including a - graphical frontend). Bug fixes. - . - * New in 0.11.0.0: New functions zip3, zip4, unzip3, unzip4, fill, - enumFromN, enumFromStepN, tail, init, drop, take, slit, gather, - gatherIf, scatter, scatterIf, and shapeSize. New simplified AST - (in package accelerate-backend-kit) for backend writers who want to - avoid the complexities of the type-safe AST. +Description: + @Data.Array.Accelerate@ defines an embedded array language for 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 may + then be online compiled and executed on a range of architectures. + . + [/A simple example/] + . + As a simple example, consider the computation of a dot product of two vectors + of 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.CUDA@ it may be on-the-fly off-loaded to the GPU. + . + [/Available backends/] + . + Currently, there are two backends: + . + 1. An interpreter that serves as a reference implementation of the intended + semantics of the language, which is included in this package. + . + 2. A CUDA backend generating code for CUDA-capable NVIDIA GPUs: + + . + Several experimental and/or incomplete backends also exist. If you are + interested in helping finish these, please contact us. + . + 1. Cilk\/ICC and OpenCL: + . + 2. Another OpenCL backend: + . + 3. A backend to the Repa array library: + . + [/Additional components/] + . + The following support packages are available: + . + 1. @accelerate-cuda@: A high-performance parallel backend targeting + CUDA-enabled NVIDIA GPUs. Requires the NVIDIA CUDA SDK and, for full + functionality, hardware with compute capability 1.2 or greater. See the + table on Wikipedia for supported GPUs: + + . + 2. @accelerate-examples@: Computational kernels and applications showcasing + /Accelerate/, as well as performance and regression tests. + . + 3. @accelerate-io@: Fast conversion between /Accelerate/ arrays and other + formats, including Repa arrays. + . + 4. @accelerate-fft@: Computation of Discrete Fourier Transforms. + . + Install them from Hackage with @cabal install PACKAGE@ + . + [/Examples and documentation/] + . + Haddock documentation is included in the package, and a tutorial is available + on the GitHub wiki: + . + The @accelerate-examples@ package demonstrates a range of computational + kernels and several complete applications, including: + . + * An implementation of the Canny edge detection algorithm + . + * An interactive Mandelbrot set generator + . + * A particle-based simulation of stable fluid flows + . + * An /n/-body simulation of gravitational attraction between solid particles + . + * A cellular automata simulation + . + * A \"password recovery\" tool, for dictionary lookup of MD5 hashes + . + [/Mailing list and contacts/] + . + * Mailing list: (discussion of both + use and development welcome). + . + * Sign up for the mailing list here: + + . + * Bug reports and issue tracking: + + . + [/Release notes/] + . + * /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 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, precompilation, Repa-style indices, + @stencil@s, more @scan@s, rank-polymorphic @fold@, @generate@, block I/O & + many bug fixes. + . + * /0.8.1.0:/ Bug fixes and some performance tweaks. + . + * /0.8.0.0:/ @replicate@, @slice@ and @foldSeg@ supported in the + CUDA backend; frontend and interpreter support for @stencil@. Bug fixes. + . + * /0.7.1.0:/ The CUDA backend and a number of scalar functions. + . - * New in 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. - . - * New in 0.9.0.0: Streaming, precompilation, Repa-style indices, stencils, - more scans, rank-polymorphic fold, generate, block I/O & many bug fixes - . - * New in 0.8.1.0: Bug fixes and some performance tweaks - . - * New in 0.8.0.0: 'replicate', 'slice' and 'foldSeg' supported in the - CUDA backend; frontend and interpreter support for 'stencil'; bug fixes - . - * New in 0.7.1.0: the CUDA backend and a number of scalar functions - . - For documentation, see the homepage and . License: BSD3 License-file: LICENSE Author: Manuel M T Chakravarty, + Robert Clifton-Everest, Gabriele Keller, Sean Lee, Ben Lever, @@ -71,9 +149,20 @@ Extra-source-files: INSTALL include/accelerate.h -Flag llvm - Description: Enable the LLVM backend (sequential) - Default: False +Flag debug + Description: + Enable tracing message flags. These are read from the command-line + arguments, which is convenient but may cause problems interacting with the + user program, so are disabled by default. The available options are: + . + * -ddump-sharing: print sharing recovery information + . + * -ddump-simpl-stats: dump statistics counts from the simplifier phase + . + * -ddump-simpl-iterations: dump the program after each iteration of the simplifier + . + * -dverbose: other, uncategorised messages + . Flag more-pp Description: Enable HTML and Graphviz pretty printing. @@ -93,43 +182,64 @@ Library Include-Dirs: include - Build-depends: array >= 0.3 && < 0.5, - base == 4.*, - containers >= 0.3 && < 0.6, + Build-depends: base == 4.*, ghc-prim, - pretty >= 1.0 && < 1.2 + array >= 0.3 && < 0.5, + containers >= 0.3 && < 0.6, + fclabels >= 1.0 && < 1.2, + hashable >= 1.1 && < 1.3, + hashtables >= 1.0 && < 1.2, + pretty >= 1.0 && < 1.2 if flag(more-pp) - Build-depends: bytestring == 0.9.*, - blaze-html == 0.3.*, - text == 0.10.* + Build-depends: bytestring >= 0.9 && < 0.11, + blaze-html >= 0.5 && < 0.7, + blaze-markup >= 0.5 && < 0.6, + directory >= 1.0 && < 1.3, + filepath >= 1.0 && < 1.4, + mtl >= 2.0 && < 2.2, + text >= 0.10 && < 0.12, + unix >= 2.4 && < 2.7 Exposed-modules: Data.Array.Accelerate Data.Array.Accelerate.AST + Data.Array.Accelerate.Analysis.Match Data.Array.Accelerate.Analysis.Shape Data.Array.Accelerate.Analysis.Stencil Data.Array.Accelerate.Analysis.Type Data.Array.Accelerate.Array.Data Data.Array.Accelerate.Array.Representation Data.Array.Accelerate.Array.Sugar + Data.Array.Accelerate.Debug Data.Array.Accelerate.Interpreter Data.Array.Accelerate.Pretty Data.Array.Accelerate.Smart + Data.Array.Accelerate.Trafo + Data.Array.Accelerate.Trafo.Sharing Data.Array.Accelerate.Tuple Data.Array.Accelerate.Type - Other-modules: Data.Array.Accelerate.Internal.Check - Data.Array.Accelerate.Array.Delayed - Data.Array.Accelerate.Debug + Other-modules: Data.Array.Accelerate.Array.Delayed + Data.Array.Accelerate.Internal.Check Data.Array.Accelerate.Language Data.Array.Accelerate.Prelude Data.Array.Accelerate.Pretty.Print Data.Array.Accelerate.Pretty.Traverse + Data.Array.Accelerate.Trafo.Algebra + Data.Array.Accelerate.Trafo.Base + Data.Array.Accelerate.Trafo.Fusion + Data.Array.Accelerate.Trafo.Rewrite + Data.Array.Accelerate.Trafo.Shrink + Data.Array.Accelerate.Trafo.Simplify + Data.Array.Accelerate.Trafo.Substitution if flag(more-pp) Other-modules: Data.Array.Accelerate.Pretty.HTML Data.Array.Accelerate.Pretty.Graphviz + if flag(debug) + cpp-options: -DACCELERATE_DEBUG + if flag(bounds-checks) cpp-options: -DACCELERATE_BOUNDS_CHECKS @@ -140,17 +250,18 @@ cpp-options: -DACCELERATE_INTERNAL_CHECKS ghc-options: -O2 -Wall -funbox-strict-fields -fno-warn-name-shadowing + ghc-prof-options: -caf-all -auto-all if impl(ghc >= 7.0) ghc-options: -fspec-constr-count=25 - Extensions: BangPatterns, CPP, DeriveDataTypeable, EmptyDataDecls, - FlexibleContexts, FlexibleInstances, GADTs, MagicHash, - MultiParamTypeClasses, PatternGuards, RankNTypes, - ScopedTypeVariables, StandaloneDeriving, - TemplateHaskell, TupleSections, TypeFamilies, - TypeOperators, TypeSynonymInstances, UnboxedTuples + -- 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. + -- + -- Extensions: Source-repository head Type: git Location: git://github.com/AccelerateHS/accelerate.git + diff --git a/include/accelerate.h b/include/accelerate.h --- a/include/accelerate.h +++ b/include/accelerate.h @@ -1,7 +1,7 @@ -#ifndef NOT_ACCELERATE_MODULE +#ifndef ACCELERATE_H +#define ACCELERATE_H import qualified Data.Array.Accelerate.Internal.Check as Ck -#endif #define ERROR(f) (Ck.f __FILE__ __LINE__) #define ASSERT (Ck.assert __FILE__ __LINE__) @@ -22,4 +22,6 @@ #define INTERNAL_ASSERT (ASSERT Ck.Internal) #define INTERNAL_ENSURE (ENSURE Ck.Internal) #define INTERNAL_CHECK(f) (CHECK(f) Ck.Internal) + +#endif