packages feed

accelerate 0.12.2.0 → 0.13.0.0

raw patch · 34 files changed

+10742/−4045 lines, 34 filesdep +blaze-markupdep +directorydep +fclabelsdep ~blaze-htmldep ~bytestringdep ~text

Dependencies added: blaze-markup, directory, fclabels, filepath, hashable, hashtables, mtl, unix

Dependency ranges changed: blaze-html, bytestring, text

Files

Data/Array/Accelerate.hs view
@@ -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 <chak@cse.unsw.edu.au>@@ -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:+  -- <http://hackage.haskell.org/package/accelerate-io>++  -- *** 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
Data/Array/Accelerate/AST.hs view
@@ -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 <chak@cse.unsw.edu.au>@@ -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"
+ Data/Array/Accelerate/Analysis/Match.hs view
@@ -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 <chak@cse.unsw.edu.au>+-- 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"+
Data/Array/Accelerate/Analysis/Shape.hs view
@@ -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 <chak@cse.unsw.edu.au>@@ -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
Data/Array/Accelerate/Analysis/Stencil.hs view
@@ -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
Data/Array/Accelerate/Analysis/Type.hs view
@@ -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 <chak@cse.unsw.edu.au>@@ -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
Data/Array/Accelerate/Array/Data.hs view
@@ -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 <chak@cse.unsw.edu.au>@@ -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
Data/Array/Accelerate/Array/Delayed.hs view
@@ -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 <chak@cse.unsw.edu.au>@@ -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)
Data/Array/Accelerate/Array/Representation.hs view
@@ -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 <chak@cse.unsw.edu.au>@@ -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 ++ ")"
Data/Array/Accelerate/Array/Sugar.hs view
@@ -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 <chak@cse.unsw.edu.au>@@ -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
Data/Array/Accelerate/Debug.hs view
@@ -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 <chak@cse.unsw.edu.au>@@ -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\<blah\>@ flags can be reversed with @-dno-\<blah\>@ ---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\<blah\>@ flags can be reversed with @-fno-\<blah\>@ ---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+
Data/Array/Accelerate/Internal/Check.hs view
@@ -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"
Data/Array/Accelerate/Interpreter.hs view
@@ -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 <chak@cse.unsw.edu.au>@@ -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 --
Data/Array/Accelerate/Language.hs view
@@ -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 <chak@cse.unsw.edu.au>@@ -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
Data/Array/Accelerate/Prelude.hs view
@@ -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 <chak@cse.unsw.edu.au>@@ -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'))
Data/Array/Accelerate/Pretty.hs view
@@ -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 <chak@cse.unsw.edu.au>@@ -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
Data/Array/Accelerate/Pretty/Graphviz.hs view
@@ -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)
Data/Array/Accelerate/Pretty/HTML.hs view
@@ -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
Data/Array/Accelerate/Pretty/Print.hs view
@@ -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 <chak@cse.unsw.edu.au>@@ -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 -}+
Data/Array/Accelerate/Pretty/Traverse.hs view
@@ -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 --
Data/Array/Accelerate/Smart.hs view
@@ -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 <chak@cse.unsw.edu.au>--- 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 <chak@cse.unsw.edu.au>+-- 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"+
+ Data/Array/Accelerate/Trafo.hs view
@@ -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 <chak@cse.unsw.edu.au>+-- 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+
+ Data/Array/Accelerate/Trafo/Algebra.hs view
@@ -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 <chak@cse.unsw.edu.au>+-- 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+
+ Data/Array/Accelerate/Trafo/Base.hs view
@@ -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 <chak@cse.unsw.edu.au>+-- 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+
+ Data/Array/Accelerate/Trafo/Fusion.hs view
@@ -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 <chak@cse.unsw.edu.au>+-- 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)))+
+ Data/Array/Accelerate/Trafo/Rewrite.hs view
@@ -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 <chak@cse.unsw.edu.au>+-- 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)+
+ Data/Array/Accelerate/Trafo/Sharing.hs view
@@ -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 <chak@cse.unsw.edu.au>+-- 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+
+ Data/Array/Accelerate/Trafo/Shrink.hs view
@@ -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 <chak@cse.unsw.edu.au>+-- 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+
+ Data/Array/Accelerate/Trafo/Simplify.hs view
@@ -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 <chak@cse.unsw.edu.au>+-- 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+
+ Data/Array/Accelerate/Trafo/Substitution.hs view
@@ -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 <chak@cse.unsw.edu.au>+-- 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)+
Data/Array/Accelerate/Tuple.hs view
@@ -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 <chak@cse.unsw.edu.au>@@ -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)
Data/Array/Accelerate/Type.hs view
@@ -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 <chak@cse.unsw.edu.au>@@ -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 -- ---------------
accelerate.cabal view
@@ -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 <https://github.com/HIPERFIT/accelerate-opencl>-                        and an experimental multicore CPU backend building on the Repa array library-                        is available at <https://github.com/blambo/accelerate-repa>.-                        .-                        Known bugs: <https://github.com/AccelerateHS/accelerate/issues>-                        .-                        * 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:+       <http://hackage.haskell.org/package/accelerate-cuda>+  .+  Several experimental and/or incomplete backends also exist. If you are+  interested in helping finish these, please contact us.+  .+    1. Cilk\/ICC and OpenCL: <https://github.com/AccelerateHS/accelerate-backend-kit>+  .+    2. Another OpenCL backend: <https://github.com/HIPERFIT/accelerate-opencl>+  .+    3. A backend to the Repa array library: <https://github.com/blambo/accelerate-repa>+  .+  [/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:+       <http://en.wikipedia.org/wiki/CUDA#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: <https://github.com/AccelerateHS/accelerate/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: <accelerate-haskell@googlegroups.com> (discussion of both+      use and development welcome).+  .+    * Sign up for the mailing list here:+      <http://groups.google.com/group/accelerate-haskell>+  .+    * Bug reports and issue tracking:+      <https://github.com/AccelerateHS/accelerate/issues>+  .+  [/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 <https://github.com/AccelerateHS/accelerate/wiki>. 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+
include/accelerate.h view
@@ -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