packages feed

accelerate 0.10.0.0 → 0.12.0.0

raw patch · 65 files changed

+1852/−7618 lines, 65 filesdep −binarydep −cudadep −directory

Dependencies removed: binary, cuda, directory, fclabels, filepath, language-c, llvm, mtl, transformers, unix, vector, zlib

Files

Data/Array/Accelerate.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-}   -- only for the deprecated class aliases  -- |@@ -38,7 +38,7 @@ module Data.Array.Accelerate (    -- * Scalar element types-  Int, Int8, Int16, Int32, Int64, Word, Word8, Word16, Word32, Word64, +  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,@@ -55,14 +55,14 @@   -- * Array shapes & indices   Z(..), (:.)(..), Shape, All(..), Any(..), Slice(..),   DIM0, DIM1, DIM2, DIM3, DIM4, DIM5, DIM6, DIM7, DIM8, DIM9,-  +   -- * Operations to use Accelerate arrays from plain Haskell   arrayDim, arrayShape, arraySize, indexArray, fromIArray, toIArray, fromList, toList,    -- * The /Accelerate/ language   module Data.Array.Accelerate.Language,   module Data.Array.Accelerate.Prelude,-  +   -- * Deprecated names for backwards compatibility   Elem, Ix, SliceIx, tuple, untuple,   @@ -73,7 +73,6 @@  -- friends import Data.Array.Accelerate.Type-import Data.Array.Accelerate.AST (Arrays) import Data.Array.Accelerate.Array.Sugar hiding ((!), shape, dim, size) import qualified Data.Array.Accelerate.Array.Sugar as Sugar import Data.Array.Accelerate.Language@@ -123,9 +122,9 @@ instance Slice sh => SliceIx sh  {-# DEPRECATED tuple "Use 'lift' instead" #-}-tuple :: Lift e => e -> Exp (Plain e)+tuple :: Lift Exp e => e -> Exp (Plain e) tuple = lift  {-# DEPRECATED untuple "Use 'unlift' instead" #-}-untuple :: Unlift e => Exp (Plain e) -> e+untuple :: Unlift Exp e => Exp (Plain e) -> e untuple = unlift
Data/Array/Accelerate/AST.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns, CPP, GADTs, DeriveDataTypeable, StandaloneDeriving #-} {-# LANGUAGE FlexibleContexts, FlexibleInstances, TypeFamilies, TypeOperators #-} {-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances, ScopedTypeVariables #-}+{-# OPTIONS_HADDOCK hide #-} -- | -- Module      : Data.Array.Accelerate.AST -- Copyright   : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee@@ -67,13 +68,12 @@ module Data.Array.Accelerate.AST (    -- * Typed de Bruijn indices-  Idx(..), deBruijnToInt,+  Idx(..), idxToInt,    -- * Valuation environment   Val(..), ValElt(..), prj, prjElt,    -- * Accelerated array expressions-  Arrays(..), ArraysR(..),    PreOpenAfun(..), OpenAfun, PreAfun, Afun, PreOpenAcc(..), OpenAcc(..), Acc,   Stencil(..), StencilR(..), @@ -90,7 +90,6 @@ import Data.Array.Accelerate.Type import Data.Array.Accelerate.Tuple import Data.Array.Accelerate.Array.Representation (SliceIndex)-import Data.Array.Accelerate.Array.Delayed        (Delayable) import Data.Array.Accelerate.Array.Sugar          as Sugar  #include "accelerate.h"@@ -108,9 +107,9 @@  -- de Bruijn Index to Int conversion ---deBruijnToInt :: Idx env t -> Int-deBruijnToInt ZeroIdx       = 0-deBruijnToInt (SuccIdx idx) = 1 + deBruijnToInt idx+idxToInt :: Idx env t -> Int+idxToInt ZeroIdx       = 0+idxToInt (SuccIdx idx) = 1 + idxToInt idx   -- Environments@@ -149,27 +148,6 @@ -- Array expressions -- ----------------- --- |Tuples of arrays (of type 'Array dim e').  This characterises the domain of results of--- Accelerate array computations.----class (Delayable arrs, Typeable arrs) => Arrays arrs where-  arrays :: ArraysR arrs-  --- |GADT reifying the 'Arrays' class.----data ArraysR arrs where-  ArraysRunit  :: ArraysR ()-  ArraysRarray :: (Shape sh, Elt e) => ArraysR (Array sh e)-  ArraysRpair  :: ArraysR arrs1 -> ArraysR arrs2 -> ArraysR (arrs1, arrs2)-  -instance Arrays () where-  arrays = ArraysRunit-instance (Shape sh, Elt e) => Arrays (Array sh e) where-  arrays = ArraysRarray-instance (Arrays arrs1, Arrays arrs2) => Arrays (arrs1, arrs2) where-  arrays = ArraysRpair arrays arrays-- -- |Function abstraction over parametrised array computations -- data PreOpenAfun acc aenv t where@@ -213,27 +191,25 @@   -- 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 expr's scope-               -> PreOpenAcc acc aenv            bodyArrs--  -- Variant of 'Let' binding a pair by decomposing it-  Alet2        :: (Arrays bndArrs1, Arrays bndArrs2, Arrays bodyArrs)-               => acc            aenv            (bndArrs1, bndArrs2)   -- bound expressions-               -> acc            ((aenv, bndArrs1), bndArrs2)-                                                 bodyArrs               -- the bound expr's scope+               => acc            aenv            bndArrs        -- bound expression+               -> acc            (aenv, bndArrs) bodyArrs       -- the bound expression scope                -> PreOpenAcc acc aenv            bodyArrs -  PairArrays  :: (Shape sh1, Shape sh2, Elt e1, Elt e2)-              => acc            aenv (Array sh1 e1)-              -> acc            aenv (Array sh2 e2)-              -> PreOpenAcc acc aenv (Array sh1 e1, Array sh2 e2)-   -- Variable bound by a 'Let', represented by a de Bruijn index   Avar        :: Arrays arrs               => Idx            aenv arrs               -> PreOpenAcc acc aenv arrs +  -- Tuples of arrays+  Atuple      :: (Arrays arrs, IsTuple arrs)+              => Atuple    (acc aenv) (TupleRepr arrs)+              -> PreOpenAcc acc aenv  arrs++  Aprj        :: (Arrays arrs, IsTuple arrs, Arrays a)+              => TupleIdx (TupleRepr arrs) a+              ->            acc aenv arrs+              -> PreOpenAcc acc aenv a+   -- Array-function application (to keep things simple for the moment, the function must be closed)   Apply       :: (Arrays arrs1, Arrays arrs2)               => PreAfun    acc      (arrs1 -> arrs2)@@ -248,8 +224,9 @@               -> PreOpenAcc acc aenv arrs    -- Array inlet (triggers async host->device transfer if necessary)-  Use         :: Array dim e-              -> PreOpenAcc acc aenv (Array dim e)+  Use         :: Arrays arrs+              => ArrRepr arrs+              -> PreOpenAcc acc aenv arrs    -- Capture a scalar (or a tuple of scalars) in a singleton array   Unit        :: Elt e@@ -263,7 +240,7 @@               -> acc            aenv (Array sh' e)       -- array to be reshaped               -> PreOpenAcc acc aenv (Array sh e) -  -- Constuct a new array by applying a function to each index.+  -- 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@@ -320,18 +297,18 @@               -> 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)+  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                -- segment descriptor+              -> acc            aenv (Segments i)            -- segment descriptor               -> PreOpenAcc acc aenv (Array (sh:.Int) e)    -- 'FoldSeg' without a default value-  Fold1Seg    :: (Shape sh, Elt e)+  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                -- segment descriptor+              -> 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*@@ -501,6 +478,7 @@                              rf' (y + 1))     where       rf' d = rf (Z:.d)+ instance Elt e => Stencil DIM1 e (e, e, e, e, e) where   stencil = StencilRunit5   stencilAccess rf (Z:.y) = (rf' (y - 2),@@ -540,26 +518,37 @@           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 (ix:.i) = (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-      rf' d ds = rf (ds :. d)+      -- Invert then re-invert to ensure each recursive step gets a shape in the+      -- standard scoc (right-recursive) ordering+      --+      ix' :. i  = invertShape xi+      ix        = invertShape ix' +      -- Inject this dimension innermost+      --+      rf' d ds  = rf $ invertShape (invertShape ds :. d)++ instance (Stencil (sh:.Int) a row1,           Stencil (sh:.Int) a row2,           Stencil (sh:.Int) a row3,           Stencil (sh:.Int) a row4,           Stencil (sh:.Int) a row5) => Stencil (sh:.Int:.Int) a (row1, row2, row3, row4, row5) where   stencil = StencilRtup5 stencil stencil stencil stencil stencil-  stencilAccess rf (ix:.i) = (stencilAccess (rf' (i - 2)) ix,-                              stencilAccess (rf' (i - 1)) ix,-                              stencilAccess (rf'  i     ) ix,-                              stencilAccess (rf' (i + 1)) ix,-                              stencilAccess (rf' (i + 2)) ix)+  stencilAccess rf xi = (stencilAccess (rf' (i - 2)) ix,+                         stencilAccess (rf' (i - 1)) ix,+                         stencilAccess (rf'  i     ) ix,+                         stencilAccess (rf' (i + 1)) ix,+                         stencilAccess (rf' (i + 2)) ix)     where-      rf' d ds = rf (ds :. d)+      ix' :. i  = invertShape xi+      ix        = invertShape ix'+      rf' d ds  = rf $ invertShape (invertShape ds :. d)  instance (Stencil (sh:.Int) a row1,           Stencil (sh:.Int) a row2,@@ -570,15 +559,17 @@           Stencil (sh:.Int) a row7)   => Stencil (sh:.Int:.Int) a (row1, row2, row3, row4, row5, row6, row7) where   stencil = StencilRtup7 stencil stencil stencil stencil stencil stencil stencil-  stencilAccess rf (ix:.i) = (stencilAccess (rf' (i - 3)) ix,-                              stencilAccess (rf' (i - 2)) ix,-                              stencilAccess (rf' (i - 1)) ix,-                              stencilAccess (rf'  i     ) ix,-                              stencilAccess (rf' (i + 1)) ix,-                              stencilAccess (rf' (i + 2)) ix,-                              stencilAccess (rf' (i + 3)) ix)+  stencilAccess rf xi = (stencilAccess (rf' (i - 3)) ix,+                         stencilAccess (rf' (i - 2)) ix,+                         stencilAccess (rf' (i - 1)) ix,+                         stencilAccess (rf'  i     ) ix,+                         stencilAccess (rf' (i + 1)) ix,+                         stencilAccess (rf' (i + 2)) ix,+                         stencilAccess (rf' (i + 3)) ix)     where-      rf' d ds = rf (ds :. d)+      ix' :. i  = invertShape xi+      ix        = invertShape ix'+      rf' d ds  = rf $ invertShape (invertShape ds :. d)  instance (Stencil (sh:.Int) a row1,           Stencil (sh:.Int) a row2,@@ -591,19 +582,39 @@           Stencil (sh:.Int) a row9)   => Stencil (sh:.Int:.Int) a (row1, row2, row3, row4, row5, row6, row7, row8, row9) where   stencil = StencilRtup9 stencil stencil stencil stencil stencil stencil stencil stencil stencil-  stencilAccess rf (ix:.i) = (stencilAccess (rf' (i - 4)) ix,-                              stencilAccess (rf' (i - 3)) ix,-                              stencilAccess (rf' (i - 2)) ix,-                              stencilAccess (rf' (i - 1)) ix,-                              stencilAccess (rf'  i     ) ix,-                              stencilAccess (rf' (i + 1)) ix,-                              stencilAccess (rf' (i + 2)) ix,-                              stencilAccess (rf' (i + 3)) ix,-                              stencilAccess (rf' (i + 4)) ix)+  stencilAccess rf xi = (stencilAccess (rf' (i - 4)) ix,+                         stencilAccess (rf' (i - 3)) ix,+                         stencilAccess (rf' (i - 2)) ix,+                         stencilAccess (rf' (i - 1)) ix,+                         stencilAccess (rf'  i     ) ix,+                         stencilAccess (rf' (i + 1)) ix,+                         stencilAccess (rf' (i + 2)) ix,+                         stencilAccess (rf' (i + 3)) ix,+                         stencilAccess (rf' (i + 4)) ix)     where-      rf' d ds = rf (ds :. d)+      ix' :. i  = invertShape xi+      ix        = invertShape ix'+      rf' d ds  = rf $ invertShape (invertShape ds :. d)  +-- For stencilAccess to match how the user draws the stencil in code as a series+-- of nested tuples, we need to recurse from the left. That is, we desire the+-- following 2D stencil to represent elements to the top, bottom, left, and+-- right of the focus as follows:+--+-- stencil2D ( (_, t, _)+--           , (l, _, r)+--           , (_, b, _) ) = ...+--+-- This function is used to reverse all components of a shape so that the+-- innermost component, now the head, can be picked off.+--+-- ...but needing to go via lists is unfortunate.+--+invertShape :: Shape sh => sh -> sh+invertShape =  listToShape . reverse . shapeToList++ -- Embedded expressions -- -------------------- @@ -649,12 +660,12 @@   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)+  Prj         :: (Elt t, IsTuple t, Elt e)               => TupleIdx (TupleRepr t) e               -> PreOpenExp acc env aenv t               -> PreOpenExp acc env aenv e@@ -703,10 +714,9 @@               => acc                aenv (Array dim e)                -> PreOpenExp acc env aenv dim -  -- Number of elements of an array-  -- the array expression can not contain any free scalar variables-  Size        :: (Shape dim, Elt e)-              => acc                aenv (Array dim e)+  -- Number of elements of an array given its shape+  ShapeSize   :: Shape dim+              => PreOpenExp acc env aenv dim               -> PreOpenExp acc env aenv Int  -- |Vanilla open expression
Data/Array/Accelerate/Analysis/Shape.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE ScopedTypeVariables, GADTs, RankNTypes #-}+{-# OPTIONS_HADDOCK hide #-} -- | -- Module      : Data.Array.Accelerate.Analysis.Shape -- Copyright   : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell@@ -12,9 +13,7 @@ module Data.Array.Accelerate.Analysis.Shape (    -- * query AST dimensionality-  AccDim, AccDim2,-  accDim, accDim2,-  preAccDim, preAccDim2+  AccDim, accDim, preAccDim,  ) where @@ -24,7 +23,6 @@   type AccDim acc  = forall aenv sh e. acc aenv (Array sh e) -> Int-type AccDim2 acc = forall aenv sh1 e1 sh2 e2. acc aenv (Array sh1 e1, Array sh2 e2) -> (Int,Int)  -- |Reify the dimensionality of the result type of an array computation --@@ -37,15 +35,24 @@ preAccDim k pacc =   case pacc of     Alet  _ acc          -> k acc-    Alet2 _ acc          -> k acc-    Avar _               -> -- ndim (eltType (undefined::sh))   -- should work - GHC 6.12 bug?-                            case arrays :: ArraysR (Array sh e) of+    Avar _               -> case arrays' (undefined :: Array sh e) of                               ArraysRarray -> ndim (eltType (undefined::sh))-    Apply _ _            -> -- ndim (eltType (undefined::sh))   -- should work - GHC 6.12 bug?-                            case arrays :: ArraysR (Array sh e) of+                              _            -> error "halt, fiend!"++    Apply _ _            -> case arrays' (undefined :: Array sh e) of                               ArraysRarray -> ndim (eltType (undefined::sh))+                              _            -> error "umm, hello"++    Atuple _             -> case arrays' (undefined :: Array sh e) of+                              ArraysRarray -> ndim (eltType (undefined::sh))+                              _            -> error "can we keep him?"++    Aprj _ _             -> case arrays' (undefined :: Array sh e) of+                              ArraysRarray -> ndim (eltType (undefined::sh))+                              _            -> error "inconceivable!"+     Acond _ acc _        -> k acc-    Use (Array _ _)      -> ndim (eltType (undefined::sh))+    Use ((),(Array _ _)) -> ndim (eltType (undefined::sh))     Unit _               -> 0     Generate _ _         -> ndim (eltType (undefined::sh))     Reshape _ _          -> ndim (eltType (undefined::sh))@@ -54,9 +61,9 @@     Map _ acc            -> k acc     ZipWith _ _ acc      -> k acc     Fold _ _ acc         -> k acc - 1-    FoldSeg _ _ _ acc    -> k acc     Fold1 _ acc          -> k acc - 1-    Fold1Seg _ _ acc     -> k acc+    FoldSeg _ _ acc _    -> k acc+    Fold1Seg _ acc _     -> k acc     Scanl _ _ acc        -> k acc     Scanl1 _ acc         -> k acc     Scanr _ _ acc        -> k acc@@ -66,42 +73,6 @@     Stencil _ _ acc      -> k acc     Stencil2 _ _ acc _ _ -> k acc ---- |Reify the dimensionality of the results of a computation that yields two--- arrays----accDim2 :: AccDim2 OpenAcc-accDim2 (OpenAcc acc) = preAccDim2 accDim accDim2 acc--preAccDim2 :: forall acc aenv sh1 e1 sh2 e2.-              AccDim  acc-           -> AccDim2 acc-           -> PreOpenAcc acc aenv (Array sh1 e1, Array sh2 e2)-           -> (Int, Int)-preAccDim2 k1 k2 pacc =-  case pacc of-    Alet  _ acc          -> k2 acc-    Alet2 _ acc          -> k2 acc-    PairArrays acc1 acc2 -> (k1 acc1, k1 acc2)-    Avar _ ->-      -- (ndim (eltType (undefined::dim1)), ndim (eltType (undefined::dim2)))-      -- should work - GHC 6.12 bug?-      case arrays :: ArraysR (Array sh1 e1, Array sh2 e2) of-        ArraysRpair ArraysRarray ArraysRarray-          -> (ndim (eltType (undefined::sh1))-             ,ndim (eltType (undefined::sh2)))-        _ -> error "GHC is too dumb to realise that this is dead code"-    Apply _ _ ->-      -- (ndim (eltType (undefined::dim1)), ndim (eltType (undefined::dim2)))-      -- should work - GHC 6.12 bug?-      case arrays :: ArraysR (Array sh1 e1, Array sh2 e2) of-        ArraysRpair ArraysRarray ArraysRarray-          -> (ndim (eltType (undefined::sh1))-             ,ndim (eltType (undefined::sh2)))-        _ -> error "GHC is too dumb to realise that this is dead code"-    Acond _ acc _  -> k2 acc-    Scanl' _ _ acc -> (k1 acc, 0)-    Scanr' _ _ acc -> (k1 acc, 0)  -- Count the number of components to a tuple type --
Data/Array/Accelerate/Analysis/Stencil.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE GADTs, ScopedTypeVariables #-}+{-# OPTIONS_HADDOCK hide #-} -- | -- Module      : Data.Array.Accelerate.CUDA.Analysis.Stencil -- Copyright   : [2010..2011] Ben Lever, Trevor L. McDonell@@ -6,7 +7,7 @@ -- -- Maintainer  : Manuel M T Chakravarty <chak@cse.unsw.edu.au> -- Stability   : experimental--- Portability : non-partable (GHC extensions)+-- Portability : non-portable (GHC extensions) --  module Data.Array.Accelerate.Analysis.Stencil (offsets, offsets2) where@@ -17,7 +18,8 @@  -- |Calculate the offset coordinates for each stencil element relative to the -- focal point. The coordinates are returned as a flattened list from the--- top-left element to the bottom-right.+-- bottom-left element to the top-right. This ordering matches the Var indexing+-- order. -- offsets :: forall a b sh aenv stencil. Stencil sh a stencil         => {- dummy -} Fun aenv (stencil -> b)@@ -38,40 +40,40 @@ -- |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 a b c) = concat-  [ map (:.(-1)) $ positionsR a+positionsR (StencilRtup3 c b a) = concat+  [ map (:.  1 ) $ positionsR c   , map (:.  0 ) $ positionsR b-  , map (:.  1 ) $ positionsR c ]+  , map (:.(-1)) $ positionsR a ] -positionsR (StencilRtup5 a b c d e) = concat-  [ map (:.(-2)) $ positionsR a-  , map (:.(-1)) $ positionsR b-  , map (:.  0 ) $ positionsR c+positionsR (StencilRtup5 e d c b a) = concat+  [ map (:.  2 ) $ positionsR e   , map (:.  1 ) $ positionsR d-  , map (:.  2 ) $ positionsR e ]+  , map (:.  0 ) $ positionsR c+  , map (:.(-1)) $ positionsR b+  , map (:.(-2)) $ positionsR a ] -positionsR (StencilRtup7 a b c d e f g) = concat-  [ map (:.(-3)) $ positionsR a-  , map (:.(-2)) $ positionsR b-  , map (:.(-1)) $ positionsR c-  , map (:.  0 ) $ positionsR d-  , map (:.  1 ) $ positionsR e+positionsR (StencilRtup7 g f e d c b a) = concat+  [ map (:.  3 ) $ positionsR g   , map (:.  2 ) $ positionsR f-  , map (:.  3 ) $ positionsR g ]+  , map (:.  1 ) $ positionsR e+  , map (:.  0 ) $ positionsR d+  , map (:.(-1)) $ positionsR c+  , map (:.(-2)) $ positionsR b+  , map (:.(-3)) $ positionsR a ] -positionsR (StencilRtup9 a b c d e f g h i) = concat-  [ map (:.(-4)) $ positionsR a-  , map (:.(-3)) $ positionsR b-  , map (:.(-2)) $ positionsR c-  , map (:.(-1)) $ positionsR d-  , map (:.  0 ) $ positionsR e-  , map (:.  1 ) $ positionsR f-  , map (:.  2 ) $ positionsR g+positionsR (StencilRtup9 i h g f e d c b a) = concat+  [ map (:.  4 ) $ positionsR i   , map (:.  3 ) $ positionsR h-  , map (:.  4 ) $ positionsR i ]+  , 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 ]
Data/Array/Accelerate/Analysis/Type.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE RankNTypes, ScopedTypeVariables #-} {-# LANGUAGE GADTs, TypeFamilies, PatternGuards #-}+{-# OPTIONS_HADDOCK hide #-} -- | -- Module      : Data.Array.Accelerate.Analysis.Type -- Copyright   : [2009..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell@@ -19,9 +20,9 @@ module Data.Array.Accelerate.Analysis.Type (    -- * Query AST types-  AccType, AccType2,-  arrayType, accType, accType2, expType, sizeOf,-  preAccType, preAccType2, preExpType+  AccType,+  arrayType, accType, expType, sizeOf,+  preAccType, preExpType  ) where @@ -30,7 +31,6 @@  -- friends import Data.Array.Accelerate.Type-import Data.Array.Accelerate.Tuple import Data.Array.Accelerate.Array.Sugar import Data.Array.Accelerate.AST @@ -49,9 +49,6 @@ -- -------------------------------------  type AccType  acc = forall aenv sh e. acc aenv (Array sh e) -> TupleType (EltRepr e)-type AccType2 acc = forall aenv sh1 e1 sh2 e2.-                      acc aenv (Array sh1 e1, Array sh2 e2) -> (TupleType (EltRepr e1), -                                                                TupleType (EltRepr e2))  -- |Reify the element type of the result of an array computation. --@@ -68,15 +65,28 @@ preAccType k pacc =   case pacc of     Alet  _ acc         -> k acc-    Alet2 _ acc         -> k acc-    Avar _              -> -- eltType (undefined::e)   -- should work - GHC 6.12 bug?-                           case arrays :: ArraysR (Array sh e) of++    -- The following all contain impossible pattern matches, but GHC's type+    -- checker does no grok that+    --+    Avar _              -> case arrays' (undefined :: (Array sh e)) of                              ArraysRarray -> eltType (undefined::e)-    Apply _ _           -> -- eltType (undefined::e)   -- should work - GHC 6.12 bug?-                           case arrays :: ArraysR (Array sh e) of+                             _            -> error "When I get sad, I stop being sad and be AWESOME instead."++    Apply _ _           -> case arrays' (undefined :: Array sh e) of                              ArraysRarray -> eltType (undefined::e)+                             _            -> error "TRUE STORY."++    Atuple _            -> case arrays' (undefined :: Array sh e) of+                             ArraysRarray -> eltType (undefined::e)+                             _            -> error "I made you a cookie, but I eated it."++    Aprj _ _            -> case arrays' (undefined :: Array sh e) of+                             ArraysRarray -> eltType (undefined::e)+                             _            -> error "Hey look! even the leaves are falling for you."+     Acond _ acc _       -> k acc-    Use arr             -> arrayType arr+    Use ((),a)          -> arrayType a     Unit _              -> eltType (undefined::e)     Generate _ _        -> eltType (undefined::e)     Reshape _ acc       -> k acc@@ -97,43 +107,7 @@     Stencil _ _ _       -> eltType (undefined::e)     Stencil2 _ _ _ _ _  -> eltType (undefined::e) --- |Reify the element types of the results of an array computation that yields--- two arrays.----accType2 :: AccType2 OpenAcc-accType2 (OpenAcc acc) = preAccType2 accType accType2 acc --- |Reify the element types of the results of an array computation that yields--- two arrays using the array computation AST before tying the knot.----preAccType2 :: forall acc aenv sh1 e1 sh2 e2.-               AccType  acc-            -> AccType2 acc-            -> PreOpenAcc acc aenv (Array sh1 e1, Array sh2 e2)-            -> (TupleType (EltRepr e1), TupleType (EltRepr e2))-preAccType2 k1 k2 pacc =-  case pacc of-    Alet  _ acc          -> k2 acc-    Alet2 _ acc          -> k2 acc-    PairArrays acc1 acc2 -> (k1 acc1, k1 acc2)-    Avar _    ->-      -- (eltType (undefined::e1), eltType (undefined::e2))-      -- should work - GHC 6.12 bug?-      case arrays :: ArraysR (Array sh1 e1, Array sh2 e2) of-        ArraysRpair ArraysRarray ArraysRarray-          -> (eltType (undefined::e1), eltType (undefined::e2))-        _ -> error "GHC is too dumb to realise that this is dead code"-    Apply _ _ ->-      -- (eltType (undefined::e1), eltType (undefined::e2))-      -- should work - GHC 6.12 bug?-      case arrays :: ArraysR (Array sh1 e1, Array sh2 e2) of-        ArraysRpair ArraysRarray ArraysRarray-          -> (eltType (undefined::e1), eltType (undefined::e2))-        _ -> error "GHC is too dumb to realise that this is dead code"-    Acond _ acc _  -> k2 acc-    Scanl' _ e acc -> (k1 acc, preExpType k1 e)-    Scanr' _ e acc -> (k1 acc, preExpType k1 e)- -- |Reify the result type of a scalar expression. -- expType :: OpenExp aenv env t -> TupleType (EltRepr t)@@ -152,7 +126,7 @@     Var _             -> eltType (undefined::t)     Const _           -> eltType (undefined::t)     Tuple _           -> eltType (undefined::t)-    Prj idx _         -> tupleIdxType idx+    Prj _ _           -> eltType (undefined::t)     IndexNil          -> eltType (undefined::t)     IndexCons _ _     -> eltType (undefined::t)     IndexHead _       -> eltType (undefined::t)@@ -163,13 +137,7 @@     PrimApp _ _       -> eltType (undefined::t)     IndexScalar acc _ -> k acc     Shape _           -> eltType (undefined::t)-    Size _            -> eltType (undefined::t)---- |Reify the result type of a tuple projection.----tupleIdxType :: forall t e. TupleIdx t e -> TupleType (EltRepr e)-tupleIdxType ZeroTupIdx       = eltType (undefined::e)-tupleIdxType (SuccTupIdx idx) = tupleIdxType idx+    ShapeSize _       -> eltType (undefined::t)   -- |Size of a tuple type, in bytes
Data/Array/Accelerate/Array/Data.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE CPP, GADTs, TypeFamilies, FlexibleContexts, FlexibleInstances #-}-{-# LANGUAGE RankNTypes, MagicHash, UnboxedTuples #-}+{-# LANGUAGE RankNTypes, MagicHash, UnboxedTuples, ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-missing-methods #-}+{-# OPTIONS_HADDOCK hide #-} -- | -- Module      : Data.Array.Accelerate.Array.Data -- Copyright   : [2009..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee@@ -34,6 +35,7 @@                            unsafeFreezeByteArray#, Int#, (*#)) import GHC.Ptr            (Ptr(Ptr)) import GHC.ST             (ST(ST))+import Data.Typeable import Control.Monad import Control.Monad.ST import qualified Data.Array.IArray  as IArray@@ -97,6 +99,11 @@ -- data instance GArrayData ba CUChar  = AD_CUChar  (ba CUChar) data instance GArrayData ba (a, b)  = AD_Pair (GArrayData ba a)                                               (GArrayData ba b)++instance (Typeable1 ba, Typeable e) => Typeable (GArrayData ba e) where+  typeOf _ = myMkTyCon "Data.Array.Accelerate.Array.Data.GArrayData"+            `mkTyConApp` [typeOf (undefined::ba e), typeOf (undefined::e)]+  -- | GADT to reify the 'ArrayElt' class. --
Data/Array/Accelerate/Array/Representation.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE CPP, GADTs, FlexibleContexts, FlexibleInstances #-} {-# LANGUAGE TypeOperators, TypeFamilies #-}+{-# OPTIONS_HADDOCK hide #-} -- | -- Module      : Data.Array.Accelerate.Array.Representation -- Copyright   : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell@@ -54,8 +55,8 @@   rangeToShape :: (sh, sh) -> sh   -- convert a minpoint-maxpoint index                                    -- into a shape   shapeToRange :: sh -> (sh, sh)   -- ...the converse-   +   -- other conversions   shapeToList :: sh -> [Int]    -- convert a shape into its list of dimensions   listToShape :: [Int] -> sh    -- convert a list of dimensions into a shape@@ -63,14 +64,14 @@ instance Shape () where   dim ()            = 0   size ()           = 1-  +   () `intersect` () = ()   ignore            = ()   index () ()       = 0   bound () () _     = Right ()-  iter  () f c e    = e `c` f ()+  iter  () f _ _    = f ()   iter1 () f _      = f ()-  +   rangeToShape ((), ()) = ()   shapeToRange ()       = ((), ()) @@ -81,11 +82,12 @@ instance Shape sh => Shape (sh, Int) where   dim (sh, _)                       = dim 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+   bound (sh, sz) (ix, i) bndy     | i < 0                         = case bndy of                                         Clamp      -> bound sh ix bndy `addDim` 0
Data/Array/Accelerate/Array/Sugar.hs view
@@ -1,6 +1,7 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE TypeOperators, GADTs, TypeFamilies, FlexibleContexts, FlexibleInstances #-}-{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, StandaloneDeriving, TupleSections #-}+{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts, FlexibleInstances #-}+{-# LANGUAGE GADTs, ScopedTypeVariables, StandaloneDeriving, TupleSections #-}+{-# LANGUAGE TypeOperators, TypeFamilies, BangPatterns #-}+{-# OPTIONS_HADDOCK hide #-} -- | -- Module      : Data.Array.Accelerate.Array.Sugar -- Copyright   : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell@@ -15,10 +16,11 @@    -- * Array representation   Array(..), Scalar, Vector, Segments,+  Arrays(..), ArraysR(..), ArrRepr, ArrRepr',    -- * Class of supported surface element types and their mapping to representation types   Elt(..), EltRepr, EltRepr',-  +   -- * Derived functions   liftToElt, liftToElt2, sinkFromElt, sinkFromElt2, @@ -27,10 +29,13 @@    -- * Array indexing and slicing   Z(..), (:.)(..), All(..), Any(..), Shape(..), Slice(..),-  +   -- * Array shape query, indexing, and conversions   shape, (!), newArray, allocateArray, fromIArray, toIArray, fromList, toList, +  -- * Miscellaneous+  showShape,+ ) where  -- standard library@@ -44,12 +49,11 @@ import qualified Data.Array.Accelerate.Array.Representation as Repr  --- |Surface types representing array indices and slices--- ----------------------------------------------------+-- 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.+-- For example, the type of a rank-2 array index is @Z :.Int :. Int@.  -- |Rank-0 index --@@ -64,7 +68,7 @@  -- |Marker for entire dimensions in slice descriptors ---data All = All +data All = All   deriving (Typeable, Show)  -- |Marker for arbitrary shapes in slice descriptors@@ -72,13 +76,13 @@ data Any sh = Any   deriving (Typeable, Show) --- |Representation change for array element types--- ----------------------------------------------+-- Representation change for array element types+-- ---------------------------------------------  -- |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 () = ()@@ -638,6 +642,146 @@ -- Surface arrays -- -------------- +-- We represent tuples of arrays in the same way as tuples of scalars; using+-- '()' and '(,)' as type-level nil and snoc. This characterises the domain of+-- results of Accelerate array computations.+--+type family ArrRepr a :: *+type instance ArrRepr () = ()+type instance ArrRepr (Array sh e) = ((), Array sh e)+type instance ArrRepr (b, a) = (ArrRepr b, ArrRepr' a)+type instance ArrRepr (c, b, a) = (ArrRepr (c, b), ArrRepr' a)+type instance ArrRepr (d, c, b, a) = (ArrRepr (d, c, b), ArrRepr' a)+type instance ArrRepr (e, d, c, b, a) = (ArrRepr (e, d, c, b), ArrRepr' a)+type instance ArrRepr (f, e, d, c, b, a) = (ArrRepr (f, e, d, c, b), ArrRepr' a)+type instance ArrRepr (g, f, e, d, c, b, a) = (ArrRepr (g, f, e, d, c, b), ArrRepr' a)+type instance ArrRepr (h, g, f, e, d, c, b, a) = (ArrRepr (h, g, f, e, d, c, b), ArrRepr' a)+type instance ArrRepr (i, h, g, f, e, d, c, b, a) = (ArrRepr (i, h, g, f, e, d, c, b), ArrRepr' a)++type family ArrRepr' a :: *+type instance ArrRepr' () = ()+type instance ArrRepr' (Array sh e) = Array sh e+type instance ArrRepr' (b, a) = (ArrRepr b, ArrRepr' a)+type instance ArrRepr' (c, b, a) = (ArrRepr (c, b), ArrRepr' a)+type instance ArrRepr' (d, c, b, a) = (ArrRepr (d, c, b), ArrRepr' a)+type instance ArrRepr' (e, d, c, b, a) = (ArrRepr (e, d, c, b), ArrRepr' a)+type instance ArrRepr' (f, e, d, c, b, a) = (ArrRepr (f, e, d, c, b), ArrRepr' a)+type instance ArrRepr' (g, f, e, d, c, b, a) = (ArrRepr (g, f, e, d, c, b), ArrRepr' a)+type instance ArrRepr' (h, g, f, e, d, c, b, a) = (ArrRepr (h, g, f, e, d, c, b), ArrRepr' a)+type instance ArrRepr' (i, h, g, f, e, d, c, b, a) = (ArrRepr (i, h, g, f, e, d, c, b), ArrRepr' a)++-- Array type reification+--+data ArraysR arrs where+  ArraysRunit  ::                                   ArraysR ()+  ArraysRarray :: (Shape sh, Elt e) =>              ArraysR (Array sh e)+  ArraysRpair  :: ArraysR arrs1 -> ArraysR arrs2 -> ArraysR (arrs1, arrs2)++class (Typeable (ArrRepr a), Typeable (ArrRepr' a), Typeable a) => Arrays a where+  arrays   :: a {- dummy -} -> ArraysR (ArrRepr  a)+  arrays'  :: a {- dummy -} -> ArraysR (ArrRepr' a)+  --+  toArr    :: ArrRepr  a -> a+  toArr'   :: ArrRepr' a -> a+  fromArr  :: a -> ArrRepr  a+  fromArr' :: a -> ArrRepr' a+++instance Arrays () where+  arrays  _ = ArraysRunit+  arrays' _ = ArraysRunit+  --+  toArr     = id+  toArr'    = id+  fromArr   = id+  fromArr'  = id++instance (Shape sh, Elt e) => Arrays (Array sh e) where+  arrays  _       = ArraysRpair ArraysRunit ArraysRarray+  arrays' _       = ArraysRarray+  --+  toArr ((), arr) = arr+  toArr'          = id+  fromArr arr     = ((), arr)+  fromArr'        = id++instance (Arrays b, Arrays a) => Arrays (b, a) where+  arrays  _ = ArraysRpair (arrays (undefined::b)) (arrays' (undefined::a))+  arrays' _ = ArraysRpair (arrays (undefined::b)) (arrays' (undefined::a))+  --+  toArr    (b, a) = (toArr b, toArr' a)+  toArr'   (b, a) = (toArr b, toArr' a)+  fromArr  (b, a) = (fromArr b, fromArr' a)+  fromArr' (b, a) = (fromArr b, fromArr' a)++instance (Arrays c, Arrays b, Arrays a) => Arrays (c, b, a) where+  arrays  _ = ArraysRpair (arrays (undefined::(c,b))) (arrays' (undefined::a))+  arrays' _ = ArraysRpair (arrays (undefined::(c,b))) (arrays' (undefined::a))+  --+  toArr    (cb, a) = let (c, b) = toArr cb in (c, b, toArr' a)+  toArr'   (cb, a) = let (c, b) = toArr cb in (c, b, toArr' a)+  fromArr  (c, b, a) = (fromArr (c, b), fromArr' a)+  fromArr' (c, b, a) = (fromArr (c, b), fromArr' a)++instance (Arrays d, Arrays c, Arrays b, Arrays a) => Arrays (d, c, b, a) where+  arrays  _ = ArraysRpair (arrays (undefined::(d,c,b))) (arrays' (undefined::a))+  arrays' _ = ArraysRpair (arrays (undefined::(d,c,b))) (arrays' (undefined::a))+  --+  toArr    (dcb, a) = let (d, c, b) = toArr dcb in (d, c, b, toArr' a)+  toArr'   (dcb, a) = let (d, c, b) = toArr dcb in (d, c, b, toArr' a)+  fromArr  (d, c, b, a) = (fromArr (d, c, b), fromArr' a)+  fromArr' (d, c, b, a) = (fromArr (d, c, b), fromArr' a)++instance (Arrays e, Arrays d, Arrays c, Arrays b, Arrays a) => Arrays (e, d, c, b, a) where+  arrays  _ = ArraysRpair (arrays (undefined::(e,d,c,b))) (arrays' (undefined::a))+  arrays' _ = ArraysRpair (arrays (undefined::(e,d,c,b))) (arrays' (undefined::a))+  --+  toArr    (edcb, a) = let (e, d, c, b) = toArr edcb in (e, d, c, b, toArr' a)+  toArr'   (edcb, a) = let (e, d, c, b) = toArr edcb in (e, d, c, b, toArr' a)+  fromArr  (e, d, c, b, a) = (fromArr (e, d, c, b), fromArr' a)+  fromArr' (e, d, c, b, a) = (fromArr (e, d, c, b), fromArr' a)++instance (Arrays f, Arrays e, Arrays d, Arrays c, Arrays b, Arrays a)+  => Arrays (f, e, d, c, b, a) where+  arrays  _ = ArraysRpair (arrays (undefined::(f,e,d,c,b))) (arrays' (undefined::a))+  arrays' _ = ArraysRpair (arrays (undefined::(f,e,d,c,b))) (arrays' (undefined::a))+  --+  toArr    (fedcb, a) = let (f, e, d, c, b) = toArr fedcb in (f, e, d, c, b, toArr' a)+  toArr'   (fedcb, a) = let (f, e, d, c, b) = toArr fedcb in (f, e, d, c, b, toArr' a)+  fromArr  (f, e, d, c, b, a) = (fromArr (f, e, d, c, b), fromArr' a)+  fromArr' (f, e, d, c, b, a) = (fromArr (f, e, d, c, b), fromArr' a)++instance (Arrays g, Arrays f, Arrays e, Arrays d, Arrays c, Arrays b, Arrays a)+  => Arrays (g, f, e, d, c, b, a) where+  arrays  _ = ArraysRpair (arrays (undefined::(g,f,e,d,c,b))) (arrays' (undefined::a))+  arrays' _ = ArraysRpair (arrays (undefined::(g,f,e,d,c,b))) (arrays' (undefined::a))+  --+  toArr    (gfedcb, a) = let (g, f, e, d, c, b) = toArr gfedcb in (g, f, e, d, c, b, toArr' a)+  toArr'   (gfedcb, a) = let (g, f, e, d, c, b) = toArr gfedcb in (g, f, e, d, c, b, toArr' a)+  fromArr  (g, f, e, d, c, b, a) = (fromArr (g, f, e, d, c, b), fromArr' a)+  fromArr' (g, f, e, d, c, b, a) = (fromArr (g, f, e, d, c, b), fromArr' a)++instance (Arrays h, Arrays g, Arrays f, Arrays e, Arrays d, Arrays c, Arrays b, Arrays a)+  => Arrays (h, g, f, e, d, c, b, a) where+  arrays  _ = ArraysRpair (arrays (undefined::(h,g,f,e,d,c,b))) (arrays' (undefined::a))+  arrays' _ = ArraysRpair (arrays (undefined::(h,g,f,e,d,c,b))) (arrays' (undefined::a))+  --+  toArr    (hgfedcb, a) = let (h, g, f, e, d, c, b) = toArr hgfedcb in (h, g, f, e, d, c, b, toArr' a)+  toArr'   (hgfedcb, a) = let (h, g, f, e, d, c, b) = toArr hgfedcb in (h, g, f, e, d, c, b, toArr' a)+  fromArr  (h, g, f, e, d, c, b, a) = (fromArr (h, g, f, e, d, c, b), fromArr' a)+  fromArr' (h, g, f, e, d, c, b, a) = (fromArr (h, g, f, e, d, c, b), fromArr' a)++instance (Arrays i, Arrays h, Arrays g, Arrays f, Arrays e, Arrays d, Arrays c, Arrays b, Arrays a)+  => Arrays (i, h, g, f, e, d, c, b, a) where+  arrays  _ = ArraysRpair (arrays (undefined::(i,h,g,f,e,d,c,b))) (arrays' (undefined::a))+  arrays' _ = ArraysRpair (arrays (undefined::(i,h,g,f,e,d,c,b))) (arrays' (undefined::a))+  --+  toArr    (ihgfedcb, a) = let (i, h, g, f, e, d, c, b) = toArr ihgfedcb in (i, h, g, f, e, d, c, b, toArr' a)+  toArr'   (ihgfedcb, a) = let (i, h, g, f, e, d, c, b) = toArr ihgfedcb in (i, h, g, f, e, d, c, b, toArr' a)+  fromArr  (i, h, g, f, e, d, c, b, a) = (fromArr (i, h, g, f, e, d, c, b), fromArr' a)+  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 -- -- * If device and host memory are separate, arrays will be transferred to the@@ -660,9 +804,12 @@ -- type Vector e = Array DIM1 e --- |Segment descriptor+-- |Segment descriptor (vector of segment lengths) ---type Segments = Vector Int+-- 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  -- Shorthand for common shape types --@@ -750,8 +897,8 @@ instance Shape sh => Shape (sh:.Int) where   sliceAnyIndex _ = Repr.SliceAll (sliceAnyIndex (undefined :: sh)) --- |Slices -aka generalised indices- as n-tuples and mappings of slice--- indicies 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))         => Slice sl where@@ -811,7 +958,7 @@ newArray sh f = adata `seq` Array (fromElt sh) adata   where      (adata, _) = runArrayData $ do-                   arr <- newArrayData (1024 `max` size sh)+                   arr <- newArrayData (size sh)                    let write ix = writeArrayData arr (index sh ix)                                                       (fromElt (f ix))                    iter sh write (>>) (return ())@@ -823,7 +970,7 @@ {-# INLINE allocateArray #-} allocateArray sh = adata `seq` Array (fromElt sh) adata   where-    (adata, _) = runArrayData $ (,undefined) `fmap` newArrayData (1024 `max` size sh)+    (adata, _) = runArrayData $ (,undefined) `fmap` newArrayData (size sh)   -- |Convert an 'IArray' to an accelerated array.@@ -847,9 +994,18 @@ -- |Convert a list (with elements in row-major order) to an accelerated array. -- fromList :: (Shape sh, Elt e) => sh -> [e] -> Array sh e-fromList sh l = newArray sh indexIntoList +{-# INLINE fromList #-}+fromList sh xs = adata `seq` Array (fromElt sh) adata   where-    indexIntoList ix = l!!index sh ix+    !n          = size sh+    (adata, _)  = runArrayData $ do+                    arr <- newArrayData (size sh)+                    let go !i _ | i >= n = return ()+                        go !i (v:vs)     = writeArrayData 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. --@@ -863,5 +1019,10 @@ -- instance Show (Array sh e) where   show arr@(Array sh _adata) -    = "Array " ++ show (toElt sh :: sh) ++ " " ++ show (toList arr)+    = "Array (" ++ showShape (toElt sh :: sh) ++ ") " ++ show (toList arr)++-- | Nicely format a shape as a string+--+showShape :: Shape sh => sh -> String+showShape = foldr (\sh str -> str ++ " :. " ++ show sh) "Z" . shapeToList
− Data/Array/Accelerate/CUDA.hs 
@@ -1,92 +0,0 @@-{-# LANGUAGE CPP, GADTs #-}--- |--- Module      : Data.Array.Accelerate.CUDA--- Copyright   : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, 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 the CUDA backend for the embedded array language.-----module Data.Array.Accelerate.CUDA (--  -- * Generate and execute CUDA code for an array expression-  Arrays, run, stream--) where---- standard library-import Prelude hiding (catch)-import Data.Label-import Control.Exception-import Control.Applicative-import System.IO.Unsafe-import qualified Data.HashTable                   as Hash---- CUDA binding-import Foreign.CUDA.Driver.Error-import qualified Foreign.CUDA.Driver              as CUDA---- friends-import Data.Array.Accelerate.AST                  (Arrays(..), ArraysR(..))-import Data.Array.Accelerate.Smart                (Acc, convertAcc, convertAccFun1)-import Data.Array.Accelerate.Array.Representation (size)-import Data.Array.Accelerate.Array.Sugar          (Array(..))-import Data.Array.Accelerate.CUDA.Array.Data-import Data.Array.Accelerate.CUDA.State-import Data.Array.Accelerate.CUDA.Compile-import Data.Array.Accelerate.CUDA.Execute--#include "accelerate.h"----- Accelerate: CUDA--- -------------------- | Compile and run a complete embedded array program using the CUDA backend----run :: Arrays a => Acc a -> a-{-# NOINLINE run #-}-run a = unsafePerformIO execute-  where-    acc     = convertAcc a-    execute = evalCUDA (compileAcc acc >>= executeAcc >>= collect)-              `catch`-              \e -> INTERNAL_ERROR(error) "unhandled" (show (e :: CUDAException))----- | Stream a lazily read list of input arrays through the given program,--- collecting results as we go----stream :: (Arrays a, Arrays b) => (Acc a -> Acc b) -> [a] -> [b]-{-# NOINLINE stream #-}-stream f arrs = unsafePerformIO $ uncurry (execute arrs) =<< runCUDA (compileAfun1 acc)-  where-    acc                       = convertAccFun1 f-    execute []     _    state = finalise state >> return []   -- release all constant arrays-    execute (a:as) afun state = do-      (b,s) <- runCUDAWith state (executeAfun1 afun a >>= collect)-               `catch`-               \e -> INTERNAL_ERROR(error) "unhandled" (show (e :: CUDAException))-      bs    <- unsafeInterleaveIO (execute as afun s)-      return (b:bs)-    ---    finalise state            = do-      mem <- Hash.toList (get memoryTable state)-      mapM_ (\(_,MemoryEntry _ p) -> CUDA.free (CUDA.castDevPtr p)) mem----- Copy from device to host, and decrement the usage counter. This last step--- should result in all transient arrays having been removed from the device.----collect :: Arrays arrs => arrs -> CIO arrs-collect arrs = collectR arrays arrs-  where-    collectR :: ArraysR arrs -> arrs -> CIO arrs-    collectR ArraysRunit         ()                = return ()-    collectR ArraysRarray        arr@(Array sh ad) = peekArray ad (size sh) >> freeArray ad >> return arr-    collectR (ArraysRpair r1 r2) (arrs1, arrs2)    = (,) <$> collectR r1 arrs1 <*> collectR r2 arrs2-
− Data/Array/Accelerate/CUDA/Analysis/Device.hs 
@@ -1,41 +0,0 @@--- |--- Module      : Data.Array.Accelerate.CUDA.Analysis.Device--- Copyright   : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell--- License     : BSD3------ Maintainer  : Manuel M T Chakravarty <chak@cse.unsw.edu.au>--- Stability   : experimental--- Portability : non-partable (GHC extensions)-----module Data.Array.Accelerate.CUDA.Analysis.Device-  where--import Data.Ord-import Data.List-import Data.Function-import Foreign.CUDA.Driver.Device-import qualified Foreign.CUDA.Driver    as CUDA----- Select the best of the available CUDA capable devices. This prefers devices--- with higher compute capability, followed by maximum throughput. This does not--- take into account any other factors, such as whether the device is currently--- in use by another process.------ Ignore the possibility of emulation-mode devices, as this has been deprecated--- as of CUDA v3.0 (compute-capability == 9999.9999)----selectBestDevice :: IO (Device, DeviceProperties)-selectBestDevice = do-  dev  <- mapM CUDA.device . enumFromTo 0 . subtract 1 . fromIntegral =<< CUDA.count-  prop <- mapM CUDA.props dev-  return . head . sortBy (cmp `on` snd) $ zip dev prop-  where-    compute = computeCapability-    flops d = multiProcessorCount d * clockRate d * cores d-    cores d | compute d < 2 = 8-            | otherwise     = 32-    cmp x y | compute x == compute y = comparing flops x y-            | otherwise              = comparing compute x y-
− Data/Array/Accelerate/CUDA/Analysis/Hash.hs 
@@ -1,143 +0,0 @@-{-# LANGUAGE CPP, GADTs #-}--- |--- Module      : Data.Array.Accelerate.CUDA.Analysis.Hash--- Copyright   : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell--- License     : BSD3------ Maintainer  : Manuel M T Chakravarty <chak@cse.unsw.edu.au>--- Stability   : experimental--- Portability : non-partable (GHC extensions)-----module Data.Array.Accelerate.CUDA.Analysis.Hash (--  AccKey, accToKey, hashAccKey--) where--import Data.Char-import Language.C-import Text.PrettyPrint-import Codec.Compression.Zlib-import Data.ByteString.Lazy.Char8                       (ByteString)-import qualified Data.ByteString.Lazy.Char8             as L-import qualified Data.HashTable                         as Hash--import Data.Array.Accelerate.AST-import Data.Array.Accelerate.Type-import Data.Array.Accelerate.Pretty ()-import Data.Array.Accelerate.Analysis.Type-import Data.Array.Accelerate.Analysis.Shape-import Data.Array.Accelerate.CUDA.CodeGen-import Data.Array.Accelerate.Array.Representation-import qualified Data.Array.Accelerate.Array.Sugar      as Sugar--#include "accelerate.h"---type AccKey = ByteString---- | Reimplementation of Data.HashTable.hashString to fold over a lazy--- bytestring rather than a list of characters.----hashAccKey :: AccKey -> Int32-hashAccKey = L.foldl' f golden-  where-    f m c  = fromIntegral (ord c) * magic + Hash.hashInt (fromIntegral m)-    magic  = 0xdeadbeef-    golden = 1013904242 -- = round ((sqrt 5 - 1) * 2^32)----- | Generate a unique key for each kernel computation----accToKey :: OpenAcc aenv a -> AccKey-accToKey acc =-  let key = compress . L.pack $ showAcc acc-  in  L.head key `seq` key----- The first radical identifies the skeleton type (actually, this is arithmetic--- sequence A000978), followed by the salient features that parameterise--- skeleton instantiation.----showAcc :: OpenAcc aenv a -> String-showAcc acc@(OpenAcc pacc) =-  case pacc of-    Generate e f       -> chr   1 : showExp e ++ showFun f-    Replicate s e a    -> chr   3 : showTy (accType a) ++ showExp e ++ showSI s e a acc-    Index s a e        -> chr   5 : showTy (accType a) ++ showExp e ++ showSI s e acc a-    Map f a            -> chr   7 : showTy (accType a) ++ showFun f-    ZipWith f x y      -> chr  11 : showTy (accType x) ++ showTy (accType y) ++ showFun f-    Fold f e a         -> chr  13 : chr (accDim a) : showTy (accType a) ++ showFun f ++ showExp e-    Fold1 f a          -> chr  17 : chr (accDim a) : showTy (accType a) ++ showFun f-    FoldSeg f e a _    -> chr  19 : chr (accDim a) : showTy (accType a) ++ showFun f ++ showExp e-    Fold1Seg f a _     -> chr  23 : chr (accDim a) : showTy (accType a) ++ showFun f-    Scanl f e a        -> chr  31 : showTy (accType a) ++ showFun f ++ showExp e-    Scanl' f e a       -> chr  43 : showTy (accType a) ++ showFun f ++ showExp e-    Scanl1 f a         -> chr  61 : showTy (accType a) ++ showFun f-    Scanr f e a        -> chr  79 : showTy (accType a) ++ showFun f ++ showExp e-    Scanr' f e a       -> chr 101 : showTy (accType a) ++ showFun f ++ showExp e-    Scanr1 f a         -> chr 127 : showTy (accType a) ++ showFun f-    Permute c _ p a    -> chr 167 : showTy (accType a) ++ showFun c ++ showFun p-    Backpermute _ p a  -> chr 191 : showTy (accType a) ++ showFun p-    Stencil f _ a      -> chr 199 : showTy (accType a) ++ showFun f-    Stencil2 f _ x _ y -> chr 313 : showTy (accType x) ++ showTy (accType y) ++ showFun f-    _                  ->-      let msg = unlines ["incomplete patterns for key generation", render (nest 2 doc)]-          ppr = show acc-          doc | length ppr <= 250 = text ppr-              | otherwise         = text (take 250 ppr) <+> text "... {truncated}"-      in-      INTERNAL_ERROR(error) "accToKey" msg--  where-    showTy :: TupleType a -> String-    showTy UnitTuple = []-    showTy (SingleTuple ty) = show ty-    showTy (PairTuple a b)  = showTy a ++ showTy b--    showFun :: OpenFun env aenv a -> String-    showFun = render . hcat . map pretty . codeGenFun--    showExp :: OpenExp env aenv a -> String-    showExp = render . hcat . map pretty . codeGenExp--    showSI :: SliceIndex (Sugar.EltRepr slix) (Sugar.EltRepr sl) co (Sugar.EltRepr dim)-           -> Exp aenv slix                         {- dummy -}-           -> OpenAcc aenv (Sugar.Array sl e)       {- dummy -}-           -> OpenAcc aenv (Sugar.Array dim e)      {- dummy -}-           -> String-    showSI sl _ _ _ = slice sl 0-      where-        slice :: SliceIndex slix sl co dim -> Int -> String-        slice (SliceNil)            _ = []-        slice (SliceAll   sliceIdx) n = '_'    :  slice sliceIdx n-        slice (SliceFixed sliceIdx) n = show n ++ slice sliceIdx (n+1)--{---- hash function from the dragon book pp437; assumes 7 bit characters and needs--- the (nearly) full range of values guaranteed for `Int' by the Haskell--- language definition; can handle 8 bit characters provided we have 29 bit for--- the `Int's without sign----quad :: String -> Int32-quad (c1:c2:c3:c4:s)  = (( ord' c4 * bits21-                         + ord' c3 * bits14-                         + ord' c2 * bits7-                         + ord' c1)-                         `mod` bits28)-                        + (quad s `mod` bits28)-quad (c1:c2:c3:[]  )  = ord' c3 * bits14 + ord' c2 * bits7 + ord' c1-quad (c1:c2:[]     )  = ord' c2 * bits7  + ord' c1-quad (c1:[]        )  = ord' c1-quad ([]           )  = 0--ord' :: Char -> Int32-ord' = fromIntegral . ord--bits7, bits14, bits21, bits28 :: Int32-bits7  = 2^(7 ::Int32)-bits14 = 2^(14::Int32)-bits21 = 2^(21::Int32)-bits28 = 2^(28::Int32)--}
− Data/Array/Accelerate/CUDA/Analysis/Launch.hs 
@@ -1,146 +0,0 @@-{-# LANGUAGE CPP, GADTs, RankNTypes #-}--- |--- Module      : Data.Array.Accelerate.CUDA.Analysis.Launch--- Copyright   : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell--- License     : BSD3------ Maintainer  : Manuel M T Chakravarty <chak@cse.unsw.edu.au>--- Stability   : experimental--- Portability : non-partable (GHC extensions)-----module Data.Array.Accelerate.CUDA.Analysis.Launch (launchConfig)-  where---- friends-import Data.Array.Accelerate.AST-import Data.Array.Accelerate.Type-import Data.Array.Accelerate.Array.Sugar                (Array(..), EltRepr)-import Data.Array.Accelerate.Analysis.Type              hiding (accType, expType)-import Data.Array.Accelerate.Analysis.Shape             hiding (accDim)--import Data.Array.Accelerate.CUDA.State-import Data.Array.Accelerate.CUDA.Compile               (ExecOpenAcc(..))---- library-import Data.Label.PureM-import Control.Monad.IO.Class--import qualified Foreign.CUDA.Analysis                  as CUDA-import qualified Foreign.CUDA.Driver                    as CUDA-import qualified Foreign.Storable                       as F--#include "accelerate.h"----- |Reify dimensionality of array computations----accDim :: ExecOpenAcc aenv (Array sh e) -> Int-accDim (ExecAcc _ _ _ acc) = preAccDim accDim acc-accDim (ExecAfun _ _)      = error "when I get sad, I stop being sad and be AWESOME instead."---- |Reify type of arrays and scalar expressions----accType :: ExecOpenAcc aenv (Array sh e) -> TupleType (EltRepr e)-accType (ExecAcc _ _ _ acc) = preAccType accType acc-accType (ExecAfun _ _)      = error "TRUE STORY."--expType :: PreOpenExp ExecOpenAcc aenv env t -> TupleType (EltRepr t)-expType = preExpType accType----- |--- Determine kernel launch parameters for the given array computation (as well--- as compiled function module). This consists of the thread block size, number--- of blocks, and dynamically allocated shared memory (bytes), respectively.------ By default, this launches the kernel with the minimum block size that gives--- maximum occupancy, and the grid size limited to the maximum number of--- physically resident blocks. Hence, kernels may need to process multiple--- elements per thread.----launchConfig :: PreOpenAcc ExecOpenAcc aenv a -> Int -> CUDA.Fun -> CIO (Int, Int, Integer)-launchConfig acc n fn = do-  regs <- liftIO $ CUDA.requires fn CUDA.NumRegs-  stat <- liftIO $ CUDA.requires fn CUDA.SharedSizeBytes        -- static memory only-  prop <- gets deviceProps--  let dyn        = sharedMem prop acc-      (cta, occ) = blockSize prop acc regs ((stat+) . dyn)-      mbk        = CUDA.multiProcessorCount prop * CUDA.activeThreadBlocks occ--  return (cta, mbk `min` gridSize prop acc n cta, toInteger (dyn cta))----- |--- Determine the optimal thread block size for a given array computation. Fold--- requires blocks with a power-of-two number of threads.----blockSize :: CUDA.DeviceProperties -> PreOpenAcc ExecOpenAcc aenv a -> Int -> (Int -> Int) -> (Int, CUDA.Occupancy)-blockSize p (Fold _ _ _) r s = CUDA.optimalBlockSizeBy p CUDA.incPow2 (const r) s-blockSize p (Fold1 _ _)  r s = CUDA.optimalBlockSizeBy p CUDA.incPow2 (const r) s-blockSize p _            r s = CUDA.optimalBlockSizeBy p CUDA.incWarp (const r) s----- |--- Determine the number of blocks of the given size necessary to process the--- given array expression. This should understand things like #elements per--- thread for the various kernels.------ foldSeg: 'size' is the number of segments, require one warp per segment----gridSize :: CUDA.DeviceProperties -> PreOpenAcc ExecOpenAcc aenv a -> Int -> Int -> Int-gridSize p acc@(FoldSeg _ _ _ _) size cta = split acc (size * CUDA.warpSize p) cta-gridSize p acc@(Fold1Seg _ _ _)  size cta = split acc (size * CUDA.warpSize p) cta-gridSize p acc@(Fold _ _ a)      size cta = if accDim a == 1 then split acc size cta else split acc (size * CUDA.warpSize p) cta-gridSize p acc@(Fold1 _ a)       size cta = if accDim a == 1 then split acc size cta else split acc (size * CUDA.warpSize p) cta-gridSize _ acc                   size cta = split acc size cta--split :: PreOpenAcc ExecOpenAcc aenv a -> Int -> Int -> Int-split acc size cta = (size `between` eltsPerThread acc) `between` cta-  where-    between arr n   = 1 `max` ((n + arr - 1) `div` n)-    eltsPerThread _ = 1----- |--- Analyse the given array expression, returning an estimate of dynamic shared--- memory usage as a function of thread block size. This can be used by the--- occupancy calculator to optimise kernel launch shape.----sharedMem :: CUDA.DeviceProperties -> PreOpenAcc ExecOpenAcc aenv a -> Int -> Int--- non-computation forms-sharedMem _ (Alet _ _)     _ = INTERNAL_ERROR(error) "sharedMem" "Let"-sharedMem _ (Alet2 _ _)    _ = INTERNAL_ERROR(error) "sharedMem" "Let2"-sharedMem _ (PairArrays _ _) _-                             = INTERNAL_ERROR(error) "sharedMem" "PairArrays"-sharedMem _ (Avar _)      _  = INTERNAL_ERROR(error) "sharedMem" "Avar"-sharedMem _ (Apply _ _)   _  = INTERNAL_ERROR(error) "sharedMem" "Apply"-sharedMem _ (Acond _ _ _) _  = INTERNAL_ERROR(error) "sharedMem" "Acond"-sharedMem _ (Use _)       _  = INTERNAL_ERROR(error) "sharedMem" "Use"-sharedMem _ (Unit _)      _  = INTERNAL_ERROR(error) "sharedMem" "Unit"-sharedMem _ (Reshape _ _) _  = INTERNAL_ERROR(error) "sharedMem" "Reshape"---- skeleton nodes-sharedMem _ (Generate _ _)      _        = 0-sharedMem _ (Replicate _ _ _)   _        = 0-sharedMem _ (Index _ _ _)       _        = 0-sharedMem _ (Map _ _)           _        = 0-sharedMem _ (ZipWith _ _ _)     _        = 0-sharedMem _ (Permute _ _ _ _)   _        = 0-sharedMem _ (Backpermute _ _ _) _        = 0-sharedMem _ (Stencil _ _ _)      _       = 0-sharedMem _ (Stencil2 _ _ _ _ _) _       = 0-sharedMem _ (Fold  _ _ a)       blockDim = sizeOf (accType a) * blockDim-sharedMem _ (Fold1 _ a)         blockDim = sizeOf (accType a) * blockDim-sharedMem _ (Scanl _ x _)       blockDim = sizeOf (expType x) * blockDim-sharedMem _ (Scanr _ x _)       blockDim = sizeOf (expType x) * blockDim-sharedMem _ (Scanl' _ x _)      blockDim = sizeOf (expType x) * blockDim-sharedMem _ (Scanr' _ x _)      blockDim = sizeOf (expType x) * blockDim-sharedMem _ (Scanl1 _ a)        blockDim = sizeOf (accType a) * blockDim-sharedMem _ (Scanr1 _ a)        blockDim = sizeOf (accType a) * blockDim-sharedMem p (FoldSeg _ _ a _)   blockDim =-  (blockDim `div` CUDA.warpSize p) * 4 * F.sizeOf (undefined::Int32) + blockDim * sizeOf (accType a)-sharedMem p (Fold1Seg _ a _) blockDim =-  (blockDim `div` CUDA.warpSize p) * 4 * F.sizeOf (undefined::Int32) + blockDim * sizeOf (accType a)-
− Data/Array/Accelerate/CUDA/Array/Data.hs 
@@ -1,612 +0,0 @@-{-# LANGUAGE CPP, FlexibleContexts, PatternGuards, ScopedTypeVariables, GADTs, TypeFamilies #-}--- |--- Module      : Data.Array.Accelerate.CUDA.Array.Data--- Copyright   : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, 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.CUDA.Array.Data (--  -- * Array operations and representations-  DevicePtrs, HostPtrs,-  freeArray, mallocArray, indexArray, copyArray, peekArray, pokeArray,-  peekArrayAsync, pokeArrayAsync, marshalArrayData, marshalTextureData,-  existsArrayData, devicePtrs,--  -- * Additional operations-  touchArray, bindArray, unbindArray--) where--import Prelude hiding (id, (.))-import Control.Category--import Foreign.Ptr-import Foreign.Storable                                 (Storable, sizeOf)-import qualified Foreign                                as F--import Data.Int-import Data.Word-import Data.Maybe-import Data.Typeable-import Data.Label-import Data.Label.PureM                                 hiding (modify)-import Control.Monad-import Control.Applicative-import Control.Monad.IO.Class-import qualified Data.HashTable                         as Hash--import Data.Array.Accelerate.CUDA.State-import qualified Data.Array.Accelerate.Array.Data       as AD-import           Data.Array.Accelerate.Array.Data       (ArrayEltR(..))-import qualified Foreign.CUDA.Driver                    as CUDA-import qualified Foreign.CUDA.Driver.Stream             as CUDA-import qualified Foreign.CUDA.Driver.Texture            as CUDA--#include "accelerate.h"----- Array Operations--- ------------------type family DevicePtrs e :: *-type family HostPtrs   e :: *---- CPP hackery to generate the cases where we dispatch to the worker function handling--- elementary types.----#define mkPrimDispatch(dispatcher,worker)                                   \-; dispatcher ArrayEltRint    = worker                                       \-; dispatcher ArrayEltRint8   = worker                                       \-; dispatcher ArrayEltRint16  = worker                                       \-; dispatcher ArrayEltRint32  = worker                                       \-; dispatcher ArrayEltRint64  = worker                                       \-; dispatcher ArrayEltRword   = worker                                       \-; dispatcher ArrayEltRword8  = worker                                       \-; dispatcher ArrayEltRword16 = worker                                       \-; dispatcher ArrayEltRword32 = worker                                       \-; dispatcher ArrayEltRword64 = worker                                       \-; dispatcher ArrayEltRfloat  = worker                                       \-; dispatcher ArrayEltRdouble = worker                                       \-; dispatcher ArrayEltRbool   = error "mkPrimDispatcher: ArrayEltRbool"      \-; dispatcher ArrayEltRchar   = error "mkPrimDispatcher: ArrayEltRchar"      \-; dispatcher _               = error "mkPrimDispatcher: not primitive"----- |Allocate a new device array to accompany the given host-side array.----mallocArray :: AD.ArrayElt e => AD.ArrayData e -> Maybe Int -> Int -> CIO ()-mallocArray adata rc n = doMalloc AD.arrayElt adata-  where-    doMalloc :: ArrayEltR e -> AD.ArrayData e -> CIO ()-    doMalloc ArrayEltRunit             _  = return ()-    doMalloc (ArrayEltRpair aeR1 aeR2) ad = doMalloc aeR1 (fst' ad) *> doMalloc aeR2 (snd' ad)-    doMalloc aer                       ad = doMallocPrim aer ad rc n-      where-        { doMallocPrim :: ArrayEltR e -> AD.ArrayData e -> Maybe Int -> Int -> CIO ()-        mkPrimDispatch(doMallocPrim,mallocArrayPrim)-        }---- |Release a device array, when its reference count drops to zero.----freeArray :: AD.ArrayElt e => AD.ArrayData e -> CIO ()-freeArray adata = doFree AD.arrayElt adata-  where-    doFree :: ArrayEltR e -> AD.ArrayData e -> CIO ()-    doFree ArrayEltRunit             _  = return ()-    doFree (ArrayEltRpair aeR1 aeR2) ad = doFree aeR1 (fst' ad) *> doFree aeR2 (snd' ad)-    doFree aer                       ad = doFreePrim aer ad-      where-        { doFreePrim :: ArrayEltR e -> AD.ArrayData e -> CIO ()-        mkPrimDispatch(doFreePrim,freeArrayPrim)-        }---- |Array indexing----indexArray :: AD.ArrayElt e => AD.ArrayData e -> Int -> CIO e-indexArray adata i = doIndex AD.arrayElt adata-  where-    doIndex :: ArrayEltR e -> AD.ArrayData e -> CIO e-    doIndex ArrayEltRunit             _  = return ()-    doIndex (ArrayEltRpair aeR1 aeR2) ad = (,) <$> doIndex aeR1 (fst' ad)-                                               <*> doIndex aeR2 (snd' ad)-    doIndex aer                       ad = doIndexPrim aer ad i-      where-        { doIndexPrim :: ArrayEltR e -> AD.ArrayData e -> Int -> CIO e-        mkPrimDispatch(doIndexPrim,indexArrayPrim)-        }---- |Copy data between two device arrays.----copyArray :: AD.ArrayElt e => AD.ArrayData e -> AD.ArrayData e -> Int -> CIO ()-copyArray adata1 adata2 i = doCopy AD.arrayElt adata1 adata2-  where-    doCopy :: ArrayEltR e -> AD.ArrayData e -> AD.ArrayData e -> CIO ()-    doCopy ArrayEltRunit             _   _   = return ()-    doCopy (ArrayEltRpair aeR1 aeR2) ad1 ad2 = doCopy aeR1 (fst' ad1) (fst' ad2) *>-                                               doCopy aeR2 (snd' ad1) (snd' ad2)-    doCopy aer                       ad1 ad2 = doCopyPrim aer ad1 ad2 i-      where-        { doCopyPrim :: ArrayEltR e -> AD.ArrayData e -> AD.ArrayData e -> Int -> CIO ()-        mkPrimDispatch(doCopyPrim,copyArrayPrim)-        }---- |Copy data from the device into its associated host-side Accelerate array.----peekArray :: AD.ArrayElt e => AD.ArrayData e -> Int -> CIO ()-peekArray adata i = doPeek AD.arrayElt adata-  where-    doPeek :: ArrayEltR e -> AD.ArrayData e -> CIO ()-    doPeek ArrayEltRunit             _  = return ()-    doPeek (ArrayEltRpair aeR1 aeR2) ad = doPeek aeR1 (fst' ad) *> doPeek aeR2 (snd' ad)-    doPeek aer                       ad = doPeekPrim aer ad i-      where-        { doPeekPrim :: ArrayEltR e -> AD.ArrayData e -> Int -> CIO ()-        mkPrimDispatch(doPeekPrim,peekArrayPrim)-        }---- |Copy data from an Accelerate array into the associated device array,--- which must have already been allocated.----pokeArray :: AD.ArrayElt e => AD.ArrayData e -> Int -> CIO ()-pokeArray adata i = doPoke AD.arrayElt adata-  where-    doPoke :: ArrayEltR e -> AD.ArrayData e -> CIO ()-    doPoke ArrayEltRunit             _  = return ()-    doPoke (ArrayEltRpair aeR1 aeR2) ad = doPoke aeR1 (fst' ad) *> doPoke aeR2 (snd' ad)-    doPoke aer                       ad = doPokePrim aer ad i-      where-        { doPokePrim :: ArrayEltR e -> AD.ArrayData e -> Int -> CIO ()-        mkPrimDispatch(doPokePrim,pokeArrayPrim)-        }---- |Asynchronous device -> host copy----peekArrayAsync :: AD.ArrayElt e => AD.ArrayData e -> Int -> Maybe CUDA.Stream -> CIO ()-peekArrayAsync adata i s = doPeek AD.arrayElt adata-  where-    doPeek :: ArrayEltR e -> AD.ArrayData e -> CIO ()-    doPeek ArrayEltRunit             _  = return ()-    doPeek (ArrayEltRpair aeR1 aeR2) ad = doPeek aeR1 (fst' ad) *> doPeek aeR2 (snd' ad)-    doPeek aer                       ad = doPeekPrim aer ad i s-      where-        { doPeekPrim :: ArrayEltR e -> AD.ArrayData e -> Int -> Maybe CUDA.Stream -> CIO ()-        mkPrimDispatch(doPeekPrim,peekArrayAsyncPrim)-        }---- |Asynchronous host -> device copy----pokeArrayAsync :: AD.ArrayElt e => AD.ArrayData e -> Int -> Maybe CUDA.Stream -> CIO ()-pokeArrayAsync adata i s = doPoke AD.arrayElt adata-  where-    doPoke :: ArrayEltR e -> AD.ArrayData e -> CIO ()-    doPoke ArrayEltRunit             _  = return ()-    doPoke (ArrayEltRpair aeR1 aeR2) ad = doPoke aeR1 (fst' ad) *> doPoke aeR2 (snd' ad)-    doPoke aer                       ad = doPokePrim aer ad i s-      where-        { doPokePrim :: ArrayEltR e -> AD.ArrayData e -> Int -> Maybe CUDA.Stream -> CIO ()-        mkPrimDispatch(doPokePrim,pokeArrayAsyncPrim)-        }---- |Wrap the device pointers corresponding to a host-side array into arguments that can be passed--- to a kernel upon invocation.----marshalArrayData :: AD.ArrayElt e => AD.ArrayData e -> CIO [CUDA.FunParam]-marshalArrayData adata = doMarshal AD.arrayElt adata-  where-    doMarshal :: ArrayEltR e -> AD.ArrayData e -> CIO [CUDA.FunParam]-    doMarshal ArrayEltRunit             _  = return []-    doMarshal (ArrayEltRpair aeR1 aeR2) ad = (++) <$> doMarshal aeR1 (fst' ad)-                                                  <*> doMarshal aeR2 (snd' ad)-    doMarshal aer                       ad = doMarshalPrim aer ad-      where-        { doMarshalPrim :: ArrayEltR e -> AD.ArrayData e -> CIO [CUDA.FunParam]-        mkPrimDispatch(doMarshalPrim,marshalArrayDataPrim)-        }---- |Bind the device memory arrays to the given texture reference(s), setting--- appropriate type. The arrays are bound, and the list of textures thereby--- consumed, in projection index order --- i.e. right-to-left----marshalTextureData :: AD.ArrayElt e => AD.ArrayData e -> Int -> [CUDA.Texture] -> CIO ()-marshalTextureData adata n texs = doMarshal AD.arrayElt adata texs >> return ()-  where-    doMarshal :: ArrayEltR e -> AD.ArrayData e -> [CUDA.Texture] -> CIO Int-    doMarshal ArrayEltRunit             _  _ = return 0-    doMarshal (ArrayEltRpair aeR1 aeR2) ad t-      = do-          r <- doMarshal aeR2 (snd' ad) t-          l <- doMarshal aeR1 (fst' ad) (drop r t)-          return $ l + r-    doMarshal aer                       ad t = doMarshalPrim aer ad n (head t) >> return 1-      where-        { doMarshalPrim :: ArrayEltR e -> AD.ArrayData e -> Int -> CUDA.Texture -> CIO ()-        mkPrimDispatch(doMarshalPrim,marshalTextureDataPrim)-        }---- |Modify the basic device memory reference for a given host-side array.----basicModify :: AD.ArrayElt e => AD.ArrayData e -> (MemoryEntry -> MemoryEntry) -> CIO ()-basicModify adata fmod = doModify AD.arrayElt adata-  where-    doModify :: ArrayEltR e -> AD.ArrayData e -> CIO ()-    doModify ArrayEltRunit             _  = return ()-    doModify (ArrayEltRpair aeR1 aeR2) ad = doModify aeR1 (fst' ad) *> doModify aeR2 (snd' ad)-    doModify aer                       ad = doModifyPrim aer ad fmod-      where-        { doModifyPrim :: ArrayEltR e -> AD.ArrayData e -> (MemoryEntry -> MemoryEntry) -> CIO ()-        mkPrimDispatch(doModifyPrim,basicModifyPrim)-        }---- |Does the array already exist on the device?----existsArrayData :: AD.ArrayElt e => AD.ArrayData e -> CIO Bool-existsArrayData adata = isJust <$> devicePtrs adata---- |Return the device pointers associated with a given host-side array----devicePtrs :: AD.ArrayElt e => AD.ArrayData e -> CIO (Maybe (DevicePtrs e))-devicePtrs adata = doPtrs AD.arrayElt adata-  where-    doPtrs :: ArrayEltR e -> AD.ArrayData e -> CIO (Maybe (DevicePtrs e))-    doPtrs ArrayEltRunit             _  = return (Just ())-    doPtrs (ArrayEltRpair aeR1 aeR2) ad = liftM2 (,) <$> doPtrs aeR1 (fst' ad)-                                                     <*> doPtrs aeR2 (snd' ad)-    doPtrs aer                       ad = doPtrsPrim aer ad-      where-        { doPtrsPrim :: ArrayEltR e -> AD.ArrayData e -> CIO (Maybe (DevicePtrs e))-        mkPrimDispatch(doPtrsPrim, devicePtrsPrim)-        }---type instance DevicePtrs () = ()-type instance HostPtrs   () = ()--#define primArrayElt(ty)                                                      \-type instance DevicePtrs ty = CUDA.DevicePtr ty ;                             \-type instance HostPtrs   ty = CUDA.HostPtr   ty ;                             \--primArrayElt(Int)-primArrayElt(Int8)-primArrayElt(Int16)-primArrayElt(Int32)-primArrayElt(Int64)--primArrayElt(Word)-primArrayElt(Word8)-primArrayElt(Word16)-primArrayElt(Word32)-primArrayElt(Word64)---- FIXME:--- CShort--- CUShort--- CInt--- CUInt--- CLong--- CULong--- CLLong--- CULLong--primArrayElt(Float)-primArrayElt(Double)---- FIXME:--- CFloat--- CDouble---- FIXME:--- No concrete implementation in Data.Array.Accelerate.Array.Data----type instance HostPtrs   Bool = ()-type instance DevicePtrs Bool = ()--type instance HostPtrs   Char = ()-type instance DevicePtrs Char = ()---- FIXME:--- CChar--- CSChar--- CUChar--type instance DevicePtrs (a,b) = (DevicePtrs a, DevicePtrs b)-type instance HostPtrs   (a,b) = (HostPtrs   a, HostPtrs   b)----- Texture References--- ---------------------- This representation must match the code generator's understanding of how to--- utilise the texture cache.----class TextureData a where-  format :: a -> (CUDA.Format, Int)--instance TextureData Int8   where format _ = (CUDA.Int8,   1)-instance TextureData Int16  where format _ = (CUDA.Int16,  1)-instance TextureData Int32  where format _ = (CUDA.Int32,  1)-instance TextureData Int64  where format _ = (CUDA.Int32,  2)-instance TextureData Word8  where format _ = (CUDA.Word8,  1)-instance TextureData Word16 where format _ = (CUDA.Word16, 1)-instance TextureData Word32 where format _ = (CUDA.Word32, 1)-instance TextureData Word64 where format _ = (CUDA.Word32, 2)-instance TextureData Float  where format _ = (CUDA.Float,  1)-instance TextureData Double where format _ = (CUDA.Int32,  2)--instance TextureData Int where-  format _ = case sizeOf (undefined :: Int) of-                  4 -> (CUDA.Int32, 1)-                  8 -> (CUDA.Int32, 2)-                  _ -> error "we can never get here"--instance TextureData Word where-  format _ = case sizeOf (undefined :: Word) of-                  4 -> (CUDA.Word32, 1)-                  8 -> (CUDA.Word32, 2)-                  _ -> error "we can never get here"----- Auxiliary Functions--- ----------------------- |Increase the reference count of an array----touchArray :: AD.ArrayElt e => AD.ArrayData e -> Int -> CIO ()-touchArray ad n = basicModify ad (modify refcount (fmap (+n)))---- |Set an array to never be released by a call to 'freeArray'. When the--- array is unbound, its reference count is set to zero.----bindArray :: AD.ArrayElt e => AD.ArrayData e -> CIO ()-bindArray ad = basicModify ad (set refcount Nothing)---- |Unset an array to never be released by a call to 'freeArray'.-unbindArray :: AD.ArrayElt e => AD.ArrayData e -> CIO ()-unbindArray ad = basicModify ad (set refcount (Just 0))----- ArrayElt Implementation--- --------------------------- Allocate a new device array to accompany the given host-side Accelerate array----mallocArrayPrim :: forall a b e.-                   ( AD.ArrayElt e, AD.ArrayPtrs e ~ Ptr a, DevicePtrs e ~ CUDA.DevicePtr b-                   , Typeable a, Typeable b, Storable b)-                => AD.ArrayData e -- host array data (reference)-                -> Maybe Int      -- initial reference count for this array; Nothing == bound array-                -> Int            -- number of elements-                -> CIO ()-mallocArrayPrim ad rc n =-  do let key = arrayToKey ad-     tab <- gets memoryTable-     mem <- liftIO $ Hash.lookup tab key-     when (isNothing mem) $ do-       _ <- liftIO $-             Hash.update tab key . MemoryEntry rc =<< (CUDA.mallocArray n :: IO (CUDA.DevicePtr b))-       return ()----- Release a device array, when its reference counter drops to zero----freeArrayPrim :: ( AD.ArrayElt e, AD.ArrayPtrs e ~ Ptr a, DevicePtrs e ~ CUDA.DevicePtr b-                 , Typeable a, Typeable b)-              => AD.ArrayData e     -- host array-              -> CIO ()-freeArrayPrim ad = free . modify refcount (fmap (subtract 1)) =<< lookupArray ad-  where-    free v = case get refcount v of-      Nothing        -> return ()-      Just x | x > 0 -> updateArray ad v-      _              -> deleteArray ad----- Array indexing----indexArrayPrim :: ( AD.ArrayElt e, AD.ArrayPtrs e ~ Ptr a, DevicePtrs e ~ CUDA.DevicePtr b-                  , Storable b, Typeable a, Typeable b)-               => AD.ArrayData e     -- host array data-               -> Int                -- index in row-major representation-               -> CIO b-indexArrayPrim ad n = do-  dp <- getArray ad-  liftIO . F.alloca $ \p -> do-    CUDA.peekArray 1 (dp `CUDA.advanceDevPtr` n) p-    F.peek p----- Copy data between two device arrays.----copyArrayPrim :: ( AD.ArrayElt e, AD.ArrayPtrs e ~ Ptr a, DevicePtrs e ~ CUDA.DevicePtr b-                 , Storable b, Typeable a, Typeable b)-              => AD.ArrayData e     -- source array-              -> AD.ArrayData e     -- destination-              -> Int                -- number of elements-              -> CIO ()-copyArrayPrim src' dst' n = do-  src <- getArray src'-  dst <- getArray dst'-  liftIO $ CUDA.copyArrayAsync n src dst----- Copy data from the device into the associated Accelerate array----peekArrayPrim :: ( AD.ArrayElt e, AD.ArrayPtrs e ~ Ptr a, DevicePtrs e ~ CUDA.DevicePtr a-                 , Storable a, Typeable a)-              => AD.ArrayData e     -- host array data-              -> Int                -- number of elements-              -> CIO ()-peekArrayPrim ad n =-  let dst = AD.ptrsOfArrayData ad-      src = arena ad-  in-  lookupArray ad >>= \me -> liftIO $ CUDA.peekArray n (src me) dst--peekArrayAsyncPrim :: ( AD.ArrayElt e, AD.ArrayPtrs e ~ Ptr a, DevicePtrs e ~ CUDA.DevicePtr a-                      , Storable a, Typeable a)-                   => AD.ArrayData e     -- host array data-                   -> Int                -- number of elements-                   -> Maybe CUDA.Stream  -- asynchronous stream (optional)-                   -> CIO ()-peekArrayAsyncPrim ad n st =-  let dst = CUDA.HostPtr . AD.ptrsOfArrayData-      src = arena ad-  in-  lookupArray ad >>= \me -> liftIO $ CUDA.peekArrayAsync n (src me) (dst ad) st----- Copy data from an Accelerate array to the associated device array. The data--- will be copied from the host-side array each time this function is called; no--- changes to the reference counter will be made.----pokeArrayPrim :: ( AD.ArrayElt e, AD.ArrayPtrs e ~ Ptr a, DevicePtrs e ~ CUDA.DevicePtr a-                 , Storable a, Typeable a)-              => AD.ArrayData e     -- host array data-              -> Int                -- number of elements-              -> CIO ()-pokeArrayPrim ad n = upload =<< lookupArray ad-  where-    src      = AD.ptrsOfArrayData-    dst      = arena ad-    upload v = liftIO $ CUDA.pokeArray n (src ad) (dst v)--pokeArrayAsyncPrim :: ( AD.ArrayElt e, AD.ArrayPtrs e ~ Ptr a, DevicePtrs e ~ CUDA.DevicePtr a-                      , Storable a, Typeable a)-                   => AD.ArrayData e     -- host array reference-                   -> Int                -- number of elements-                   -> Maybe CUDA.Stream  -- asynchronous stream to associate (optional)-                   -> CIO ()-pokeArrayAsyncPrim ad n st = upload =<< lookupArray ad-  where-    src      = CUDA.HostPtr . AD.ptrsOfArrayData-    dst      = arena ad-    upload v = liftIO $ CUDA.pokeArrayAsync n (src ad) (dst v) st----- Wrap the device pointers corresponding to a host-side array into arguments--- that can be passed to a kernel on invocation.----marshalArrayDataPrim :: ( AD.ArrayElt e, AD.ArrayPtrs e ~ Ptr a, DevicePtrs e ~ CUDA.DevicePtr b-                        , Typeable a, Typeable b)-                     => AD.ArrayData e-                     -> CIO [CUDA.FunParam]-marshalArrayDataPrim ad = return . CUDA.VArg <$> getArray ad----- Bind device memory to the given texture reference, setting appropriate type----marshalTextureDataPrim :: forall a e.-                          ( AD.ArrayElt e, AD.ArrayPtrs e ~ Ptr a, DevicePtrs e ~ CUDA.DevicePtr a-                          , Storable a, TextureData a, Typeable a)-                       => AD.ArrayData e     -- host array data-                       -> Int                -- number of elements-                       -> CUDA.Texture       -- texture reference to bind to-                       -> CIO ()-marshalTextureDataPrim ad n tex = do-  let (fmt,c) = format (undefined :: a)-  ptr <- getArray ad-  liftIO $ do-    CUDA.setFormat tex fmt c-    CUDA.bind tex ptr (fromIntegral $ n * sizeOf (undefined :: a))----- Modify the internal memory reference for a host-side array.----basicModifyPrim :: (AD.ArrayElt e, AD.ArrayPtrs e ~ Ptr a, Typeable a)-                => AD.ArrayData e-                -> (MemoryEntry -> MemoryEntry)-                -> CIO ()-basicModifyPrim ad f = updateArray ad . f =<< lookupArray ad----- Return the device pointers----devicePtrsPrim :: ( AD.ArrayPtrs e ~ Ptr a, AD.ArrayElt e, Typeable a-                  , DevicePtrs e ~ CUDA.DevicePtr b, Typeable b)-               => AD.ArrayData e-               -> CIO (Maybe (DevicePtrs e))-devicePtrsPrim ad = do-  t <- gets memoryTable-  x <- liftIO $ Hash.lookup t (arrayToKey ad)-  return (arena ad `fmap` x)----- Utility functions--- --------------------- Get a device pointer out of our existential wrapper----arena :: (DevicePtrs e ~ CUDA.DevicePtr b, Typeable b)-      => AD.ArrayData e-      -> MemoryEntry-      -> CUDA.DevicePtr b-arena _ (MemoryEntry _ p)-  | Just ptr <- gcast p = ptr-  | otherwise           = INTERNAL_ERROR(error) "arena" "type mismatch"---- Generate a memory map key from the given ArrayData----arrayToKey :: (AD.ArrayElt e, AD.ArrayPtrs e ~ Ptr a, Typeable a)-           => AD.ArrayData e-           -> AccArrayData-arrayToKey = AccArrayData---- Retrieve the device memory entry from the state structure associated with a--- particular Accelerate array.----lookupArray :: (AD.ArrayElt e, AD.ArrayPtrs e ~ Ptr a, Typeable a)-            => AD.ArrayData e-            -> CIO MemoryEntry-lookupArray ad = do-  t <- gets memoryTable-  x <- liftIO $ Hash.lookup t (arrayToKey ad)-  case x of-       Just e -> return e-       _      -> INTERNAL_ERROR(error) "lookupArray" "lost device memory reference"-                 -- TLM: better if the file/line markings are of the use site---- Update (or insert) a memory entry into the state structure----updateArray :: (AD.ArrayPtrs e ~ Ptr a, Typeable a, AD.ArrayElt e)-            => AD.ArrayData e-            -> MemoryEntry-            -> CIO ()-updateArray ad me = do-  t <- gets memoryTable-  liftIO $ Hash.update t (arrayToKey ad) me >> return ()---- Delete an entry from the state structure and release the corresponding device--- memory area----deleteArray :: ( AD.ArrayElt e, AD.ArrayPtrs e ~ Ptr a, DevicePtrs e ~ CUDA.DevicePtr b-               , Typeable a, Typeable b)-            => AD.ArrayData e-            -> CIO ()-deleteArray ad = do-  let key = arrayToKey ad-  tab <- gets memoryTable-  val <- liftIO $ Hash.lookup tab key-  case val of-       Just m -> liftIO $ CUDA.free (arena ad m) >> Hash.delete tab key-       _      -> INTERNAL_ERROR(error) "deleteArray" "lost device memory reference: double free?"---- Return the device pointer associated with a host-side Accelerate array----getArray :: ( AD.ArrayElt e, AD.ArrayPtrs e ~ Ptr a, DevicePtrs e ~ CUDA.DevicePtr b-            , Typeable a, Typeable b)-         => AD.ArrayData e-         -> CIO (CUDA.DevicePtr b)-getArray ad = arena ad <$> lookupArray ad---- Array tuple extraction----fst' :: AD.ArrayData (a,b) -> AD.ArrayData a-fst' = AD.fstArrayData--snd' :: AD.ArrayData (a,b) -> AD.ArrayData b-snd' = AD.sndArrayData-
− Data/Array/Accelerate/CUDA/CodeGen.hs 
@@ -1,658 +0,0 @@-{-# LANGUAGE CPP, GADTs, PatternGuards, ScopedTypeVariables, TemplateHaskell #-}--- |--- Module      : Data.Array.Accelerate.CUDA.CodeGen--- Copyright   : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, 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.CUDA.CodeGen (--  -- * types-  CUTranslSkel, AccBinding(..),--  -- * code generation-  codeGenAcc, codeGenFun, codeGenExp--) where--import Data.Char-import Language.C-import Text.PrettyPrint--import Data.Array.Accelerate.AST-import Data.Array.Accelerate.Type-import Data.Array.Accelerate.Tuple-import Data.Array.Accelerate.Pretty ()-import Data.Array.Accelerate.Analysis.Type-import Data.Array.Accelerate.Analysis.Shape-import Data.Array.Accelerate.Analysis.Stencil-import Data.Array.Accelerate.Array.Representation-import qualified Data.Array.Accelerate.Array.Sugar              as Sugar-import qualified Foreign.Storable                               as F--import Data.Array.Accelerate.CUDA.CodeGen.Data-import Data.Array.Accelerate.CUDA.CodeGen.Util-import Data.Array.Accelerate.CUDA.CodeGen.Skeleton---#include "accelerate.h"----- Array computations that were embedded within scalar expressions, and will be--- required to execute the kernel; i.e. bound to texture references or similar.----data AccBinding aenv where-  ArrayVar :: (Sugar.Shape sh, Sugar.Elt e)-           => Idx aenv (Sugar.Array sh e) -> AccBinding aenv--instance Eq (AccBinding aenv) where-  ArrayVar ix1 == ArrayVar ix2 = deBruijnToInt ix1 == deBruijnToInt ix2------ Array expressions--- --------------------- | Instantiate an array computation with a set of concrete function and type--- definitions to fix the parameters of an algorithmic skeleton. The generated--- code can then be pretty-printed to file, and compiled to object code--- executable on the device.------ The code generator needs to include binding points for array references from--- scalar code. We require that the only array form allowed within expressions--- are array variables.----codeGenAcc :: forall aenv a. OpenAcc aenv a -> [AccBinding aenv] -> CUTranslSkel-codeGenAcc acc vars =-  let fvars                      = concatMap (liftAcc acc) vars-      CUTranslSkel code def skel = codeGen acc-      CTranslUnit decl node      = code-  in-  CUTranslSkel (CTranslUnit (fvars ++ decl) node) def skel-  where-    codeGen :: OpenAcc aenv a -> CUTranslSkel-    codeGen (OpenAcc pacc) =-      case pacc of-        -- non-computation forms-        ---        Alet _ _          -> internalError-        Alet2 _ _         -> internalError-        Avar _            -> internalError-        Apply _ _         -> internalError-        Acond _ _ _       -> internalError-        PairArrays _ _    -> internalError-        Use _             -> internalError-        Unit _            -> internalError-        Reshape _ _       -> internalError--        -- computation nodes-        ---        Generate _ f      -> mkGenerate (codeGenAccTypeDim acc) (codeGenFun f)-        Fold f e a        -> mkFold  (codeGenAccTypeDim a) (codeGenExp e) (codeGenFun f)-        Fold1 f a         -> mkFold1 (codeGenAccTypeDim a) (codeGenFun f)-        FoldSeg f e a s   -> mkFoldSeg  (codeGenAccTypeDim a) (codeGenAccType s) (codeGenExp e) (codeGenFun f)-        Fold1Seg f a s    -> mkFold1Seg (codeGenAccTypeDim a) (codeGenAccType s) (codeGenFun f)-        Scanl f e _       -> mkScanl  (codeGenExpType e) (codeGenExp e) (codeGenFun f)-        Scanr f e _       -> mkScanr  (codeGenExpType e) (codeGenExp e) (codeGenFun f)-        Scanl' f e _      -> mkScanl' (codeGenExpType e) (codeGenExp e) (codeGenFun f)-        Scanr' f e _      -> mkScanr' (codeGenExpType e) (codeGenExp e) (codeGenFun f)-        Scanl1 f a        -> mkScanl1 (codeGenAccType a) (codeGenFun f)-        Scanr1 f a        -> mkScanr1 (codeGenAccType a) (codeGenFun f)-        Map f a           -> mkMap (codeGenAccType acc) (codeGenAccType a) (codeGenFun f)-        ZipWith f a b     -> mkZipWith (codeGenAccTypeDim acc) (codeGenAccTypeDim a) (codeGenAccTypeDim b) (codeGenFun f)-        Permute f _ g a   -> mkPermute (codeGenAccType a) (accDim acc) (accDim a) (codeGenFun f) (codeGenFun g)-        Backpermute _ f a -> mkBackpermute (codeGenAccType a) (accDim acc) (accDim a) (codeGenFun f)-        Replicate sl _ a  ->-          let dimSl  = accDim a-              dimOut = accDim acc-              ---              extend :: SliceIndex slix sl co dim -> Int -> [CExpr]-              extend (SliceNil)            _ = []-              extend (SliceAll   sliceIdx) n = mkPrj dimOut "dim" n : extend sliceIdx (n+1)-              extend (SliceFixed sliceIdx) n = extend sliceIdx (n+1)-          in-          mkReplicate (codeGenAccType a) dimSl dimOut . reverse $ extend sl 0--        Index sl a slix   ->-          let dimCo  = length (codeGenExpType slix)-              dimSl  = accDim acc-              dimIn0 = accDim a-              ---              restrict :: SliceIndex slix sl co dim -> (Int,Int) -> [CExpr]-              restrict (SliceNil)            _     = []-              restrict (SliceAll   sliceIdx) (m,n) = mkPrj dimSl "sl" n : restrict sliceIdx (m,n+1)-              restrict (SliceFixed sliceIdx) (m,n) = mkPrj dimCo "co" m : restrict sliceIdx (m+1,n)-          in-          mkIndex (codeGenAccType a) dimSl dimCo dimIn0 . reverse $ restrict sl (0,0)--        Stencil f bndy a     ->-          let ty0   = codeGenTupleTex (accType a)-              decl0 = map (map CTypeSpec) (reverse ty0)-              sten0 = zipWith mkGlobal decl0 (map (\n -> "stencil0_a" ++ show n) [0::Int ..])-          in-          mkStencil (codeGenAccTypeDim acc)-                    sten0 (codeGenAccType a) (map (reverse . Sugar.shapeToList) $ offsets f a) (codeGenBoundary a bndy)-                    (codeGenFun f)--        Stencil2 f bndy1 a1 bndy0 a0 ->-          let ty1          = codeGenTupleTex (accType a1)-              ty0          = codeGenTupleTex (accType a0)-              decl         = map (map CTypeSpec) . reverse-              sten n       = zipWith (flip mkGlobal) (map (\k -> "stencil" ++ shows (n::Int) "_a" ++ show k) [0::Int ..]) . decl-              (pos1, pos0) = offsets2 f a1 a0-          in-          mkStencil2 (codeGenAccTypeDim acc)-                     (sten 1 ty1) (codeGenAccType a1) (map (reverse . Sugar.shapeToList) pos1) (codeGenBoundary a1 bndy1)-                     (sten 0 ty0) (codeGenAccType a0) (map (reverse . Sugar.shapeToList) pos0) (codeGenBoundary a0 bndy0)-                     (codeGenFun f)--    ---    -- Generate binding points (texture references and shapes) for arrays lifted-    -- from scalar expressions-    ---    liftAcc :: OpenAcc aenv a -> AccBinding aenv -> [CExtDecl]-    liftAcc _ (ArrayVar idx) =-      let avar    = OpenAcc (Avar idx)-          idx'    = show $ deBruijnToInt idx-          sh      = mkShape (accDim avar) ("sh" ++ idx')-          ty      = codeGenTupleTex (accType avar)-          arr n   = "arr" ++ idx' ++ "_a" ++ show n-          var t n = mkGlobal (map CTypeSpec t) (arr n)-      in-      sh : zipWith var (reverse ty) (enumFrom 0 :: [Int])--    ---    -- caffeine and misery-    ---    internalError =-      let msg = unlines ["unsupported array primitive", render (nest 2 doc)]-          ppr = show acc-          doc | length ppr <= 250 = text ppr-              | otherwise         = text (take 250 ppr) <+> text "... {truncated}"-      in-      INTERNAL_ERROR(error) "codeGenAcc" msg----- code generation for stencil boundary conditions----codeGenBoundary :: forall aenv dim e. Sugar.Elt e-                => OpenAcc aenv (Sugar.Array dim e) {- dummy -}-                -> Boundary (Sugar.EltRepr e)-                -> Boundary [CExpr]-codeGenBoundary _ (Constant c) = Constant $ codeGenConst (Sugar.eltType (undefined::e)) c-codeGenBoundary _ Clamp        = Clamp-codeGenBoundary _ Mirror       = Mirror-codeGenBoundary _ Wrap         = Wrap---mkPrj :: Int -> String -> Int -> CExpr-mkPrj ndim var c- | ndim <= 1 = cvar var- | otherwise = CMember (cvar var) (internalIdent ('a':show c)) False internalNode----- Scalar Expressions--- ---------------------- Function abstraction------ Although Accelerate includes lambda abstractions, it does not include a--- general application form. That is, lambda abstractions of scalar expressions--- are only introduced as arguments to collective operations, so lambdas are--- always outermost, and can always be translated into plain C functions.----codeGenFun :: OpenFun env aenv t -> [CExpr]-codeGenFun (Lam  lam)  = codeGenFun lam-codeGenFun (Body body) = codeGenExp body----- Embedded scalar computations------ The state is used here to track array expressions that have been hoisted out--- of the scalar computation; namely, the arguments to 'IndexScalar' and 'Shape'----codeGenExp :: forall env aenv t. OpenExp env aenv t -> [CExpr]-codeGenExp (PrimConst c)   = [codeGenPrimConst c]-codeGenExp (PrimApp f arg) = [codeGenPrim f (codeGenExp arg)]-codeGenExp (Const c)       = codeGenConst (Sugar.eltType (undefined::t)) c-codeGenExp (Tuple t)       = codeGenTup t-codeGenExp p@(Prj idx e)-  = reverse-  . take (length $ codeGenTupleType (expType p))-  . drop (prjToInt idx (expType e))-  . reverse-  $ codeGenExp e--codeGenExp IndexNil         = []-codeGenExp IndexAny         = INTERNAL_ERROR(error) "codeGenExp" "IndexAny: not implemented yet"-codeGenExp (IndexCons ix i) = codeGenExp ix ++ codeGenExp i--codeGenExp (IndexHead sh@(Shape a)) =-  let [var] = codeGenExp sh-  in if accDim a > 1-        then [CMember var (internalIdent "a0") False internalNode]-        else [var]--codeGenExp (IndexTail sh@(Shape a)) =-  let [var] = codeGenExp sh-      idx   = reverse [1 .. accDim a - 1]-  in-  map (\i -> CMember var (internalIdent ('a':show i)) False internalNode) idx--codeGenExp (IndexHead ix) = return . last $ codeGenExp ix-codeGenExp (IndexTail ix) =          init $ codeGenExp ix--codeGenExp (Let _ _) = INTERNAL_ERROR(error) "codeGenExp" "Let: not implemented yet"-codeGenExp (Var i)   =-  let var = cvar ('x' : show (deBruijnToInt i))-  in-  case codeGenTupleType (Sugar.eltType (undefined::t)) of-       [_] -> [var]-       cps -> reverse . take (length cps) . flip map (enumFrom 0 :: [Int]) $-         \c -> CMember var (internalIdent ('a':show c)) False internalNode--codeGenExp (Cond p t e) =-  let [predicate] = codeGenExp p-      branch a b  = CCond predicate (Just a) b internalNode-  in-  zipWith branch (codeGenExp t) (codeGenExp e)--codeGenExp (Size a)         = return $ ccall "size" (codeGenExp (Shape a))-codeGenExp (Shape a)-  | OpenAcc (Avar var) <- a = return $ cvar ("sh" ++ show (deBruijnToInt var))-  | otherwise               = INTERNAL_ERROR(error) "codeGenExp" "expected array variable"--codeGenExp (IndexScalar a e)-  | OpenAcc (Avar var) <- a =-      let var'  = show $ deBruijnToInt var-          arr n = cvar ("arr" ++ var' ++ "_a" ++ show n)-          sh    = cvar ("sh"  ++ var')-          ix    = ccall "toIndex" [sh, ccall "shape" (codeGenExp e)]-          ---          ty         = codeGenTupleTex (accType a)-          indexA t n = ccall indexer [arr n, ix]-            where-              indexer = case t of-                          [CDoubleType _] -> "indexDArray"-                          _               -> "indexArray"-      in-      reverse $ zipWith indexA (reverse ty) (enumFrom 0 :: [Int])-  | otherwise               = INTERNAL_ERROR(error) "codeGenExp" "expected array variable"----- Tuples are defined as snoc-lists, so generate code right-to-left----codeGenTup :: Tuple (OpenExp env aenv) t -> [CExpr]-codeGenTup NilTup          = []-codeGenTup (t `SnocTup` e) = codeGenTup t ++ codeGenExp e---- Convert a tuple index into the corresponding integer. Since the internal--- representation is flat, be sure to walk over all sub components when indexing--- past nested tuples.----prjToInt :: TupleIdx t e -> TupleType a -> Int-prjToInt ZeroTupIdx     _                 = 0-prjToInt (SuccTupIdx i) (b `PairTuple` a) = length (codeGenTupleType a) + prjToInt i b-prjToInt _ _ =-  INTERNAL_ERROR(error) "prjToInt" "inconsistent valuation"----- Types--- --------- Generate types for the reified elements of an array computation----codeGenAccType :: OpenAcc aenv (Sugar.Array dim e) -> [CType]-codeGenAccType =  codeGenTupleType . accType--codeGenExpType :: OpenExp aenv env t -> [CType]-codeGenExpType =  codeGenTupleType . expType--codeGenAccTypeDim :: OpenAcc aenv (Sugar.Array dim e) -> ([CType],Int)-codeGenAccTypeDim acc = (codeGenAccType acc, accDim acc)----- Implementation----codeGenTupleType :: TupleType a -> [CType]-codeGenTupleType UnitTuple         = []-codeGenTupleType (SingleTuple  ty) = [codeGenScalarType ty]-codeGenTupleType (PairTuple t1 t0) = codeGenTupleType t1 ++ codeGenTupleType t0--codeGenScalarType :: ScalarType a -> CType-codeGenScalarType (NumScalarType    ty) = codeGenNumType ty-codeGenScalarType (NonNumScalarType ty) = codeGenNonNumType ty--codeGenNumType :: NumType a -> CType-codeGenNumType (IntegralNumType ty) = codeGenIntegralType ty-codeGenNumType (FloatingNumType ty) = codeGenFloatingType ty--codeGenIntegralType :: IntegralType a -> CType-codeGenIntegralType (TypeInt8    _) = [CTypeDef (internalIdent "int8_t")   internalNode]-codeGenIntegralType (TypeInt16   _) = [CTypeDef (internalIdent "int16_t")  internalNode]-codeGenIntegralType (TypeInt32   _) = [CTypeDef (internalIdent "int32_t")  internalNode]-codeGenIntegralType (TypeInt64   _) = [CTypeDef (internalIdent "int64_t")  internalNode]-codeGenIntegralType (TypeWord8   _) = [CTypeDef (internalIdent "uint8_t")  internalNode]-codeGenIntegralType (TypeWord16  _) = [CTypeDef (internalIdent "uint16_t") internalNode]-codeGenIntegralType (TypeWord32  _) = [CTypeDef (internalIdent "uint32_t") internalNode]-codeGenIntegralType (TypeWord64  _) = [CTypeDef (internalIdent "uint64_t") internalNode]-codeGenIntegralType (TypeCShort  _) = [CShortType internalNode]-codeGenIntegralType (TypeCUShort _) = [CUnsigType internalNode, CShortType internalNode]-codeGenIntegralType (TypeCInt    _) = [CIntType   internalNode]-codeGenIntegralType (TypeCUInt   _) = [CUnsigType internalNode, CIntType internalNode]-codeGenIntegralType (TypeCLong   _) = [CLongType  internalNode, CIntType internalNode]-codeGenIntegralType (TypeCULong  _) = [CUnsigType internalNode, CLongType internalNode, CIntType internalNode]-codeGenIntegralType (TypeCLLong  _) = [CLongType  internalNode, CLongType internalNode, CIntType internalNode]-codeGenIntegralType (TypeCULLong _) = [CUnsigType internalNode, CLongType internalNode, CLongType internalNode, CIntType internalNode]--codeGenIntegralType (TypeInt     _) =-  case F.sizeOf (undefined::Int) of-       4 -> [CTypeDef (internalIdent "int32_t") internalNode]-       8 -> [CTypeDef (internalIdent "int64_t") internalNode]-       _ -> error "we can never get here"--codeGenIntegralType (TypeWord    _) =-  case F.sizeOf (undefined::Int) of-       4 -> [CTypeDef (internalIdent "uint32_t") internalNode]-       8 -> [CTypeDef (internalIdent "uint64_t") internalNode]-       _ -> error "we can never get here"--codeGenFloatingType :: FloatingType a -> CType-codeGenFloatingType (TypeFloat   _) = [CFloatType  internalNode]-codeGenFloatingType (TypeDouble  _) = [CDoubleType internalNode]-codeGenFloatingType (TypeCFloat  _) = [CFloatType  internalNode]-codeGenFloatingType (TypeCDouble _) = [CDoubleType internalNode]--codeGenNonNumType :: NonNumType a -> CType-codeGenNonNumType (TypeBool   _) = error "codeGenNonNum :: Bool" -- [CUnsigType internalNode, CCharType internalNode]-codeGenNonNumType (TypeChar   _) = error "codeGenNonNum :: Char" -- [CCharType internalNode]-codeGenNonNumType (TypeCChar  _) = [CCharType internalNode]-codeGenNonNumType (TypeCSChar _) = [CSignedType internalNode, CCharType internalNode]-codeGenNonNumType (TypeCUChar _) = [CUnsigType  internalNode, CCharType internalNode]----- Texture types----codeGenTupleTex :: TupleType a -> [CType]-codeGenTupleTex UnitTuple         = []-codeGenTupleTex (SingleTuple t)   = [codeGenScalarTex t]-codeGenTupleTex (PairTuple t1 t0) = codeGenTupleTex t1 ++ codeGenTupleTex t0--codeGenScalarTex :: ScalarType a -> CType-codeGenScalarTex (NumScalarType    ty) = codeGenNumTex ty-codeGenScalarTex (NonNumScalarType ty) = codeGenNonNumTex ty;--codeGenNumTex :: NumType a -> CType-codeGenNumTex (IntegralNumType ty) = codeGenIntegralTex ty-codeGenNumTex (FloatingNumType ty) = codeGenFloatingTex ty--codeGenIntegralTex :: IntegralType a -> CType-codeGenIntegralTex (TypeInt8    _) = [CTypeDef (internalIdent "TexInt8")    internalNode]-codeGenIntegralTex (TypeInt16   _) = [CTypeDef (internalIdent "TexInt16")   internalNode]-codeGenIntegralTex (TypeInt32   _) = [CTypeDef (internalIdent "TexInt32")   internalNode]-codeGenIntegralTex (TypeInt64   _) = [CTypeDef (internalIdent "TexInt64")   internalNode]-codeGenIntegralTex (TypeWord8   _) = [CTypeDef (internalIdent "TexWord8")   internalNode]-codeGenIntegralTex (TypeWord16  _) = [CTypeDef (internalIdent "TexWord16")  internalNode]-codeGenIntegralTex (TypeWord32  _) = [CTypeDef (internalIdent "TexWord32")  internalNode]-codeGenIntegralTex (TypeWord64  _) = [CTypeDef (internalIdent "TexWord64")  internalNode]-codeGenIntegralTex (TypeCShort  _) = [CTypeDef (internalIdent "TexCShort")  internalNode]-codeGenIntegralTex (TypeCUShort _) = [CTypeDef (internalIdent "TexCUShort") internalNode]-codeGenIntegralTex (TypeCInt    _) = [CTypeDef (internalIdent "TexCInt")    internalNode]-codeGenIntegralTex (TypeCUInt   _) = [CTypeDef (internalIdent "TexCUInt")   internalNode]-codeGenIntegralTex (TypeCLong   _) = [CTypeDef (internalIdent "TexCLong")   internalNode]-codeGenIntegralTex (TypeCULong  _) = [CTypeDef (internalIdent "TexCULong")  internalNode]-codeGenIntegralTex (TypeCLLong  _) = [CTypeDef (internalIdent "TexCLLong")  internalNode]-codeGenIntegralTex (TypeCULLong _) = [CTypeDef (internalIdent "TexCULLong") internalNode]--codeGenIntegralTex (TypeInt     _) =-  case F.sizeOf (undefined::Int) of-       4 -> [CTypeDef (internalIdent "TexInt32") internalNode]-       8 -> [CTypeDef (internalIdent "TexInt64") internalNode]-       _ -> error "we can never get here"--codeGenIntegralTex (TypeWord    _) =-  case F.sizeOf (undefined::Word) of-       4 -> [CTypeDef (internalIdent "TexWord32") internalNode]-       8 -> [CTypeDef (internalIdent "TexWord64") internalNode]-       _ -> error "we can never get here"--codeGenFloatingTex :: FloatingType a -> CType-codeGenFloatingTex (TypeFloat   _) = [CTypeDef (internalIdent "TexFloat")   internalNode]-codeGenFloatingTex (TypeCFloat  _) = [CTypeDef (internalIdent "TexCFloat")  internalNode]-codeGenFloatingTex (TypeDouble  _) = [CTypeDef (internalIdent "TexDouble")  internalNode]-codeGenFloatingTex (TypeCDouble _) = [CTypeDef (internalIdent "TexCDouble") internalNode]---- TLM 2010-06-29:---   Bool and Char can be implemented once the array types in---   Data.Array.Accelerate.[CUDA.]Array.Data are made concrete.----codeGenNonNumTex :: NonNumType a -> CType-codeGenNonNumTex (TypeBool   _) = error "codeGenNonNumTex :: Bool"-codeGenNonNumTex (TypeChar   _) = error "codeGenNonNumTex :: Char"-codeGenNonNumTex (TypeCChar  _) = [CTypeDef (internalIdent "TexCChar")  internalNode]-codeGenNonNumTex (TypeCSChar _) = [CTypeDef (internalIdent "TexCSChar") internalNode]-codeGenNonNumTex (TypeCUChar _) = [CTypeDef (internalIdent "TexCUChar") internalNode]----- Scalar Primitives--- -------------------codeGenPrimConst :: PrimConst a -> CExpr-codeGenPrimConst (PrimMinBound ty) = codeGenMinBound ty-codeGenPrimConst (PrimMaxBound ty) = codeGenMaxBound ty-codeGenPrimConst (PrimPi       ty) = codeGenPi ty--codeGenPrim :: PrimFun p -> [CExpr] -> CExpr-codeGenPrim (PrimAdd              _) [a,b] = CBinary CAddOp a b internalNode-codeGenPrim (PrimSub              _) [a,b] = CBinary CSubOp a b internalNode-codeGenPrim (PrimMul              _) [a,b] = CBinary CMulOp a b internalNode-codeGenPrim (PrimNeg              _) [a]   = CUnary  CMinOp a   internalNode-codeGenPrim (PrimAbs             ty) [a]   = codeGenAbs ty a-codeGenPrim (PrimSig             ty) [a]   = codeGenSig ty a-codeGenPrim (PrimQuot             _) [a,b] = CBinary CDivOp a b internalNode-codeGenPrim (PrimRem              _) [a,b] = CBinary CRmdOp a b internalNode-codeGenPrim (PrimIDiv             _) [a,b] = ccall "idiv" [a,b]-codeGenPrim (PrimMod              _) [a,b] = ccall "mod"  [a,b]-codeGenPrim (PrimBAnd             _) [a,b] = CBinary CAndOp a b internalNode-codeGenPrim (PrimBOr              _) [a,b] = CBinary COrOp  a b internalNode-codeGenPrim (PrimBXor             _) [a,b] = CBinary CXorOp a b internalNode-codeGenPrim (PrimBNot             _) [a]   = CUnary  CCompOp a  internalNode-codeGenPrim (PrimBShiftL          _) [a,b] = CBinary CShlOp a b internalNode-codeGenPrim (PrimBShiftR          _) [a,b] = CBinary CShrOp a b internalNode-codeGenPrim (PrimBRotateL         _) [a,b] = ccall "rotateL" [a,b]-codeGenPrim (PrimBRotateR         _) [a,b] = ccall "rotateR" [a,b]-codeGenPrim (PrimFDiv             _) [a,b] = CBinary CDivOp a b internalNode-codeGenPrim (PrimRecip           ty) [a]   = codeGenRecip ty a-codeGenPrim (PrimSin             ty) [a]   = ccall (FloatingNumType ty `postfix` "sin")   [a]-codeGenPrim (PrimCos             ty) [a]   = ccall (FloatingNumType ty `postfix` "cos")   [a]-codeGenPrim (PrimTan             ty) [a]   = ccall (FloatingNumType ty `postfix` "tan")   [a]-codeGenPrim (PrimAsin            ty) [a]   = ccall (FloatingNumType ty `postfix` "asin")  [a]-codeGenPrim (PrimAcos            ty) [a]   = ccall (FloatingNumType ty `postfix` "acos")  [a]-codeGenPrim (PrimAtan            ty) [a]   = ccall (FloatingNumType ty `postfix` "atan")  [a]-codeGenPrim (PrimAsinh           ty) [a]   = ccall (FloatingNumType ty `postfix` "asinh") [a]-codeGenPrim (PrimAcosh           ty) [a]   = ccall (FloatingNumType ty `postfix` "acosh") [a]-codeGenPrim (PrimAtanh           ty) [a]   = ccall (FloatingNumType ty `postfix` "atanh") [a]-codeGenPrim (PrimExpFloating     ty) [a]   = ccall (FloatingNumType ty `postfix` "exp")   [a]-codeGenPrim (PrimSqrt            ty) [a]   = ccall (FloatingNumType ty `postfix` "sqrt")  [a]-codeGenPrim (PrimLog             ty) [a]   = ccall (FloatingNumType ty `postfix` "log")   [a]-codeGenPrim (PrimFPow            ty) [a,b] = ccall (FloatingNumType ty `postfix` "pow")   [a,b]-codeGenPrim (PrimLogBase         ty) [a,b] = codeGenLogBase ty a b-codeGenPrim (PrimTruncate     ta tb) [a]   = codeGenTruncate ta tb a-codeGenPrim (PrimRound        ta tb) [a]   = codeGenRound ta tb a-codeGenPrim (PrimFloor        ta tb) [a]   = codeGenFloor ta tb a-codeGenPrim (PrimCeiling      ta tb) [a]   = codeGenCeiling ta tb a-codeGenPrim (PrimAtan2           ty) [a,b] = ccall (FloatingNumType ty `postfix` "atan2") [a,b]-codeGenPrim (PrimLt               _) [a,b] = CBinary CLeOp  a b internalNode-codeGenPrim (PrimGt               _) [a,b] = CBinary CGrOp  a b internalNode-codeGenPrim (PrimLtEq             _) [a,b] = CBinary CLeqOp a b internalNode-codeGenPrim (PrimGtEq             _) [a,b] = CBinary CGeqOp a b internalNode-codeGenPrim (PrimEq               _) [a,b] = CBinary CEqOp  a b internalNode-codeGenPrim (PrimNEq              _) [a,b] = CBinary CNeqOp a b internalNode-codeGenPrim (PrimMax             ty) [a,b] = codeGenMax ty a b-codeGenPrim (PrimMin             ty) [a,b] = codeGenMin ty a b-codeGenPrim PrimLAnd                 [a,b] = CBinary CLndOp a b internalNode-codeGenPrim PrimLOr                  [a,b] = CBinary CLorOp a b internalNode-codeGenPrim PrimLNot                 [a]   = CUnary  CNegOp a   internalNode-codeGenPrim PrimOrd                  [a]   = codeGenOrd a-codeGenPrim PrimChr                  [a]   = codeGenChr a-codeGenPrim PrimBoolToInt            [a]   = codeGenBoolToInt a-codeGenPrim (PrimFromIntegral ta tb) [a]   = codeGenFromIntegral ta tb a---- If the argument lists are not the correct length-codeGenPrim _ _ =-  INTERNAL_ERROR(error) "codeGenPrim" "inconsistent valuation"----- Implementation of scalar primitives----codeGenConst :: TupleType a -> a -> [CExpr]-codeGenConst UnitTuple           _      = []-codeGenConst (SingleTuple ty)    c      = [codeGenScalar ty c]-codeGenConst (PairTuple ty1 ty0) (cs,c) = codeGenConst ty1 cs ++ codeGenConst ty0 c---- Scalar constants------ Add an explicit type annotation (cast) to all scalar constants, which avoids--- ambiguity as to what type we actually want. Without this:------   1. Floating-point constants will be implicitly promoted to double---      precision, which will emit warnings on pre-1.3 series devices and---      unnecessary runtime conversion and register pressure on later hardware---      that actually does support double precision arithmetic.------   2. Interaction of differing word sizes on the host and device in overloaded---      functions such as max() leads to ambiguity.----codeGenScalar :: ScalarType a -> a -> CExpr-codeGenScalar st c = ccast st $ case st of-  NumScalarType (IntegralNumType ty)-    | IntegralDict <- integralDict ty -> CConst $ CIntConst (cInteger (fromIntegral c)) internalNode-  NumScalarType (FloatingNumType ty)-    | FloatingDict <- floatingDict ty -> CConst $ CFloatConst (cFloat (realToFrac c)) internalNode-  NonNumScalarType (TypeCChar  _)     -> CConst $ CCharConst (cChar . chr . fromIntegral $ c) internalNode-  NonNumScalarType (TypeCUChar _)     -> CConst $ CCharConst (cChar . chr . fromIntegral $ c) internalNode-  NonNumScalarType (TypeCSChar _)     -> CConst $ CCharConst (cChar . chr . fromIntegral $ c) internalNode-  NonNumScalarType (TypeChar   _)     -> CConst $ CCharConst (cChar c) internalNode-  NonNumScalarType (TypeBool   _)     -> fromBool c----- Constant methods of floating--codeGenPi :: FloatingType a -> CExpr-codeGenPi ty-  | FloatingDict <- floatingDict ty-  = codeGenScalar (NumScalarType (FloatingNumType ty)) pi---- Constant methods of bounded--codeGenMinBound :: BoundedType a -> CExpr-codeGenMinBound (IntegralBoundedType ty)-  | IntegralDict <- integralDict ty-  = codeGenScalar (NumScalarType (IntegralNumType ty)) minBound-codeGenMinBound (NonNumBoundedType   ty)-  | NonNumDict   <- nonNumDict   ty-  = codeGenScalar (NonNumScalarType ty) minBound--codeGenMaxBound :: BoundedType a -> CExpr-codeGenMaxBound (IntegralBoundedType ty)-  | IntegralDict <- integralDict ty-  = codeGenScalar (NumScalarType (IntegralNumType ty)) maxBound-codeGenMaxBound (NonNumBoundedType   ty)-  | NonNumDict   <- nonNumDict   ty-  = codeGenScalar (NonNumScalarType ty) maxBound---- Methods from Num, Floating, Fractional and RealFrac--codeGenAbs :: NumType a -> CExpr -> CExpr-codeGenAbs ty@(IntegralNumType _) x = ccall (ty `postfix` "abs")  [x]-codeGenAbs ty@(FloatingNumType _) x = ccall (ty `postfix` "fabs") [x]--codeGenSig :: NumType a -> CExpr -> CExpr-codeGenSig ty@(IntegralNumType t) a-  | IntegralDict <- integralDict t-  = CCond (CBinary CGeqOp a (codeGenScalar (NumScalarType ty) 0) internalNode)-          (Just (codeGenScalar (NumScalarType ty) 1))-          (codeGenScalar (NumScalarType ty) 0)-          internalNode-codeGenSig ty@(FloatingNumType t) a-  | FloatingDict <- floatingDict t-  = CCond (CBinary CGeqOp a (codeGenScalar (NumScalarType ty) 0) internalNode)-          (Just (codeGenScalar (NumScalarType ty) 1))-          (codeGenScalar (NumScalarType ty) 0)-          internalNode--codeGenRecip :: FloatingType a -> CExpr -> CExpr-codeGenRecip ty x | FloatingDict <- floatingDict ty-  = CBinary CDivOp (codeGenScalar (NumScalarType (FloatingNumType ty)) 1) x internalNode--codeGenLogBase :: FloatingType a -> CExpr -> CExpr -> CExpr-codeGenLogBase ty x y = let a = ccall (FloatingNumType ty `postfix` "log") [x]-                            b = ccall (FloatingNumType ty `postfix` "log") [y]-                        in-                        CBinary CDivOp b a internalNode--codeGenMin :: ScalarType a -> CExpr -> CExpr -> CExpr-codeGenMin (NumScalarType ty@(IntegralNumType _)) a b = ccall (ty `postfix` "min")  [a,b]-codeGenMin (NumScalarType ty@(FloatingNumType _)) a b = ccall (ty `postfix` "fmin") [a,b]-codeGenMin (NonNumScalarType _)                   a b =-  let ty = NumScalarType (IntegralNumType (TypeInt32 (undefined :: IntegralDict Int32)))-  in  codeGenMin ty (ccast ty a) (ccast ty b)--codeGenMax :: ScalarType a -> CExpr -> CExpr -> CExpr-codeGenMax (NumScalarType ty@(IntegralNumType _)) a b = ccall (ty `postfix` "max")  [a,b]-codeGenMax (NumScalarType ty@(FloatingNumType _)) a b = ccall (ty `postfix` "fmax") [a,b]-codeGenMax (NonNumScalarType _)                   a b =-  let ty = NumScalarType (IntegralNumType (TypeInt32 (undefined :: IntegralDict Int32)))-  in  codeGenMax ty (ccast ty a) (ccast ty b)----- Type coercions--codeGenOrd :: CExpr -> CExpr-codeGenOrd = ccast (NumScalarType (IntegralNumType (TypeInt (undefined :: IntegralDict Int))))--codeGenChr :: CExpr -> CExpr-codeGenChr = ccast (NonNumScalarType (TypeChar (undefined :: NonNumDict Char)))--codeGenBoolToInt :: CExpr -> CExpr-codeGenBoolToInt = ccast (NumScalarType (IntegralNumType (TypeInt (undefined :: IntegralDict Int))))--codeGenFromIntegral :: IntegralType a -> NumType b -> CExpr -> CExpr-codeGenFromIntegral _ ty = ccast (NumScalarType ty)--codeGenTruncate :: FloatingType a -> IntegralType b -> CExpr -> CExpr-codeGenTruncate ta tb x-  = ccast (NumScalarType (IntegralNumType tb))-  $ ccall (FloatingNumType ta `postfix` "trunc") [x]--codeGenRound :: FloatingType a -> IntegralType b -> CExpr -> CExpr-codeGenRound ta tb x-  = ccast (NumScalarType (IntegralNumType tb))-  $ ccall (FloatingNumType ta `postfix` "round") [x]--codeGenFloor :: FloatingType a -> IntegralType b -> CExpr -> CExpr-codeGenFloor ta tb x-  = ccast (NumScalarType (IntegralNumType tb))-  $ ccall (FloatingNumType ta `postfix` "floor") [x]--codeGenCeiling :: FloatingType a -> IntegralType b -> CExpr -> CExpr-codeGenCeiling ta tb x-  = ccast (NumScalarType (IntegralNumType tb))-  $ ccall (FloatingNumType ta `postfix` "ceil") [x]----- Auxiliary Functions--- ---------------------ccast :: ScalarType a -> CExpr -> CExpr-ccast ty x = CCast (CDecl (map CTypeSpec (codeGenScalarType ty)) [] internalNode) x internalNode--postfix :: NumType a -> String -> String-postfix (FloatingNumType (TypeFloat  _)) = (++ "f")-postfix (FloatingNumType (TypeCFloat _)) = (++ "f")-postfix _                                = id-
− Data/Array/Accelerate/CUDA/CodeGen/Data.hs 
@@ -1,41 +0,0 @@--- |--- Module      : Data.Array.Accelerate.CUDA.CodeGen.Data--- Copyright   : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell--- License     : BSD3------ Maintainer  : Manuel M T Chakravarty <chak@cse.unsw.edu.au>--- Stability   : experimental--- Portability : non-partable (GHC extensions)------ Common data types for code generation-----module Data.Array.Accelerate.CUDA.CodeGen.Data-  (-    CType, CMacro, CUTranslSkel(..)-  )-  where--import Language.C-import Text.PrettyPrint--type CType        = [CTypeSpec]-type CMacro       = (Ident, Maybe CExpr)-data CUTranslSkel = CUTranslSkel CTranslUnit [CMacro] FilePath--instance Pretty CUTranslSkel where-  pretty (CUTranslSkel code defs skel) =-    vcat [ include "accelerate_cuda_extras.h"-         , vcat (map macro defs)-         , pretty code-         , include skel-         ]---include :: FilePath -> Doc-include hdr = text "#include <" <> text hdr <> text ">"--macro :: CMacro -> Doc-macro (d,v) = text "#define" <+> text (identToString d)-                             <+> maybe empty (parens . pretty) v-
− Data/Array/Accelerate/CUDA/CodeGen/Skeleton.hs 
@@ -1,280 +0,0 @@--- |--- Module      : Data.Array.Accelerate.CUDA.CodeGen.Skeleton--- Copyright   : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell--- License     : BSD3------ Maintainer  : Manuel M T Chakravarty <chak@cse.unsw.edu.au>--- Stability   : experimental--- Portability : non-portable (GHC extensions)------ Constructors for array computation skeletons-----module Data.Array.Accelerate.CUDA.CodeGen.Skeleton-  (-    mkGenerate, mkFold, mkFold1, mkFoldSeg, mkFold1Seg, mkMap, mkZipWith,-    mkStencil, mkStencil2,-    mkScanl, mkScanr, mkScanl', mkScanr', mkScanl1, mkScanr1,-    mkPermute, mkBackpermute, mkIndex, mkReplicate-  )-  where--import Language.C-import System.FilePath-import Data.Array.Accelerate.Type-import Data.Array.Accelerate.CUDA.CodeGen.Data-import Data.Array.Accelerate.CUDA.CodeGen.Util-import Data.Array.Accelerate.CUDA.CodeGen.Tuple-import Data.Array.Accelerate.CUDA.CodeGen.Stencil----- Construction--- --------------mkGenerate :: ([CType],Int) -> [CExpr] -> CUTranslSkel-mkGenerate (tyOut, dimOut) apply = CUTranslSkel code [] skel-  where-    skel = "generate.inl"-    code = CTranslUnit-            ( mkTupleType Nothing  tyOut ++-            [ mkDim "DimOut" dimOut-            , mkDim "TyIn0"  dimOut-            , mkApply 1 apply ])-            (mkNodeInfo (initPos skel) (Name 0))----- Reduction--- -----------mkFold :: ([CType],Int) -> [CExpr] -> [CExpr] -> CUTranslSkel-mkFold (ty,dim) identity apply = CUTranslSkel code [] skel-  where-    skel | dim == 1  = "foldAll.inl"-         | otherwise = "fold.inl"-    code = CTranslUnit-            ( mkTupleTypeAsc 2 ty ++-            [ mkTuplePartition "ArrOut" ty True-            , mkIdentity identity-            , mkApply 2 apply-            , mkDim "DimIn0" dim-            , mkDim "DimOut" (dim-1) ])-            (mkNodeInfo (initPos skel) (Name 0))--mkFold1 :: ([CType],Int) -> [CExpr] -> CUTranslSkel-mkFold1 (ty,dim) apply = CUTranslSkel code inc skel-  where-    skel | dim == 1  = "foldAll.inl"-         | otherwise = "fold.inl"-    inc  = [(internalIdent "INCLUSIVE", Just (fromBool True))]-    code = CTranslUnit-            ( mkTupleTypeAsc 2 ty ++-            [ mkTuplePartition "ArrOut" ty True-            , mkApply 2 apply-            , mkDim "DimIn0" dim-            , mkDim "DimOut" (dim-1) ])-            (mkNodeInfo (initPos skel) (Name 0))--mkFoldSeg :: ([CType],Int) -> [CType] -> [CExpr] -> [CExpr] -> CUTranslSkel-mkFoldSeg (ty,dim) int identity apply = CUTranslSkel code [] skel-  where-    skel = "foldSeg.inl"-    code = CTranslUnit-            ( mkTupleTypeAsc 2 ty ++-            [ mkTuplePartition "ArrOut" ty True-            , mkIdentity identity-            , mkApply 2 apply-            , mkTypedef "Int" False False (head int)-            , mkDim "DimIn0" dim-            , mkDim "DimOut" dim ])-            (mkNodeInfo (initPos skel) (Name 0))--mkFold1Seg :: ([CType],Int) -> [CType] -> [CExpr] -> CUTranslSkel-mkFold1Seg (ty,dim) int apply = CUTranslSkel code inc skel-  where-    skel = "foldSeg.inl"-    inc  = [(internalIdent "INCLUSIVE", Just (fromBool True))]-    code = CTranslUnit-            ( mkTupleTypeAsc 2 ty ++-            [ mkTuplePartition "ArrOut" ty True-            , mkApply 2 apply-            , mkTypedef "Int" False False (head int)-            , mkDim "DimIn0" dim-            , mkDim "DimOut" dim ])-            (mkNodeInfo (initPos skel) (Name 0))----- Map--- -----mkMap :: [CType] -> [CType] -> [CExpr] -> CUTranslSkel-mkMap tyOut tyIn0 apply = CUTranslSkel code [] skel-  where-    skel = "map.inl"-    code = CTranslUnit-            ( mkTupleType Nothing  tyOut ++-              mkTupleType (Just 0) tyIn0 ++-            [ mkApply 1 apply ])-            (mkNodeInfo (initPos skel) (Name 0))---mkZipWith :: ([CType], Int) -> ([CType], Int) -> ([CType], Int) -> [CExpr] -> CUTranslSkel-mkZipWith (tyOut,dimOut) (tyIn1,dimIn1) (tyIn0,dimIn0) apply = CUTranslSkel code [] skel-  where-    skel = "zipWith.inl"-    code = CTranslUnit-            ( mkTupleType Nothing  tyOut ++-              mkTupleType (Just 1) tyIn1 ++-              mkTupleType (Just 0) tyIn0 ++-            [ mkApply 2 apply-            , mkDim "DimOut" dimOut-            , mkDim "DimIn1" dimIn1-            , mkDim "DimIn0" dimIn0 ])-            (mkNodeInfo (initPos skel) (Name 0))----- Stencil--- ---------mkStencil :: ([CType], Int)-          -> [CExtDecl] -> [CType] -> [[Int]] -> Boundary [CExpr]-          -> [CExpr]-          -> CUTranslSkel-mkStencil (tyOut, dim) stencil0 tyIn0 ixs0 boundary0 apply = CUTranslSkel code [] skel-  where-    skel = "stencil.inl"-    code = CTranslUnit-            ( stencil0                   ++-              mkTupleType Nothing  tyOut ++-            [ mkDim "DimOut" dim-            , mkDim "DimIn0" dim-            , head $ mkTupleType (Just 0) tyIn0 -- just the scalar type-            , mkStencilType 0 (length ixs0) tyIn0 ] ++-              mkStencilGet 0 boundary0 tyIn0 ++-            [ mkStencilGather 0 dim tyIn0 ixs0-            , mkStencilApply 1 apply ] )-            (mkNodeInfo (initPos skel) (Name 0))---mkStencil2 :: ([CType], Int)-           -> [CExtDecl] -> [CType] -> [[Int]] -> Boundary [CExpr]-           -> [CExtDecl] -> [CType] -> [[Int]] -> Boundary [CExpr]-           -> [CExpr]-           -> CUTranslSkel-mkStencil2 (tyOut, dim) stencil1 tyIn1 ixs1 boundary1-                        stencil0 tyIn0 ixs0 boundary0 apply =-  CUTranslSkel code [] skel-  where-    skel = "stencil2.inl"-    code = CTranslUnit-            ( stencil0                   ++-              stencil1                   ++-              mkTupleType Nothing  tyOut ++-            [ mkDim "DimOut" dim-            , mkDim "DimIn1" dim-            , mkDim "DimIn0" dim-            , head $ mkTupleType (Just 0) tyIn0 -- just the scalar type-            , head $ mkTupleType (Just 1) tyIn1-            , mkStencilType 1 (length ixs1) tyIn1-            , mkStencilType 0 (length ixs0) tyIn0 ] ++-              mkStencilGet 1 boundary1 tyIn1 ++-              mkStencilGet 0 boundary0 tyIn0 ++-            [ mkStencilGather 1 dim tyIn1 ixs1-            , mkStencilGather 0 dim tyIn0 ixs0-            , mkStencilApply 2 apply ] )-            (mkNodeInfo (initPos skel) (Name 0))----- Scan--- -------- TODO: use a fast scan for primitive types----mkExclusiveScan :: Bool -> Bool -> [CType] -> [CExpr] -> [CExpr] -> CUTranslSkel-mkExclusiveScan isReverse isHaskellStyle ty identity apply = CUTranslSkel code defs skel-  where-    skel = "scan.inl"-    defs = [(internalIdent "REVERSE",       Just (fromBool isReverse))-           ,(internalIdent "HASKELL_STYLE", Just (fromBool isHaskellStyle))]-    code = CTranslUnit-            ( mkTupleTypeAsc 2 ty ++-            [ mkIdentity identity-            , mkApply 2 apply ])-            (mkNodeInfo (initPos (takeFileName skel)) (Name 0))--mkInclusiveScan :: Bool -> [CType] -> [CExpr] -> CUTranslSkel-mkInclusiveScan isReverse ty apply = CUTranslSkel code [rev] skel-  where-    skel = "scan1.inl"-    rev  = (internalIdent "REVERSE", Just (fromBool isReverse))-    code = CTranslUnit-            ( mkTupleTypeAsc 2 ty ++-            [ mkApply 2 apply ])-            (mkNodeInfo (initPos (takeFileName skel)) (Name 0))--mkScanl, mkScanr :: [CType] -> [CExpr] -> [CExpr] -> CUTranslSkel-mkScanl = mkExclusiveScan False True-mkScanr = mkExclusiveScan True  True--mkScanl', mkScanr' :: [CType] -> [CExpr] -> [CExpr] -> CUTranslSkel-mkScanl' = mkExclusiveScan False False-mkScanr' = mkExclusiveScan True  False--mkScanl1, mkScanr1 :: [CType] -> [CExpr] -> CUTranslSkel-mkScanl1 = mkInclusiveScan False-mkScanr1 = mkInclusiveScan True----- Permutation--- -------------mkPermute :: [CType] -> Int -> Int -> [CExpr] -> [CExpr] -> CUTranslSkel-mkPermute ty dimOut dimIn0 combinefn indexfn = CUTranslSkel code [] skel-  where-    skel = "permute.inl"-    code = CTranslUnit-            ( mkTupleTypeAsc 2 ty ++-            [ mkDim "DimOut" dimOut-            , mkDim "DimIn0" dimIn0-            , mkProject Forward indexfn-            , mkApply 2 combinefn ])-            (mkNodeInfo (initPos skel) (Name 0))--mkBackpermute :: [CType] -> Int -> Int -> [CExpr] -> CUTranslSkel-mkBackpermute ty dimOut dimIn0 indexFn = CUTranslSkel code [] skel-  where-    skel = "backpermute.inl"-    code = CTranslUnit-            ( mkTupleTypeAsc 1 ty ++-            [ mkDim "DimOut" dimOut-            , mkDim "DimIn0" dimIn0-            , mkProject Backward indexFn ])-            (mkNodeInfo (initPos skel) (Name 0))----- Multidimensional Index and Replicate--- --------------------------------------mkIndex :: [CType] -> Int -> Int -> Int -> [CExpr] -> CUTranslSkel-mkIndex ty dimSl dimCo dimIn0 slix = CUTranslSkel code [] skel-  where-    skel = "slice.inl"-    code = CTranslUnit-            ( mkTupleTypeAsc 1 ty ++-            [ mkDim "Slice"    dimSl-            , mkDim "CoSlice"  dimCo-            , mkDim "SliceDim" dimIn0-            , mkSliceIndex slix ])-            (mkNodeInfo (initPos skel) (Name 0))---mkReplicate :: [CType] -> Int -> Int -> [CExpr] -> CUTranslSkel-mkReplicate ty dimSl dimOut slix = CUTranslSkel code [] skel-  where-    skel = "replicate.inl"-    code = CTranslUnit-            ( mkTupleTypeAsc 1 ty ++-            [ mkDim "Slice"    dimSl-            , mkDim "SliceDim" dimOut-            , mkSliceReplicate slix ])-            (mkNodeInfo (initPos skel) (Name 0))-
− Data/Array/Accelerate/CUDA/CodeGen/Stencil.hs 
@@ -1,124 +0,0 @@--- |--- Module      : Data.Array.Accelerate.CUDA.CodeGen.Tuple--- Copyright   : [2010..2011] Ben Lever--- License     : BSD3------ Maintainer  : Manuel M T Chakravarty <chak@cse.unsw.edu.au>--- Stability   : experimental--- Portability : non-partable (GHC extensions)-----module Data.Array.Accelerate.CUDA.CodeGen.Stencil (-  mkStencilType, mkStencilGet, mkStencilGather, mkStencilApply-)-where--import Language.C-import Data.Array.Accelerate.CUDA.CodeGen.Data-import Data.Array.Accelerate.CUDA.CodeGen.Util--import Data.Array.Accelerate.Type----- Getter function for a single element of a stencil array. These arrays are--- read via texture memory, and additionally we need to specify the boundary--- condition handler.----mkStencilGet :: Int -> Boundary [CExpr] -> [CType] -> [CExtDecl]-mkStencilGet base bndy ty =-  case bndy of-    Constant e -> [mkConstant e, mkFun [constant]]-    Clamp      -> [mkFun (boundary "clamp")]-    Mirror     -> [mkFun (boundary "mirror")]-    Wrap       -> [mkFun (boundary "wrap")]-  where-    dim   = typename (subscript "DimIn")-    mkFun = mkDeviceFun' (subscript "get") (typename (subscript "TyIn")) [(dim, "sh"), (dim, "ix")]--    mkConstant = mkDeviceFun (subscript "constant") (typename (subscript "TyIn")) []--    constant   = CBlockStmt $-      CIf (ccall "inRange" [cvar "sh", cvar "ix"])-      (CCompound [] [ CBlockDecl (CDecl [CTypeQual (CConstQual internalNode), CTypeSpec (CTypeDef (internalIdent "Ix") internalNode)] [(Just (CDeclr (Just (internalIdent "i")) [] Nothing [] internalNode),Just (CInitExpr (ccall "toIndex" [cvar "sh", cvar "ix"]) internalNode),Nothing)] internalNode)-                    , initA-                    , CBlockStmt (CReturn (Just (cvar "r")) internalNode) ]-                    internalNode)-      (Just (CCompound [] [CBlockStmt (CReturn (Just (ccall (subscript "constant") [])) internalNode)] internalNode))-      internalNode--    boundary f =-      [ CBlockDecl (CDecl [CTypeQual (CConstQual internalNode), CTypeSpec (CTypeDef (internalIdent "Ix") internalNode)] [(Just (CDeclr (Just (internalIdent "i")) [] Nothing [] internalNode),Just (CInitExpr (ccall "toIndex" [cvar "sh", ccall f [cvar "sh", cvar "ix"]]) internalNode),Nothing)] internalNode)-      , initA-      , CBlockStmt (CReturn (Just (CVar (internalIdent "r") internalNode)) internalNode)-      ]--    subscript = (++ show base)-    ix        = cvar "i"-    arr c     = cvar (subscript "stencil" ++ "_a" ++ show c)--    initA = CBlockDecl-      (CDecl [CTypeSpec (CTypeDef (internalIdent (subscript "TyIn")) internalNode)]-             [( Just (CDeclr (Just (internalIdent "r")) [] Nothing [] internalNode)-              , Just . mkInitList . reverse $ zipWith indexA (reverse ty) (enumFrom 0 :: [Int])-              , Nothing)]-             internalNode)--    indexA [CDoubleType _] c = ccall "indexDArray" [arr c, ix]-    indexA _               c = ccall "indexArray"  [arr c, ix]----- A structure to hold all components of a stencil, mimicking our nested-tuple--- representation for neighbouring elements.----mkStencilType :: Int -> Int -> [CType] -> CExtDecl-mkStencilType subscript size-  = mkStruct ("Stencil" ++ show subscript) False False-  . concat . replicate size----- Gather all neighbouring array elements for our stencil----mkStencilGather :: Int -> Int -> [CType] -> [[Int]] -> CExtDecl-mkStencilGather base dim ty ixs =-  mkDeviceFun' (subscript "gather") (typename (subscript "Stencil")) [(dimIn, "sh"), (dimIn, "ix")] body-  where-    dimIn     = typename (subscript "DimIn")-    subscript = (++ show base)--    plus a b  = CBinary CAddOp a b internalNode-    cint c    = CConst $ CIntConst (cInteger (toInteger c)) internalNode-    offset is-      | dim == 1  = [cvar "ix" `plus` cint (head is)]-      | otherwise = zipWith (\c i -> CMember (cvar "ix") (internalIdent ('a':show c)) False internalNode `plus` cint i) [dim-1, dim-2 ..] is--    initX x is = CBlockDecl-      (CDecl [CTypeQual (CConstQual internalNode), CTypeSpec (CTypeDef (internalIdent (subscript "TyIn")) internalNode)]-             [( Just (CDeclr (Just (internalIdent ('x':show x))) [] Nothing [] internalNode)-              , Just (CInitExpr (ccall (subscript "get") [cvar "sh", ccall "shape" (offset is)]) internalNode)-              , Nothing)]-             internalNode)--    initS =-      let xs    = let l = length ixs in [l-1, l-2 .. 0]-          names = case length ty of-            1 -> [ cvar ('x':show x) | x <- xs]-            n -> [ CMember (cvar ('x':show x)) (internalIdent ('a':show c)) False internalNode | x <- xs , c <- [n-1,n-2..0]]-      in-      CBlockDecl-      (CDecl [CTypeSpec (CTypeDef (internalIdent (subscript "Stencil")) internalNode)]-             [( Just (CDeclr (Just (internalIdent "r")) [] Nothing [] internalNode)-              , Just (mkInitList names)-              , Nothing)]-             internalNode)--    body =-      zipWith initX [0::Int ..] (reverse ixs) ++-      [ initS-      , CBlockStmt (CReturn (Just (CVar (internalIdent "r") internalNode)) internalNode) ]---mkStencilApply :: Int -> [CExpr] -> CExtDecl-mkStencilApply argc-  = mkDeviceFun "apply" (typename "TyOut")-  $ map (\n -> (typename ("Stencil" ++ show n), 'x':show n)) [argc-1, argc-2 .. 0]-
− Data/Array/Accelerate/CUDA/CodeGen/Tuple.hs 
@@ -1,112 +0,0 @@--- |--- Module      : Data.Array.Accelerate.CUDA.CodeGen.Tuple--- Copyright   : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell--- License     : BSD3------ Maintainer  : Manuel M T Chakravarty <chak@cse.unsw.edu.au>--- Stability   : experimental--- Portability : non-partable (GHC extensions)-----module Data.Array.Accelerate.CUDA.CodeGen.Tuple-  (-    mkTupleType, mkTupleTypeAsc, mkTuplePartition-  )-  where--import Data.Maybe-import Language.C-import Data.Array.Accelerate.CUDA.CodeGen.Data-import Data.Array.Accelerate.CUDA.CodeGen.Util---mkTupleType :: Maybe Int -> [CType] -> [CExtDecl]-mkTupleType subscript ty = types ++ [accessor]-  where-    n        = length ty-    volatile = isNothing subscript-    base     = maybe "Out" (\p -> "In" ++ show p) subscript-    accessor = maybe (mkSet n) (mkGet n) subscript-    types-      | n <= 1    = [ mkTypedef ("Ty"  ++ base) False False (head ty), mkTypedef ("Arr" ++ base) volatile True (head ty)]-      | otherwise = [ mkStruct  ("Ty"  ++ base) False False ty,        mkStruct  ("Arr" ++ base) volatile True ty]---- A variant of tuple generation for associative array computations, generating--- base get and set functions, and the given number of type synonyms.----mkTupleTypeAsc :: Int -> [CType] -> [CExtDecl]-mkTupleTypeAsc syn ty = types ++ synonyms ++ [mkSet n, mkGet n 0]-  where-    n        = length ty-    synonyms = concat . take syn . flip map ([0..] :: [Int]) $ \v ->-      [ mkTypedef ("TyIn"  ++ show v) False False [CTypeDef (internalIdent "TyOut")  internalNode]-      , mkTypedef ("ArrIn" ++ show v) False False [CTypeDef (internalIdent "ArrOut") internalNode] ]-    types-      | n <= 1    = [ mkTypedef "TyOut" False False (head ty), mkTypedef "ArrOut" True True (head ty)]-      | otherwise = [ mkStruct  "TyOut" False False ty,        mkStruct  "ArrOut" True True ty]----- Getter and setter functions for reading and writing (respectively) to global--- device arrays. Since arrays of tuples are stored as tuples of arrays, we--- retrieve each component separately and pack into a local structure.------ This unfortunately also means that we can not declare an overloaded indexing--- operator[], since it is not possible to return an l-value to the discrete--- component arrays (we could read, but not write).------ NOTE: The Accelerate language uses snoc based tuple projection, so the last---       field of the structure is named 'a' instead of the first, while the---       arrays themselves are still stored "in order".----mkGet :: Int -> Int -> CExtDecl-mkGet n prj =-  CFDefExt-    (CFunDef-      [CStorageSpec (CStatic internalNode), CTypeQual (CInlineQual internalNode), CTypeQual (CAttrQual (CAttr (internalIdent "device") [] internalNode)), CTypeSpec (CTypeDef (internalIdent ("TyIn" ++ show prj)) internalNode)]-      (CDeclr (Just (internalIdent ("get" ++ show prj))) [CFunDeclr (Right ([CDecl [CTypeQual (CConstQual internalNode), CTypeSpec (CTypeDef (internalIdent ("ArrIn" ++ show prj)) internalNode)] [(Just (CDeclr (Just arrIn) [] Nothing [] internalNode), Nothing, Nothing)] internalNode, CDecl [CTypeQual (CConstQual internalNode), CTypeSpec (CTypeDef (internalIdent "Ix") internalNode)] [(Just (CDeclr (Just (internalIdent "idx")) [] Nothing [] internalNode), Nothing, Nothing)] internalNode], False)) [] internalNode] Nothing [] internalNode)-      []-      (CCompound [] [CBlockDecl (CDecl [CTypeSpec (CTypeDef (internalIdent ("TyIn" ++ show prj)) internalNode)] [(Just (CDeclr (Just (internalIdent "x")) [] Nothing [] internalNode),Just initList,Nothing)] internalNode),CBlockStmt (CReturn (Just (CVar (internalIdent "x") internalNode)) internalNode)] internalNode)-      internalNode)-  where-    arrIn         = internalIdent ("d_in" ++ show prj)-    initList-      | n <= 1    = CInitExpr (CIndex (CVar arrIn internalNode) (CVar (internalIdent "idx") internalNode) internalNode) internalNode-      | otherwise = flip CInitList internalNode . reverse . take n . flip map (enumFrom 0 :: [Int]) $ \v ->-                      ([], CInitExpr (CIndex (CMember (CVar arrIn internalNode) (internalIdent ('a':show v)) False internalNode) (CVar (internalIdent "idx") internalNode) internalNode) internalNode)---mkSet :: Int -> CExtDecl-mkSet n =-  CFDefExt-    (CFunDef-      [CStorageSpec (CStatic internalNode),CTypeQual (CInlineQual internalNode),CTypeQual (CAttrQual (CAttr (internalIdent "device") [] internalNode)),CTypeSpec (CVoidType internalNode)]-      (CDeclr (Just (internalIdent "set")) [CFunDeclr (Right ([CDecl [CTypeSpec (CTypeDef (internalIdent "ArrOut") internalNode)] [(Just (CDeclr (Just (internalIdent "d_out")) [] Nothing [] internalNode),Nothing,Nothing)] internalNode,CDecl [CTypeQual (CConstQual internalNode),CTypeSpec (CTypeDef (internalIdent "Ix") internalNode)] [(Just (CDeclr (Just (internalIdent "idx")) [] Nothing [] internalNode),Nothing,Nothing)] internalNode,CDecl [CTypeQual (CConstQual internalNode),CTypeSpec (CTypeDef (internalIdent "TyOut") internalNode)] [(Just (CDeclr (Just (internalIdent "val")) [] Nothing [] internalNode),Nothing,Nothing)] internalNode],False)) [] internalNode] Nothing [] internalNode)-      []-      (CCompound [] assignList internalNode)-      internalNode)-  where-  assignList-    | n <= 1    = [CBlockStmt (CExpr (Just (CAssign CAssignOp (CIndex (CVar (internalIdent "d_out") internalNode) (CVar (internalIdent "idx") internalNode) internalNode) (CVar (internalIdent "val") internalNode) internalNode)) internalNode)]-    | otherwise = reverse . take n . flip map (enumFrom 0 :: [Int]) $ \v ->-                    CBlockStmt (CExpr (Just (CAssign CAssignOp (CIndex (CMember (CVar (internalIdent "d_out") internalNode) (internalIdent ('a':show v)) False internalNode) (CVar (internalIdent "idx") internalNode) internalNode) (CMember (CVar (internalIdent "val") internalNode) (internalIdent ('a':show v)) False internalNode) internalNode)) internalNode)---mkTuplePartition :: String -> [CType] -> Bool -> CExtDecl-mkTuplePartition tyName ty isVolatile =-  CFDefExt-    (CFunDef-      [CStorageSpec (CStatic internalNode),CTypeQual (CInlineQual internalNode),CTypeQual (CAttrQual (CAttr (internalIdent "device") [] internalNode)),CTypeSpec (CTypeDef (internalIdent tyName) internalNode)]-      (CDeclr (Just (internalIdent "partition")) [CFunDeclr (Right ([CDecl [CTypeQual (CConstQual internalNode),CTypeSpec (CVoidType internalNode)] [(Just (CDeclr (Just (internalIdent "s_data")) [CPtrDeclr [] internalNode] Nothing [] internalNode),Nothing,Nothing)] internalNode,CDecl [CTypeQual (CConstQual internalNode),CTypeSpec (CIntType internalNode)] [(Just (CDeclr (Just (internalIdent "n")) [] Nothing [] internalNode),Nothing,Nothing)] internalNode],False)) [] internalNode] Nothing [] internalNode)-      []-      (CCompound [] (stmts ++ [CBlockDecl (CDecl [CTypeSpec (CTypeDef (internalIdent tyName) internalNode)] [(Just (CDeclr (Just (internalIdent "r")) [] Nothing [] internalNode),Just initp,Nothing)] internalNode) ,CBlockStmt (CReturn (Just (CVar (internalIdent "r") internalNode)) internalNode)]) internalNode)-      internalNode)-  where-    n     = length ty-    var s = CVar (internalIdent s) internalNode-    names = map (('p':) . show) [n-1,n-2..0]-    initp = mkInitList (map var names)-    volat = [CTypeQual (CVolatQual internalNode) | isVolatile]-    stmts = zipWith  (\l r -> CBlockDecl (CDecl (volat ++ map CTypeSpec l) r internalNode)) ty-          . zipWith3 (\p t s -> [(Just (CDeclr (Just (internalIdent p)) [CPtrDeclr [] internalNode] Nothing [] internalNode),Just (CInitExpr (CCast (CDecl (map CTypeSpec t) [(Just (CDeclr Nothing [CPtrDeclr [] internalNode] Nothing [] internalNode),Nothing,Nothing)] internalNode) s internalNode) internalNode),Nothing)]) names ty-          $ var "s_data" : map (\v -> CUnary CAdrOp (CIndex (var v) (CVar (internalIdent "n") internalNode) internalNode) internalNode) names-
− Data/Array/Accelerate/CUDA/CodeGen/Util.hs 
@@ -1,154 +0,0 @@--- |--- Module      : Data.Array.Accelerate.CUDA.CodeGen.Util--- Copyright   : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell--- License     : BSD3------ Maintainer  : Manuel M T Chakravarty <chak@cse.unsw.edu.au>--- Stability   : experimental--- Portability : non-partable (GHC extensions)-----module Data.Array.Accelerate.CUDA.CodeGen.Util-  where--import Language.C-import Data.Array.Accelerate.CUDA.CodeGen.Data--data Direction = Forward | Backward---- Common device functions--- -------------------------mkIdentity :: [CExpr] -> CExtDecl-mkIdentity = mkDeviceFun "identity" (typename "TyOut") []--mkApply :: Int -> [CExpr] -> CExtDecl-mkApply argc-  = mkDeviceFun "apply" (typename "TyOut")-  $ map (\n -> (typename ("TyIn"++ show n), 'x':show n)) [argc-1,argc-2..0]--mkProject :: Direction -> [CExpr] -> CExtDecl-mkProject Forward  = mkDeviceFun "project" (typename "DimOut") [(typename "DimIn0","x0")]-mkProject Backward = mkDeviceFun "project" (typename "DimIn0") [(typename "DimOut","x0")]--mkSliceIndex :: [CExpr] -> CExtDecl-mkSliceIndex =-  mkDeviceFun "sliceIndex" (typename "SliceDim") [(typename "Slice","sl"), (typename "CoSlice","co")]--mkSliceReplicate :: [CExpr] -> CExtDecl-mkSliceReplicate =-  mkDeviceFun "sliceIndex" (typename "Slice") [(typename "SliceDim","dim")]----- Helper functions--- ------------------cvar :: String -> CExpr-cvar x = CVar (internalIdent x) internalNode--ccall :: String -> [CExpr] -> CExpr-ccall fn args = CCall (cvar fn) args internalNode--typename :: String -> CType-typename var = [CTypeDef (internalIdent var) internalNode]--fromBool :: Bool -> CExpr-fromBool True  = CConst $ CIntConst (cInteger 1) internalNode-fromBool False = CConst $ CIntConst (cInteger 0) internalNode--mkDim :: String -> Int -> CExtDecl-mkDim name n =-  mkTypedef name False False [CTypeDef (internalIdent ("DIM" ++ show n)) internalNode]--mkTypedef :: String -> Bool -> Bool -> CType -> CExtDecl-mkTypedef var volatile ptr ty =-  CDeclExt $ CDecl-    (CStorageSpec (CTypedef internalNode) : [CTypeQual (CVolatQual internalNode) | volatile] ++ map CTypeSpec ty)-    [(Just (CDeclr (Just (internalIdent var)) [CPtrDeclr [] internalNode | ptr] Nothing [] internalNode), Nothing, Nothing)]-    internalNode--mkShape :: Int -> String -> CExtDecl-mkShape d n = mkGlobal [constant,dimension] n-  where-    constant  = CTypeQual (CAttrQual (CAttr (internalIdent "constant") [] internalNode))-    dimension = CTypeSpec (CTypeDef (internalIdent ("DIM" ++ show d)) internalNode)--mkGlobal :: [CDeclSpec] -> String -> CExtDecl-mkGlobal spec name =-  CDeclExt (CDecl (CStorageSpec (CStatic internalNode) : spec)-           [(Just (CDeclr (Just (internalIdent name)) [] Nothing [] internalNode),Nothing,Nothing)] internalNode)--mkInitList :: [CExpr] -> CInit-mkInitList []  = CInitExpr (CConst (CIntConst (cInteger 0) internalNode)) internalNode-mkInitList [x] = CInitExpr x internalNode-mkInitList xs  = CInitList (map (\e -> ([],CInitExpr e internalNode)) xs) internalNode----- typedef struct {---   ... (volatile?) ty1 (*?) a1; (volatile?) ty0 (*?) a0;--- } var;------ NOTE: The Accelerate language uses snoc based tuple projection, so the last---       field of the structure is named 'a' instead of the first.----mkStruct :: String -> Bool -> Bool -> [CType] -> CExtDecl-mkStruct name volatile ptr types =-  CDeclExt $ CDecl-    [CStorageSpec (CTypedef internalNode) , CTypeSpec (CSUType (CStruct CStructTag Nothing (Just (zipWith field names types)) [] internalNode) internalNode)]-    [(Just (CDeclr (Just (internalIdent name)) [] Nothing [] internalNode),Nothing,Nothing)]-    internalNode-  where-    names      = reverse . take (length types) $ (enumFrom 0 :: [Int])-    field v ty = CDecl ([CTypeQual (CVolatQual internalNode) | volatile] ++ map CTypeSpec ty)-                       [(Just (CDeclr (Just (internalIdent ('a':show v))) [CPtrDeclr [] internalNode | ptr] Nothing [] internalNode), Nothing, Nothing)]-                       internalNode----- typedef struct __attribute__((aligned(n * sizeof(ty)))) {---     ty [x, y, z, w];--- } var;----mkTyVector :: String -> Int -> CType -> CExtDecl-mkTyVector var n ty =-  CDeclExt $ CDecl-    [CStorageSpec (CTypedef internalNode), CTypeSpec (CSUType (CStruct CStructTag Nothing (Just [CDecl (map CTypeSpec ty) fields internalNode]) [CAttr (internalIdent "aligned") [CBinary CMulOp (CConst (CIntConst (cInteger (toInteger n)) internalNode)) (CSizeofType (CDecl (map CTypeSpec ty) [] internalNode) internalNode) internalNode] internalNode] internalNode) internalNode)]-    [(Just (CDeclr (Just (internalIdent var)) [] Nothing [] internalNode), Nothing, Nothing)]-    internalNode-  where-    fields = take n . flip map "xyzw" $ \f ->-      (Just (CDeclr (Just (internalIdent [f])) [] Nothing [] internalNode), Nothing, Nothing)----- static inline __attribute__((device)) tyout name(args)--- {---   tyout r = { expr };---   return r;--- }----mkDeviceFun :: String -> CType -> [(CType,String)] -> [CExpr] -> CExtDecl-mkDeviceFun name tyout args expr =-  let body = [ CBlockDecl (CDecl (map CTypeSpec tyout) [(Just (CDeclr (Just (internalIdent "r")) [] Nothing [] internalNode), Just (mkInitList expr), Nothing)] internalNode)-             , CBlockStmt (CReturn (Just (CVar (internalIdent "r") internalNode)) internalNode)]-  in-  mkDeviceFun' name tyout args body----- static inline __attribute__((device)) tyout name(args)--- {---   body--- }----mkDeviceFun' :: String -> CType -> [(CType, String)] -> [CBlockItem] -> CExtDecl-mkDeviceFun' name tyout args body =-  CFDefExt $ CFunDef-    ([CStorageSpec (CStatic internalNode), CTypeQual (CInlineQual internalNode), CTypeQual (CAttrQual (CAttr (builtinIdent "device") [] internalNode))] ++ map CTypeSpec tyout)-    (CDeclr (Just (internalIdent name)) [CFunDeclr (Right (argv,False)) [] internalNode] Nothing [] internalNode)-    []-    (CCompound [] body internalNode)-    internalNode-    where-      argv = flip map args $ \(ty,var) ->-        CDecl (CTypeQual (CConstQual internalNode) : map CTypeSpec ty)-              [(Just (CDeclr (Just (internalIdent var)) [] Nothing [] internalNode), Nothing, Nothing)]-              internalNode-
− Data/Array/Accelerate/CUDA/Compile.hs 
@@ -1,729 +0,0 @@-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE BangPatterns, CPP, GADTs, TupleSections, TypeSynonymInstances #-}--- |--- Module      : Data.Array.Accelerate.CUDA.Compile--- Copyright   : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell--- License     : BSD3------ Maintainer  : Manuel M T Chakravarty <chak@cse.unsw.edu.au>--- Stability   : experimental--- Portability : non-partable (GHC extensions)-----module Data.Array.Accelerate.CUDA.Compile (--  -- * Types parameterising our annotated computation form-  ExecAcc, ExecOpenAcc(..),-  AccKernel, AccRefcount(..),--  -- * generate and compile kernels to realise a computation-  compileAcc, compileAfun1--) where--#include "accelerate.h"---- friends-import Data.Array.Accelerate.Type-import Data.Array.Accelerate.Tuple-import Data.Array.Accelerate.AST                        hiding (Val(..))-import Data.Array.Accelerate.Array.Sugar                (Array(..), Segments, Shape, Elt)-import Data.Array.Accelerate.Array.Representation       hiding (Shape)-import Data.Array.Accelerate.Pretty.Print--import Data.Array.Accelerate.CUDA.State-import Data.Array.Accelerate.CUDA.CodeGen-import Data.Array.Accelerate.CUDA.Array.Data-import Data.Array.Accelerate.CUDA.Analysis.Hash---- libraries-import Prelude                                          hiding (exp)-import Control.Applicative                              hiding (Const)-import Control.Monad.Trans-import Control.Monad-import Control.Concurrent.MVar-import Data.Maybe-import Data.Label.PureM-import Language.C-import System.FilePath-import System.Directory-import System.IO-import System.Exit                                      (ExitCode(..))-import System.Posix.Types                               (ProcessID)-import System.Posix.Process-import Text.PrettyPrint-import Foreign.Storable-import qualified Data.HashTable                         as Hash-import qualified Foreign.CUDA.Driver                    as CUDA--import Paths_accelerate                                 (getDataDir)----- A binary object that will be used to execute a kernel----type AccKernel a = (String, CIO CUDA.Module)--noKernel :: AccKernel a-noKernel = INTERNAL_ERROR(error) "ExecAcc" "no kernel module for this node"---- The number of times an array computation will be used. This is an overzealous--- estimate, due to the presence of array branching. Only the scanl' and scanr'--- primitives use two reference counts.----data AccRefcount = R1 !Int-                 | R2 !Int !Int--instance Show AccRefcount where-  show (R1 x)   = show x-  show (R2 x y) = show (x,y)--noRefcount :: AccRefcount-noRefcount = INTERNAL_ERROR(error) "ExecAcc" "no reference count for this node"--singleRef :: AccRefcount-singleRef = R1 1----- A pseudo array environment that holds the number of times each indexed--- variable has been accessed.----data Ref c where-  Empty :: Ref ()-  Push  :: Ref c-        -> Either (IndirectRef c) AccRefcount-        -> Ref (c, AccRefcount)--data IndirectRef c = forall env t.-                     IRef (Idx env t) (AccRefcount -> AccRefcount)---incIdx :: Idx env t -> Ref count -> Ref count-incIdx = modIdx incR1-  where-    incR1 (R1 x) = R1 (x+1)-    incR1 _      = INTERNAL_ERROR(error) "incR1" "inconsistent valuation"--modIdx :: (AccRefcount -> AccRefcount) -> Idx env t -> Ref count -> Ref count-modIdx f (SuccIdx ix) (Push next c) = modIdx f ix next `Push` c-modIdx f ZeroIdx      (Push rest c) =-  case c of-    Left (IRef ix' f') -> modIdx f' ix' rest `Push` c-    Right n            -> rest               `Push` Right (f n)-modIdx _ _            _             = INTERNAL_ERROR(error) "modIdx" "inconsistent valuation"----- Interleave execution state annotations into an open array computation AST----data ExecOpenAcc aenv a where-  ExecAfun :: AccRefcount                       -- reference count attached to an enclosed lambda-           -> PreOpenAfun ExecOpenAcc () t-           -> ExecOpenAcc aenv t--  ExecAcc  :: AccRefcount                       -- number of times the result is used (zealous)-           -> AccKernel a                       -- an executable binary object-           -> [AccBinding aenv]                 -- auxiliary arrays from the environment the kernel needs access to-           -> PreOpenAcc ExecOpenAcc aenv a     -- the actual computation-           -> ExecOpenAcc aenv a---- An annotated AST suitable for execution in the CUDA environment----type ExecAcc a = ExecOpenAcc () a--instance Show (ExecOpenAcc aenv a) where-  show = render . prettyExecAcc 0 noParens----- |Initiate code generation, compilation, and data transfer for an array--- expression. If we are in `streaming' mode, then the arrays are marked so that--- they will be retained between iterations.------ The returned array computation is annotated so to be suitable for execution--- in the CUDA environment. This includes:------   1. The kernel module that can be used to execute the computation, and the---      list of array variables that were embedded within scalar expressions---      (TLM: todo)------   2. Array reference counts (TLM: not accurate in the presence of branches)------   3. Wrap the segment descriptor of FoldSeg and similar in 'Scanl (+) 0', to---      transform the segment lengths into global offset indices.----compileAcc :: Acc a -> CIO (ExecAcc a)-compileAcc acc = fst `fmap` prepareAcc False acc Empty---compileAfun1 :: Afun (a -> b) -> CIO (ExecAcc (a -> b))-compileAfun1 (Alam (Abody b)) = do-  (b', Empty `Push` Right c) <- prepareAcc True b (Empty `Push` Right (R1 0))-  return $ ExecAfun c (Alam (Abody b'))--compileAfun1 _ =-  error "Hope (noun): something that happens to facts when the world refuses to agree"---prepareAcc :: Bool -> OpenAcc aenv a -> Ref count -> CIO (ExecOpenAcc aenv a, Ref count)-prepareAcc iss rootAcc rootEnv = do-  puts memoryTable =<< liftIO newAccMemoryTable-  travA rootAcc rootEnv-  where-    -- Traverse an open array expression in depth-first order-    ---    travA :: OpenAcc aenv a -> Ref count -> CIO (ExecOpenAcc aenv a, Ref count)-    travA acc@(OpenAcc pacc) aenv =-      case pacc of--        -- Environment manipulations-        ---        Avar ix -> return (node (Avar ix), incIdx ix aenv)--        -- Let bindings to computations that yield two arrays-        ---        Alet2 a b | Avar ia <- unAcc a-                  , Avar ib <- unAcc b ->-          let a'   = node (Avar ia)-              b'   = node (Avar ib)-              env' = modIdx (eitherIx ib incSucc incZero) ia aenv-          in-          return (node (Alet2 a' b'), env')--        Alet2 a b | Avar ix <- unAcc a ->-          let a' = node (Avar ix)-          in do-          (b', env1 `Push` _ `Push` _) <- travA b (aenv `Push` Left (IRef ix incSucc)-                                                        `Push` Left (IRef ix incZero))-          return (node (Alet2 a' b'), env1)--        Alet2 a b -> do-          (a', env1)                      <- travA a aenv-          (b', env2 `Push` Right (R1 c1)-                    `Push` Right (R1 c0)) <- travA b (env1 `Push` Right (R1 0) `Push` Right (R1 0))-          return (node (Alet2 (setref (R2 c1 c0) a') b'), env2)--        -- Let bindings to a single computation-        ---        Alet a b | Alet2 x y <- unAcc a-                 , Avar u    <- unAcc x-                 , Avar v    <- unAcc y ->-          let a' = node (Alet2 (node (Avar u)) (node (Avar v)))-              rc = Left (IRef u (eitherIx v incSucc incZero))-          in do-          (b', env1 `Push` _) <- travA b (aenv `Push` rc)-          return (node (Alet a' b'), env1)--        Alet a b | Alet2 _ y <- unAcc a-                 , Avar v    <- unAcc y -> do-          (ExecAcc _ _ _ (Alet2 x' y'), env1) <- travA a aenv-          (b', env2 `Push` Right (R1 c))      <- travA b (env1 `Push` Right (R1 0))-          ---          let a' = node (Alet2 (setref (eitherIx v (R2 c 0) (R2 0 c)) x') y')-          return  (node (Alet a' b'), env2)--        Alet a b | Alet _ _ <- unAcc a -> do-          (ExecAcc _ _ _ (Alet x' y'), env1) <- travA a aenv-          (b', env2 `Push` Right c)          <- travA b (env1 `Push` Right (R1 0))-          return (node (Alet (node (Alet x' (setref c y'))) b'), env2)--        Alet a b  -> do-          (a', env1)                <- travA a aenv-          (b', env2 `Push` Right c) <- travA b (env1 `Push` Right rc)-          return (node (Alet (setref c a') b'), env2)-          where-            rc | isAcc2 a  = R2 0 0-               | otherwise = R1 0---        Apply (Alam (Abody b)) a -> do-          (a', env1)                <- travA a aenv-          (b', env2 `Push` Right c) <- travA b (env1 `Push` Right (R1 0))-          return (node (Apply (Alam (Abody b')) (setref c a')), env2)-        Apply _                _ -> error "I made you a cookie, but I eated it"--        PairArrays arr1 arr2 -> do-          (arr1', env1) <- travA arr1 aenv-          (arr2', env2) <- travA arr2 env1-          return (node (PairArrays arr1' arr2'), env2)--        Acond c t e -> do-          (c', env1, _) <- travE c aenv []-          (t', env2)    <- travA t env1      -- TLM: separate use counts for each branch?-          (e', env3)    <- travA e env2-          return (ExecAcc noRefcount noKernel [] (Acond c' t' e'), env3)--        -- Array injection-        ---        -- If this array is let-bound, we will only see this case once, and need-        -- to update the reference count when retrieved during execution-        ---        Use arr@(Array sh ad) ->-          let n = size sh-              c = if iss then Nothing else Just 1-          in do mallocArray    ad c (max 1 n)-                pokeArrayAsync ad n Nothing-                return (ExecAcc singleRef noKernel [] (Use arr), aenv)--        -- Computation nodes-        ---        Reshape sh a -> do-          (sh', env1, _) <- travE sh aenv []-          (a',  env2)    <- travA a  env1-          return (ExecAcc singleRef noKernel [] (Reshape sh' a'), env2)--        Unit e  -> do-          (e', env1, _) <- travE e aenv []-          return (ExecAcc singleRef noKernel [] (Unit e'), env1)--        Generate e f -> do-          (e', env1, _)    <- travE e aenv []-          (f', env2, var1) <- travF f env1 []-          kernel           <- build "generate" acc var1-          return (ExecAcc singleRef kernel var1 (Generate e' f'), env2)--        Replicate slix e a -> do-          (e', env1, _) <- travE e aenv []-          (a', env2)    <- travA a env1-          kernel        <- build "replicate" acc []-          return (ExecAcc singleRef kernel [] (Replicate slix e' a'), env2)--        Index slix a e -> do-          (a', env1)    <- travA a aenv-          (e', env2, _) <- travE e env1 []-          kernel        <- build "slice" acc []-          return (ExecAcc singleRef kernel [] (Index slix a' e'), env2)--        Map f a -> do-          (f', env1, var1) <- travF f aenv []-          (a', env2)       <- travA a env1-          kernel           <- build "map" acc var1-          return (ExecAcc singleRef kernel var1 (Map f' a'), env2)--        ZipWith f a b -> do-          (f', env1, var1) <- travF f aenv []-          (a', env2)       <- travA a env1-          (b', env3)       <- travA b env2-          kernel           <- build "zipWith" acc var1-          return (ExecAcc singleRef kernel var1 (ZipWith f' a' b'), env3)--        Fold f e a -> do-          (f', env1, var1) <- travF f aenv []-          (e', env2, var2) <- travE e env1 var1-          (a', env3)       <- travA a env2-          kernel           <- build "fold" acc var2-          return (ExecAcc singleRef kernel var2 (Fold f' e' a'), env3)--        Fold1 f a -> do-          (f', env1, var1) <- travF f aenv []-          (a', env2)       <- travA a env1-          kernel           <- build "fold" acc var1-          return (ExecAcc singleRef kernel var1 (Fold1 f' a'), env2)--        FoldSeg f e a s -> do-          (f', env1, var1) <- travF f aenv []-          (e', env2, var2) <- travE e env1 var1-          (a', env3)       <- travA a env2-          (s', env4)       <- travA (scan s) env3-          kernel           <- build "foldSeg" acc var2-          return (ExecAcc singleRef kernel var2 (FoldSeg f' e' a' s'), env4)--        Fold1Seg f a s -> do-          (f', env1, var1) <- travF f aenv []-          (a', env2)       <- travA a env1-          (s', env3)       <- travA (scan s) env2-          kernel           <- build "foldSeg" acc var1-          return (ExecAcc singleRef kernel var1 (Fold1Seg f' a' s'), env3)--        Scanl f e a -> do-          (f', env1, var1) <- travF f aenv []-          (e', env2, var2) <- travE e env1 var1-          (a', env3)       <- travA a env2-          kernel           <- build "inclusive_scan" acc var2-          return (ExecAcc singleRef kernel var2 (Scanl f' e' a'), env3)--        Scanl' f e a -> do-          (f', env1, var1) <- travF f aenv []-          (e', env2, var2) <- travE e env1 var1-          (a', env3)       <- travA a env2-          kernel           <- build "inclusive_scan" acc var2-          return (ExecAcc (R2 0 0) kernel var2 (Scanl' f' e' a'), env3)--        Scanl1 f a -> do-          (f', env1, var1) <- travF f aenv []-          (a', env2)       <- travA a env1-          kernel           <- build "inclusive_scan" acc var1-          return (ExecAcc singleRef kernel var1 (Scanl1 f' a'), env2)--        Scanr f e a -> do-          (f', env1, var1) <- travF f aenv []-          (e', env2, var2) <- travE e env1 var1-          (a', env3)       <- travA a env2-          kernel           <- build "inclusive_scan" acc var2-          return (ExecAcc singleRef kernel var2 (Scanr f' e' a'), env3)--        Scanr' f e a -> do-          (f', env1, var1) <- travF f aenv []-          (e', env2, var2) <- travE e env1 var1-          (a', env3)       <- travA a env2-          kernel           <- build "inclusive_scan" acc var2-          return (ExecAcc (R2 0 0) kernel var2 (Scanr' f' e' a'), env3)--        Scanr1 f a -> do-          (f', env1, var1) <- travF f aenv []-          (a', env2)       <- travA a env1-          kernel           <- build "inclusive_scan" acc var1-          return (ExecAcc singleRef kernel var1 (Scanr1 f' a'), env2)--        Permute f a g b -> do-          (f', env1, var1) <- travF f aenv []-          (g', env2, var2) <- travF g env1 var1-          (a', env3)       <- travA a env2-          (b', env4)       <- travA b env3-          kernel           <- build "permute" acc var2-          return (ExecAcc singleRef kernel var2 (Permute f' a' g' b'), env4)--        Backpermute e f a -> do-          (e', env1, _)    <- travE e aenv []-          (f', env2, var2) <- travF f env1 []-          (a', env3)       <- travA a env2-          kernel           <- build "backpermute" acc var2-          return (ExecAcc singleRef kernel var2 (Backpermute e' f' a'), env3)--        Stencil f b a -> do-          (f', env1, var1) <- travF f aenv []-          (a', env2)       <- travA a env1-          kernel           <- build "stencil" acc var1-          return (ExecAcc singleRef kernel var1 (Stencil f' b a'), env2)--        Stencil2 f b1 a1 b2 a2 -> do-          (f', env1, var1) <- travF f aenv []-          (a1', env2)      <- travA a1 env1-          (a2', env3)      <- travA a2 env2-          kernel           <- build "stencil2" acc var1-          return (ExecAcc singleRef kernel var1 (Stencil2 f' b1 a1' b2 a2'), env3)---    -- Traverse a scalar expression-    ---    travE :: OpenExp env aenv e-          -> Ref count-          -> [AccBinding aenv]-          -> CIO (PreOpenExp ExecOpenAcc env aenv e, Ref count, [AccBinding aenv])-    travE exp aenv vars =-      case exp of-        Let _ _         -> INTERNAL_ERROR(error) "prepareAcc" "Let: not implemented yet"-        Var ix          -> return (Var ix, aenv, vars)-        Const c         -> return (Const c, aenv, vars)-        PrimConst c     -> return (PrimConst c, aenv, vars)-        IndexAny        -> INTERNAL_ERROR(error) "prepareAcc" "IndexAny: not implemented yet"-        IndexNil        -> return (IndexNil, aenv, vars)-        IndexCons ix i  -> do-          (ix', env1, var1) <- travE ix aenv vars-          (i',  env2, var2) <- travE i  env1 var1-          return (IndexCons ix' i', env2, var2)--        IndexHead ix    -> do-          (ix', env1, var1) <- travE ix aenv vars-          return (IndexHead ix', env1, var1)--        IndexTail ix    -> do-          (ix', env1, var1) <- travE ix aenv vars-          return (IndexTail ix', env1, var1)--        Tuple t         -> do-          (t', env1, var1) <- travT t aenv vars-          return (Tuple t', env1, var1)--        Prj idx e       -> do-          (e', env1, var1) <- travE e aenv vars-          return (Prj idx e', env1, var1)--        Cond p t e      -> do-          (p', env1, var1) <- travE p aenv vars-          (t', env2, var2) <- travE t env1 var1 -- TLM: reference count contingent on which-          (e', env3, var3) <- travE e env2 var2 --      branch is taken?-          return (Cond p' t' e', env3, var3)--        PrimApp f e     -> do-          (e', env1, var1) <- travE e aenv vars-          return (PrimApp f e', env1, var1)--        IndexScalar a e -> do-          (a', env1)       <- travA a aenv-          (e', env2, var2) <- travE e env1 vars-          return (IndexScalar a' e', env2, bind a' `cons` var2)--        Shape a         -> do-          (a', env1) <- travA a aenv-          return (Shape a', env1, bind a' `cons` vars)--        Size a          -> do-          (a', env1) <- travA a aenv-          return (Size a', env1, bind a' `cons` vars)---    travT :: Tuple (OpenExp env aenv) t-          -> Ref count-          -> [AccBinding aenv]-          -> CIO (Tuple (PreOpenExp ExecOpenAcc env aenv) t, Ref count, [AccBinding aenv])-    travT NilTup        aenv vars = return (NilTup, aenv, vars)-    travT (SnocTup t e) aenv vars = do-      (e', env1, var1) <- travE e aenv vars-      (t', env2, var2) <- travT t env1 var1-      return (SnocTup t' e', env2, var2)--    travF :: OpenFun env aenv t-          -> Ref count-          -> [AccBinding aenv]-          -> CIO (PreOpenFun ExecOpenAcc env aenv t, Ref count, [AccBinding aenv])-    travF (Body b) aenv vars = do-      (b', env1, var1) <- travE b aenv vars-      return (Body b', env1, var1)-    travF (Lam  f) aenv vars = do-      (f', env1, var1) <- travF f aenv vars-      return (Lam f', env1, var1)---    -- Auxiliary-    ---    scan :: OpenAcc aenv Segments -> OpenAcc aenv Segments-    scan = OpenAcc . Scanl plus (Const ((),0))--    plus :: PreOpenFun OpenAcc () aenv (Int -> Int -> Int)-    plus = Lam (Lam (Body (PrimAdd numType-                          `PrimApp`-                          Tuple (NilTup `SnocTup` Var (SuccIdx ZeroIdx)-                                        `SnocTup` Var ZeroIdx))))--    unAcc :: OpenAcc aenv a -> PreOpenAcc OpenAcc aenv a-    unAcc (OpenAcc pacc) = pacc--    node :: PreOpenAcc ExecOpenAcc aenv a -> ExecOpenAcc aenv a-    node = ExecAcc noRefcount noKernel []--    isAcc2 :: OpenAcc aenv a -> Bool-    isAcc2 (OpenAcc pacc) = case pacc of-        Scanl' _ _ _ -> True-        Scanr' _ _ _ -> True-        _            -> False--    incSucc :: AccRefcount -> AccRefcount-    incSucc (R2 x y) = R2 (x+1) y-    incSucc _        = INTERNAL_ERROR(error) "incSucc" "inconsistent valuation"--    incZero :: AccRefcount -> AccRefcount-    incZero (R2 x y) = R2 x (y+1)-    incZero _        = INTERNAL_ERROR(error) "incZero" "inconsistent valuation"--    eitherIx :: Idx env t -> f -> f -> f-    eitherIx ZeroIdx           _ z = z-    eitherIx (SuccIdx ZeroIdx) s _ = s-    eitherIx _                 _ _ =-      INTERNAL_ERROR(error) "eitherIx" "inconsistent valuation"--    setref :: AccRefcount -> ExecOpenAcc aenv a -> ExecOpenAcc aenv a-    setref count (ExecAfun _ fun)     = ExecAfun count fun-    setref count (ExecAcc  _ k b acc) = ExecAcc  count k b acc--    cons :: AccBinding aenv -> [AccBinding aenv] -> [AccBinding aenv]-    cons x xs | x `notElem` xs = x : xs-              | otherwise      = xs--    bind :: (Shape sh, Elt e) => ExecOpenAcc aenv (Array sh e) -> AccBinding aenv-    bind (ExecAcc _ _ _ (Avar ix)) = ArrayVar ix-    bind _                         =-     INTERNAL_ERROR(error) "bind" "expected array variable"----- Compilation--- --------------- Initiate compilation and provide a closure to later link the compiled module--- when it is required.------ TLM: should get name(s) from code generation----build :: String -> OpenAcc aenv a -> [AccBinding aenv] -> CIO (AccKernel a)-build name acc fvar =-  let key = accToKey acc-  in do-    mvar   <- liftIO newEmptyMVar-    table  <- gets kernelTable-    cached <- isJust `fmap` liftIO (Hash.lookup table key)-    unless cached $ compile table key acc fvar-    return . (name,) . liftIO $ memo mvar (link table key)---- A simple memoisation routine--- TLM: maybe we can be a bit clever than this...----memo :: MVar a -> IO a -> IO a-memo mvar fun = do-  full <- not `fmap` isEmptyMVar mvar-  if full-     then readMVar mvar-     else do a <- fun-             putMVar mvar a-             return a----- Link a compiled binary and update the associated kernel entry in the hash--- table. This may entail waiting for the external compilation process to--- complete. If successfully, the temporary files are removed.----link :: KernelTable -> AccKey -> IO CUDA.Module-link table key =-  let intErr = INTERNAL_ERROR(error) "link" "missing kernel entry"-  in do-    (KernelEntry cufile stat) <- fromMaybe intErr `fmap` Hash.lookup table key-    case stat of-      Right mdl -> return mdl-      Left  pid -> do-        -- wait for compiler to finish and load binary object-        ---        waitFor pid-        mdl <- CUDA.loadFile (replaceExtension cufile ".cubin")--#ifndef ACCELERATE_CUDA_PERSISTENT_CACHE-        -- remove build products-        ---        removeFile      cufile-        removeFile      (replaceExtension cufile ".cubin")-        removeDirectory (dropFileName cufile)-          `catch` \_ -> return ()       -- directory not empty-#endif--        -- update hash table-        ---        Hash.insert table key (KernelEntry cufile (Right mdl))-        return mdl----- Generate and compile code for a single open array expression----compile :: KernelTable -> AccKey -> OpenAcc aenv a -> [AccBinding aenv] -> CIO ()-compile table key acc fvar = do-  dir     <- outputDir-  nvcc    <- fromMaybe (error "nvcc: command not found") <$> liftIO (findExecutable "nvcc")-  cufile  <- outputName acc (dir </> "dragon.cu")        -- rawr!-  flags   <- compileFlags cufile-  pid     <- liftIO $ do-               writeCode cufile (codeGenAcc acc fvar)-               forkProcess $ executeFile nvcc False flags Nothing-  ---  liftIO $ Hash.insert table key (KernelEntry cufile (Left pid))----- Wait for the compilation process to finish----waitFor :: ProcessID -> IO ()-waitFor pid = do-  status <- getProcessStatus True True pid-  case status of-    Just (Exited ExitSuccess) -> return ()-    _                         -> error  $ "nvcc (" ++ show pid ++ ") terminated abnormally"----- Determine the appropriate command line flags to pass to the compiler process.--- This is dependent on the host architecture and device capabilities.----compileFlags :: FilePath -> CIO [String]-compileFlags cufile =-  let machine = case sizeOf (undefined :: Int) of-                  4 -> "-m32"-                  8 -> "-m64"-                  _ -> error "huh? non 32-bit or 64-bit architecture"-  in do-  arch <- CUDA.computeCapability <$> gets deviceProps-  ddir <- liftIO getDataDir-  return [ "-I", ddir </> "cubits"-         , "-O2", "--compiler-options", "-fno-strict-aliasing"-         , "-arch=sm_" ++ show (round (arch * 10) :: Int)-         , "-DUNIX"-         , "-cubin"-         , "-o", cufile `replaceExtension` "cubin"-         , machine-         , cufile ]----- Return a unique output filename for the generated CUDA code----outputName :: OpenAcc aenv a -> FilePath -> CIO FilePath-outputName acc cufile = do-  n <- freshVar-  x <- liftIO $ doesFileExist (filename n)-  if x then outputName acc cufile-       else return (filename n)-  where-    (base,suffix) = splitExtension cufile-    filename n    = base ++ pad (show n) <.> suffix-    pad s         = replicate (4-length s) '0' ++ s-    freshVar      = gets unique <* modify unique (+1)----- Return the output directory for compilation by-products, creating if it does--- not exist.----outputDir :: CIO FilePath-outputDir = liftIO $ do-#ifdef ACCELERATE_CUDA_PERSISTENT_CACHE-  tmp <- getDataDir-  let dir = tmp </> "cache"-#else-  tmp <- getTemporaryDirectory-  pid <- getProcessID-  let dir = tmp </> "accelerate-cuda-" ++ show pid-#endif-  createDirectoryIfMissing True dir-  canonicalizePath dir----- Pretty printing--- ------------------- Write the generated code to file----writeCode :: FilePath -> CUTranslSkel -> IO ()-writeCode f code =-  withFile f WriteMode $ \hdl ->-  printDoc PageMode hdl (pretty code)----- stolen from $fptools/ghc/compiler/utils/Pretty.lhs------ This code has a BSD-style license----printDoc :: Mode -> Handle -> Doc -> IO ()-printDoc m hdl doc = do-  fullRender m cols 1.5 put done doc-  hFlush hdl-  where-    put (Chr c)  next = hPutChar hdl c >> next-    put (Str s)  next = hPutStr  hdl s >> next-    put (PStr s) next = hPutStr  hdl s >> next--    done = hPutChar hdl '\n'-    cols = 100----- Display the annotated AST----prettyExecAcc :: PrettyAcc ExecOpenAcc-prettyExecAcc alvl wrap ecc =-  case ecc of-    ExecAfun rc pfun      -> braces (usecount rc)-                              <+> prettyPreAfun prettyExecAcc alvl pfun-    ExecAcc  rc _ fv pacc ->-      let base = prettyPreAcc prettyExecAcc alvl wrap pacc-          ann  = braces (usecount rc <> comma <+> freevars fv)-      in case pacc of-           Avar _         -> base-           Alet  _ _      -> base-           Alet2 _ _      -> base-           Apply _ _      -> base-           PairArrays _ _ -> base-           Acond _ _ _    -> base-           _              -> ann <+> base-  where-    usecount (R1 x)   = text "rc=" <> int x-    usecount (R2 x y) = text "rc=" <> text (show (x,y))-    freevars = (text "fv=" <>) . brackets . hcat . punctuate comma-                               . map (\(ArrayVar ix) -> char 'a' <> int (deBruijnToInt ix))-
− Data/Array/Accelerate/CUDA/Execute.hs 
@@ -1,836 +0,0 @@-{-# LANGUAGE BangPatterns, CPP, GADTs, ScopedTypeVariables #-}-{-# LANGUAGE RankNTypes, TupleSections, TypeOperators, TypeSynonymInstances #-}--- |--- Module      : Data.Array.Accelerate.CUDA.Execute--- Copyright   : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell--- License     : BSD3------ Maintainer  : Manuel M T Chakravarty <chak@cse.unsw.edu.au>--- Stability   : experimental--- Portability : non-partable (GHC extensions)-----module Data.Array.Accelerate.CUDA.Execute (--  -- * Execute a computation under a CUDA environment-  executeAcc, executeAfun1--) where----- friends-import Data.Array.Accelerate.AST-import Data.Array.Accelerate.Type-import Data.Array.Accelerate.Tuple-import Data.Array.Accelerate.Array.Representation               hiding (Shape, sliceIndex)-import Data.Array.Accelerate.Array.Sugar                        hiding-  (dim, size, index, newArray, shapeToList, sliceIndex)-import qualified Data.Array.Accelerate.Interpreter              as I-import qualified Data.Array.Accelerate.Array.Data               as AD-import qualified Data.Array.Accelerate.Array.Sugar              as Sugar-import qualified Data.Array.Accelerate.Array.Representation     as R--import Data.Array.Accelerate.CUDA.State-import Data.Array.Accelerate.CUDA.Compile-import Data.Array.Accelerate.CUDA.CodeGen-import Data.Array.Accelerate.CUDA.Array.Data-import Data.Array.Accelerate.CUDA.Analysis.Launch---- libraries-import Prelude                                                  hiding (sum)-import Control.Applicative                                      hiding (Const)-import Control.Monad-import Control.Monad.Trans-import System.IO.Unsafe--import Foreign.Ptr (Ptr)-import qualified Foreign.CUDA.Driver                            as CUDA--#include "accelerate.h"----- Array expression evaluation--- ------------------------------- Computations are evaluated by traversing the AST bottom-up, and for each node--- distinguishing between three cases:------ 1. If it is a Use node, return a reference to the device memory holding the---    array data------ 2. If it is a non-skeleton node, such as a let-binding or shape conversion,---    this is executed directly by updating the environment or similar------ 3. If it is a skeleton node, the associated binary object is retrieved,---    memory allocated for the result, and the kernel(s) that implement the---    skeleton are invoked------- Evaluate a closed array expression----executeAcc :: Arrays a => ExecAcc a -> CIO a-executeAcc acc = executeOpenAcc acc Empty---- Evaluate an expression with free array variables----executeAfun1 :: (Arrays a, Arrays b) => ExecAcc (a -> b) -> a -> CIO b-executeAfun1 (ExecAfun (R1 c) (Alam (Abody f))) arrs =-  applyArraysR uploadArray arrays arrs *>-  executeOpenAcc f (Empty `Push` arrs) <*-  applyArraysR deleteArray arrays arrs-  where-    uploadArray :: (Shape sh, Elt e) => Array sh e -> CIO ()-    uploadArray (Array sh ad) =-      let n = size sh-      in do mallocArray    ad (Just c) (max 1 n)-            pokeArrayAsync ad n Nothing--executeAfun1 _ _ = error "the sword comes out after you swallow it, right?"----- Evaluate an open array expression----executeOpenAcc :: ExecOpenAcc aenv a -> Val aenv -> CIO a-executeOpenAcc (ExecAcc count kernel bindings acc) aenv =-  let R1 c     = count-      R2 c1 c0 = count-  in case acc of-    ---    -- (1) Array introduction-    ---    Use arr@(Array _ ad) -> do-      when (c > 1) $ touchArray ad (c-1)-      return arr--    ---    -- (2) Environment manipulation-    ---    Avar ix  -> return (prj ix aenv)--    Alet  a b -> do-      a0 <- executeOpenAcc a aenv-      executeOpenAcc b (aenv `Push` a0) <* applyArraysR deleteArray arrays a0--    Alet2 a b -> do-      (a1, a0) <- executeOpenAcc a aenv-      executeOpenAcc b (aenv `Push` a1 `Push` a0) -- <* applyArraysR deleteArray arrays a0-                                                  -- <* applyArraysR deleteArray arrays a1--    PairArrays a b ->-      (,) <$> executeOpenAcc a aenv-          <*> executeOpenAcc b aenv--    Apply (Alam (Abody f)) a -> do-      a0 <- executeOpenAcc a aenv-      executeOpenAcc f (Empty `Push` a0) <* applyArraysR deleteArray arrays a0-    Apply _ _   -> error "Awww... the sky is crying"--    Acond p t e -> do-      cond <- executeExp p aenv-      if cond then executeOpenAcc t aenv-              else executeOpenAcc e aenv--    Reshape e a -> do-      ix <- executeExp e aenv-      a0 <- executeOpenAcc a aenv-      reshapeOp c ix a0--    Unit e ->-      unitOp c =<< executeExp e aenv--    ---    -- (3) Array computations-    ---    Generate e _        ->-      generateOp c kernel bindings acc aenv =<< executeExp e aenv--    Replicate sliceIndex e a -> do-      slix <- executeExp e aenv-      a0   <- executeOpenAcc a aenv-      replicateOp c kernel bindings acc aenv sliceIndex slix a0--    Index sliceIndex a e -> do-      slix <- executeExp e aenv-      a0   <- executeOpenAcc a aenv-      indexOp c kernel bindings acc aenv sliceIndex a0 slix--    Map _ a             -> do-      a0 <- executeOpenAcc a aenv-      mapOp c kernel bindings acc aenv a0--    ZipWith _ a b       -> do-      a1 <- executeOpenAcc a aenv-      a0 <- executeOpenAcc b aenv-      zipWithOp c kernel bindings acc aenv a1 a0--    Fold _ _ a          -> do-      a0 <- executeOpenAcc a aenv-      foldOp c kernel bindings acc aenv a0--    Fold1 _ a           -> do-      a0 <- executeOpenAcc a aenv-      foldOp c kernel bindings acc aenv a0--    FoldSeg _ _ a s     -> do-      a0 <- executeOpenAcc a aenv-      s0 <- executeOpenAcc s aenv-      foldSegOp c kernel bindings acc aenv a0 s0--    Fold1Seg _ a s      -> do-      a0 <- executeOpenAcc a aenv-      s0 <- executeOpenAcc s aenv-      foldSegOp c kernel bindings acc aenv a0 s0--    Scanl _ _ a         -> do-      a0 <- executeOpenAcc a aenv-      scanOp c kernel bindings acc aenv a0--    Scanl' _ _ a        -> do-      a0 <- executeOpenAcc a aenv-      scan'Op (c1,c0) kernel bindings acc aenv a0--    Scanl1 _ a          -> do-      a0 <- executeOpenAcc a aenv-      scan1Op c kernel bindings acc aenv a0--    Scanr _ _ a         -> do-      a0 <- executeOpenAcc a aenv-      scanOp c kernel bindings acc aenv a0--    Scanr' _ _ a        -> do-      a0 <- executeOpenAcc a aenv-      scan'Op (c1,c0) kernel bindings acc aenv a0--    Scanr1 _ a          -> do-      a0 <- executeOpenAcc a aenv-      scan1Op c kernel bindings acc aenv a0--    Permute _ a _ b     -> do-      a0 <- executeOpenAcc a aenv-      a1 <- executeOpenAcc b aenv-      permuteOp c kernel bindings acc aenv a0 a1--    Backpermute e _ a   -> do-      sh <- executeExp e aenv-      a0 <- executeOpenAcc a aenv-      backpermuteOp c kernel bindings acc aenv sh a0--    Stencil _ _ a       -> do-      a0 <- executeOpenAcc a aenv-      stencilOp c kernel bindings acc aenv a0--    Stencil2 _ _ a _ b  -> do-      a1 <- executeOpenAcc a aenv-      a0 <- executeOpenAcc b aenv-      stencil2Op c kernel bindings acc aenv a1 a0--executeOpenAcc (ExecAfun _ _) _ =-  INTERNAL_ERROR(error) "executeOpenAcc" "impossible evaluation"----- Implementation of primitive array operations--- ----------------------------------------------reshapeOp :: Shape dim-          => Int-          -> dim-          -> Array dim' e-          -> CIO (Array dim e)-reshapeOp rc newShape (Array oldShape adata)-  = BOUNDS_CHECK(check) "reshape" "shape mismatch" (Sugar.size newShape == size oldShape)-  $ do when (rc-1 > 0) $ touchArray adata (rc-1)-       return          $ Array (fromElt newShape) adata---unitOp :: Elt e-       => Int-       -> e-       -> CIO (Scalar e)-unitOp rc v = do-  let (!ad,_) = AD.runArrayData $ do-        arr  <- AD.newArrayData 1024  -- FIXME: small arrays moved by the GC-        AD.writeArrayData arr 0 (fromElt v)-        return (arr, undefined)-  mallocArray ad (Just rc) 1-  pokeArrayAsync ad 1 Nothing-  return $ Array () ad---generateOp :: (Shape dim, Elt e)-           => Int-           -> AccKernel a-           -> [AccBinding aenv]-           -> PreOpenAcc ExecOpenAcc aenv (Array dim e)-           -> Val aenv-           -> dim-           -> CIO (Array dim e)-generateOp c kernel bindings acc aenv sh = do-  res@(Array s out) <- newArray c sh-  execute kernel bindings acc aenv (Sugar.size sh) (((),out),convertIx s)-  return res---replicateOp :: (Shape dim, Elt slix)-            => Int-            -> AccKernel (Array dim e)-            -> [AccBinding aenv]-            -> PreOpenAcc ExecOpenAcc aenv (Array dim e)-            -> Val aenv-            -> SliceIndex (EltRepr slix) (EltRepr sl) co (EltRepr dim)-            -> slix-            -> Array sl e-            -> CIO (Array dim e)-replicateOp c kernel bindings acc aenv sliceIndex slix (Array sh0 in0) = do-  res@(Array sh out) <- newArray c (toElt $ extend sliceIndex (fromElt slix) sh0)-  execute kernel bindings acc aenv (size sh) (((((),out),in0),convertIx sh0),convertIx sh)-  freeArray in0-  return res-  where-    extend :: SliceIndex slix sl co dim -> slix -> sl -> dim-    extend (SliceNil)            ()       ()      = ()-    extend (SliceAll sliceIdx)   (slx,()) (sl,sz) = (extend sliceIdx slx sl, sz)-    extend (SliceFixed sliceIdx) (slx,sz) sl      = (extend sliceIdx slx sl, sz)---indexOp :: (Shape sl, Elt slix)-        => Int-        -> AccKernel (Array dim e)-        -> [AccBinding aenv]-        -> PreOpenAcc ExecOpenAcc aenv (Array sl e)-        -> Val aenv-        -> SliceIndex (EltRepr slix) (EltRepr sl) co (EltRepr dim)-        -> Array dim e-        -> slix-        -> CIO (Array sl e)-indexOp c kernel bindings acc aenv sliceIndex (Array sh0 in0) slix = do-  res@(Array sh out) <- newArray c (toElt $ restrict sliceIndex (fromElt slix) sh0)-  execute kernel bindings acc aenv (size sh)-    ((((((),out),in0),convertIx sh),convertSlix sliceIndex (fromElt slix)),convertIx sh0)-  freeArray in0-  return res-  where-    restrict :: SliceIndex slix sl co dim -> slix -> dim -> sl-    restrict (SliceNil)            ()       ()      = ()-    restrict (SliceAll sliceIdx)   (slx,()) (sh,sz) = (restrict sliceIdx slx sh, sz)-    restrict (SliceFixed sliceIdx) (slx,i)  (sh,sz)-      = BOUNDS_CHECK(checkIndex) "slice" i sz $ restrict sliceIdx slx sh-    ---    convertSlix :: SliceIndex slix sl co dim -> slix -> [Int32]-    convertSlix (SliceNil)            ()     = []-    convertSlix (SliceAll   sliceIdx) (s,()) = convertSlix sliceIdx s-    convertSlix (SliceFixed sliceIdx) (s,i)  = fromIntegral i : convertSlix sliceIdx s---mapOp :: Elt e-      => Int-      -> AccKernel (Array dim e)-      -> [AccBinding aenv]-      -> PreOpenAcc ExecOpenAcc aenv (Array dim e)-      -> Val aenv-      -> Array dim e'-      -> CIO (Array dim e)-mapOp c kernel bindings acc aenv (Array sh0 in0) = do-  res@(Array _ out) <- newArray c (toElt sh0)-  execute kernel bindings acc aenv (size sh0) ((((),out),in0),size sh0)-  freeArray in0-  return res--zipWithOp :: Elt c-          => Int-          -> AccKernel (Array dim c)-          -> [AccBinding aenv]-          -> PreOpenAcc ExecOpenAcc aenv (Array dim c)-          -> Val aenv-          -> Array dim a-          -> Array dim b-          -> CIO (Array dim c)-zipWithOp c kernel bindings acc aenv (Array sh1 in1) (Array sh0 in0) = do-  res@(Array sh out) <- newArray c $ toElt (sh1 `intersect` sh0)-  execute kernel bindings acc aenv (size sh) (((((((),out),in1),in0),convertIx sh),convertIx sh1),convertIx sh0)-  freeArray in1-  freeArray in0-  return res--foldOp :: forall dim e aenv. Shape dim-       => Int-       -> AccKernel (Array dim e)-       -> [AccBinding aenv]-       -> PreOpenAcc ExecOpenAcc aenv (Array dim e)-       -> Val aenv-       -> Array (dim:.Int) e-       -> CIO (Array dim e)-foldOp c kernel bindings acc aenv (Array sh0 in0)-  -- A recursive multi-block reduction when collapsing to a single value-  ---  -- TLM: multiple bind/free of arrays in scalar expressions in the recursive-  --      case, which probably breaks reference counting.-  ---  | dim sh0 == 1 = do-      cfg@(_,_,(_,g,_)) <- configure kernel acc (size sh0)-      res@(Array _ out) <- newArray (bool c 1 (g > 1)) (toElt (fst sh0,g)) :: CIO (Array (dim:.Int) e)-      dispatch cfg bindings aenv ((((),out),in0),size sh0)-      freeArray in0-      if g > 1 then foldOp c kernel bindings acc aenv res-               else return (Array (fst sh0) out)-  ---  -- Reduction over the innermost dimension of an array (single pass operation)-  ---  | otherwise    = do-      res@(Array sh out) <- newArray c $ toElt (fst sh0)-      execute kernel bindings acc aenv (size (fst sh0)) (((((),out),in0),convertIx sh),convertIx sh0)-      freeArray in0-      return res--foldSegOp :: Shape dim-          => Int-          -> AccKernel (Array dim e)-          -> [AccBinding aenv]-          -> PreOpenAcc ExecOpenAcc aenv (Array (dim:.Int) e)-          -> Val aenv-          -> Array (dim:.Int) e-          -> Segments-          -> CIO (Array (dim:.Int) e)-foldSegOp c kernel bindings acc aenv (Array sh0 in0) (Array shs seg) = do-  res@(Array sh out) <- newArray c $ toElt (fst sh0, size shs-1)-  execute kernel bindings acc aenv (size sh) ((((((),out),in0),seg),convertIx sh),convertIx sh0)-  freeArray in0-  freeArray seg-  return res---scanOp :: forall aenv e. Elt e-       => Int-       -> AccKernel (Vector e)-       -> [AccBinding aenv]-       -> PreOpenAcc ExecOpenAcc aenv (Vector e)-       -> Val aenv-       -> Vector e-       -> CIO (Vector e)-scanOp c kernel bindings acc aenv (Array sh0 in0) = do-  (mdl,fscan,(t,g,m)) <- configure kernel acc (size sh0)-  fadd                <- liftIO $ CUDA.getFun mdl "exclusive_update"-  res@(Array _ out)   <- newArray c (Z :. size sh0 + 1)-  (Array _ bks)       <- newArray 1 (Z :. g) :: CIO (Vector e)-  (Array _ sum)       <- newArray 1 Z        :: CIO (Scalar e)-  let n   = size sh0-      itv = (n + g - 1) `div` g-  ---  bindLifted mdl aenv bindings-  launch (t,g,m) fscan ((((((),out),in0),bks),n),itv)   -- inclusive scan of input array-  launch (t,1,m) fscan ((((((),bks),bks),sum),g),itv)   -- inclusive scan block-level sums-  launch (t,g,m) fadd  ((((((),out),bks),sum),n),itv)   -- distribute partial results-  freeLifted aenv bindings-  freeArray in0-  freeArray bks-  freeArray sum-  return res--scan'Op :: forall aenv e. Elt e-        => (Int,Int)-        -> AccKernel (Vector e)-        -> [AccBinding aenv]-        -> PreOpenAcc ExecOpenAcc aenv (Vector e, Scalar e)-        -> Val aenv-        -> Vector e-        -> CIO (Vector e, Scalar e)-scan'Op (c1,c0) kernel bindings acc aenv (Array sh0 in0) = do-  (mdl,fscan,(t,g,m)) <- configure kernel acc (size sh0)-  fadd                <- liftIO $ CUDA.getFun mdl "exclusive_update"-  res1@(Array _ out)  <- newArray c1 (toElt sh0)-  res2@(Array _ sum)  <- newArray c0 Z-  (Array _ bks)       <- newArray 1  (Z :. g) :: CIO (Vector e)-  let n   = size sh0-      itv = (n + g - 1) `div` g-  ---  bindLifted mdl aenv bindings-  launch (t,g,m) fscan ((((((),out),in0),bks),n),itv)   -- inclusive scan of input array-  launch (t,1,m) fscan ((((((),bks),bks),sum),g),itv)   -- inclusive scan block-level sums-  launch (t,g,m) fadd  ((((((),out),bks),sum),n),itv)   -- distribute partial results-  freeLifted aenv bindings-  freeArray in0-  freeArray bks-  when (c1 == 0) $ freeArray out-  when (c0 == 0) $ freeArray sum-  return (res1,res2)--scan1Op :: forall aenv e. Elt e-        => Int-        -> AccKernel (Vector e)-        -> [AccBinding aenv]-        -> PreOpenAcc ExecOpenAcc aenv (Vector e)-        -> Val aenv-        -> Vector e-        -> CIO (Vector e)-scan1Op c kernel bindings acc aenv (Array sh0 in0) = do-  (mdl,fscan,(t,g,m)) <- configure kernel acc (size sh0)-  fadd                <- liftIO $ CUDA.getFun mdl "inclusive_update"-  res@(Array _ out)   <- newArray c (toElt sh0)-  (Array _ bks)       <- newArray 1 (Z :. g) :: CIO (Vector e)-  (Array _ sum)       <- newArray 1 Z        :: CIO (Scalar e)-  let n   = size sh0-      itv = (n + g - 1) `div` g-  ---  bindLifted mdl aenv bindings-  launch (t,g,m) fscan ((((((),out),in0),bks),n),itv)   -- inclusive scan of input array-  launch (t,1,m) fscan ((((((),bks),bks),sum),g),itv)   -- inclusive scan block-level sums-  launch (t,g,m) fadd  (((((),out),bks),n),itv)         -- distribute partial results-  freeLifted aenv bindings-  freeArray in0-  freeArray bks-  freeArray sum-  return res--permuteOp :: Elt e-          => Int-          -> AccKernel (Array dim e)-          -> [AccBinding aenv]-          -> PreOpenAcc ExecOpenAcc aenv (Array dim' e)-          -> Val aenv-          -> Array dim' e       -- default values-          -> Array dim e        -- permuted array-          -> CIO (Array dim' e)-permuteOp c kernel bindings acc aenv (Array sh0 in0) (Array sh1 in1) = do-  res@(Array _ out) <- newArray c (toElt sh0)-  copyArray in0 out (size sh0)-  execute kernel bindings acc aenv (size sh0) (((((),out),in1),convertIx sh0),convertIx sh1)-  freeArray in0-  freeArray in1-  return res--backpermuteOp :: (Shape dim', Elt e)-              => Int-              -> AccKernel (Array dim e)-              -> [AccBinding aenv]-              -> PreOpenAcc ExecOpenAcc aenv (Array dim' e)-              -> Val aenv-              -> dim'-              -> Array dim e-              -> CIO (Array dim' e)-backpermuteOp c kernel bindings acc aenv dim' (Array sh0 in0) = do-  res@(Array sh out) <- newArray c dim'-  execute kernel bindings acc aenv (size sh) (((((),out),in0),convertIx sh),convertIx sh0)-  freeArray in0-  return res--stencilOp :: Elt e-          => Int-          -> AccKernel (Array dim e)-          -> [AccBinding aenv]-          -> PreOpenAcc ExecOpenAcc aenv (Array dim e)-          -> Val aenv-          -> Array dim e'-          -> CIO (Array dim e)-stencilOp c kernel bindings acc aenv sten0@(Array sh0 in0) = do-  res@(Array _ out)  <- newArray c (toElt sh0)-  (mdl,fstencil,cfg) <- configure kernel acc (size sh0)-  bindLifted mdl aenv bindings-  bindStencil 0 mdl sten0-  launch cfg fstencil (((),out),convertIx sh0)-  freeLifted aenv bindings-  freeArray in0-  return res--stencil2Op :: Elt e-           => Int-           -> AccKernel (Array dim e)-           -> [AccBinding aenv]-           -> PreOpenAcc ExecOpenAcc aenv (Array dim e)-           -> Val aenv-           -> Array dim e1-           -> Array dim e2-           -> CIO (Array dim e)-stencil2Op c kernel bindings acc aenv sten1@(Array sh1 in1) sten0@(Array sh0 in0) = do-  res@(Array sh out) <- newArray c $ toElt (sh1 `intersect` sh0)-  (mdl,fstencil,cfg) <- configure kernel acc (size sh)-  bindLifted mdl aenv bindings-  bindStencil 0 mdl sten0-  bindStencil 1 mdl sten1-  launch cfg fstencil (((((),out),convertIx sh),convertIx sh1),convertIx sh0)-  freeLifted aenv bindings-  freeArray in0-  freeArray in1-  return res----- Expression evaluation--- ------------------------- Evaluate an open expression----executeOpenExp :: PreOpenExp ExecOpenAcc env aenv t -> Val env -> Val aenv -> CIO t-executeOpenExp (Let _ _)         _   _    = INTERNAL_ERROR(error) "executeOpenExp" "Let: not implemented yet"-executeOpenExp (Var idx)         env _    = return $ prj idx env-executeOpenExp (Const c)         _   _    = return $ toElt c-executeOpenExp (PrimConst c)     _   _    = return $ I.evalPrimConst c-executeOpenExp (PrimApp fun arg) env aenv = I.evalPrim fun <$> executeOpenExp arg env aenv-executeOpenExp (Tuple tup)       env aenv = toTuple                   <$> executeTuple tup env aenv-executeOpenExp (Prj idx e)       env aenv = I.evalPrj idx . fromTuple <$> executeOpenExp e env aenv-executeOpenExp IndexAny          _   _    = INTERNAL_ERROR(error) "executeOpenExp" "IndexAny: not implemented yet"-executeOpenExp IndexNil          _   _    = return Z-executeOpenExp (IndexCons sh i)  env aenv = (:.) <$> executeOpenExp sh env aenv <*> executeOpenExp i env aenv-executeOpenExp (IndexHead ix)    env aenv = (\(_:.h) -> h) <$> executeOpenExp ix env aenv-executeOpenExp (IndexTail ix)    env aenv = (\(t:._) -> t) <$> executeOpenExp ix env aenv-executeOpenExp (IndexScalar a e) env aenv = do-  (Array sh ad) <- executeOpenAcc a aenv-  ix            <- executeOpenExp e env aenv-  res           <- toElt <$> ad `indexArray` index sh (fromElt ix)-  freeArray ad-  return res--executeOpenExp (Shape a) _ aenv = do-  (Array sh ad) <- executeOpenAcc a aenv-  freeArray ad-  return (toElt sh)--executeOpenExp (Size a) _ aenv = do-  (Array sh ad) <- executeOpenAcc a aenv-  freeArray ad-  return (size sh)--executeOpenExp (Cond c t e) env aenv = do-  p <- executeOpenExp c env aenv-  if p then executeOpenExp t env aenv-       else executeOpenExp e env aenv----- Evaluate a closed expression----executeExp :: PreExp ExecOpenAcc aenv t -> Val aenv -> CIO t-executeExp e = executeOpenExp e Empty----- Tuple evaluation----executeTuple :: Tuple (PreOpenExp ExecOpenAcc env aenv) t -> Val env -> Val aenv -> CIO t-executeTuple NilTup          _   _    = return ()-executeTuple (t `SnocTup` e) env aenv = (,) <$> executeTuple   t env aenv-                                            <*> executeOpenExp e env aenv----- Array references in scalar code--- ---------------------------------bindLifted :: CUDA.Module -> Val aenv -> [AccBinding aenv] -> CIO ()-bindLifted mdl aenv = mapM_ (bindAcc mdl aenv)--freeLifted :: Val aenv -> [AccBinding aenv] -> CIO ()-freeLifted aenv = mapM_ free-  where-    free (ArrayVar idx) =-      let Array _ ad = prj idx aenv-      in  freeArray ad---bindAcc :: CUDA.Module-        -> Val aenv-        -> AccBinding aenv-        -> CIO ()-bindAcc mdl aenv (ArrayVar idx) =-  let idx'        = show $ deBruijnToInt idx-      Array sh ad = prj idx aenv-      ---      bindDim = liftIO $-        CUDA.getPtr mdl ("sh" ++ idx') >>=-        CUDA.pokeListArray (convertIx sh) . fst-      ---      arr n   = "arr" ++ idx' ++ "_a" ++ show (n::Int)-      tex     = CUDA.getTex mdl . arr-      bindTex =-        marshalTextureData ad (size sh) =<< liftIO (sequence' $ map tex [0..])-  in-  bindDim >> bindTex---bindStencil :: Int-            -> CUDA.Module-            -> Array dim e-            -> CIO ()-bindStencil s mdl (Array sh ad) =-  let sten n = "stencil" ++ show s ++ "_a" ++ show (n::Int)-      tex    = CUDA.getTex mdl . sten-  in-  marshalTextureData ad (size sh) =<< liftIO (sequence' $ map tex [0..])----- Kernel execution--- -------------------- Data which can be marshalled as arguments to a kernel invocation. For Int and--- Word, we match the device bit-width of these types.----class Marshalable a where-  marshal :: a -> CIO [CUDA.FunParam]--instance Marshalable () where-  marshal _ = return []--instance Marshalable Int where-  marshal x = marshal (fromIntegral x :: Int32)         -- TLM: this isn't so good...--instance Marshalable Word where-  marshal x = marshal (fromIntegral x :: Word32)--#define primMarshalable(ty)                                                    \-instance Marshalable ty where {                                                \-  marshal x = return [CUDA.VArg x] }--primMarshalable(Int8)-primMarshalable(Int16)-primMarshalable(Int32)-primMarshalable(Int64)-primMarshalable(Word8)-primMarshalable(Word16)-primMarshalable(Word32)-primMarshalable(Word64)-primMarshalable(Float)-primMarshalable(Double)-primMarshalable((Ptr a))-primMarshalable((CUDA.DevicePtr a))--instance Marshalable CUDA.FunParam where-  marshal x = return [x]--instance AD.ArrayElt e => Marshalable (AD.ArrayData e) where-  marshal = marshalArrayData    -- Marshalable (DevicePtrs a) does not type )=--instance Marshalable a => Marshalable [a] where-  marshal = concatMapM marshal--instance (Marshalable a, Marshalable b) => Marshalable (a,b) where-  marshal (a,b) = (++) <$> marshal a <*> marshal b----- Link the binary object implementing the computation, configure the kernel--- launch parameters, and initiate the computation. This also handles lifting--- and binding of array references from scalar expressions.----execute :: Marshalable args-        => AccKernel a          -- The binary module implementing this kernel-        -> [AccBinding aenv]    -- Array variables embedded in scalar expressions-        -> PreOpenAcc ExecOpenAcc aenv a-        -> Val aenv-        -> Int-        -> args-        -> CIO ()-execute kernel bindings acc aenv n args =-  configure kernel acc n >>= \cfg ->-  dispatch cfg bindings aenv args---- Pre-execution configuration and kernel linking----configure :: AccKernel a-          -> PreOpenAcc ExecOpenAcc aenv a-          -> Int-          -> CIO (CUDA.Module, CUDA.Fun, (Int,Int,Integer))-configure (name, kernel) acc n = do-  mdl <- kernel-  fun <- liftIO $ CUDA.getFun mdl name-  cfg <- launchConfig acc n fun-  return (mdl, fun, cfg)----- Binding of lifted array expressions and kernel invocation----dispatch :: Marshalable args-         => (CUDA.Module, CUDA.Fun, (Int,Int,Integer))-         -> [AccBinding aenv]-         -> Val aenv-         -> args-         -> CIO ()-dispatch (mdl, fun, cfg) fvs aenv args = do-  bindLifted mdl aenv fvs-  launch cfg fun args-  freeLifted aenv fvs---- Execute a device function, with the given thread configuration and function--- parameters. The tuple contains (threads per block, grid size, shared memory)----launch :: Marshalable args => (Int,Int,Integer) -> CUDA.Fun -> args -> CIO ()-launch (cta,grid,smem) fn a = do-  args <- marshal a-  liftIO $ do-    CUDA.setParams     fn args-    CUDA.setSharedSize fn smem-    CUDA.setBlockShape fn (cta,1,1)-    CUDA.launch        fn (grid,1) Nothing----- Memory management--- --------------------- Allocate a new device array to accompany the given host-side Accelerate--- array, of given shape and reference count.----newArray :: (Shape sh, Elt e)-         => Int                         -- use/reference count-         -> sh                          -- shape-         -> CIO (Array sh e)-newArray rc sh = do-  ad `seq` mallocArray ad (Just rc) (1 `max` n)-  return $ Array (fromElt sh) ad-  where-    n      = Sugar.size sh-    (ad,_) = AD.runArrayData $ (,undefined) `fmap` AD.newArrayData (1024 `max` n)-      -- FIXME: small arrays moved by the GC-      -- FIXME: only the final output array needs to be allocated to full size----- Auxiliary functions--- ----------------------- Fold over a boolean value, analogous to 'maybe' and 'either'----bool :: a -> a -> Bool -> a-bool x _ False = x-bool _ y True  = y---- Like 'when' but in teh monadz----whenM :: Monad m => m Bool -> m () -> m ()-whenM predicate action = do-  doit <- predicate-  when doit action---- Generalise concatMap to arbitrary monads----concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]-concatMapM f xs = concat `liftM` mapM f xs---- A lazier version of 'Control.Monad.sequence'----sequence' :: [IO a] -> IO [a]-sequence' = foldr k (return [])-  where k m ms = do { x <- m; xs <- unsafeInterleaveIO ms; return (x:xs) }---- Extract shape dimensions as a list of 32-bit integers (the base integer width--- of the device, and used for index calculations). Singleton dimensions are--- considered to be of unit size.------ Internally, Accelerate uses snoc-based tuple projection, while the data--- itself is stored in reading order. Ensure we match the behaviour of regular--- tuples and code generation thereof.------ TLM: keep native integer sizes, now that we have conversion functions----convertIx :: R.Shape sh => sh -> [Int32]-convertIx = post . map fromIntegral . shapeToList-  where post [] = [1]-        post xs = reverse xs---- Cautiously delete a array, checking if it still exists on the device first.--- This is because we have over zealous reference counting.----deleteArray :: Elt e => Array sh e -> CIO ()-deleteArray (Array _ ad) = whenM (existsArrayData ad) (freeArray ad)---- Apply a function to all components of an Arrays structure----applyArraysR-    :: (forall sh e. (Shape sh, Elt e) => Array sh e -> CIO ())-    -> ArraysR arrs-    -> arrs-    -> CIO ()-applyArraysR _  ArraysRunit         ()       = return ()-applyArraysR go (ArraysRpair r1 r0) (a1, a0) = applyArraysR go r1 a1 >> applyArraysR go r0 a0-applyArraysR go ArraysRarray        arr      = go arr-
− Data/Array/Accelerate/CUDA/State.hs 
@@ -1,236 +0,0 @@-{-# LANGUAGE CPP, GADTs, PatternGuards, TemplateHaskell #-}-{-# LANGUAGE TupleSections, TypeFamilies, TypeOperators #-}--- |--- Module      : Data.Array.Accelerate.CUDA.State--- Copyright   : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell--- License     : BSD3------ Maintainer  : Manuel M T Chakravarty <chak@cse.unsw.edu.au>--- Stability   : experimental--- Portability : non-partable (GHC extensions)------ This module defines a state monad token which keeps track of the code--- generator state, including memory transfers and external compilation--- processes.-----module Data.Array.Accelerate.CUDA.State (--  evalCUDA, runCUDA, runCUDAWith, CIO,-  CUDAState, unique, deviceProps, deviceContext, memoryTable, kernelTable,--  KernelTable, KernelEntry(KernelEntry), kernelName, kernelStatus,-  MemoryEntry(..), AccArrayData(..), refcount, newAccMemoryTable--) where---- friends-import Data.Array.Accelerate.CUDA.Analysis.Device-import Data.Array.Accelerate.CUDA.Analysis.Hash-import qualified Data.Array.Accelerate.Array.Data       as AD---- library-import Data.Int-import Data.IORef-import Data.Maybe-import Data.Typeable-import Data.Label-import Control.Applicative-import Control.Monad-import Control.Monad.State.Strict                       (StateT(..))-import System.Posix.Types                               (ProcessID)-import System.Mem.Weak-import System.IO.Unsafe-import Foreign.Ptr-import qualified Foreign.CUDA.Driver                    as CUDA-import qualified Data.HashTable                         as Hash--#ifdef ACCELERATE_CUDA_PERSISTENT_CACHE-import Data.Binary                                      (encodeFile, decodeFile)-import Control.Arrow                                    (second)-import Paths_accelerate                                 (getDataDir)-#endif--#include "accelerate.h"----- An exact association between an accelerate computation and its--- implementation, which is either a reference to the external compiler (nvcc)--- or the resulting binary module. This is keyed by a string representation of--- the generated kernel code.------ An Eq instance of Accelerate expressions does not facilitate persistent--- caching.----type KernelTable = Hash.HashTable AccKey KernelEntry-data KernelEntry = KernelEntry-  {-    _kernelName   :: FilePath,-    _kernelStatus :: Either ProcessID CUDA.Module-  }---- Associations between host- and device-side arrays, with reference counting.--- Facilitates reuse and delayed allocation at the cost of explicit release.------ This maps to a single concrete array. Arrays of tuples, which are represented--- internally as tuples of arrays, will generate multiple entries.----type MemoryTable = Hash.HashTable AccArrayData MemoryEntry--data AccArrayData where-  AccArrayData :: (Typeable a, AD.ArrayPtrs e ~ Ptr a, AD.ArrayElt e)-               => AD.ArrayData e-               -> AccArrayData--instance Eq AccArrayData where-  AccArrayData ad1 == AccArrayData ad2-    | Just p1 <- gcast (AD.ptrsOfArrayData ad1) = p1 == AD.ptrsOfArrayData ad2-    | otherwise                                 = False--data MemoryEntry where-  MemoryEntry :: Typeable a-              => Maybe Int         -- if Nothing, the array is not released by 'freeArray'-              -> CUDA.DevicePtr a-              -> MemoryEntry--newAccMemoryTable :: IO MemoryTable-newAccMemoryTable = Hash.new (==) hashAccArray-  where-    hashAccArray :: AccArrayData -> Int32-    hashAccArray (AccArrayData ad) = fromIntegral . ptrToIntPtr-                                   $ AD.ptrsOfArrayData ad--refcount :: MemoryEntry :-> Maybe Int-refcount = lens get set-  where-    get   (MemoryEntry c _) = c-    set c (MemoryEntry _ p) = MemoryEntry c p----- The state token for accelerated CUDA array operations------ TLM: the memory table is not persistent between computations. Move elsewhere?----type CIO       = StateT CUDAState IO-data CUDAState = CUDAState-  {-    _unique        :: Int,-    _deviceProps   :: CUDA.DeviceProperties,-    _deviceContext :: CUDA.Context,-    _kernelTable   :: KernelTable,-    _memoryTable   :: MemoryTable-  }--$(mkLabels [''CUDAState, ''KernelEntry])----- Execution State--- -----------------#ifdef ACCELERATE_CUDA_PERSISTENT_CACHE-indexFileName :: IO FilePath-indexFileName = do-  tmp <- (</> "cache") `fmap` getDataDir-  dir <- createDirectoryIfMissing True tmp >> canonicalizePath tmp-  return (dir </> "_index")-#endif---- Store the kernel module map to file----saveIndexFile :: CUDAState -> IO ()-#ifdef ACCELERATE_CUDA_PERSISTENT_CACHE-saveIndexFile s = do-  ind <- indexFileName-  encodeFile ind . map (second _kernelName) =<< Hash.toList (_kernelTable s)-#else-saveIndexFile _ = return ()-#endif---- Read the kernel index map file (if it exists), loading modules into the--- current context----loadIndexFile :: IO (KernelTable, Int)-#ifdef ACCELERATE_CUDA_PERSISTENT_CACHE-loadIndexFile = do-  f <- indexFileName-  x <- doesFileExist f-  e <- if x then mapM reload =<< decodeFile f-            else return []-  (,length e) <$> Hash.fromList hashAccKey e-  where-    reload (k,n) = (k,) . KernelEntry n . Right <$> CUDA.loadFile (n `replaceExtension` ".cubin")-#else-loadIndexFile = (,0) <$> Hash.new (==) hashAccKey-#endif------ Select and initialise the CUDA device, and create a new execution context.--- This will be done only once per program execution, as initialising the CUDA--- context is relatively expensive.------ Would like to put the finaliser on the state token, since finalising the--- context affects the various hash tables. However, this places the finaliser--- on the CUDAState "box", and the box is removed by optimisations causing the--- finaliser to fire prematurely.----initialise :: IO CUDAState-initialise = do-  CUDA.initialise []-  (d,prp) <- selectBestDevice-  ctx     <- CUDA.create d [CUDA.SchedAuto]-  (knl,n) <- loadIndexFile-  addFinalizer ctx (CUDA.destroy ctx)-  return $ CUDAState n prp ctx knl undefined----- | Evaluate a CUDA array computation under the standard global environment----evalCUDA :: CIO a -> IO a-evalCUDA = liftM fst . runCUDA--runCUDA :: CIO a -> IO (a, CUDAState)-runCUDA acc = readIORef onta >>= flip runCUDAWith acc----- | Execute a computation under the provided state, returning the updated--- environment structure and replacing the global state.----runCUDAWith :: CUDAState -> CIO a -> IO (a, CUDAState)-runCUDAWith state acc = do-  (a,s) <- runStateT acc state-  saveIndexFile s-  writeIORef onta =<< sanitise s-  return (a,s)-  where-    -- The memory table and compute table are transient data structures: they-    -- exist only for the life of a single computation [stream]. Don't record-    -- them into the persistent state token.-    ---    sanitise :: CUDAState -> IO CUDAState-    sanitise st = do-      entries <- filter (isJust . get refcount . snd) <$> Hash.toList (get memoryTable st)-      INTERNAL_ASSERT "runCUDA.sanitise" (null entries)-        $ return (set memoryTable undefined st)----- Nasty global statesses--- ------------------------{----- Execute an IO action at most once----mkOnceIO :: IO a -> IO (IO a)-mkOnceIO io = do-  mvar   <- newEmptyMVar-  demand <- newEmptyMVar-  forkIO (takeMVar demand >> io >>= putMVar mvar)-  return (tryPutMVar demand ()  >>  readMVar mvar)---}---- hic sunt dracones: truly unsafe use of unsafePerformIO----onta :: IORef CUDAState-{-# NOINLINE onta #-}-onta = unsafePerformIO (initialise >>= newIORef)-
− Data/Array/Accelerate/IO.hs 
@@ -1,33 +0,0 @@--- |--- Module      : Data.Array.Accelerate.IO--- Copyright   : [2010..2011] Sean Seefried, Trevor L. McDonell--- License     : BSD3------ Maintainer  : Manuel M T Chakravarty <chak@cse.unsw.edu.au>--- Stability   : experimental--- Portability : non-portable (GHC extensions)------ This module provides functions for efficient block copies of primitive arrays--- (i.e. one dimensional, in row-major order in contiguous memory) to Accelerate--- Arrays.------ You should only use this module if you really know what you are doing.--- Potential pitfalls include:------   * copying from memory your program doesn't have access to (e.g. it may be---     unallocated or not enough memory is allocated)------   * memory alignment errors-----module Data.Array.Accelerate.IO (--  module Data.Array.Accelerate.IO.Ptr,-  module Data.Array.Accelerate.IO.ByteString,-  module Data.Array.Accelerate.IO.Vector--) where--import Data.Array.Accelerate.IO.Ptr-import Data.Array.Accelerate.IO.ByteString-import Data.Array.Accelerate.IO.Vector
− Data/Array/Accelerate/IO/BlockCopy.hs 
@@ -1,189 +0,0 @@-{-# LANGUAGE GADTs, MagicHash, ForeignFunctionInterface, TypeFamilies, ScopedTypeVariables #-}--- |--- Module      : Data.Array.Accelerate.IO.BlockCopy--- Copyright   : [2010..2011] Sean Seefried--- License     : BSD3------ Maintainer  : Manuel M T Chakravarty <chak@cse.unsw.edu.au>--- Stability   : experimental--- Portability : non-portable (GHC extensions)-----module Data.Array.Accelerate.IO.BlockCopy (--  -- * Types-  BlockCopyFun, BlockCopyFuns, BlockPtrs, ByteStrings,--  -- * The low-level machinery-  allocateArray, blockCopyFunGenerator--) where---- standard libraries-import Foreign-import Foreign.C-import GHC.Base-import Data.Array.Base (bOOL_SCALE, wORD_SCALE, fLOAT_SCALE, dOUBLE_SCALE)-import Data.ByteString---- friends-import Data.Array.Accelerate.Array.Data-import Data.Array.Accelerate.Array.Sugar----- | Functions of this type are passed as arguments to 'toArray'. A function of---   this type should copy a number of bytes (equal to the value of the---   parameter of type 'Int') to the destination memory pointed to by @Ptr e@.----type BlockCopyFun e = Ptr e -> Int -> IO ()---- | Represents a collection of "block copy functions" (see 'BlockCopyFun'). The---   structure of the collection of 'BlockCopyFun's depends on the element type---   @e@.------   e.g.------   If @e :: Float@---   then @BlockCopyFuns (EltRepr e) :: ((), Ptr Float -> Int -> IO ())@------   If @e :: (Double, Float)@---   then @BlockCopyFuns (EltRepr e) :: (((), Ptr Double -> Int -> IO ()), Ptr Float -> Int -> IO ())@----type family BlockCopyFuns e--type instance BlockCopyFuns ()     = ()-type instance BlockCopyFuns Int    = BlockCopyFun Int-type instance BlockCopyFuns Int8   = BlockCopyFun Int8-type instance BlockCopyFuns Int16  = BlockCopyFun Int16-type instance BlockCopyFuns Int32  = BlockCopyFun Int32-type instance BlockCopyFuns Int64  = BlockCopyFun Int64-type instance BlockCopyFuns Word   = BlockCopyFun Word-type instance BlockCopyFuns Word8  = BlockCopyFun Word8-type instance BlockCopyFuns Word16 = BlockCopyFun Word16-type instance BlockCopyFuns Word32 = BlockCopyFun Word32-type instance BlockCopyFuns Word64 = BlockCopyFun Word64-type instance BlockCopyFuns Float  = BlockCopyFun Float-type instance BlockCopyFuns Double = BlockCopyFun Double-type instance BlockCopyFuns Bool   = BlockCopyFun Word8 -- Packed a bit vector-type instance BlockCopyFuns Char   = BlockCopyFun Char-type instance BlockCopyFuns (a,b)  = (BlockCopyFuns a, BlockCopyFuns b)---- | A family of types that represents a collection of pointers that are the---   source/destination addresses for a block copy. The structure of the---   collection of pointers depends on the element type @e@.------  e.g.------  If @e :: Int@,            then @BlockPtrs (EltRepr e) :: ((), Ptr Int)@------  If @e :: (Double, Float)@ then @BlockPtrs (EltRepr e) :: (((), Ptr Double), Ptr Float)@----type family BlockPtrs e--type instance BlockPtrs ()     = ()-type instance BlockPtrs Int    = Ptr Int-type instance BlockPtrs Int8   = Ptr Int8-type instance BlockPtrs Int16  = Ptr Int16-type instance BlockPtrs Int32  = Ptr Int32-type instance BlockPtrs Int64  = Ptr Int64-type instance BlockPtrs Word   = Ptr Word-type instance BlockPtrs Word8  = Ptr Word8-type instance BlockPtrs Word16 = Ptr Word16-type instance BlockPtrs Word32 = Ptr Word32-type instance BlockPtrs Word64 = Ptr Word64-type instance BlockPtrs Float  = Ptr Float-type instance BlockPtrs Double = Ptr Double-type instance BlockPtrs Bool   = Ptr Word8 -- Packed as a bit vector-type instance BlockPtrs Char   = Ptr Char-type instance BlockPtrs (a,b)  = (BlockPtrs a, BlockPtrs b)---- | A family of types that represents a collection of 'ByteString's. They are---   the source data for function 'fromByteString' and the result data for---   'toByteString'----type family ByteStrings e--type instance ByteStrings ()     = ()-type instance ByteStrings Int    = ByteString-type instance ByteStrings Int8   = ByteString-type instance ByteStrings Int16  = ByteString-type instance ByteStrings Int32  = ByteString-type instance ByteStrings Int64  = ByteString-type instance ByteStrings Word   = ByteString-type instance ByteStrings Word8  = ByteString-type instance ByteStrings Word16 = ByteString-type instance ByteStrings Word32 = ByteString-type instance ByteStrings Word64 = ByteString-type instance ByteStrings Float  = ByteString-type instance ByteStrings Double = ByteString-type instance ByteStrings Bool   = ByteString-type instance ByteStrings Char   = ByteString-type instance ByteStrings (a,b)  = (ByteStrings a, ByteStrings b)---type GenFuns e = (( BlockPtrs e -> IO ()-                  , ByteStrings e -> IO ())-                 ,( BlockPtrs e -> IO ()-                  , IO (ByteStrings e))-                 , BlockCopyFuns e -> IO ())--base :: forall a b. Ptr b -> Int -> (( Ptr a -> IO (), ByteString -> IO ())-                                    ,( Ptr a -> IO (), IO ByteString)-                                    ,(Ptr b -> Int -> IO ()) -> IO ())-base accArrayPtr byteSize =-   ((blockPtrToArray, byteStringToArray)-   ,(arrayToBlockPtr, arrayToByteString)-   , blockCopyFunToOrFromArray)-  where-    blockPtrToArray :: Ptr a -> IO ()-    blockPtrToArray blockPtr = blockCopy blockPtr accArrayPtr byteSize-    arrayToBlockPtr :: Ptr a -> IO ()-    arrayToBlockPtr blockPtr = blockCopy accArrayPtr blockPtr byteSize-    blockCopyFunToOrFromArray :: (Ptr b -> Int -> IO ()) -> IO ()-    blockCopyFunToOrFromArray blockCopyFun = blockCopyFun accArrayPtr byteSize-    byteStringToArray :: ByteString -> IO ()-    byteStringToArray bs = useAsCString bs (blockPtrToArray . castPtr)-    arrayToByteString :: IO ByteString-    arrayToByteString = packCStringLen (castPtr accArrayPtr, byteSize)--blockCopyFunGenerator :: Array sh e -> GenFuns (EltRepr e)-blockCopyFunGenerator array@(Array _ arrayData) = aux arrayElt arrayData-  where-   sizeA = size (shape array)-   aux :: ArrayEltR e -> ArrayData e -> GenFuns e-   aux ArrayEltRunit _ = let f () = return () in ((f,f),(f,return ()),f)-   aux ArrayEltRint    ad = base (ptrsOfArrayData ad) (box wORD_SCALE sizeA)-   aux ArrayEltRint8   ad = base (ptrsOfArrayData ad) sizeA-   aux ArrayEltRint16  ad = base (ptrsOfArrayData ad) (sizeA * 2)-   aux ArrayEltRint32  ad = base (ptrsOfArrayData ad) (sizeA * 4)-   aux ArrayEltRint64  ad = base (ptrsOfArrayData ad) (sizeA * 8)-   aux ArrayEltRword   ad = base (ptrsOfArrayData ad) (box wORD_SCALE sizeA)-   aux ArrayEltRword8  ad = base (ptrsOfArrayData ad) sizeA-   aux ArrayEltRword16 ad = base (ptrsOfArrayData ad) (sizeA * 2)-   aux ArrayEltRword32 ad = base (ptrsOfArrayData ad) (sizeA * 4)-   aux ArrayEltRword64 ad = base (ptrsOfArrayData ad) (sizeA * 8)-   aux ArrayEltRfloat  ad = base (ptrsOfArrayData ad) (box fLOAT_SCALE sizeA)-   aux ArrayEltRdouble ad = base (ptrsOfArrayData ad) (box dOUBLE_SCALE sizeA)-   aux ArrayEltRbool   ad = base (ptrsOfArrayData ad) (box bOOL_SCALE sizeA)-   aux ArrayEltRchar   _ = error "not defined yet" -- base (castPtr $ ptrsOfArrayData ad) (sizeA * 4)-   aux (ArrayEltRpair a b) (AD_Pair ad1 ad2) = ((bpFromC, bsFromC), (bpToC, bsToC), toH)-     where-       ((bpFromC1, bsFromC1), (bpToC1, bsToC1), toH1) = aux a ad1-       ((bpFromC2, bsFromC2), (bpToC2, bsToC2), toH2) = aux b ad2-       toH (funs1, funs2)   = toH1 funs1    >> toH2 funs2-       bpToC (ptrA, ptrB)   = bpToC1 ptrA   >> bpToC2 ptrB-       bsToC                = do { bsA <- bsToC1; bsB <- bsToC2; return (bsA, bsB) }-       bpFromC (ptrA, ptrB) = bpFromC1 ptrA >> bpFromC2 ptrB-       bsFromC (bsA, bsB)   = bsFromC1 bsA  >> bsFromC2 bsB--blockCopy :: Ptr a -> Ptr b -> Int -> IO ()-blockCopy src dst byteSize = memcpy dst src (fromIntegral byteSize)----- Foreign imports-foreign import ccall memcpy :: Ptr a -> Ptr b -> CInt -> IO ()---- Helpers-box :: (Int# -> Int#) -> Int -> Int-box f (I# x) = I# (f x)-
− Data/Array/Accelerate/IO/ByteString.hs 
@@ -1,49 +0,0 @@--- |--- Module      : Data.Array.Accelerate.IO.ByteString--- Copyright   : [2010..2011] Sean Seefried, 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.IO.ByteString (--  -- * Copy to/from (strict) ByteString`s-  ByteStrings, fromByteString, toByteString--) where--import Data.Array.Accelerate.IO.BlockCopy-import Data.Array.Accelerate.Array.Sugar------ | Block copies bytes from a collection of 'ByteString's to freshly allocated---   Accelerate array.------   The type of elements (@e@) in the output Accelerate array determines the---   structure of the collection of 'ByteString's that will be required as the---   second argument to this function. See 'ByteStrings'----fromByteString :: (Shape sh, Elt e) => sh -> ByteStrings (EltRepr e) -> IO (Array sh e)-fromByteString sh byteStrings = do-  let arr    = allocateArray sh-      copier = let ((_,f),_,_) = blockCopyFunGenerator arr in f-  copier byteStrings-  return arr----- | Block copy from an Accelerate array to a collection of freshly allocated---   'ByteString's.------   The type of elements (@e@) in the input Accelerate array determines the---   structure of the collection of 'ByteString's that will be output. See---   'ByteStrings'----toByteString :: (Shape sh, Elt e) => Array sh e -> IO (ByteStrings (EltRepr e))-toByteString arr = do-  let copier = let (_,(_,f),_) = blockCopyFunGenerator arr in f-  copier-
− Data/Array/Accelerate/IO/Ptr.hs 
@@ -1,100 +0,0 @@--- |--- Module      : Data.Array.Accelerate.IO.Ptr--- Copyright   : [2010..2011] Sean Seefried, 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.IO.Ptr (--  -- * Copying to/from raw pointers-  BlockPtrs, fromPtr, toPtr,--  -- * Direct copying into/from an Accelerate array-  BlockCopyFun, BlockCopyFuns, fromArray, toArray--) where--import Data.Array.Accelerate.IO.BlockCopy-import Data.Array.Accelerate.Array.Sugar------ | Block copy regions of memory into a freshly allocated Accelerate array. The---   type of elements (@e@) in the output Accelerate array determines the---   structure of the collection of pointers that will be required as the second---   argument to this function. See 'BlockPtrs'------   Each one of these pointers points to a block of memory that is the source---   of data for the Accelerate array (unlike function 'toArray' where one---   passes in function which copies data to a destination address.).----fromPtr :: (Shape sh, Elt e) => sh -> BlockPtrs (EltRepr e) -> IO (Array sh e)-fromPtr sh blkPtrs = do-  let arr    = allocateArray sh-      copier = let ((f,_),_,_) = blockCopyFunGenerator arr in f-  copier blkPtrs-  return arr----- | Block copy from Accelerate array to pre-allocated regions of memory. The---   type of element of the input Accelerate array (@e@) determines the---   structure of the collection of pointers that will be required as the second---   argument to this function. See 'BlockPtrs'------   The memory associated with the pointers must have already been allocated.----toPtr :: (Shape sh, Elt e) => Array sh e -> BlockPtrs (EltRepr e) -> IO ()-toPtr arr blockPtrs = do-  let copier = let (_,(f,_),_) = blockCopyFunGenerator arr in f-  copier blockPtrs-  return ()----- | Copy values from an Accelerate array using a collection of functions that---   have type 'BlockCopyFun'. The argument of type @Ptr e@ in each of these---   functions refers to the address of the /source/ block of memory in the---   Accelerate Array. The /destination/ address is implicit. e.g. the---   'BlockCopyFun' could be the result of partially application to a @Ptr e@---   pointing to the destination block.------   The structure of this collection of functions depends on the elemente type---   @e@. Each function (of type 'BlockCopyFun') copies data to a destination---   address (pointed to by the argument of type @Ptr ()@).------   Unless there is a particularly pressing reason to use this function, the---   'fromPtr' function is sufficient as it uses an efficient low-level call to---   libc's @memcpy@ to perform the copy.----fromArray :: (Shape sh, Elt e) => Array sh e -> BlockCopyFuns (EltRepr e) -> IO ()-fromArray arr blockCopyFuns = do-   let copier = let (_,_,f) = blockCopyFunGenerator arr in f-   copier blockCopyFuns-   return ()----- | Copy values to a freshly allocated Accelerate array using a collection of---   functions that have type 'BlockCopyFun'. The argument of type @Ptr e@ in---   each of these functions refers to the address of the /destination/ block of---   memory in the Accelerate Array. The /source/ address is implicit. e.g. the---   'BlockCopyFun' could be the result of a partial application to a @Ptr e@---   pointing to the source block.------   The structure of this collection of functions depends on the elemente type---   @e@. Each function (of type 'BlockCopyFun') copies data to a destination---   address (pointed to by the argument of type @Ptr ()@).------   Unless there is a particularly pressing reason to use this function, the---   'fromPtr' function is sufficient as it uses an efficient low-level call to---   libc's @memcpy@ to perform the copy.----toArray :: (Shape sh, Elt e) => sh -> BlockCopyFuns (EltRepr e) -> IO (Array sh e)-toArray sh blockCopyFuns = do-  let arr    = allocateArray sh-      copier = let (_,_,f) = blockCopyFunGenerator arr in f-  copier blockCopyFuns-  return arr-
− Data/Array/Accelerate/IO/Vector.hs 
@@ -1,55 +0,0 @@--- |--- Module      : Data.Array.Accelerate.IO.Vector--- Copyright   : [2012] Adam C. Foltzer--- License     : BSD3------ Maintainer  : Manuel M T Chakravarty <chak@cse.unsw.edu.au>--- Stability   : experimental--- Portability : non-portable (GHC extensions)------ Helpers for fast conversion of 'Data.Vector.Storable' vectors into--- Accelerate arrays.-module Data.Array.Accelerate.IO.Vector (-    -- * Vector conversions-    fromVector-  , toVector-  , fromVectorIO-  , toVectorIO-) where--import Data.Array.Accelerate ( arrayShape-                             , Array-                             , DIM1-                             , Elt-                             , Z(..)-                             , (:.)(..))-import Data.Array.Accelerate.Array.Sugar (EltRepr)-import Data.Array.Accelerate.IO.Ptr-import Data.Vector.Storable ( unsafeFromForeignPtr0-                            , unsafeToForeignPtr0-                            , Vector)--import Foreign (mallocForeignPtrArray, Ptr, Storable, withForeignPtr)--import System.IO.Unsafe--fromVectorIO :: (Storable a, Elt a, BlockPtrs (EltRepr a) ~ ((), Ptr a))-             => Vector a -> IO (Array DIM1 a)-fromVectorIO v = withForeignPtr fp $ \ptr -> fromPtr (Z :. len) ((), ptr)-  where (fp, len) = unsafeToForeignPtr0 v--toVectorIO :: (Storable a, Elt a, BlockPtrs (EltRepr a) ~ ((), Ptr a)) -           => Array DIM1 a -> IO (Vector a)-toVectorIO arr = do-  let (Z :. len) = arrayShape arr-  fp <- mallocForeignPtrArray len-  withForeignPtr fp $ \ptr -> toPtr arr ((), ptr)-  return $ unsafeFromForeignPtr0 fp len--fromVector :: (Storable a, Elt a, BlockPtrs (EltRepr a) ~ ((), Ptr a))-           => Vector a -> Array DIM1 a-fromVector v = unsafePerformIO $ fromVectorIO v--toVector :: (Storable a, Elt a, BlockPtrs (EltRepr a) ~ ((), Ptr a)) -         => Array DIM1 a -> Vector a-toVector arr = unsafePerformIO $ toVectorIO arr
Data/Array/Accelerate/Interpreter.hs view
@@ -36,22 +36,23 @@  -- standard libraries import Control.Monad-import Control.Monad.ST                            (ST)+import Control.Monad.ST                                 ( ST ) import Data.Bits-import Data.Char                                   (chr, ord)-import Prelude                                     hiding (sum)+import Data.Char                                        ( chr, ord )+import Prelude                                          hiding ( sum )  -- friends import Data.Array.Accelerate.Type import Data.Array.Accelerate.Array.Data-import Data.Array.Accelerate.Array.Representation  hiding (sliceIndex)+import Data.Array.Accelerate.Array.Representation       hiding ( sliceIndex ) import Data.Array.Accelerate.Array.Sugar (-  Z(..), (:.)(..), Array(..), Scalar, Vector, Segments)-import Data.Array.Accelerate.Array.Delayed+  Z(..), (:.)(..), Array(..), ArraysR(..), Arrays, Scalar, Vector, Segments) import Data.Array.Accelerate.AST import Data.Array.Accelerate.Tuple-import qualified Data.Array.Accelerate.Smart       as Sugar-import qualified Data.Array.Accelerate.Array.Sugar as Sugar+import Data.Array.Accelerate.Array.Delayed              hiding ( force, delay, Delayed )+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" @@ -72,33 +73,53 @@   where     acc = Sugar.convertAccFun1 afun -    run1 :: Delayable b => Afun (a -> b) -> a -> b+    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!"  +-- Delayed arrays+--+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)++ -- Array expression evaluation -- ---------------------------  -- Evaluate an open array expression ---evalOpenAcc :: Delayable a => OpenAcc aenv a -> Val aenv -> Delayed a+evalOpenAcc :: OpenAcc aenv a -> Val aenv -> Delayed a evalOpenAcc (OpenAcc acc) = evalPreOpenAcc acc -evalPreOpenAcc :: Delayable a => PreOpenAcc OpenAcc aenv a -> Val aenv -> Delayed a+evalPreOpenAcc :: forall aenv a. PreOpenAcc OpenAcc aenv a -> Val aenv -> Delayed a -evalPreOpenAcc (Alet acc1 acc2) aenv +evalPreOpenAcc (Alet acc1 acc2) aenv   = let !arr1 = force $ evalOpenAcc acc1 aenv     in evalOpenAcc acc2 (aenv `Push` arr1) -evalPreOpenAcc (Alet2 acc1 acc2) aenv -  = let (!arr1, !arr2) = force $ evalOpenAcc acc1 aenv-    in evalOpenAcc acc2 (aenv `Push` arr1 `Push` arr2)+evalPreOpenAcc (Avar idx) aenv = delay $ prj idx aenv -evalPreOpenAcc (PairArrays acc1 acc2) aenv-  = DelayedPair (evalOpenAcc acc1 aenv) (evalOpenAcc acc2 aenv)+evalPreOpenAcc (Atuple tup) aenv = delay (toTuple $ evalAtuple tup aenv :: a) -evalPreOpenAcc (Avar idx) aenv = delay $ prj idx aenv+evalPreOpenAcc (Aprj ix (tup :: OpenAcc aenv arrs)) aenv =+  let tup'  = force $ evalOpenAcc tup aenv :: arrs+  in  delay $ evalPrj ix (fromTuple tup')  evalPreOpenAcc (Apply (Alam (Abody funAcc)) acc) aenv   = let !arr = force $ evalOpenAcc acc aenv@@ -109,7 +130,7 @@ evalPreOpenAcc (Acond cond acc1 acc2) aenv   = if (evalExp cond aenv) then evalOpenAcc acc1 aenv else evalOpenAcc acc2 aenv -evalPreOpenAcc (Use arr) _aenv = delay arr+evalPreOpenAcc (Use arr) _aenv = delay (Sugar.toArr arr :: a)  evalPreOpenAcc (Unit e) aenv = unitOp (evalExp e aenv) @@ -137,11 +158,13 @@   = fold1Op (evalFun f aenv) (evalOpenAcc acc aenv)  evalPreOpenAcc (FoldSeg f e acc1 acc2) aenv-  = foldSegOp (evalFun f aenv) (evalExp e aenv) +  = foldSegOp integralType+              (evalFun f aenv) (evalExp e aenv)               (evalOpenAcc acc1 aenv) (evalOpenAcc acc2 aenv)  evalPreOpenAcc (Fold1Seg f acc1 acc2) aenv-  = fold1SegOp (evalFun f aenv) (evalOpenAcc acc1 aenv) (evalOpenAcc acc2 aenv)+  = fold1SegOp integralType+               (evalFun f aenv) (evalOpenAcc acc1 aenv) (evalOpenAcc acc2 aenv)  evalPreOpenAcc (Scanl f e acc) aenv   = scanlOp (evalFun f aenv) (evalExp e aenv) (evalOpenAcc acc aenv)@@ -162,7 +185,7 @@   = scanr1Op (evalFun f aenv) (evalOpenAcc acc aenv)  evalPreOpenAcc (Permute f dftAcc p acc) aenv-  = permuteOp (evalFun f aenv) (evalOpenAcc dftAcc aenv) +  = permuteOp (evalFun f aenv) (evalOpenAcc dftAcc aenv)               (evalFun p aenv) (evalOpenAcc acc aenv)  evalPreOpenAcc (Backpermute e p acc) aenv@@ -176,27 +199,38 @@  -- Evaluate a closed array expressions ---evalAcc :: Delayable a => Acc a -> Delayed a+evalAcc :: Acc a -> Delayed a evalAcc acc = evalOpenAcc acc Empty  +-- Array tuple construction and projection+--+evalAtuple :: Atuple (OpenAcc aenv) t -> Val aenv -> t+evalAtuple NilAtup        _    = ()+evalAtuple (SnocAtup t a) aenv = (evalAtuple t aenv, force $ evalOpenAcc a aenv)++ -- Array primitives -- ----------------  unitOp :: Sugar.Elt e => e -> Delayed (Scalar e)-unitOp e = DelayedArray {shapeDA = (), repfDA = const (Sugar.fromElt e)}+unitOp e+  = DelayedPair DelayedUnit+  $ DelayedArray {shapeDA = (), repfDA = const (Sugar.fromElt e)}  generateOp :: (Sugar.Shape dim, Sugar.Elt e)       => dim       -> (dim -> e)       -> Delayed (Array dim e)-generateOp sh rf = DelayedArray (Sugar.fromElt sh) (Sugar.sinkFromElt rf)+generateOp sh rf+  = DelayedPair DelayedUnit+  $ DelayedArray (Sugar.fromElt sh) (Sugar.sinkFromElt rf) -reshapeOp :: Sugar.Shape dim +reshapeOp :: Sugar.Shape dim           => dim -> Delayed (Array dim' e) -> Delayed (Array dim e)-reshapeOp newShape darr@(DelayedArray {shapeDA = oldShape})+reshapeOp newShape darr@(DelayedPair DelayedUnit (DelayedArray {shapeDA = oldShape}))   = let Array _ adata = force darr-    in +    in     BOUNDS_CHECK(check) "reshape" "shape mismatch" (Sugar.size newShape == size oldShape)     $ delay $ Array (Sugar.fromElt newShape) adata @@ -208,8 +242,8 @@             -> slix             -> Delayed (Array sl e)             -> Delayed (Array dim e)-replicateOp sliceIndex slix (DelayedArray sh pf)-  = DelayedArray sh' (pf . pf')+replicateOp sliceIndex slix (DelayedPair DelayedUnit (DelayedArray sh pf))+  = DelayedPair DelayedUnit (DelayedArray sh' (pf . pf'))   where     (sh', pf') = extend sliceIndex (Sugar.fromElt slix) sh @@ -235,8 +269,8 @@         -> Delayed (Array dim e)         -> slix         -> Delayed (Array sl e)-indexOp sliceIndex (DelayedArray sh pf) slix-  = DelayedArray sh' (pf . pf')+indexOp sliceIndex (DelayedPair DelayedUnit (DelayedArray sh pf)) slix+  = DelayedPair DelayedUnit (DelayedArray sh' (pf . pf'))   where     (sh', pf') = restrict sliceIndex (Sugar.fromElt slix) sh @@ -258,74 +292,105 @@       => (e -> e')        -> Delayed (Array dim e)        -> Delayed (Array dim e')-mapOp f (DelayedArray sh rf) = DelayedArray sh (Sugar.sinkFromElt f . rf)+mapOp f (DelayedPair DelayedUnit (DelayedArray sh rf))+  = DelayedPair DelayedUnit+  $ DelayedArray 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 (DelayedArray sh1 rf1) (DelayedArray sh2 rf2) -  = DelayedArray (sh1 `intersect` sh2) +zipWithOp f (DelayedPair DelayedUnit (DelayedArray sh1 rf1)) (DelayedPair DelayedUnit (DelayedArray sh2 rf2))+  = DelayedPair DelayedUnit+  $ DelayedArray (sh1 `intersect` sh2)                   (\ix -> (Sugar.sinkFromElt2 f) (rf1 ix) (rf2 ix)) -foldOp :: Sugar.Shape dim +foldOp :: Sugar.Shape dim        => (e -> e -> e)        -> e        -> Delayed (Array (dim:.Int) e)        -> Delayed (Array dim e)-foldOp f e (DelayedArray (sh, n) rf)-  = DelayedArray sh +foldOp f e (DelayedPair DelayedUnit (DelayedArray (sh, n) rf))+  | size sh == 0+  = DelayedPair DelayedUnit+  $ DelayedArray (listToShape . map (max 1) . shapeToList $ sh)+      (\_ -> Sugar.fromElt e)+  --+  | otherwise+  = DelayedPair DelayedUnit+  $ DelayedArray 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 (DelayedArray (sh, n) rf)-  = DelayedArray sh (\ix -> iter1 ((), n) (\((), i) -> rf (ix, i)) (Sugar.sinkFromElt2 f))-    -foldSegOp :: forall e dim.-             (e -> e -> e)+fold1Op f (DelayedPair DelayedUnit (DelayedArray (sh, n) rf))+  = DelayedPair DelayedUnit+  $ DelayedArray sh (\ix -> iter1 ((), n) (\((), i) -> rf (ix, i)) (Sugar.sinkFromElt2 f))++foldSegOp :: IntegralType i+          -> (e -> e -> e)           -> e           -> Delayed (Array (dim:.Int) e)-          -> Delayed Segments+          -> Delayed (Segments i)           -> Delayed (Array (dim:.Int) e)-foldSegOp f e (DelayedArray (sh, _n) rf) seg@(DelayedArray shSeg rfSeg)+foldSegOp ty f e arr seg+  | IntegralDict <- integralDict ty = foldSegOp' f e arr seg++foldSegOp' :: forall i e dim. Integral i+           => (e -> e -> e)+           -> e+           -> 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))   = delay arr   where-    DelayedPair (DelayedArray _shSeg rfStarts) _ = scanl'Op (+) 0 seg+    DelayedPair (DelayedPair DelayedUnit (DelayedArray _shSeg rfStarts)) _ = scanl'Op (+) 0 seg     arr = Sugar.newArray (Sugar.toElt (sh, Sugar.toElt shSeg)) foldOne     --     foldOne :: dim:.Int -> e     foldOne ix = let                    (ix', i) = Sugar.fromElt ix-                   start    = (Sugar.liftToElt rfStarts) i-                   len      = (Sugar.liftToElt rfSeg) i+                   start    = fromIntegral ((Sugar.liftToElt rfStarts) i :: i)+                   len      = fromIntegral ((Sugar.liftToElt rfSeg)    i :: i)                  in                  fold ix' e start (start + len)      fold :: Sugar.EltRepr dim -> e -> Int -> Int -> e-    fold ix' v j end+    fold ix' !v j end       | j >= end  = v       | otherwise = fold ix' (f v (Sugar.toElt . rf $ (ix', j))) (j + 1) end -fold1SegOp :: forall e dim.-              (e -> e -> e)++fold1SegOp :: IntegralType i+           -> (e -> e -> e)            -> Delayed (Array (dim:.Int) e)-           -> Delayed Segments+           -> Delayed (Segments i)            -> Delayed (Array (dim:.Int) e)-fold1SegOp f (DelayedArray (sh, _n) rf) seg@(DelayedArray shSeg rfSeg)+fold1SegOp ty f arr seg+  | IntegralDict <- integralDict ty = fold1SegOp' f arr seg+++fold1SegOp' :: forall i e dim. Integral i+            => (e -> e -> e)+            -> 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))   = delay arr   where-    DelayedPair (DelayedArray _shSeg rfStarts) _ = scanl'Op (+) 0 seg+    DelayedPair prefix _sum                                = scanl'Op (+) 0 seg+    DelayedPair DelayedUnit (DelayedArray _shSeg rfStarts) = prefix     arr = Sugar.newArray (Sugar.toElt (sh, Sugar.toElt shSeg)) foldOne     --     foldOne :: dim:.Int -> e     foldOne ix = let                    (ix', i) = Sugar.fromElt ix-                   start    = (Sugar.liftToElt rfStarts) i-                   len      = (Sugar.liftToElt rfSeg) i+                   start    = fromIntegral ((Sugar.liftToElt rfStarts) i :: i)+                   len      = fromIntegral ((Sugar.liftToElt rfSeg)    i :: i)                  in                  if len == 0                    then@@ -334,15 +399,16 @@                      fold ix' (Sugar.toElt . rf $ (ix', start)) (start + 1) (start + len)      fold :: Sugar.EltRepr dim -> e -> Int -> Int -> e-    fold ix' v j end+    fold ix' !v j end       | j >= end  = v       | otherwise = fold ix' (f v (Sugar.toElt . rf $ (ix', j))) (j + 1) end + scanlOp :: forall e. (e -> e -> e)         -> e         -> Delayed (Vector e)         -> Delayed (Vector e)-scanlOp f e (DelayedArray sh rf)+scanlOp f e (DelayedPair DelayedUnit (DelayedArray sh rf))   = delay $ adata `seq` Array ((), n + 1) adata   where     n  = size sh@@ -365,18 +431,19 @@          -> e          -> Delayed (Vector e)          -> Delayed (Vector e, Scalar e)-scanl'Op f e (DelayedArray sh rf)-  = DelayedPair (delay $ adata `seq` Array sh adata) -                (unitOp (Sugar.toElt final))+scanl'Op f e (DelayedPair DelayedUnit (DelayedArray sh rf))+  = DelayedPair (delay $ adata `seq` Array sh adata) final   where     n  = size sh     f' = Sugar.sinkFromElt2 f     ---    (adata, final) = runArrayData $ do-                       arr <- newArrayData n-                       sum <- traverse arr 0 (Sugar.fromElt e)-                       return (arr, sum)+    DelayedPair DelayedUnit final = unitOp (Sugar.toElt asum) +    (adata, asum) = runArrayData $ do+                      arr <- newArrayData n+                      sum <- traverse arr 0 (Sugar.fromElt e)+                      return (arr, sum)+     traverse :: MutableArrayData s (Sugar.EltRepr e) -> Int -> (Sugar.EltRepr e) -> ST s (Sugar.EltRepr e)     traverse arr i v       | i >= n    = return v@@ -387,7 +454,7 @@ scanl1Op :: forall e. (e -> e -> e)          -> Delayed (Vector e)          -> Delayed (Vector e)-scanl1Op f (DelayedArray sh rf)+scanl1Op f (DelayedPair DelayedUnit (DelayedArray sh rf))   = delay $ adata `seq` Array sh adata   where     n  = size sh@@ -414,7 +481,7 @@         -> e         -> Delayed (Vector e)         -> Delayed (Vector e)-scanrOp f e (DelayedArray sh rf)+scanrOp f e (DelayedPair DelayedUnit (DelayedArray sh rf))   = delay $ adata `seq` Array ((), n + 1) adata   where     n  = size sh@@ -437,18 +504,19 @@          -> e          -> Delayed (Vector e)          -> Delayed (Vector e, Scalar e)-scanr'Op f e (DelayedArray sh rf)-  = DelayedPair (delay $ adata `seq` Array sh adata)-                (unitOp (Sugar.toElt final))+scanr'Op f e (DelayedPair DelayedUnit (DelayedArray sh rf))+  = DelayedPair (delay $ adata `seq` Array sh adata) final   where     n  = size sh     f' = Sugar.sinkFromElt2 f     ---    (adata, final) = runArrayData $ do-                       arr <- newArrayData n-                       sum <- traverse arr (n-1) (Sugar.fromElt e)-                       return (arr, sum)+    DelayedPair DelayedUnit final = unitOp (Sugar.toElt asum) +    (adata, asum) = runArrayData $ do+                      arr <- newArrayData n+                      sum <- traverse arr (n-1) (Sugar.fromElt e)+                      return (arr, sum)+     traverse :: MutableArrayData s (Sugar.EltRepr e) -> Int -> (Sugar.EltRepr e) -> ST s (Sugar.EltRepr e)     traverse arr i v       | i < 0     = return v@@ -459,7 +527,7 @@ scanr1Op :: forall e. (e -> e -> e)          -> Delayed (Vector e)          -> Delayed (Vector e)-scanr1Op f (DelayedArray sh rf)+scanr1Op f (DelayedPair DelayedUnit (DelayedArray sh rf))   = delay $ adata `seq` Array sh adata   where     n  = size sh@@ -487,7 +555,8 @@           -> (dim -> dim')           -> Delayed (Array dim e)           -> Delayed (Array dim' e)-permuteOp f (DelayedArray dftsSh dftsPf) p (DelayedArray sh pf)+permuteOp f (DelayedPair DelayedUnit (DelayedArray dftsSh dftsPf))+          p (DelayedPair DelayedUnit (DelayedArray sh pf))   = delay $ adata `seq` Array dftsSh adata   where      f' = Sugar.sinkFromElt2 f@@ -512,7 +581,7 @@                               e <- readArrayData arr i                               writeArrayData arr i (pf ix `f'` e)            iter sh update (>>) (return ())-          +             -- return the updated array           return (arr, undefined) @@ -521,16 +590,18 @@               -> (dim' -> dim)               -> Delayed (Array dim e)               -> Delayed (Array dim' e)-backpermuteOp sh' p (DelayedArray _sh rf)-  = DelayedArray (Sugar.fromElt sh') (rf . Sugar.sinkFromElt p)+backpermuteOp sh' p (DelayedPair DelayedUnit (DelayedArray _sh rf))+  = DelayedPair DelayedUnit+  $ DelayedArray (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 (DelayedArray sh rf)-  = DelayedArray sh rf'+stencilOp sten bndy (DelayedPair DelayedUnit (DelayedArray sh rf))+  = DelayedPair DelayedUnit+  $ DelayedArray sh rf'   where     rf' = Sugar.sinkFromElt (sten . stencilAccess rfBounded) @@ -549,14 +620,14 @@            -> Boundary (Sugar.EltRepr e2)            -> Delayed (Array dim e2)            -> Delayed (Array dim e')-stencil2Op sten bndy1 (DelayedArray sh1 rf1) bndy2 (DelayedArray sh2 rf2)-  = DelayedArray (sh1 `intersect` sh2) rf'+stencil2Op sten bndy1 (DelayedPair DelayedUnit (DelayedArray sh1 rf1))+                bndy2 (DelayedPair DelayedUnit (DelayedArray sh2 rf2))+  = DelayedPair DelayedUnit (DelayedArray (sh1 `intersect` sh2) rf')   where     rf' = Sugar.sinkFromElt (\ix -> sten (stencilAccess rf1Bounded ix)                                          (stencilAccess rf2Bounded ix))      -- add a boundary to the source arrays as specified by the boundary conditions-         rf1Bounded :: dim -> e1     rf1Bounded ix = Sugar.toElt $ case Sugar.bound (Sugar.toElt sh1) ix bndy1 of                                      Left v    -> v@@ -636,7 +707,7 @@  evalOpenExp (IndexScalar acc ix) env aenv    = case evalOpenAcc acc aenv of-      DelayedArray sh pf -> +      DelayedPair DelayedUnit (DelayedArray sh pf) ->         let ix' = Sugar.fromElt $ evalOpenExp ix env aenv         in         index sh ix' `seq` (Sugar.toElt $ pf ix')@@ -644,12 +715,10 @@                               --       ensure bounds checking  evalOpenExp (Shape acc) _ aenv -  = case force $ evalOpenAcc acc aenv of-      Array sh _ -> Sugar.toElt sh+  = case evalOpenAcc acc aenv of+      DelayedPair DelayedUnit (DelayedArray sh _) -> Sugar.toElt sh -evalOpenExp (Size acc) _ aenv -  = case force $ evalOpenAcc acc aenv of-      Array sh _ -> size sh+evalOpenExp (ShapeSize sh) env aenv = size $ Sugar.fromElt $ evalOpenExp sh env aenv  -- Evaluate a closed expression --
Data/Array/Accelerate/Language.hs view
@@ -14,7 +14,7 @@ -- bit manipulation) to reify such expressions.  With non-overloaded -- operations (such as, the logical connectives) and partially overloaded -- operations (such as comparisons), we use the standard operator names with a--- '*' attached.  We keep the standard alphanumeric names as they can be+-- \'*\' attached.  We keep the standard alphanumeric names as they can be -- easily qualified. -- @@ -22,7 +22,7 @@    -- ** Array and scalar expressions   Acc, Exp,                                 -- re-exporting from 'Smart'-  +   -- ** Stencil specification   Boundary(..), Stencil,                    -- re-exporting from 'Smart' @@ -37,50 +37,49 @@    -- ** Array construction   use, unit, replicate, generate,-  fstA, sndA, pairA,    -- ** Shape manipulation   reshape,    -- ** Extraction of subarrays-  slice, -  +  slice,+   -- ** Map-like functions   map, zipWith,-  +   -- ** Reductions   fold, fold1, foldSeg, fold1Seg,-  +   -- ** Scan functions   scanl, scanl', scanl1, scanr, scanr', scanr1,-  +   -- ** Permutations-  permute, backpermute, -  +  permute, backpermute,+   -- ** Stencil operations   stencil, stencil2,-  +   -- ** Pipelining   (>->),-  +   -- ** Array-level flow-control   cond, (?|),    -- ** Lifting and unlifting   Lift(..), Unlift(..), lift1, lift2, ilift1, ilift2,-  +   -- ** Tuple construction and destruction   fst, snd, curry, uncurry,-  +   -- ** Index construction and destruction   index0, index1, unindex1, index2, unindex2,-  +   -- ** Conditional expressions   (?),-  +   -- ** Array operations with a scalar result-  (!), the, shape, size,-  +  (!), the, shape, size, shapeSize,+   -- ** Methods of H98 classes that we need to redefine as their signatures change   (==*), (/=*), (<*), (<=*), (>*), (>=*), max, min,   bit, setBit, clearBit, complementBit, testBit,@@ -90,7 +89,7 @@    -- ** Standard functions that we need to redefine as their signatures change   (&&*), (||*), not,-  +   -- ** Conversions   boolToInt, fromIntegral, @@ -116,7 +115,6 @@ 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.AST (Arrays)   -- Array introduction@@ -125,7 +123,7 @@ -- |Array inlet: makes an array available for processing using the Accelerate -- language; triggers asynchronous host->device transfer if necessary. ---use :: (Shape ix, Elt e) => Array ix e -> Acc (Array ix e)+use :: Arrays arrays => arrays -> Acc arrays use = Acc . Use  -- |Scalar inlet: injects a scalar (or a tuple of scalars) into a singleton@@ -144,14 +142,29 @@ -- yields a three dimensional array, where 'arr' is replicated twice across the -- first and three times across the third dimension. ---replicate :: (Slice slix, Elt e) -          => Exp slix -          -> Acc (Array (SliceShape slix) e) +replicate :: (Slice slix, Elt e)+          => Exp slix+          -> Acc (Array (SliceShape slix) e)           -> Acc (Array (FullShape  slix) e) replicate = Acc $$ Replicate  -- |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:+--+-- > generate (index1 3) (\_ -> 1.2)+--+-- Or, equivalently:+--+-- > generate (constant (Z :. (3::Int))) (\_ -> 1.2)+--+-- Finally, the following will create an array equivalent to '[1..10]':+--+-- > generate (index1 10) $ \ ix ->+-- >          let (Z :. i) = unlift ix+-- >          in fromIntegral i+-- generate :: (Shape ix, Elt a)          => Exp ix          -> (Exp ix -> Exp a)@@ -165,41 +178,41 @@ -- -- > precondition: size ix == size ix' ---reshape :: (Shape ix, Shape ix', Elt e) -        => Exp ix -        -> Acc (Array ix' e) +reshape :: (Shape ix, Shape ix', Elt e)+        => Exp ix+        -> Acc (Array ix' e)         -> Acc (Array ix e) reshape = Acc $$ Reshape --- Extraction of subarrays--- -----------------------+-- 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. ---slice :: (Slice slix, Elt e) -      => Acc (Array (FullShape slix) e) -      -> Exp slix +slice :: (Slice slix, Elt e)+      => Acc (Array (FullShape slix) e)+      -> Exp slix       -> Acc (Array (SliceShape slix) e) slice = Acc $$ Index  -- Map-like functions -- ------------------ --- |Apply the given function elementwise to the given array.--- -map :: (Shape ix, Elt a, Elt b) -    => (Exp a -> Exp b) +-- |Apply the given function element-wise to the given array.+--+map :: (Shape ix, Elt a, Elt b)+    => (Exp a -> Exp b)     -> Acc (Array ix a)     -> Acc (Array ix b) map = Acc $$ Map --- |Apply the given binary function elementwise 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)-        => (Exp a -> Exp b -> Exp c) +        => (Exp a -> Exp b -> Exp c)         -> Acc (Array ix a)         -> Acc (Array ix b)         -> Acc (Array ix c)@@ -210,19 +223,19 @@  -- |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) -     -> Exp a +     => (Exp a -> Exp a -> Exp a)+     -> Exp a      -> Acc (Array (ix:.Int) a)      -> 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.--- +-- fold1 :: (Shape ix, Elt a)-      => (Exp a -> Exp a -> Exp a) +      => (Exp a -> Exp a -> Exp a)       -> Acc (Array (ix:.Int) a)       -> Acc (Array ix a) fold1 = Acc $$ Fold1@@ -230,25 +243,27 @@ -- |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 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)-        => (Exp a -> Exp a -> Exp a) -        -> Exp a +foldSeg :: (Shape ix, Elt a, Elt i, IsIntegral i)+        => (Exp a -> Exp a -> Exp a)+        -> Exp a         -> Acc (Array (ix:.Int) a)-        -> Acc Segments+        -> Acc (Segments i)         -> 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. ----- The source array must have at least rank 1.+-- 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)-         => (Exp a -> Exp a -> Exp a) +fold1Seg :: (Shape ix, Elt a, Elt i, IsIntegral i)+         => (Exp a -> Exp a -> Exp a)          -> Acc (Array (ix:.Int) a)-         -> Acc Segments+         -> Acc (Segments i)          -> Acc (Array (ix:.Int) a) fold1Seg = Acc $$$ Fold1Seg @@ -266,7 +281,7 @@       -> Acc (Vector a) scanl = Acc $$$ Scanl --- |Variant of 'scanl', where the final result of the reduction is returned separately. +-- |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))@@ -279,9 +294,9 @@        -> Exp a        -> Acc (Vector a)        -> (Acc (Vector a), Acc (Scalar a))-scanl' = unpair . Acc $$$ Scanl'+scanl' = unlift . Acc $$$ Scanl' --- |'Data.List' style left-to-right scan without an intial value (aka inclusive scan).  Again, the+-- |'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@@ -304,14 +319,14 @@       -> 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)        -> Exp a        -> Acc (Vector a)        -> (Acc (Vector a), Acc (Scalar a))-scanr' = unpair . Acc $$$ Scanr'+scanr' = unlift . Acc $$$ Scanr'  -- |Right-to-left variant of 'scanl1'. --@@ -329,23 +344,23 @@ -- into the result array are added to the current value using the given -- combination function. ----- The combination function must be /associative/.  Eltents that are mapped to+-- The combination function must be /associative/.  Elements that are mapped to -- the magic value 'ignore' by the permutation function are being dropped. -- permute :: (Shape ix, Shape ix', Elt a)         => (Exp a -> Exp a -> Exp a)    -- ^combination function         -> Acc (Array ix' a)            -- ^array of default values         -> (Exp ix -> Exp ix')          -- ^permutation-        -> Acc (Array ix  a)            -- ^permuted array+        -> Acc (Array ix  a)            -- ^array to be permuted         -> Acc (Array ix' a) permute = Acc $$$$ Permute --- |Backward permutation +-- |Backward permutation -- backpermute :: (Shape ix, Shape ix', Elt a)             => Exp ix'                  -- ^shape of the result array             -> (Exp ix' -> Exp ix)      -- ^permutation-            -> Acc (Array ix  a)        -- ^permuted array+            -> Acc (Array ix  a)        -- ^source array             -> Acc (Array ix' a) backpermute = Acc $$$ Backpermute @@ -398,8 +413,8 @@ -- |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, +stencil2 :: (Shape ix, Elt a, Elt b, Elt c,+             Stencil ix a stencil1,              Stencil ix b stencil2)         => (stencil1 -> stencil2 -> Exp c)    -- ^binary stencil function         -> Boundary a                         -- ^boundary condition #1@@ -419,7 +434,7 @@ -- -- > (acc1 >-> acc2) arrs = let tmp = acc1 arrs in acc2 tmp ----- Operationally, the array computations 'acc1' and 'acc2' will not share any subcomputations,+-- Operationally, the array computations 'acc1' and 'acc2' will not share any sub-computations, -- neither between each other nor with the environment.  This makes them truly independent stages -- that only communicate by way of the result of 'acc1' which is being fed as an argument to 'acc2'. --@@ -447,300 +462,381 @@ c ?| (t, e) = cond c t e  --- Construction and destruction of array pairs--- ----------------------------------------------- |Extract the first component of an array pair.----fstA :: (Shape sh1, Shape sh2, Elt e1, Elt e2)-     => Acc (Array sh1 e1, Array sh2 e2)-     -> Acc (Array sh1 e1)-fstA = Acc . FstArray----- |Extract the second component of an array pair.----sndA :: (Shape sh1, Shape sh2, Elt e1, Elt e2)-     => Acc (Array sh1 e1, Array sh2 e2)-     -> Acc (Array sh2 e2)-sndA = Acc . SndArray---- |Create an array pair from two separate arrays.----pairA :: (Shape sh1, Shape sh2, Elt e1, Elt e2)-      => Acc (Array sh1 e1)-      -> Acc (Array sh2 e2)-      -> Acc (Array sh1 e1, Array sh2 e2)-pairA = Acc $$ PairArrays------ Lifting scalar expressions--- --------------------------+-- Lifting surface expressions+-- --------------------------- -class Lift e where+class Lift c e where   type Plain e -  -- |Lift the given value into 'Exp'.  The value may already contain subexpressions in 'Exp'.-  -- -  lift :: e -> Exp (Plain e)-  -class Lift e => Unlift e where+  -- | Lift the given value into a surface type 'c' --- either 'Exp' for scalar+  -- expressions or 'Acc' for array computations. The value may already contain+  -- subexpressions in 'c'.+  --+  lift :: e -> c (Plain e) -  -- |Unlift the outmost constructor through 'Exp'.  This is only possible if the constructor is-  -- fully determined by its type - i.e., it is a singleton.-  -- -  unlift :: Exp (Plain e) -> e+class Lift c e => Unlift c e where +  -- | Unlift the outermost constructor through the surface type. This is only+  -- possible if the constructor is fully determined by its type - i.e., it is a+  -- singleton.+  --+  unlift :: c (Plain e) -> e+ -- instances for indices -instance Lift () where+instance Lift Exp () where   type Plain () = ()   lift _ = Exp $ Tuple NilTup -instance Unlift () where+instance Unlift Exp () where   unlift _ = () -instance Lift Z where+instance Lift Exp Z where   type Plain Z = Z   lift _ = Exp $ IndexNil -instance Unlift Z where+instance Unlift Exp Z where   unlift _ = Z -instance (Slice (Plain ix), Lift ix) => Lift (ix :. Int) where+instance (Slice (Plain ix), Lift Exp ix) => Lift Exp (ix :. Int) where   type Plain (ix :. Int) = Plain ix :. Int   lift (ix:.i) = Exp $ IndexCons (lift ix) (Exp $ Const i) -instance (Slice (Plain ix), Lift ix) => Lift (ix :. All) where+instance (Slice (Plain ix), Lift Exp ix) => Lift Exp (ix :. All) where   type Plain (ix :. All) = Plain ix :. All   lift (ix:.i) = Exp $ IndexCons (lift ix) (Exp $ Const i) -instance (Elt e, Slice (Plain ix), Lift ix) => Lift (ix :. Exp e) where+instance (Elt e, Slice (Plain ix), Lift Exp ix) => Lift Exp (ix :. Exp e) where   type Plain (ix :. Exp e) = Plain ix :. e   lift (ix:.i) = Exp $ IndexCons (lift ix) i -instance (Elt e, Slice (Plain ix), Unlift ix) => Unlift (ix :. Exp e) where+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 Shape sh => Lift (Any sh) where+instance Shape sh => Lift Exp (Any sh) where  type Plain (Any sh) = Any sh  lift Any = Exp $ IndexAny  -- instances for numeric types -instance Lift Int where+instance Lift Exp Int where   type Plain Int = Int   lift = Exp . Const-  -instance Lift Int8 where++instance Lift Exp Int8 where   type Plain Int8 = Int8   lift = Exp . Const-  -instance Lift Int16 where++instance Lift Exp Int16 where   type Plain Int16 = Int16   lift = Exp . Const-  -instance Lift Int32 where++instance Lift Exp Int32 where   type Plain Int32 = Int32   lift = Exp . Const-  -instance Lift Int64 where++instance Lift Exp Int64 where   type Plain Int64 = Int64   lift = Exp . Const-  -instance Lift Word where++instance Lift Exp Word where   type Plain Word = Word   lift = Exp . Const-  -instance Lift Word8 where++instance Lift Exp Word8 where   type Plain Word8 = Word8   lift = Exp . Const-  -instance Lift Word16 where++instance Lift Exp Word16 where   type Plain Word16 = Word16   lift = Exp . Const-  -instance Lift Word32 where++instance Lift Exp Word32 where   type Plain Word32 = Word32   lift = Exp . Const-  -instance Lift Word64 where++instance Lift Exp Word64 where   type Plain Word64 = Word64   lift = Exp . Const -{-  -instance Lift CShort where+{-+instance Lift Exp CShort where   type Plain CShort = CShort   lift = Exp . Const-  -instance Lift CUShort where++instance Lift Exp CUShort where   type Plain CUShort = CUShort   lift = Exp . Const-  -instance Lift CInt where++instance Lift Exp CInt where   type Plain CInt = CInt   lift = Exp . Const-  -instance Lift CUInt where++instance Lift Exp CUInt where   type Plain CUInt = CUInt   lift = Exp . Const-  -instance Lift CLong where++instance Lift Exp CLong where   type Plain CLong = CLong   lift = Exp . Const-  -instance Lift CULong where++instance Lift Exp CULong where   type Plain CULong = CULong   lift = Exp . Const-  -instance Lift CLLong where++instance Lift Exp CLLong where   type Plain CLLong = CLLong   lift = Exp . Const-  -instance Lift CULLong where++instance Lift Exp CULLong where   type Plain CULLong = CULLong   lift = Exp . Const  -}- -instance Lift Float where++instance Lift Exp Float where   type Plain Float = Float   lift = Exp . Const -instance Lift Double where+instance Lift Exp Double where   type Plain Double = Double   lift = Exp . Const  {--instance Lift CFloat where+instance Lift Exp CFloat where   type Plain CFloat = CFloat   lift = Exp . Const -instance Lift CDouble where+instance Lift Exp CDouble where   type Plain CDouble = CDouble   lift = Exp . Const  -} -instance Lift Bool where+instance Lift Exp Bool where   type Plain Bool = Bool   lift = Exp . Const -instance Lift Char where+instance Lift Exp Char where   type Plain Char = Char   lift = Exp . Const  {--instance Lift CChar where+instance Lift Exp CChar where   type Plain CChar = CChar   lift = Exp . Const -instance Lift CSChar where+instance Lift Exp CSChar where   type Plain CSChar = CSChar   lift = Exp . Const -instance Lift CUChar where-  type Plain CUChar = CUChar+instance Lift Exp CUChar where++type Plain CUChar = CUChar   lift = Exp . Const  -}  -- Instances for tuples -instance (Lift a, Lift b, Elt (Plain a), Elt (Plain b)) => Lift (a, b) where+instance (Lift Exp a, Lift Exp b, Elt (Plain a), Elt (Plain b)) => Lift Exp (a, b) where   type Plain (a, b) = (Plain a, Plain b)   lift (x, y) = tup2 (lift x, lift y) -instance (Elt a, Elt b) => Unlift (Exp a, Exp b) where+instance (Elt a, Elt b) => Unlift Exp (Exp a, Exp b) where   unlift = untup2 -instance (Lift a, Lift b, Lift c, Elt (Plain a), Elt (Plain b), Elt (Plain c)) => Lift (a, b, c) where+instance (Lift Exp a, Lift Exp b, Lift Exp c,+          Elt (Plain a), Elt (Plain b), Elt (Plain c))+  => Lift Exp (a, b, c) where   type Plain (a, b, c) = (Plain a, Plain b, Plain c)   lift (x, y, z) = tup3 (lift x, lift y, lift z) -instance (Elt a, Elt b, Elt c) => Unlift (Exp a, Exp b, Exp c) where+instance (Elt a, Elt b, Elt c) => Unlift Exp (Exp a, Exp b, Exp c) where   unlift = untup3 -instance (Lift a, Lift b, Lift c, Lift d,-          Elt (Plain a), Elt (Plain b), Elt (Plain c), Elt (Plain d)) -  => Lift (a, b, c, d) where+instance (Lift Exp a, Lift Exp b, Lift Exp c, Lift Exp d,+          Elt (Plain a), Elt (Plain b), Elt (Plain c), Elt (Plain d))+  => Lift Exp (a, b, c, d) where   type Plain (a, b, c, d) = (Plain a, Plain b, Plain c, Plain d)   lift (x, y, z, u) = tup4 (lift x, lift y, lift z, lift u) -instance (Elt a, Elt b, Elt c, Elt d) => Unlift (Exp a, Exp b, Exp c, Exp d) where+instance (Elt a, Elt b, Elt c, Elt d) => Unlift Exp (Exp a, Exp b, Exp c, Exp d) where   unlift = untup4 -instance (Lift a, Lift b, Lift c, Lift d, Lift e,-          Elt (Plain a), Elt (Plain b), Elt (Plain c), Elt (Plain d), Elt (Plain e)) -  => Lift (a, b, c, d, e) where+instance (Lift Exp a, Lift Exp b, Lift Exp c, Lift Exp d, Lift Exp e,+          Elt (Plain a), Elt (Plain b), Elt (Plain c), Elt (Plain d), Elt (Plain e))+  => Lift Exp (a, b, c, d, e) where   type Plain (a, b, c, d, e) = (Plain a, Plain b, Plain c, Plain d, Plain e)   lift (x, y, z, u, v) = tup5 (lift x, lift y, lift z, lift u, lift v) -instance (Elt a, Elt b, Elt c, Elt d, Elt e) => Unlift (Exp a, Exp b, Exp c, Exp d, Exp e) where+instance (Elt a, Elt b, Elt c, Elt d, Elt e)+  => Unlift Exp (Exp a, Exp b, Exp c, Exp d, Exp e) where   unlift = untup5 -instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f,-          Elt (Plain a), Elt (Plain b), Elt (Plain c), Elt (Plain d), Elt (Plain e), Elt (Plain f)) -  => Lift (a, b, c, d, e, f) where+instance (Lift Exp a, Lift Exp b, Lift Exp c, Lift Exp d, Lift Exp e, Lift Exp f,+          Elt (Plain a), Elt (Plain b), Elt (Plain c), Elt (Plain d), Elt (Plain e), Elt (Plain f))+  => Lift Exp (a, b, c, d, e, f) where   type Plain (a, b, c, d, e, f) = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f)   lift (x, y, z, u, v, w) = tup6 (lift x, lift y, lift z, lift u, lift v, lift w) -instance (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f) -  => Unlift (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f) where+instance (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f)+  => Unlift Exp (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f) where   unlift = untup6 -instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f, Lift g,+instance (Lift Exp a, Lift Exp b, Lift Exp c, Lift Exp d, Lift Exp e, Lift Exp f, Lift Exp g,           Elt (Plain a), Elt (Plain b), Elt (Plain c), Elt (Plain d), Elt (Plain e), Elt (Plain f),-          Elt (Plain g)) -  => Lift (a, b, c, d, e, f, g) where+          Elt (Plain g))+  => Lift Exp (a, b, c, d, e, f, g) where   type Plain (a, b, c, d, e, f, g) = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g)   lift (x, y, z, u, v, w, r) = tup7 (lift x, lift y, lift z, lift u, lift v, lift w, lift r) -instance (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g) -  => Unlift (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g) where+instance (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g)+  => Unlift Exp (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g) where   unlift = untup7 -instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f, Lift g, Lift h,+instance (Lift Exp a, Lift Exp b, Lift Exp c, Lift Exp d, Lift Exp e, Lift Exp f, Lift Exp g, Lift Exp h,           Elt (Plain a), Elt (Plain b), Elt (Plain c), Elt (Plain d), Elt (Plain e), Elt (Plain f),-          Elt (Plain g), Elt (Plain h)) -  => Lift (a, b, c, d, e, f, g, h) where-  type Plain (a, b, c, d, e, f, g, h) +          Elt (Plain g), Elt (Plain h))+  => Lift Exp (a, b, c, d, e, f, g, h) where+  type Plain (a, b, c, d, e, f, g, h)     = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g, Plain h)-  lift (x, y, z, u, v, w, r, s) +  lift (x, y, z, u, v, w, r, s)     = tup8 (lift x, lift y, lift z, lift u, lift v, lift w, lift r, lift s) -instance (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h) -  => Unlift (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h) where+instance (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h)+  => Unlift Exp (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h) where   unlift = untup8 -instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f, Lift g, Lift h, Lift i,-          Elt (Plain a), Elt (Plain b), Elt (Plain c), Elt (Plain d), Elt (Plain e), Elt (Plain f),-          Elt (Plain g), Elt (Plain h), Elt (Plain i)) -  => Lift (a, b, c, d, e, f, g, h, i) where-  type Plain (a, b, c, d, e, f, g, h, i) +instance (Lift Exp a, Lift Exp b, Lift Exp c, Lift Exp d, Lift Exp e,+          Lift Exp f, Lift Exp g, Lift Exp h, Lift Exp i,+          Elt (Plain a), Elt (Plain b), Elt (Plain c), Elt (Plain d), Elt (Plain e),+          Elt (Plain f), Elt (Plain g), Elt (Plain h), Elt (Plain i))+  => Lift Exp (a, b, c, d, e, f, g, h, i) where+  type Plain (a, b, c, d, e, f, g, h, i)     = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g, Plain h, Plain i)-  lift (x, y, z, u, v, w, r, s, t) +  lift (x, y, z, u, v, w, r, s, t)     = tup9 (lift x, lift y, lift z, lift u, lift v, lift w, lift r, lift s, lift t) -instance (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i) -  => Unlift (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i) where+instance (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i)+  => Unlift Exp (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i) where   unlift = untup9  -- Instance for scalar Accelerate expressions -instance Lift (Exp e) where+instance Lift Exp (Exp e) where   type Plain (Exp e) = e   lift = id ++-- Instance for Accelerate array computations++instance Lift Acc (Acc a) where+  type Plain (Acc a) = a+  lift = id++-- Instances for Arrays class++--instance Lift Acc () where+--  type Plain () = ()+--  lift _ = Acc (Atuple NilAtup)++instance (Shape sh, Elt e) => Lift Acc (Array sh e) where+  type Plain (Array sh e) = Array sh e+  lift = Acc . Use++instance (Lift Acc a, Lift Acc b, Arrays (Plain a), Arrays (Plain b)) => Lift Acc (a, b) where+  type Plain (a, b) = (Plain a, Plain b)+  lift (x, y) = atup2 (lift x, lift y)++instance (Arrays a, Arrays b) => Unlift Acc (Acc a, Acc b) where+  unlift = unatup2++instance (Lift Acc a, Lift Acc b, Lift Acc c,+          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c))+  => Lift Acc (a, b, c) where+  type Plain (a, b, c) = (Plain a, Plain b, Plain c)+  lift (x, y, z) = atup3 (lift x, lift y, lift z)++instance (Arrays a, Arrays b, Arrays c) => Unlift Acc (Acc a, Acc b, Acc c) where+  unlift = unatup3++instance (Lift Acc a, Lift Acc b, Lift Acc c, Lift Acc d,+          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d))+  => Lift Acc (a, b, c, d) where+  type Plain (a, b, c, d) = (Plain a, Plain b, Plain c, Plain d)+  lift (x, y, z, u) = atup4 (lift x, lift y, lift z, lift u)++instance (Arrays a, Arrays b, Arrays c, Arrays d) => Unlift Acc (Acc a, Acc b, Acc c, Acc d) where+  unlift = unatup4++instance (Lift Acc a, Lift Acc b, Lift Acc c, Lift Acc d, Lift Acc e,+          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d), Arrays (Plain e))+  => Lift Acc (a, b, c, d, e) where+  type Plain (a, b, c, d, e) = (Plain a, Plain b, Plain c, Plain d, Plain e)+  lift (x, y, z, u, v) = atup5 (lift x, lift y, lift z, lift u, lift v)++instance (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e)+  => Unlift Acc (Acc a, Acc b, Acc c, Acc d, Acc e) where+  unlift = unatup5++instance (Lift Acc a, Lift Acc b, Lift Acc c, Lift Acc d, Lift Acc e, Lift Acc f,+          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d), Arrays (Plain e), Arrays (Plain f))+  => Lift Acc (a, b, c, d, e, f) where+  type Plain (a, b, c, d, e, f) = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f)+  lift (x, y, z, u, v, w) = atup6 (lift x, lift y, lift z, lift u, lift v, lift w)++instance (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f)+  => Unlift Acc (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f) where+  unlift = unatup6++instance (Lift Acc a, Lift Acc b, Lift Acc c, Lift Acc d, Lift Acc e, Lift Acc f, Lift Acc g,+          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d), Arrays (Plain e), Arrays (Plain f),+          Arrays (Plain g))+  => Lift Acc (a, b, c, d, e, f, g) where+  type Plain (a, b, c, d, e, f, g) = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g)+  lift (x, y, z, u, v, w, r) = atup7 (lift x, lift y, lift z, lift u, lift v, lift w, lift r)++instance (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g)+  => Unlift Acc (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g) where+  unlift = unatup7++instance (Lift Acc a, Lift Acc b, Lift Acc c, Lift Acc d, Lift Acc e, Lift Acc f, Lift Acc g, Lift Acc h,+          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d), Arrays (Plain e), Arrays (Plain f),+          Arrays (Plain g), Arrays (Plain h))+  => Lift Acc (a, b, c, d, e, f, g, h) where+  type Plain (a, b, c, d, e, f, g, h)+    = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g, Plain h)+  lift (x, y, z, u, v, w, r, s)+    = atup8 (lift x, lift y, lift z, lift u, lift v, lift w, lift r, lift s)++instance (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h)+  => Unlift Acc (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h) where+  unlift = unatup8++instance (Lift Acc a, Lift Acc b, Lift Acc c, Lift Acc d, Lift Acc e,+          Lift Acc f, Lift Acc g, Lift Acc h, Lift Acc i,+          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d), Arrays (Plain e),+          Arrays (Plain f), Arrays (Plain g), Arrays (Plain h), Arrays (Plain i))+  => Lift Acc (a, b, c, d, e, f, g, h, i) where+  type Plain (a, b, c, d, e, f, g, h, i)+    = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g, Plain h, Plain i)+  lift (x, y, z, u, v, w, r, s, t)+    = atup9 (lift x, lift y, lift z, lift u, lift v, lift w, lift r, lift s, lift t)++instance (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i)+  => Unlift Acc (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i) where+  unlift = unatup9++ -- Helpers to lift functions  -- |Lift a unary function into 'Exp'. ---lift1 :: (Unlift e1, Lift e2) +lift1 :: (Unlift Exp e1, Lift Exp e2)       => (e1 -> e2) -> Exp (Plain e1) -> Exp (Plain e2) lift1 f = lift . f . unlift  -- |Lift a binary function into 'Exp'. ---lift2 :: (Unlift e1, Unlift e2, Lift e3) +lift2 :: (Unlift Exp e1, Unlift Exp e2, Lift Exp e3)       => (e1 -> e2 -> e3) -> Exp (Plain e1) -> Exp (Plain e2) -> Exp (Plain e3) lift2 f x y = lift $ f (unlift x) (unlift y) @@ -789,18 +885,18 @@ index1 :: Exp Int -> Exp (Z:. Int) index1 = lift . (Z:.) --- |Turn an 'Int' expression into a rank-1 indexing expression.+-- |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-  --- | Creates a rank-2 index from two exp ints.--- ++-- | Creates a rank-2 index from two Exp Int`s+-- index2 :: Exp Int -> Exp Int -> Exp DIM2 index2 i j = lift (Z :. i :. j) --- | Destructs a rank-2 index to an exp tuple of two ints.--- +-- | 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)) @@ -837,9 +933,15 @@ -- |Expression form that yields the size of an array. -- size :: (Shape ix, Elt e) => Acc (Array ix e) -> Exp Int-size = Exp . Size+size = shapeSize . shape +-- |The same as `size` but not operates directly on a shape without the+--  array.+--+shapeSize :: Shape ix => Exp ix -> Exp Int+shapeSize = Exp . ShapeSize + -- Instances of all relevant H98 classes -- ------------------------------------- @@ -1030,7 +1132,7 @@  -- |Convert a Boolean value to an 'Int', where 'False' turns into '0' and 'True' -- into '1'.--- +-- boolToInt :: Exp Bool -> Exp Int boolToInt = mkBoolToInt @@ -1047,3 +1149,4 @@ -- ignore :: Shape ix => Exp ix ignore = constant Sugar.ignore+
Data/Array/Accelerate/Prelude.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators, ScopedTypeVariables #-} -- | -- Module      : Data.Array.Accelerate.Prelude -- Copyright   : [2010..2011] Manuel M T Chakravarty, Ben Lever@@ -15,82 +15,142 @@ module Data.Array.Accelerate.Prelude (    -- ** Map-like-  zip, unzip, zip3,-  +  zip, zip3, zip4,+  unzip, unzip3, unzip4,+   -- ** Reductions   foldAll, fold1All,-  +   -- ** Scans-  prescanl, postscanl, prescanr, postscanr, +  prescanl, postscanl, prescanr, postscanr,    -- ** Segmented scans-  scanlSeg, scanlSeg', scanl1Seg, prescanlSeg, postscanlSeg, -  scanrSeg, scanrSeg', scanr1Seg, prescanrSeg, postscanrSeg,-  +  scanlSeg, scanl'Seg, scanl1Seg, prescanlSeg, postscanlSeg,+  scanrSeg, scanr'Seg, scanr1Seg, prescanrSeg, postscanrSeg,+   -- ** Reshaping of arrays-  flatten+  flatten, +  -- ** Enumeration and filling+  fill, enumFromN, enumFromStepN,++  -- ** Gather and scatter+  gather, gatherIf, scatter, scatterIf,++  -- ** Subvector extraction+  init, tail, take, drop, slit+ ) where  -- avoid clashes with Prelude functions-import Prelude   hiding (replicate, zip, unzip, zip3, map, scanl, scanl1, scanr, scanr1, zipWith,-                         filter, max, min, not, fst, snd, curry, uncurry)+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 --- friends  +-- friends import Data.Array.Accelerate.Array.Sugar hiding ((!), ignore, shape, size, index) import Data.Array.Accelerate.Language+import Data.Array.Accelerate.Type   -- Map-like composites -- ------------------- --- |Combine the elements of two arrays pairwise.  The shape of the result is +-- |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) +zip :: (Shape sh, Elt a, Elt b)     => Acc (Array sh a)     -> Acc (Array sh b)     -> Acc (Array sh (a, b)) zip = zipWith (curry lift) +-- |Take three arrays and 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)+     -> Acc (Array sh b)+     -> Acc (Array sh c)+     -> Acc (Array sh (a, b, c))+zip3 as bs cs+  = 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.+--+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)+     -> Acc (Array sh b)+     -> Acc (Array sh c)+     -> Acc (Array sh d)+     -> Acc (Array sh (a, b, c, d))+zip4 as bs cs ds+  = 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 -- shape of the argument.--- +-- unzip :: (Shape sh, Elt a, Elt b)       => Acc (Array sh (a, b))       -> (Acc (Array sh a), Acc (Array sh b)) unzip arr = (map fst arr, map snd arr) --- | Takes three arrays and produces an array of a three-tuple.---   TODO Maybe there is a better way to implement this but with 2 zips?!+-- |Take an array of triples and return three arrays, analogous to unzip. ---zip3 :: forall a b c sh. (Shape sh, Elt a, Elt b, Elt c) -     => Acc (Array sh a) -> Acc (Array sh b) -> Acc (Array sh c) -> Acc (Array sh (a, b, c))-zip3 a b c = zipWith f a $ zip b c+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)   where-    f a bc = let (b, c) = unlift bc :: (Exp b, Exp c)-             in -             lift (a, b, c) :: Exp (a, b, c)+    (bs, cs)  = unzip bcs+    (as, bcs) = unzip $ map swizzle abcs +    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)++-- |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)+  where+    (abs, cds)  = unzip $ map swizzle abcds+    (as,  bs)   = unzip abs+    (cs,  ds)   = unzip cds++    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)++ -- 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.--- +-- foldAll :: (Shape sh, Elt a)-        => (Exp a -> Exp a -> Exp a) -        -> Exp 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)  -- |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) +         => (Exp a -> Exp a -> Exp a)          -> Acc (Array sh a)          -> Acc (Scalar a) fold1All f arr = fold1 f (reshape (index1 $ size arr) arr)@@ -151,11 +211,11 @@  -- |Segmented version of 'scanl'. ---scanlSeg :: Elt a+scanlSeg :: forall a i. (Elt a, Elt i, IsIntegral i)          => (Exp a -> Exp a -> Exp a)          -> Exp a          -> Acc (Vector a)-         -> Acc Segments+         -> Acc (Segments i)          -> Acc (Vector a) scanlSeg f e arr seg = scans   where@@ -165,45 +225,45 @@     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)+    headFlags  = permute (+) zerosArr' (\ix -> index1' $ segOffsets' ! ix)+               $ generate (shape seg) (const (1 :: Exp i)) -    arrShifted = backpermute nSh (\ix -> index1 $ shiftCoords ! ix) arr+    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+    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)+    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      ---    nSh       = index1 $ size arr + size 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 '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 -- the segment vector. ---scanlSeg' :: Elt a+scanl'Seg :: forall a i. (Elt a, Elt i, IsIntegral i)           => (Exp a -> Exp a -> Exp a)           -> Exp a           -> Acc (Vector a)-          -> Acc Segments+          -> Acc (Segments i)           -> (Acc (Vector a), Acc (Vector a))-scanlSeg' f e arr seg = (scans, sums)+scanl'Seg f e arr seg = (scans, sums)   where     -- Segmented scan' implemented by performing segmented exclusive-scan on vector     -- fromed by inserting identity element in at the start of each segment, shifting@@ -211,8 +271,8 @@     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 Int))+    headFlags  = permute (+) zerosArr (\ix -> index1' $ segOffsets ! ix)+               $ generate (shape seg) (const (1 :: Exp i))     segOffsets = Prelude.fst $ scanl' (+) 0 seg      arrShifted = backpermute (shape arr) (ilift1 $ \i -> i ==* 0 ? (i, i - 1)) arr@@ -223,46 +283,46 @@     -- 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)+               $ backpermute (shape seg) (\ix -> index1' $ sumOffsets ! ix)                $ scanl1Seg f arr seg     sumOffsets = map (subtract 1) $ scanl1 (+) seg  -- |Segmented version of 'scanl1'. ---scanl1Seg :: Elt a+scanl1Seg :: (Elt a, Elt i, IsIntegral i)           => (Exp a -> Exp a -> Exp a)           -> Acc (Vector a)-          -> Acc Segments+          -> Acc (Segments i)           -> Acc (Vector a) scanl1Seg f arr seg = map snd $ scanl1 (mkSegApply f) $ zip (mkHeadFlags seg) arr  -- |Segmented version of 'prescanl'. ---prescanlSeg :: Elt a+prescanlSeg :: (Elt a, Elt i, IsIntegral i)             => (Exp a -> Exp a -> Exp a)             -> Exp a             -> Acc (Vector a)-            -> Acc Segments+            -> Acc (Segments i)             -> Acc (Vector a)-prescanlSeg f e arr seg = Prelude.fst $ scanlSeg' f e arr seg+prescanlSeg f e arr seg = Prelude.fst $ scanl'Seg f e arr seg  -- |Segmented version of 'postscanl'. ---postscanlSeg :: Elt a+postscanlSeg :: (Elt a, Elt i, IsIntegral i)              => (Exp a -> Exp a -> Exp a)              -> Exp a              -> Acc (Vector a)-             -> Acc Segments+             -> Acc (Segments i)              -> Acc (Vector a) postscanlSeg f e arr seg = map (e `f`) $ scanl1Seg f arr seg  -- |Segmented version of 'scanr'. ---scanrSeg :: Elt a+scanrSeg :: forall a i. (Elt a, Elt i, IsIntegral i)          => (Exp a -> Exp a -> Exp a)          -> Exp a          -> Acc (Vector a)-         -> Acc Segments+         -> Acc (Segments i)          -> Acc (Vector a) scanrSeg f e arr seg = scans   where@@ -270,46 +330,46 @@     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)+    tailFlags  = permute (+) zerosArr' (\ix -> index1' $ (segOffsets' ! ix) - 1)+               $ generate (shape seg) (const (1 :: Exp i)) -    arrShifted = backpermute nSh (\ix -> index1 $ shiftCoords ! ix) arr+    arrShifted = backpermute nSh (\ix -> index1' $ shiftCoords ! ix) arr      idsArr     = generate nSh (const e)      ---    shiftCoords = permute (+) zerosArr' (ilift1 $ \i -> i + (offsetArr ! index1 i)) coords+    shiftCoords = permute (+) zerosArr' (ilift1 $ \i -> i + (offsetArr ! index1' i)) coords     coords      = Prelude.fst $ scanl' (+) 0 onesArr -    offsetArr   = scanl1 max $ permute (+) zerosArr (\ix -> index1 $ segOffsets ! ix) segIxs+    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+    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 'scanrSeg\''.+-- | Segmented version of 'scanr''. ---scanrSeg' :: Elt a-            => (Exp a -> Exp a -> Exp a)-            -> Exp a-            -> Acc (Vector a)-            -> Acc Segments-            -> (Acc (Vector a), Acc (Vector a))-scanrSeg' f e arr seg = (scans, sums)+scanr'Seg :: forall a i. (Elt a, Elt i, IsIntegral i)+          => (Exp a -> Exp a -> Exp a)+          -> Exp a+          -> Acc (Vector a)+          -> Acc (Segments i)+          -> (Acc (Vector a), Acc (Vector a))+scanr'Seg f e arr seg = (scans, sums)   where-    -- Using technique described for scanlSeg'.+    -- 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 -    tailFlags  = permute (+) zerosArr (\ix -> index1 $ (segOffsets ! ix) - 1)-               $ generate (shape seg) (const (1 :: Exp Int))+    tailFlags  = permute (+) zerosArr (\ix -> index1' $ (segOffsets ! ix) - 1)+               $ generate (shape seg) (const (1 :: Exp i))     segOffsets = scanl1 (+) seg      arrShifted = backpermute (shape arr) (ilift1 $ \i -> i ==* (size arr - 1) ? (i, i + 1)) arr@@ -318,36 +378,36 @@     zerosArr   = generate (shape arr) (const 0)      ---    sums       = map (`f` e) $  backpermute (shape seg) (\ix -> index1 $ sumOffsets ! ix)+    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+scanr1Seg :: (Elt a, Elt i, IsIntegral i)           => (Exp a -> Exp a -> Exp a)           -> Acc (Vector a)-          -> Acc Segments+          -> Acc (Segments i)           -> Acc (Vector a) scanr1Seg f arr seg = map snd $ scanr1 (mkSegApply f) $ zip (mkTailFlags seg) arr  -- |Segmented version of 'prescanr'. ---prescanrSeg :: Elt a+prescanrSeg :: (Elt a, Elt i, IsIntegral i)             => (Exp a -> Exp a -> Exp a)             -> Exp a             -> Acc (Vector a)-            -> Acc Segments+            -> Acc (Segments i)             -> Acc (Vector a)-prescanrSeg f e arr seg = Prelude.fst $ scanrSeg' f e arr seg+prescanrSeg f e arr seg = Prelude.fst $ scanr'Seg f e arr seg  -- |Segmented version of 'postscanr'. ---postscanrSeg :: Elt a+postscanrSeg :: (Elt a, Elt i, IsIntegral i)              => (Exp a -> Exp a -> Exp a)              -> Exp a              -> Acc (Vector a)-             -> Acc Segments+             -> Acc (Segments i)              -> Acc (Vector a) postscanrSeg f e arr seg = map (`f` e) $ scanr1Seg f arr seg @@ -357,37 +417,43 @@  -- |Compute head flags vector from segment vector for left-scans. ---mkHeadFlags :: Acc (Array DIM1 Int) -> Acc (Array DIM1 Int)-mkHeadFlags seg = permute (\_ _ -> 1) zerosArr (\ix -> index1 (segOffsets ! ix)) segOffsets+mkHeadFlags :: (Elt i, IsIntegral i) => Acc (Segments i) -> Acc (Segments i)+mkHeadFlags seg = permute (\_ _ -> 1) zerosArr (\ix -> index1' (segOffsets ! ix)) segOffsets   where     (segOffsets, len) = scanl' (+) 0 seg-    zerosArr          = generate (index1 $ the len) (const 0)+    zerosArr          = generate (index1' $ the len) (const 0)  -- |Compute tail flags vector from segment vector for right-scans. ---mkTailFlags :: Acc (Array DIM1 Int) -> Acc (Array DIM1 Int)+mkTailFlags :: (Elt i, IsIntegral i) => Acc (Segments i) -> Acc (Segments i) mkTailFlags seg-  = permute (\_ _ -> 1) zerosArr (ilift1 $ \i -> (segOffsets ! index1 i) - 1) segOffsets+  = permute (\_ _ -> 1) zerosArr (ilift1 $ \i -> (fromIntegral $ segOffsets ! index1' i) - 1) segOffsets   where     segOffsets = scanl1 (+) seg-    len        = segOffsets ! index1 (size seg - 1)-    zerosArr   = generate (index1 len) (const 0)+    len        = segOffsets ! index1' (size seg - 1)+    zerosArr   = generate (index1' len) (const 0)  -- |Construct a segmented version of apply from a non-segmented version. The segmented apply -- operates on a head-flag value tuple. ---mkSegApply :: (Elt e)+mkSegApply :: (Elt e, Elt i, IsIntegral i)            => (Exp e -> Exp e -> Exp e)-           -> (Exp (Int, e) -> Exp (Int, e) -> Exp (Int, e))+           -> (Exp (i, e) -> Exp (i, e) -> Exp (i, e)) mkSegApply op = apply   where-    apply a b = lift (((aF ==* 1) ||* (bF ==* 1)) ? (1, 0), (bF ==* 1) ? (bV, aV `op` bV))+    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 +-- As 'index1', but parameterised in the first argument over integral types+--+index1' :: (Elt i, IsIntegral i) => Exp i -> Exp (Z :. Int)+index1' = index1 . fromIntegral++ -- Reshaping of arrays -- ------------------- @@ -395,3 +461,179 @@ -- flatten :: (Shape ix, Elt a) => Acc (Array ix a) -> Acc (Array DIM1 a) flatten a = reshape (index1 $ size a) a++-- Enumeration and filling+-- -----------------------++-- | Create an array where all elements are the same value.+--+fill :: (Shape sh, Elt e) => Exp sh -> Exp e -> Acc (Array sh e)+fill sh c = generate sh (const c)++-- | Create an array of the given shape containing the values x, x+1, etc (in+--   row-major order).+--+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).+--+enumFromStepN :: (Shape sh, Elt e, IsNum e)+              => Exp sh+              -> Exp e    -- ^x+              -> Exp e    -- ^y+              -> Acc (Array sh e)+enumFromStepN sh x y = reshape sh+                     $ generate (index1 $ shapeSize sh)+                                ((\i -> ((fromIntegral i) * y) + x) . unindex1)+++-- 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:+--+--    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+       -> Acc (Vector e)        -- ^input+       -> Acc (Vector e)        -- ^output+gather mapV inputV = backpermute (shape mapV) bpF inputV+  where+    bpF ix = lift (Z :. (mapV ! ix))+++-- | Conditionally copy elements from source array to destination array according+--   to a map. This is a backpermute opereation where a 'map' vector encdes 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]+--+--    output  = [6, 6, 1, 6, 2, 4]+--+gatherIf :: (Elt e, Elt e')+         => Acc (Vector Int)    -- ^map+         -> Acc (Vector e)      -- ^mask+         -> (Exp e -> Exp Bool) -- ^predicate+         -> Acc (Vector e')     -- ^default+         -> Acc (Vector e')     -- ^input+         -> Acc (Vector e')     -- ^output+gatherIf mapV maskV pred defaultV inputV = zipWith zwF predV gatheredV+  where+    zwF p g   = p ? (unlift g)+    gatheredV = zip (gather mapV inputV) defaultV+    predV     = map pred maskV+++-- Scatter operations+-- ------------------++-- | 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 = [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.+--+scatter :: (Elt e)+        => Acc (Vector Int)      -- ^map+        -> Acc (Vector e)        -- ^default+        -> Acc (Vector e)        -- ^input+        -> Acc (Vector e)        -- ^output+scatter mapV defaultV inputV = permute (const) defaultV pF inputV+  where+    pF ix = lift (Z :. (mapV ! ix))+++-- | Conditionally 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. 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]+--+--    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.+--+scatterIf :: (Elt e, Elt e')+          => Acc (Vector Int)      -- ^map+          -> Acc (Vector e)        -- ^mask+          -> (Exp e -> Exp Bool)   -- ^predicate+          -> Acc (Vector e')       -- ^default+          -> Acc (Vector e')       -- ^input+          -> Acc (Vector e')       -- ^output+scatterIf mapV maskV pred defaultV inputV = permute const defaultV pF inputV+  where+    pF ix = (pred (maskV ! ix)) ? (lift (Z :. (mapV ! ix)), ignore)++++-- Extracting subvectors+-- ---------------------+++-- | 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++-- | Yield all but the first 'n' elements of the input vector. The vector must+--   contain no more 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+++-- | Yield all but the last element of the input vector. The vector may 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.+tail :: Elt e => Acc (Vector e) -> Acc (Vector e)+tail = drop 1+++-- | Yield a slit (slice) from the vector. The vector must contain at least+--   i + n elements.+--+slit :: Elt e+      => Exp Int+      -> Exp Int+      -> Acc (Vector e)+      -> Acc (Vector e)+slit i n = backpermute (index1 n) (ilift1 (+ i))+
Data/Array/Accelerate/Pretty.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE GADTs, FlexibleInstances, 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@@ -11,6 +12,9 @@ --  module Data.Array.Accelerate.Pretty (++  -- * Pretty printing functions+  module Data.Array.Accelerate.Pretty.Print    -- * Instances of Show
Data/Array/Accelerate/Pretty/Print.hs view
@@ -13,10 +13,10 @@    -- * Pretty printing functions   PrettyAcc,-  prettyPreAcc, prettyAcc, -  prettyPreExp, prettyExp, -  prettyPreAfun, prettyAfun, -  prettyPreFun, prettyFun, +  prettyPreAcc,  prettyAcc,+  prettyPreExp,  prettyExp,+  prettyPreAfun, prettyAfun,+  prettyPreFun,  prettyFun,   noParens  ) where@@ -43,30 +43,31 @@ prettyAcc :: PrettyAcc OpenAcc prettyAcc alvl wrap (OpenAcc acc) = prettyPreAcc prettyAcc alvl wrap acc -prettyPreAcc :: PrettyAcc acc -> Int -> (Doc -> Doc) -> PreOpenAcc acc aenv a -> Doc+prettyPreAcc+    :: forall acc aenv a.+       PrettyAcc acc+    -> Int+    -> (Doc -> Doc)+    -> 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         ]-prettyPreAcc pp alvl wrap (Alet2 acc1 acc2)-  = wrap-  $ sep [ hang (text "let (a" <> int alvl <> text ", a" <> int (alvl + 1) <> char ')' <+>-                char '=') 2 $-            pp alvl noParens acc1-        , text "in" <+> pp (alvl + 2) noParens acc2-        ]-prettyPreAcc pp alvl wrap (PairArrays acc1 acc2)-  = wrap $ sep [pp alvl parens acc1, pp alvl parens acc2] prettyPreAcc _  alvl _    (Avar idx)-  = text $ 'a' : show (alvl - deBruijnToInt idx - 1)+  = text $ 'a' : show (alvl - idxToInt idx - 1)+prettyPreAcc pp alvl wrap (Aprj ix arrs)+  = wrap $ char '#' <> prettyTupleIdx ix <+> pp alvl parens arrs+prettyPreAcc pp alvl _    (Atuple tup)+  = prettyAtuple pp alvl tup prettyPreAcc pp alvl wrap (Apply afun acc)   = wrap $ sep [parens (prettyPreAfun pp alvl afun), pp alvl parens acc] prettyPreAcc pp alvl wrap (Acond e acc1 acc2)   = wrap $ prettyArrOp "cond" [prettyPreExp pp 0 alvl parens e, pp alvl parens acc1, pp alvl parens acc2] prettyPreAcc _  _    wrap (Use arr)-  = wrap $ prettyArrOp "use" [prettyArray arr]+  = wrap $ prettyArrOp "use" [prettyArrays (arrays (undefined::a)) arr] prettyPreAcc pp alvl wrap (Unit e)   = wrap $ prettyArrOp "unit" [prettyPreExp pp 0 alvl parens e] prettyPreAcc pp alvl wrap (Generate sh f)@@ -202,7 +203,7 @@         , text "in" <+> prettyPreExp pp (lvl + 1) alvl noParens e2         ] prettyPreExp _pp lvl _ _ (Var idx)-  = text $ 'x' : show (lvl - deBruijnToInt idx - 1)+  = text $ 'x' : show (lvl - idxToInt idx - 1) prettyPreExp _pp _ _ _ (Const v)   = text $ show (toElt v :: t) prettyPreExp pp lvl alvl _ (Tuple tup)@@ -228,26 +229,48 @@ prettyPreExp _pp _ _ _ (PrimConst a)  = prettyConst a prettyPreExp pp lvl alvl wrap (PrimApp p a)-  = wrap $ prettyPrim p <+> prettyPreExp pp lvl alvl parens a+  | infixOp, Tuple (NilTup `SnocTup` x `SnocTup` y) <- a+  = wrap $ prettyPreExp pp lvl alvl parens x <+> f <+> prettyPreExp pp lvl alvl parens y++  | 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.+    --+    (infixOp, f) = prettyPrim p+    f'           = if infixOp then parens f else f+ prettyPreExp pp lvl alvl wrap (IndexScalar idx i)   = wrap $ cat [pp alvl parens idx, char '!', 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 (Size idx)-  = wrap $ text "size" <+> pp alvl parens idx+prettyPreExp pp lvl alvl wrap (ShapeSize idx)+  = wrap $ text "shapeSize" <+> parens (prettyPreExp pp lvl alvl parens idx)  -- Pretty print nested pairs as a proper tuple. --+prettyAtuple :: forall acc aenv t.+                PrettyAcc acc+             -> Int+             -> Atuple (acc aenv) t+             -> Doc+prettyAtuple pp alvl = encloseSep lparen rparen comma . collect+  where+    collect :: Atuple (acc aenv) t' -> [Doc]+    collect NilAtup          = []+    collect (SnocAtup tup a) = collect tup ++ [pp alvl id a]+ prettyTuple :: forall acc env aenv t.                PrettyAcc acc -> Int -> Int -> Tuple (PreOpenExp acc env aenv) t -> Doc-prettyTuple pp lvl alvl exp = parens $ sep (map (<> comma) (init es) ++ [last es])+prettyTuple pp lvl alvl = encloseSep lparen rparen comma . collect   where-    es = collect exp-    --     collect :: Tuple (PreOpenExp acc env aenv) t' -> [Doc]     collect NilTup          = []     collect (SnocTup tup e) = collect tup ++ [prettyPreExp pp lvl alvl noParens e] + -- Pretty print an index for a tuple projection -- prettyTupleIdx :: TupleIdx t e -> Doc@@ -264,63 +287,64 @@ prettyConst (PrimMaxBound _) = text "maxBound" prettyConst (PrimPi       _) = text "pi" --- Pretty print a primitive operation+-- Pretty print a primitive operation. The first parameter indicates whether the+-- operator should be printed infix. ---prettyPrim :: PrimFun a -> Doc-prettyPrim (PrimAdd _)            = text "(+)"-prettyPrim (PrimSub _)            = text "(-)"-prettyPrim (PrimMul _)            = text "(*)"-prettyPrim (PrimNeg _)            = text "negate"-prettyPrim (PrimAbs _)            = text "abs"-prettyPrim (PrimSig _)            = text "signum"-prettyPrim (PrimQuot _)           = text "quot"-prettyPrim (PrimRem _)            = text "rem"-prettyPrim (PrimIDiv _)           = text "div"-prettyPrim (PrimMod _)            = text "mod"-prettyPrim (PrimBAnd _)           = text "(.&.)"-prettyPrim (PrimBOr _)            = text "(.|.)"-prettyPrim (PrimBXor _)           = text "xor"-prettyPrim (PrimBNot _)           = text "complement"-prettyPrim (PrimBShiftL _)        = text "shiftL"-prettyPrim (PrimBShiftR _)        = text "shiftR"-prettyPrim (PrimBRotateL _)       = text "rotateL"-prettyPrim (PrimBRotateR _)       = text "rotateR"-prettyPrim (PrimFDiv _)           = text "(/)"-prettyPrim (PrimRecip _)          = text "recip"-prettyPrim (PrimSin _)            = text "sin"-prettyPrim (PrimCos _)            = text "cos"-prettyPrim (PrimTan _)            = text "tan"-prettyPrim (PrimAsin _)           = text "asin"-prettyPrim (PrimAcos _)           = text "acos"-prettyPrim (PrimAtan _)           = text "atan"-prettyPrim (PrimAsinh _)          = text "asinh"-prettyPrim (PrimAcosh _)          = text "acosh"-prettyPrim (PrimAtanh _)          = text "atanh"-prettyPrim (PrimExpFloating _)    = text "exp"-prettyPrim (PrimSqrt _)           = text "sqrt"-prettyPrim (PrimLog _)            = text "log"-prettyPrim (PrimFPow _)           = text "(**)"-prettyPrim (PrimLogBase _)        = text "logBase"-prettyPrim (PrimTruncate _ _)     = text "truncate"-prettyPrim (PrimRound _ _)        = text "round"-prettyPrim (PrimFloor _ _)        = text "floor"-prettyPrim (PrimCeiling _ _)      = text "ceiling"-prettyPrim (PrimAtan2 _)          = text "atan2"-prettyPrim (PrimLt _)             = text "(<*)"-prettyPrim (PrimGt _)             = text "(>*)"-prettyPrim (PrimLtEq _)           = text "(<=*)"-prettyPrim (PrimGtEq _)           = text "(>=*)"-prettyPrim (PrimEq _)             = text "(==*)"-prettyPrim (PrimNEq _)            = text "(/=*)"-prettyPrim (PrimMax _)            = text "max"-prettyPrim (PrimMin _)            = text "min"-prettyPrim PrimLAnd               = text "&&*"-prettyPrim PrimLOr                = text "||*"-prettyPrim PrimLNot               = text "not"-prettyPrim PrimOrd                = text "ord"-prettyPrim PrimChr                = text "chr"-prettyPrim PrimBoolToInt          = text "boolToInt"-prettyPrim (PrimFromIntegral _ _) = text "fromIntegral"+prettyPrim :: PrimFun a -> (Bool, Doc)+prettyPrim (PrimAdd _)            = (True,  char '+')+prettyPrim (PrimSub _)            = (True,  char '-')+prettyPrim (PrimMul _)            = (True,  char '*')+prettyPrim (PrimNeg _)            = (False, text "negate")+prettyPrim (PrimAbs _)            = (False, text "abs")+prettyPrim (PrimSig _)            = (False, text "signum")+prettyPrim (PrimQuot _)           = (False, text "quot")+prettyPrim (PrimRem _)            = (False, text "rem")+prettyPrim (PrimIDiv _)           = (False, text "div")+prettyPrim (PrimMod _)            = (False, text "mod")+prettyPrim (PrimBAnd _)           = (True,  text ".&.")+prettyPrim (PrimBOr _)            = (True,  text ".|.")+prettyPrim (PrimBXor _)           = (False, text "xor")+prettyPrim (PrimBNot _)           = (False, text "complement")+prettyPrim (PrimBShiftL _)        = (False, text "shiftL")+prettyPrim (PrimBShiftR _)        = (False, text "shiftR")+prettyPrim (PrimBRotateL _)       = (False, text "rotateL")+prettyPrim (PrimBRotateR _)       = (False, text "rotateR")+prettyPrim (PrimFDiv _)           = (True,  char '/')+prettyPrim (PrimRecip _)          = (False, text "recip")+prettyPrim (PrimSin _)            = (False, text "sin")+prettyPrim (PrimCos _)            = (False, text "cos")+prettyPrim (PrimTan _)            = (False, text "tan")+prettyPrim (PrimAsin _)           = (False, text "asin")+prettyPrim (PrimAcos _)           = (False, text "acos")+prettyPrim (PrimAtan _)           = (False, text "atan")+prettyPrim (PrimAsinh _)          = (False, text "asinh")+prettyPrim (PrimAcosh _)          = (False, text "acosh")+prettyPrim (PrimAtanh _)          = (False, text "atanh")+prettyPrim (PrimExpFloating _)    = (False, text "exp")+prettyPrim (PrimSqrt _)           = (False, text "sqrt")+prettyPrim (PrimLog _)            = (False, text "log")+prettyPrim (PrimFPow _)           = (True,  text "**")+prettyPrim (PrimLogBase _)        = (False, text "logBase")+prettyPrim (PrimTruncate _ _)     = (False, text "truncate")+prettyPrim (PrimRound _ _)        = (False, text "round")+prettyPrim (PrimFloor _ _)        = (False, text "floor")+prettyPrim (PrimCeiling _ _)      = (False, text "ceiling")+prettyPrim (PrimAtan2 _)          = (False, text "atan2")+prettyPrim (PrimLt _)             = (True,  text "<*")+prettyPrim (PrimGt _)             = (True,  text ">*")+prettyPrim (PrimLtEq _)           = (True,  text "<=*")+prettyPrim (PrimGtEq _)           = (True,  text ">=*")+prettyPrim (PrimEq _)             = (True,  text "==*")+prettyPrim (PrimNEq _)            = (True,  text "/=*")+prettyPrim (PrimMax _)            = (False, text "max")+prettyPrim (PrimMin _)            = (False, text "min")+prettyPrim PrimLAnd               = (True,  text "&&*")+prettyPrim PrimLOr                = (True,  text "||*")+prettyPrim PrimLNot               = (False, text "not")+prettyPrim PrimOrd                = (False, text "ord")+prettyPrim PrimChr                = (False, text "chr")+prettyPrim PrimBoolToInt          = (False, text "boolToInt")+prettyPrim (PrimFromIntegral _ _) = (False, text "fromIntegral")  {- -- Pretty print type@@ -329,11 +353,22 @@ prettyAnyType ty = text $ show ty -} +-- TLM: seems to flatten the nesting structure+--+prettyArrays :: ArraysR arrs -> arrs -> Doc+prettyArrays arrs = encloseSep lparen rparen comma . collect arrs+  where+    collect :: ArraysR arrs -> arrs -> [Doc]+    collect ArraysRunit         _        = []+    collect ArraysRarray        arr      = [prettyArray arr]+    collect (ArraysRpair r1 r2) (a1, a2) = collect r1 a1 ++ collect r2 a2+ prettyArray :: forall dim e. Array dim e -> Doc prettyArray arr@(Array sh _)   = parens $       hang (text "Array") 2 $-        sep [showDoc (toElt sh :: dim), dataDoc]+        sep [ parens . text $ showShape (toElt sh :: dim)+            , dataDoc]   where     showDoc :: forall a. Show a => a -> Doc     showDoc = text . show@@ -348,6 +383,13 @@  noParens :: Doc -> Doc noParens = id++encloseSep :: Doc -> Doc -> Doc -> [Doc] -> Doc+encloseSep left right p ds =+  case ds of+    []  -> left <> right+    [d] -> left <> d <> right+    _   -> left <> sep (punctuate p ds) <> right  -- Auxiliary ops --
Data/Array/Accelerate/Pretty/Traverse.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE GADTs, ScopedTypeVariables, NoMonomorphismRestriction #-}+{-# LANGUAGE GADTs, ScopedTypeVariables #-} -- | -- Module      : Data.Array.Accelerate.Pretty.Traverse -- Copyright   : [2010..2011] Sean Seefried@@ -36,40 +36,41 @@   where     combine = c (accFormat f)     leaf    = l (accFormat f)+     travAcc' :: PreOpenAcc OpenAcc aenv a -> m b-    travAcc' (Alet acc1 acc2)  = combine "Alet" [travAcc f c l acc1, travAcc f c l acc2]-    travAcc' (Alet2 acc1 acc2) = combine "Alet2" [ travAcc f c l acc1, travAcc f c l acc2 ]-    travAcc' (PairArrays acc1 acc2) = combine "PairArrays" [travAcc f c l acc1, travAcc f c l acc2]-    travAcc' (Avar idx) = leaf ("AVar " `cat` deBruijnToInt idx)-    travAcc' (Apply afun acc) = combine "Apply" [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' (Use arr) = combine "Use" [ travArray f l 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' (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' (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]-    travAcc' (Fold1 fun acc) = combine "Fold1" [ travFun f c l fun, travAcc f c l acc]-    travAcc' (FoldSeg fun e acc1 acc2) = combine "FoldSeg" [ travFun f c l fun, travExp f c l  e,-                                                            travAcc f c l acc1, travAcc f c l acc2 ]-    travAcc' (Fold1Seg fun acc1 acc2) = combine "FoldSeg1" [ travFun f c l fun, travAcc f c l acc1, travAcc f c l acc2 ]-    travAcc' (Scanl fun e acc) = combine "Scanl" [ travFun f c l fun, travExp f c l  e, travAcc f c l acc ]-    travAcc' (Scanl' fun e acc) = combine "Scanl'" [ travFun f c l fun, travExp f c l  e, travAcc f c l acc ]-    travAcc' (Scanl1 fun acc) = combine "Scanl1" [ travFun f c l fun, travAcc f c l acc ]-    travAcc' (Scanr fun e acc) = combine "Scanr" [ travFun f c l fun, travExp f c l  e, travAcc f c l acc ]-    travAcc' (Scanr' fun e acc) = combine "Scanr'" [ travFun f c l fun, travExp f c l  e, travAcc f c l acc ]-    travAcc' (Scanr1 fun acc) = combine "Scanr1" [ travFun f c l fun, travAcc f c l acc ]-    travAcc' (Permute fun dfts p acc) = combine "Permute" [ travFun f c l fun, travAcc f c l dfts,-                                                           travFun f c l p, travAcc f c l acc]-    travAcc' (Backpermute sh p acc) = combine "Backpermute" [ travExp f c l  sh, travFun f c l p, travAcc f c l acc]-    travAcc' (Stencil sten bndy acc) = combine "Stencil" [ travFun f c l sten, travBoundary f l acc bndy-                                                        , travAcc f c l acc]-    travAcc' (Stencil2 sten bndy1 acc1 bndy2 acc2) = combine "Stencil2" [ travFun f c l sten, travBoundary f l acc1 bndy1,-                                                                   travAcc f c l acc1, travBoundary f l acc2 bndy2,-                                                                   travAcc f c l acc2]+    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' (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' (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' (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]+    travAcc' (Fold1 fun acc)                       = combine "Fold1" [ travFun f c l fun, travAcc f c l acc]+    travAcc' (FoldSeg fun e acc1 acc2)             = combine "FoldSeg" [ travFun f c l fun, travExp f c l  e+                                                                       , travAcc f c l acc1, travAcc f c l acc2 ]+    travAcc' (Fold1Seg fun acc1 acc2)              = combine "FoldSeg1" [ travFun f c l fun, travAcc f c l acc1, travAcc f c l acc2 ]+    travAcc' (Scanl fun e acc)                     = combine "Scanl" [ travFun f c l fun, travExp f c l  e, travAcc f c l acc ]+    travAcc' (Scanl' fun e acc)                    = combine "Scanl'" [ travFun f c l fun, travExp f c l  e, travAcc f c l acc ]+    travAcc' (Scanl1 fun acc)                      = combine "Scanl1" [ travFun f c l fun, travAcc f c l acc ]+    travAcc' (Scanr fun e acc)                     = combine "Scanr" [ travFun f c l fun, travExp f c l  e, travAcc f c l acc ]+    travAcc' (Scanr' fun e acc)                    = combine "Scanr'" [ travFun f c l fun, travExp f c l  e, travAcc f c l acc ]+    travAcc' (Scanr1 fun acc)                      = combine "Scanr1" [ travFun f c l fun, travAcc f c l acc ]+    travAcc' (Permute fun dfts p acc)              = combine "Permute" [ travFun f c l fun, travAcc f c l dfts+                                                                       , travFun f c l p, travAcc f c l acc]+    travAcc' (Backpermute sh p acc)                = combine "Backpermute" [ travExp f c l  sh, travFun f c l p, travAcc f c l acc]+    travAcc' (Stencil sten bndy acc)               = combine "Stencil" [ travFun f c l sten, travBoundary f l acc bndy+                                                                       , travAcc f c l acc]+    travAcc' (Stencil2 sten bndy1 acc1 bndy2 acc2) = combine "Stencil2" [ travFun f c l sten, travBoundary f l acc1 bndy1+                                                                        , travAcc f c l acc1, travBoundary f l acc2 bndy2+                                                                        , travAcc f c l acc2]  travExp :: forall m env aenv a b . Monad m => Labels        -> (String -> String -> [m b] -> m b)@@ -79,9 +80,10 @@   where     combine = c (expFormat f)     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` deBruijnToInt idx)+    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 ]@@ -95,7 +97,7 @@     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' (Size idx)          = combine "Size" [ travAcc f c l idx ]+    travExp' (ShapeSize e)       = combine "ShapeSize" [ travExp f c l e ]   travAfun :: forall m b aenv fun. Monad m => Labels -> (String -> String -> [m b] -> m b)@@ -107,14 +109,23 @@     travAfun' (Abody body) = combine "Abody" [ travAcc f c l body ]     travAfun' (Alam fun)   = combine "Alam"  [ travAfun f c l fun ] -travFun :: forall m b env aenv fun.Monad m => Labels -> (String -> String -> [m b] -> m b)-        -> (String -> String -> m b) -> OpenFun env aenv fun -> m b-travFun f c l openFun = travFun' openFun+travArrays+    :: forall m a b. Monad m+    => Labels+    -> (String -> String -> [m b] -> m b)+    -> (String -> String -> m b)+    -> ArraysR a+    -> a+    -> m b+travArrays f c l = trav   where-    combine = c (funFormat f)-    travFun' :: OpenFun env aenv fun -> m b-    travFun' (Body body) = combine "Body" [ travExp f c l body ]-    travFun' (Lam fun)   = combine "Lam"  [ travFun f c l fun ]+    combine = c (accFormat f)+    leaf    = l (accFormat f)+    --+    trav :: ArraysR a' -> a' -> m b+    trav ArraysRunit         ()       = leaf    "ArraysRunit"+    trav ArraysRarray        a        = combine "ArraysRarray" [ travArray f l a ]+    trav (ArraysRpair r1 r2) (a1, a2) = combine "ArraysRpair"  [trav r1 a1, trav r2 a2]  travArray :: forall dim a m b. Monad m => Labels -> (String -> String -> m b) -> Array dim a -> m b travArray f l (Array sh _) = l (arrayFormat f) ("Array" `cat` (toElt sh :: dim))@@ -130,6 +141,33 @@     travBoundary' _ Mirror       = leaf "Mirror"     travBoundary' _ Wrap         = leaf "Wrap"     travBoundary' _ (Constant e) = leaf ("Constant " `cat` (toElt e :: e))+++travAtuple+    :: forall m b aenv t. Monad m+    => Labels+    -> (String -> String -> [m b] -> m b)+    -> (String -> String -> m b)+    -> Atuple (OpenAcc aenv) t+    -> m b+travAtuple f c l = trav+  where+    leaf    = l (tupleFormat f)+    combine = c (tupleFormat f)+    --+    trav :: Atuple (OpenAcc aenv) t' -> m b+    trav NilAtup          = leaf    "NilAtup"+    trav (SnocAtup tup a) = combine "SnocAtup" [ trav tup, travAcc f c l a ]+++travFun :: forall m b env aenv fun.Monad m => Labels -> (String -> String -> [m b] -> m b)+        -> (String -> String -> m b) -> OpenFun env aenv fun -> m b+travFun f c l openFun = travFun' openFun+  where+    combine = c (funFormat f)+    travFun' :: OpenFun env aenv fun -> m b+    travFun' (Body body) = combine "Body" [ travExp f c l body ]+    travFun' (Lam fun)   = combine "Lam"  [ travFun f c l fun ]   travTuple :: forall m b env aenv t. Monad m => Labels -> (String -> String -> [m b] -> m b)
Data/Array/Accelerate/Smart.hs view
@@ -1,6 +1,7 @@ {-# 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@@ -23,9 +24,6 @@   -- * HOAS -> de Bruijn conversion   convertAcc, convertAccFun1, -  -- * Smart constructors for pairing and unpairing-  pair, unpair,-   -- * Smart constructors for literals   constant, @@ -33,6 +31,9 @@   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,@@ -56,7 +57,7 @@   ($$), ($$$), ($$$$), ($$$$$)  ) where-  + -- standard library import Control.Applicative                      hiding (Const) import Control.Monad.Fix@@ -102,7 +103,7 @@ -- Recover the sharing of scalar expressions? -- recoverExpSharing :: Bool-recoverExpSharing = False+recoverExpSharing = True   -- Layouts@@ -149,6 +150,11 @@ -- 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]@@ -160,7 +166,7 @@ data PreAcc acc exp as where       -- Needed for conversion to de Bruijn form   Atag        :: Arrays as-              => Int                        -- environment size at defining occurrence+              => Level                      -- environment size at defining occurrence               -> PreAcc acc exp as    Pipe        :: (Arrays as, Arrays bs, Arrays cs) @@ -173,19 +179,20 @@               -> acc as               -> acc as               -> PreAcc acc exp as-  FstArray    :: (Shape sh1, Shape sh2, Elt e1, Elt e2)-              => acc (Array sh1 e1, Array sh2 e2)-              -> PreAcc acc exp (Array sh1 e1)-  SndArray    :: (Shape sh1, Shape sh2, Elt e1, Elt e2)-              => acc (Array sh1 e1, Array sh2 e2)-              -> PreAcc acc exp (Array sh2 e2)-  PairArrays  :: (Shape sh1, Shape sh2, Elt e1, Elt e2)-              => acc (Array sh1 e1)-              -> acc (Array sh2 e2)-              -> PreAcc acc exp (Array sh1 e1, Array sh2 e2) -  Use         :: (Shape sh, Elt e)-              => Array sh e -> PreAcc acc exp (Array sh e)+  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)@@ -229,16 +236,16 @@               => (Exp e -> Exp e -> exp e)               -> acc (Array (sh:.Int) e)               -> PreAcc acc exp (Array sh e)-  FoldSeg     :: (Shape sh, Elt 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+              -> acc (Segments i)               -> PreAcc acc exp (Array (sh:.Int) e)-  Fold1Seg    :: (Shape sh, Elt e)+  Fold1Seg    :: (Shape sh, Elt e, Elt i, IsIntegral i)               => (Exp e -> Exp e -> exp e)               -> acc (Array (sh:.Int) e)-              -> acc Segments+              -> acc (Segments i)               -> PreAcc acc exp (Array (sh:.Int) e)   Scanl       :: Elt e               => (Exp e -> Exp e -> exp e)@@ -306,24 +313,18 @@ -- information. -- convertAcc :: Arrays arrs => Acc arrs -> AST.Acc arrs-convertAcc = convertOpenAcc EmptyLayout+convertAcc = convertOpenAcc 0 [] EmptyLayout  -- |Convert an open array expression to de Bruijn form while also incorporating sharing -- information. ---convertOpenAcc :: Arrays arrs => Layout aenv aenv -> Acc arrs -> AST.OpenAcc aenv arrs-convertOpenAcc alyt acc+convertOpenAcc :: Arrays arrs => Level -> [Level] -> Layout aenv aenv -> Acc arrs -> AST.OpenAcc aenv arrs+convertOpenAcc lvl fvs alyt acc   = let -      (sharingAcc, initialEnv) = recoverSharingAcc floatOutAccFromExp acc+      (sharingAcc, initialEnv) = recoverSharingAcc floatOutAccFromExp lvl fvs acc     in     convertSharingAcc alyt initialEnv sharingAcc-    -- FIXME: Somewhat dodgy as the 'alyt' and 'initialEnv' always have to be in sync-    --        Would be better to look at the 'Atag's in 'initialEnv' and compute a-    --        matching 'alyt' (that may have duplicated entries — if not all sharing was-    --        preserved).-    --        !!!Same problem in the convertExp, convertFun1/2 and convertStencil1/2 functions. - -- |Convert a unary function over array computations -- convertAccFun1 :: forall a b. (Arrays a, Arrays b)@@ -331,11 +332,12 @@                -> AST.Afun (a -> b) convertAccFun1 f = Alam (Abody openF)   where-    a     = Atag 0+    lvl   = 0+    a     = Atag lvl     alyt  = EmptyLayout              `PushLayout`              (ZeroIdx :: Idx ((), a) a)-    openF = convertOpenAcc alyt (f (Acc 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@@ -378,17 +380,12 @@       Acond b acc1 acc2         -> AST.Acond (convertExp alyt env b) (convertSharingAcc alyt env acc1)                      (convertSharingAcc alyt env acc2)-      FstArray acc-        -> AST.Alet2 (convertSharingAcc alyt env acc) -                    (AST.OpenAcc $ AST.Avar (AST.SuccIdx AST.ZeroIdx))-      SndArray acc-        -> AST.Alet2 (convertSharingAcc alyt env acc) -                    (AST.OpenAcc $ AST.Avar AST.ZeroIdx)-      PairArrays acc1 acc2-        -> AST.PairArrays (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 array+        -> AST.Use (fromArr array)       Unit e         -> AST.Unit (convertExp alyt env e)       Generate sh f@@ -456,6 +453,19 @@                         (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)@@ -481,7 +491,7 @@ data PreExp acc exp t where     -- Needed for conversion to de Bruijn form   Tag         :: Elt t-              => Int                            -> PreExp acc exp t+              => Level                          -> PreExp acc exp t                  -- environment size at defining occurrence      -- All the same constructors as 'AST.Exp'@@ -512,8 +522,8 @@               => acc (Array sh t) -> exp sh     -> PreExp acc exp t   Shape       :: (Shape sh, Elt e)                             => acc (Array sh e)               -> PreExp acc exp sh-  Size        :: (Shape sh, Elt e)              -              => acc (Array sh e)               -> PreExp acc exp Int+  ShapeSize   :: Shape sh              +              => exp sh                         -> PreExp acc exp Int  -- |Scalar expressions for plain array computations. --@@ -572,7 +582,7 @@           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)-          Size a          -> AST.Size (convertSharingAcc alyt aenv a)+          ShapeSize e     -> AST.ShapeSize (cvt e)   -- |Convert a tuple expression --@@ -605,7 +615,7 @@             -> AST.Fun aenv (a -> b) convertFun1 alyt aenv f = Lam (Body openF)   where-    a               = Exp $ Tag 0+    a               = Exp $ undefined           -- the 'tag' was already embedded in Phase 1     lyt             = EmptyLayout                        `PushLayout`                        (ZeroIdx :: Idx ((), a) a)@@ -621,8 +631,8 @@             -> AST.Fun aenv (a -> b -> c) convertFun2 alyt aenv f = Lam (Lam (Body openF))   where-    a               = Exp $ Tag 1-    b               = Exp $ Tag 0+    a               = Exp $ undefined+    b               = Exp $ undefined     lyt             = EmptyLayout                        `PushLayout`                       (SuccIdx ZeroIdx :: Idx (((), a), b) a)@@ -641,7 +651,7 @@                   -> AST.Fun aenv (StencilRepr sh stencil -> b) convertStencilFun _ alyt aenv stencilFun = Lam (Body openStencilFun)   where-    stencil = Exp $ Tag 0 :: Exp (StencilRepr sh stencil)+    stencil = Exp $ undefined :: Exp (StencilRepr sh stencil)     lyt     = EmptyLayout                `PushLayout`                (ZeroIdx :: Idx ((), StencilRepr sh stencil)@@ -665,8 +675,8 @@                                     StencilRepr sh stencil2 -> c) convertStencilFun2 _ _ alyt aenv stencilFun = Lam (Lam (Body openStencilFun))   where-    stencil1 = Exp $ Tag 1 :: Exp (StencilRepr sh stencil1)-    stencil2 = Exp $ Tag 0 :: Exp (StencilRepr sh stencil2)+    stencil1 = Exp $ undefined :: Exp (StencilRepr sh stencil1)+    stencil2 = Exp $ undefined :: Exp (StencilRepr sh stencil2)     lyt     = EmptyLayout                `PushLayout`                (SuccIdx ZeroIdx :: Idx (((), StencilRepr sh stencil1),@@ -725,15 +735,20 @@ -- -- 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 of sharing recovery for array computations, we mark all scalar expression nodes with--- a stable name, but we do /not/ yet enter them into an occurence map.  The later needs to be done--- separately into a separate map for each expression, so that the counts of independent--- expressions do not interfere.  Otherwise, sharing recovery for scalar expressions proceeds in--- the same manner as for array computations.+-- 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 @@ -880,6 +895,11 @@   | 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.@@ -899,13 +919,13 @@ -- Expressions rooted in 'Acc' computations. -- -- * Between counting occurences and determining scopes, the root of every expression embedded in an---   'Acc' is annotated by an occurence map for that one expression (excluding any subterms that---   are rooted in embedded 'Acc's.)+--   '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 :: OccMap Exp         -> SharingExp t -> RootExp t+  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.@@ -931,6 +951,11 @@   | 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). --@@ -956,18 +981,18 @@ -- 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 => Acc arrs -> IO (SharingAcc arrs, OccMapHash Acc)-makeOccMap rootAcc+makeOccMap :: Typeable arrs => Level -> Acc arrs -> IO (SharingAcc arrs, OccMapHash Acc)+makeOccMap lvl rootAcc   = do       traceLine "makeOccMap" "Enter"       occMap <- newASTHashTable-      (rootAcc', _) <- traverseAcc occMap rootAcc+      (rootAcc', _) <- traverseAcc lvl occMap rootAcc       traceLine "makeOccMap" "Exit"       return (rootAcc', occMap)   where     traverseAcc :: forall arrs. Typeable arrs -                => OccMapHash Acc -> Acc arrs -> IO (SharingAcc arrs, Int)-    traverseAcc occMap acc@(Acc pacc)+                => 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@@ -1002,39 +1027,39 @@             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 occMap e-                                          (acc1', h2) <- traverseAcc occMap acc1-                                          (acc2', h3) <- traverseAcc occMap acc2+                                          (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)-            FstArray acc             -> reconstruct $ travA FstArray acc-            SndArray acc             -> reconstruct $ travA SndArray acc-            PairArrays acc1 acc2     -> reconstruct $ do-                                          (acc1', h1) <- traverseAcc occMap acc1-                                          (acc2', h2) <- traverseAcc occMap acc2-                                          return (PairArrays acc1' acc2', h1 `max` h2 + 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 occMap e+                                          (e', h) <- enterExp lvl occMap e                                           return (Unit e', h + 1)             Generate e f             -> reconstruct $ do-                                          (e', h1) <- enterExp  occMap e-                                          (f', h2) <- traverseFun1 occMap f+                                          (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 occMap f-                                          (acc', h2) <- traverseAcc  occMap acc+                                          (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 occMap f-                                          (e'   , h2) <- enterExp  occMap e-                                          (acc1', h3) <- traverseAcc  occMap acc1-                                          (acc2', h4) <- traverseAcc  occMap acc2+                                          (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@@ -1045,26 +1070,26 @@             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 occMap c-                                          (p'   , h2) <- traverseFun1 occMap p-                                          (acc1', h3) <- traverseAcc  occMap acc1-                                          (acc2', h4) <- traverseAcc  occMap acc2+                                          (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  occMap e-                                          (p'  , h2) <- traverseFun1 occMap p-                                          (acc', h3) <- traverseAcc occMap acc+                                          (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 occMap s-                                          (acc', h2) <- traverseAcc occMap acc+                                          (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 occMap s-                                          (acc1', h2) <- traverseAcc occMap acc1-                                          (acc2', h3) <- traverseAcc occMap acc2+                                          (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)         }@@ -1074,7 +1099,7 @@               -> Acc arrs' -> IO (PreAcc SharingAcc RootExp arrs, Int)         travA c acc           = do-              (acc', h) <- traverseAcc occMap acc+              (acc', h) <- traverseAcc lvl occMap acc               return (c acc', h + 1)          travEA :: (Typeable b, Arrays arrs')@@ -1082,8 +1107,8 @@                -> Exp b -> Acc arrs' -> IO (PreAcc SharingAcc RootExp arrs, Int)         travEA c exp acc           = do-              (exp', h1) <- enterExp occMap exp-              (acc', h2) <- traverseAcc occMap acc+              (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')@@ -1093,8 +1118,8 @@                 -> IO (PreAcc SharingAcc RootExp arrs, Int)         travF2A c fun acc           = do-              (fun', h1) <- traverseFun2 occMap fun-              (acc', h2) <- traverseAcc occMap acc+              (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')@@ -1104,9 +1129,9 @@                  -> IO (PreAcc SharingAcc RootExp arrs, Int)         travF2EA c fun exp acc           = do-              (fun', h1) <- traverseFun2 occMap fun-              (exp', h2) <- enterExp occMap exp-              (acc', h3) <- traverseAcc occMap acc+              (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)@@ -1116,66 +1141,84 @@                  -> IO (PreAcc SharingAcc RootExp arrs, Int)         travF2A2 c fun acc1 acc2           = do-              (fun' , h1) <- traverseFun2 occMap fun-              (acc1', h2) <- traverseAcc occMap acc1-              (acc2', h3) <- traverseAcc occMap acc2+              (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) -                  => OccMapHash Acc -> (Exp b -> Exp c) -> IO (Exp b -> RootExp c, Int)-    traverseFun1 occMap f+                  => 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) <- enterExp occMap $ f (Exp $ Tag 0)+          (body, h) <- enterFun (lvl + 1) [lvl] occMap $ f (Exp $ Tag lvl)           return (const body, h + 1)      traverseFun2 :: (Elt b, Elt c, Typeable d) -                  => OccMapHash Acc -> (Exp b -> Exp c -> Exp d) +                  => Level -> OccMapHash Acc -> (Exp b -> Exp c -> Exp d)                    -> IO (Exp b -> Exp c -> RootExp d, Int)-    traverseFun2 occMap f+    traverseFun2 lvl occMap f       = do             -- see Note [Traversing functions and side effects]-          (body, h) <- enterExp occMap $ f (Exp $ Tag 1) (Exp $ Tag 0)+          (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-}-                     -> OccMapHash Acc -> (stencil -> Exp c) -> IO (stencil -> RootExp c, Int)-    traverseStencil1 _ occMap stencilFun +                     -> 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) <- enterExp occMap $ -                         stencilFun (stencilPrj (undefined::sh) (undefined::b) (Exp $ Tag 0))+          (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 _ _ occMap stencilFun +    traverseStencil2 _ _ lvl occMap stencilFun        = do             -- see Note [Traversing functions and side effects]-          (body, h) <- enterExp occMap $ -                         stencilFun (stencilPrj (undefined::sh) (undefined::b) (Exp $ Tag 1))-                                    (stencilPrj (undefined::sh) (undefined::c) (Exp $ Tag 0))+          (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     ---    enterExp :: forall a. Typeable a => OccMapHash Acc -> Exp a -> IO (RootExp a, Int)-    enterExp accOccMap exp+    -- 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 accOccMap expOccMap exp+        ; (exp', h)       <- traverseExp lvl accOccMap expOccMap exp         ; frozenExpOccMap <- freezeOccMap expOccMap-        ; return (OccMapExp frozenExpOccMap exp', h)+        ; return (OccMapExp fvs frozenExpOccMap exp', h)         } -    traverseExp :: forall a. Typeable a => OccMapHash Acc -> OccMapHash Exp -> Exp a -> IO (SharingExp a, Int)-    traverseExp accOccMap expOccMap exp@(Exp pexp)+    -- '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@@ -1224,14 +1267,14 @@             PrimApp p e     -> reconstruct $ travE1 (PrimApp p) e             IndexScalar a e -> reconstruct $ travAE IndexScalar a e             Shape a         -> reconstruct $ travA Shape a-            Size a          -> reconstruct $ travA Size 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 accOccMap expOccMap e+              (e', h) <- traverseExp lvl accOccMap expOccMap e               return (c e', h + 1)          travE2 :: (Typeable b, Typeable c) @@ -1240,8 +1283,8 @@                -> IO (PreExp SharingAcc SharingExp a, Int)         travE2 c e1 e2           = do-              (e1', h1) <- traverseExp accOccMap expOccMap e1-              (e2', h2) <- traverseExp accOccMap expOccMap e2+              (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) @@ -1250,16 +1293,16 @@                -> IO (PreExp SharingAcc SharingExp a, Int)         travE3 c e1 e2 e3           = do-              (e1', h1) <- traverseExp accOccMap expOccMap e1-              (e2', h2) <- traverseExp accOccMap expOccMap e2-              (e3', h3) <- traverseExp accOccMap expOccMap e3+              (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 accOccMap acc+              (acc', h) <- traverseAcc lvl accOccMap acc               return (c acc', h + 1)          travAE :: (Typeable b, Typeable c) @@ -1268,15 +1311,15 @@                -> IO (PreExp SharingAcc SharingExp a, Int)         travAE c acc e           = do-              (acc', h1) <- traverseAcc accOccMap acc-              (e'  , h2) <- traverseExp accOccMap expOccMap e+              (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 accOccMap expOccMap e+                                    (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.@@ -1349,38 +1392,68 @@     (StableSharingExp _ (VarSharing _))  `pickNoneVar`  sa2  = sa2     sa1                                  `pickNoneVar`  _sa2 = sa1     --- Sort 'StableSharingAcc's consisting of 'Atag' nodes only in order of ascending tags and drop the--- counts.+-- 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.) ---sortInEnvOrderAcc :: [StableSharingAcc] -> [StableSharingAcc]-sortInEnvOrderAcc = sortBy envOrder+-- 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-    envOrder (StableSharingAcc _ (AccSharing _ (Atag t1)))-             (StableSharingAcc _ (AccSharing _ (Atag t2))) = compare t1 t2-    envOrder sa1 sa2 -      = INTERNAL_ERROR(error) "sortInEnvOrderAcc" -          ("Encountered a node that is not a plain 'Atag'\n  " ++ showSA sa1 ++ "\n  " ++ showSA sa2)-    -    showSA (StableSharingAcc _ (AccSharing  sn acc)) = show (hashStableNameHeight sn) ++ ": " ++ showPreAccOp acc+    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 ++ "..." --- Sort 'StableSharingExo's consisting of 'Tag' nodes only in order of ascending tags and drop the--- counts.+-- 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.) ---sortInEnvOrderExp :: [StableSharingExp] -> [StableSharingExp]-sortInEnvOrderExp = sortBy envOrder+-- 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-    envOrder (StableSharingExp _ (ExpSharing _ (Tag t1)))-             (StableSharingExp _ (ExpSharing _ (Tag t2))) = compare t1 t2-    envOrder se1 se2 -      = INTERNAL_ERROR(error) "sortInEnvOrderExp" -          ("Encountered a node that is not a plain 'Tag'\n  " ++ showSE se1 ++ "\n  " ++ showSE se2)+    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) -    showSE (StableSharingExp _ (ExpSharing sn exp)) = show (hashStableNameHeight sn) ++ ": " ++ showPreExpOp exp+        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@@ -1400,15 +1473,15 @@ -- Precondition: there are only 'AvarSharing' and 'AccSharing' nodes in the argument. -- determineScopes :: Typeable a -                => Bool -> OccMap Acc -> SharingAcc a -> (SharingAcc a, [StableSharingAcc])-determineScopes floatOutAcc accOccMap rootAcc +                => 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, sortInEnvOrderAcc [sa | AccNodeCount sa _ <- counts])+        (sharingAcc, buildInitialEnvAcc fvs [sa | AccNodeCount sa _ <- counts])       else         INTERNAL_ERROR(error) "determineScopes" ("unbound shared subtrees" ++ show unboundTrees)   where@@ -1429,13 +1502,11 @@                                      in                                      reconstruct (Acond e' acc1' acc2')                                                  (accCount1 +++ accCount2 +++ accCount3)-          FstArray acc            -> travA FstArray acc-          SndArray acc            -> travA SndArray acc-          PairArrays acc1 acc2    -> let-                                       (acc1', accCount1) = scopesAcc acc1-                                       (acc2', accCount2) = scopesAcc acc2-                                     in-                                     reconstruct (PairArrays acc1' acc2') (accCount1 +++ accCount2)++          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@@ -1549,6 +1620,14 @@             (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' @@ -1627,12 +1706,12 @@             notComplete _                                             = True      scopesExpInit :: RootExp t -> (RootExp t, NodeCounts)-    scopesExpInit (OccMapExp expOccMap exp)+    scopesExpInit (OccMapExp fvs expOccMap exp)       = let           (expWithScopes, nodeCounts) = scopesExp expOccMap exp           (expCounts, accCounts)      = break isAccNodeCount nodeCounts         in-        (EnvExp (sortInEnvOrderExp [se | ExpNodeCount se _ <- expCounts]) expWithScopes, accCounts)+        (EnvExp (buildInitialEnvExp fvs [se | ExpNodeCount se _ <- expCounts]) expWithScopes, accCounts)       where         isAccNodeCount (AccNodeCount {}) = True         isAccNodeCount _                 = False@@ -1661,7 +1740,7 @@           PrimApp p e     -> travE1 (PrimApp p) e           IndexScalar a e -> travAE IndexScalar a e           Shape a         -> travA Shape a-          Size a          -> travA Size a+          ShapeSize e     -> travE1 ShapeSize e       where         travTup :: Tuple.Tuple SharingExp tup -> (Tuple.Tuple SharingExp tup, NodeCounts)         travTup NilTup          = (NilTup, noNodeCounts)@@ -1856,14 +1935,14 @@ --     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.+--       wrong size, which is fatal. (The 'buildInitialEnv*' functions will already bail out.) ---recoverSharingAcc :: Typeable a => Bool -> Acc a -> (SharingAcc a, [StableSharingAcc])+recoverSharingAcc :: Typeable a => Bool -> Level -> [Level] -> Acc a -> (SharingAcc a, [StableSharingAcc]) {-# NOINLINE recoverSharingAcc #-}-recoverSharingAcc floatOutAcc acc +recoverSharingAcc floatOutAcc lvl fvs acc    = let (acc', occMap) =           unsafePerformIO $ do        -- to enable stable pointers; it's safe as explained above-            { (acc', occMap) <- makeOccMap acc+            { (acc', occMap) <- makeOccMap lvl acc               ; occMapList <- Hash.toList occMap             ; traceChunk "OccMap" $@@ -1873,7 +1952,7 @@             ; return (acc', frozenOccMap)             }     in -    determineScopes floatOutAcc occMap acc'+    determineScopes floatOutAcc fvs occMap acc'   -- Pretty printing@@ -1901,24 +1980,23 @@                                                            (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 a)+            IndexScalar a e -> ExpSharing undefined $ IndexScalar (fst $ recoverSharingAcc False 0 [] a)                                                                   (toSharingExp e)-            Shape a         -> ExpSharing undefined $ Shape (fst $ recoverSharingAcc False a)-            Size a          -> ExpSharing undefined $ Size (fst $ recoverSharingAcc False a)+            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 :: PreAcc acc exp arrs -> String+showPreAccOp :: forall acc exp arrs. PreAcc acc exp arrs -> String showPreAccOp (Atag i)             = "Atag " ++ show i showPreAccOp (Pipe _ _ _)         = "Pipe" showPreAccOp (Acond _ _ _)        = "Acond"-showPreAccOp (FstArray _)         = "FstArray"-showPreAccOp (SndArray _)         = "SndArray"-showPreAccOp (PairArrays _ _)     = "PairArrays"-showPreAccOp (Use arr)            = "Use " ++ showShortendArr arr+showPreAccOp (Atuple _)           = "Atuple"+showPreAccOp (Aprj _ _)           = "Aprj"+showPreAccOp (Use a)              = "Use " ++ showArrays a showPreAccOp (Unit _)             = "Unit" showPreAccOp (Generate _ _)       = "Generate" showPreAccOp (Reshape _ _)        = "Reshape"@@ -1941,6 +2019,19 @@ 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 ""@@ -1969,10 +2060,10 @@ showPreExpOp (PrimApp _ _)     = "PrimApp" showPreExpOp (IndexScalar _ _) = "IndexScalar" showPreExpOp (Shape _)         = "Shape"-showPreExpOp (Size _)          = "Size"+showPreExpOp (ShapeSize _)     = "ShapeSize" --- |Smart constructors to construct representation AST forms--- ---------------------------------------------------------+-- Smart constructors to construct representation AST forms+-- --------------------------------------------------------  mkIndex :: forall slix e aenv. (Slice slix, Elt e)         => AST.OpenAcc                aenv (Array (FullShape slix) e)@@ -1992,10 +2083,139 @@   where     slix = undefined :: slix +-- Smart constructors and destructors for array tuples+-- --- |Smart constructors for stencil reification--- -------------------------------------------+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@@ -2133,33 +2353,17 @@ tix8 :: Elt s => TupleIdx (((((((((t, s), s1), s2), s3), s4), s5), s6), s7), s8) s tix8 = SuccTupIdx tix7 --- Pushes the 'Acc' constructor through a pair----unpair :: (Shape sh1, Shape sh2, Elt e1, Elt e2)-       => Acc (Array sh1 e1, Array sh2 e2) -       -> (Acc (Array sh1 e1), Acc (Array sh2 e2))-unpair acc = (Acc $ FstArray acc, Acc $ SndArray acc) --- Creates an 'Acc' pair from two separate 'Acc's.----pair :: (Shape sh1, Shape sh2, Elt e1, Elt e2)-     => Acc (Array sh1 e1)-     -> Acc (Array sh2 e2)-     -> Acc (Array sh1 e1, Array sh2 e2)-pair acc1 acc2 = Acc $ PairArrays acc1 acc2-- -- Smart constructor for literals--- +--  -- |Constant scalar expression -- constant :: Elt t => t -> Exp t constant = Exp . Const --- Smart constructor and destructors for tuples+-- 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) @@ -2189,7 +2393,7 @@ 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+             `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)@@ -2197,7 +2401,7 @@ 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+             `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)@@ -2205,7 +2409,7 @@ 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+             `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)
Data/Array/Accelerate/Tuple.hs view
@@ -1,28 +1,29 @@ {-# LANGUAGE GADTs, TypeFamilies, FlexibleInstances #-}+{-# OPTIONS_HADDOCK hide #-} -- | -- Module      : Data.Array.Accelerate.Tuple--- Copyright   : [2009..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee+-- Copyright   : [2009..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell -- License     : BSD3 -- -- Maintainer  : Manuel M T Chakravarty <chak@cse.unsw.edu.au> -- Stability   : experimental -- Portability : non-portable (GHC extensions) ----- Our representation of tuples are heterogenous snoc lists, which are typed --- by type lists, where '()' and '(,)' are type-level nil and snoc,--- respectively.  The components may only be drawn from types that can be--- used as array elements.+-- Our representation of tuples are heterogenous snoc lists, which are typed by+-- type lists, where '()' and '(,)' are type-level nil and snoc, respectively.+-- The components may only be drawn from types that can be used as array+-- elements. --  module Data.Array.Accelerate.Tuple (    -- * Tuple representation-  Tuple(..), TupleIdx(..), IsTuple(..)-  +  Tuple(..), Atuple(..), TupleIdx(..), IsTuple(..)+ ) where  -- friends-import Data.Array.Accelerate.Array.Sugar +import Data.Array.Accelerate.Array.Sugar   -- Tuple representation@@ -34,13 +35,20 @@   NilTup  ::                              Tuple c ()   SnocTup :: Elt t => Tuple c s -> c t -> Tuple c (s, t) --- |Type-safe projection indicies for tuples.+-- TLM: It is irritating that we need a separate data type for tuples of scalars+--   vs. arrays, purely to carry the class constraint. --+data Atuple c t where+  NilAtup  ::                                  Atuple c ()+  SnocAtup :: Arrays a => Atuple c s -> c a -> Atuple c (s, a)++-- |Type-safe projection indices for tuples.+-- -- NB: We index tuples by starting to count from the *right*! -- data TupleIdx t e where-  ZeroTupIdx :: Elt s =>                 TupleIdx (t, s) s-  SuccTupIdx ::          TupleIdx t e -> TupleIdx (t, s) e+  ZeroTupIdx ::                 TupleIdx (t, s) s+  SuccTupIdx :: TupleIdx t e -> TupleIdx (t, s) e  -- |Conversion between surface n-tuples and our tuple representation. --@@ -53,12 +61,12 @@   type TupleRepr () = ()   fromTuple         = id   toTuple           = id-            + instance IsTuple (a, b) where   type TupleRepr (a, b) = (((), a), b)   fromTuple (x, y)      = (((), x), y)   toTuple (((), x), y)  = (x, y)-            + instance IsTuple (a, b, c) where   type TupleRepr (a, b, c)  = (TupleRepr (a, b), c)   fromTuple (x, y, z)       = ((((), x), y), z)@@ -91,8 +99,8 @@  instance IsTuple (a, b, c, d, e, f, g, h, i) where   type TupleRepr (a, b, c, d, e, f, g, h, i) = (TupleRepr (a, b, c, d, e, f, g, h), i)-  fromTuple (x, y, z, v, w, r, s, t, u)                 +  fromTuple (x, y, z, v, w, r, s, t, u)     = ((((((((((), x), y), z), v), w), r), s), t), u)-  toTuple ((((((((((), x), y), z), v), w), r), s), t), u) +  toTuple ((((((((((), x), y), z), v), w), r), s), t), u)     = (x, y, z, v, w, r, s, t, u)
Data/Array/Accelerate/Type.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE CPP, TypeOperators, GADTs, TypeFamilies, FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_HADDOCK hide #-} -- | -- Module      : Data.Array.Accelerate.Type -- Copyright   : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee
LICENSE view
@@ -1,5 +1,4 @@-Copyright (c) [2007..2009] Manuel M T Chakravarty, Gabriele Keller, Sean Lee &-Trevor L. McDonell, University of New South Wales.  All rights reserved.+Copyright (c) [2007..2012] The Accelerate Team.  All rights reserved.  Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:@@ -8,9 +7,9 @@     * Redistributions in binary form must reproduce the above copyright       notice, this list of conditions and the following disclaimer in the       documentation and/or other materials provided with the distribution.-    * Neither the name of the University of New South Wales nor the-      names of its contributors may be used to endorse or promote products-      derived from this software without specific prior written permission.+    * Neither the names of the contributors nor of their affiliations may +      be used to endorse or promote products derived from this software +      without specific prior written permission.  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS ''AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
accelerate.cabal view
@@ -1,5 +1,5 @@ Name:                   accelerate-Version:                0.10.0.0+Version:                0.12.0.0 Cabal-version:          >= 1.6 Tested-with:            GHC >= 7.0.3 Build-type:             Simple@@ -22,8 +22,19 @@                         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/mchakravarty/accelerate/issues>+                        Known bugs: <https://github.com/AccelerateHS/accelerate/issues>                         .+                        * 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.+                         * 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.@@ -31,14 +42,14 @@                         * 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.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/mchakravarty/accelerate/wiki>.+                        For documentation, see the homepage and <https://github.com/AccelerateHS/accelerate/wiki>. License:                BSD3 License-file:           LICENSE Author:                 Manuel M T Chakravarty,@@ -46,67 +57,26 @@                         Sean Lee,                         Ben Lever,                         Trevor L. McDonell,+                        Ryan Newtown,                         Sean Seefried Maintainer:             Manuel M T Chakravarty <chak@cse.unsw.edu.au>-Homepage:               http://www.cse.unsw.edu.au/~chak/project/accelerate/-Bug-reports:            https://github.com/mchakravarty/accelerate/issues+Homepage:               https://github.com/AccelerateHS/accelerate/+Bug-reports:            https://github.com/AccelerateHS/accelerate/issues -Category:               Compilers/Interpreters, Concurrency, Data+Category:               Compilers/Interpreters, Concurrency, Data, Parallelism Stability:              Experimental --- Should be in the Library stanza, and only enabled for the CUDA backend,--- but Cabal does not support that.-Data-files:             cubits/accelerate_cuda_extras.h-                        cubits/accelerate_cuda_function.h-                        cubits/accelerate_cuda_shape.h-                        cubits/accelerate_cuda_stencil.h-                        cubits/accelerate_cuda_texture.h-                        cubits/accelerate_cuda_util.h-                        cubits/generate.inl-                        cubits/backpermute.inl-                        cubits/fold.inl-                        cubits/foldAll.inl-                        cubits/foldSeg.inl-                        cubits/map.inl-                        cubits/stencil.inl-                        cubits/stencil2.inl-                        cubits/permute.inl-                        cubits/reduce.inl-                        cubits/replicate.inl-                        cubits/scan.inl-                        cubits/scan1.inl-                        cubits/slice.inl-                        cubits/zipWith.inl-                        cubits/thrust/safe_scan_intervals.inl-                        cubits/thrust/inclusive_scan.inl-                        cubits/thrust/exclusive_scan.inl- Extra-source-files:     INSTALL                         include/accelerate.h-                        utils/README-                        utils/Paths_accelerate.hs-                        utils/dot_ghci  Flag llvm   Description:          Enable the LLVM backend (sequential)   Default:              False -Flag cuda-  Description:          Enable the CUDA parallel backend for NVIDIA GPUs-  Default:              True- Flag more-pp   Description:          Enable HTML and Graphviz pretty printing.   Default:              False -Flag pcache-  Description:          Enable the persistent caching of the compiled CUDA modules (experimental)-  Default:              False--Flag test-suite-  Description:          Export extra test modules-  Default:              False- Flag bounds-checks   Description:          Enable bounds checking   Default:              True@@ -119,121 +89,45 @@   Description:          Enable internal consistency checks   Default:              False -Flag io-  Description:          Provide access to the block copy I/O functionality-  Default:              False--Flag inplace-  Default:              False- Library+  Include-Dirs:         include   Build-depends:        array           >= 0.3 && < 0.5,                         base            == 4.*,                         containers      >= 0.3 && < 0.5,-                        directory       >= 1.0 && < 1.2,                         ghc-prim        == 0.2.*,-                        mtl             == 2.0.*,                         pretty          >= 1.0 && < 1.2 -  Include-Dirs:         include--  if flag(llvm)-    Build-depends:      llvm            >= 0.6.8--  if flag(cuda)-    Build-depends:      binary          == 0.5.*,-                        bytestring      == 0.9.*,-                        cuda            >= 0.2.2,-                        fclabels        >= 1.0 && < 1.2,-                        filepath        >= 1.0 && < 1.4,-                        language-c      >= 0.3 && < 0.5,-                        transformers    == 0.2.*,-                        unix            >= 2.4 && < 2.6,-                        zlib            == 0.5.* && < 0.5.3.2--  if flag(io)-    Build-depends:      bytestring      == 0.9.*,-                        vector          == 0.9.*----  if flag(test-suite)---    Build-depends:      QuickCheck      == 2.*-   if flag(more-pp)     Build-depends:      bytestring      == 0.9.*,                         blaze-html      == 0.3.*,                         text            == 0.10.* -  if flag(inplace)-    hs-source-dirs:     . utils-   Exposed-modules:      Data.Array.Accelerate-                        Data.Array.Accelerate.Interpreter+                        Data.Array.Accelerate.AST                         Data.Array.Accelerate.Analysis.Shape+                        Data.Array.Accelerate.Analysis.Stencil                         Data.Array.Accelerate.Analysis.Type-                        Data.Array.Accelerate.Array.Sugar+                        Data.Array.Accelerate.Array.Data                         Data.Array.Accelerate.Array.Representation+                        Data.Array.Accelerate.Array.Sugar+                        Data.Array.Accelerate.Interpreter+                        Data.Array.Accelerate.Pretty                         Data.Array.Accelerate.Smart-                        Data.Array.Accelerate.AST-                        Data.Array.Accelerate.Array.Data                         Data.Array.Accelerate.Tuple                         Data.Array.Accelerate.Type-                        Data.Array.Accelerate.Pretty ---  If flag(llvm)---    Exposed-modules:    Data.Array.Accelerate.LLVM--  if flag(cuda)-    Exposed-modules:    Data.Array.Accelerate.CUDA--  if flag(io)-    Other-modules:      Data.Array.Accelerate.IO.BlockCopy-    Exposed-modules:    Data.Array.Accelerate.IO-                        Data.Array.Accelerate.IO.Ptr-                        Data.Array.Accelerate.IO.ByteString-                        Data.Array.Accelerate.IO.Vector----  If flag(test-suite)---    Exposed-modules:    Data.Array.Accelerate.Test---    Other-modules:      Data.Array.Accelerate.Test.QuickCheck---                        Data.Array.Accelerate.Test.QuickCheck.Arbitrary-   Other-modules:        Data.Array.Accelerate.Internal.Check                         Data.Array.Accelerate.Array.Delayed-                        Data.Array.Accelerate.Analysis.Stencil                         Data.Array.Accelerate.Debug                         Data.Array.Accelerate.Language                         Data.Array.Accelerate.Prelude                         Data.Array.Accelerate.Pretty.Print                         Data.Array.Accelerate.Pretty.Traverse-                        Paths_accelerate    if flag(more-pp)     Other-modules:      Data.Array.Accelerate.Pretty.HTML                         Data.Array.Accelerate.Pretty.Graphviz ----  If flag(llvm)---    Other-modules:      Data.Array.Accelerate.LLVM.CodeGen--  if flag(cuda)-    CPP-options:        -DACCELERATE_CUDA_BACKEND-    Other-modules:      Data.Array.Accelerate.CUDA.Analysis.Device-                        Data.Array.Accelerate.CUDA.Analysis.Hash-                        Data.Array.Accelerate.CUDA.Analysis.Launch-                        Data.Array.Accelerate.CUDA.Array.Data-                        Data.Array.Accelerate.CUDA.CodeGen.Data-                        Data.Array.Accelerate.CUDA.CodeGen.Skeleton-                        Data.Array.Accelerate.CUDA.CodeGen.Stencil-                        Data.Array.Accelerate.CUDA.CodeGen.Tuple-                        Data.Array.Accelerate.CUDA.CodeGen.Util-                        Data.Array.Accelerate.CUDA.CodeGen-                        Data.Array.Accelerate.CUDA.Compile-                        Data.Array.Accelerate.CUDA.Execute-                        Data.Array.Accelerate.CUDA.State--  if flag(pcache)-    CPP-options:        -DACCELERATE_CUDA_PERSISTENT_CACHE-   if flag(bounds-checks)     cpp-options:        -DACCELERATE_BOUNDS_CHECKS @@ -257,4 +151,4 @@  Source-repository head   Type:                 git-  Location:             git://github.com/mchakravarty/accelerate.git+  Location:             git://github.com/AccelerateHS/accelerate.git
− cubits/accelerate_cuda_extras.h 
@@ -1,22 +0,0 @@-/* ------------------------------------------------------------------------------ *- * Module      : Extras- * Copyright   : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell- * License     : BSD3- *- * Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>- * Stability   : experimental- *- * ---------------------------------------------------------------------------*/--#ifndef __ACCELERATE_CUDA_EXTRAS_H__-#define __ACCELERATE_CUDA_EXTRAS_H__--#include "accelerate_cuda_function.h"-#include "accelerate_cuda_shape.h"-#include "accelerate_cuda_stencil.h"-#include "accelerate_cuda_texture.h"-#include "accelerate_cuda_util.h"--#endif-
− cubits/accelerate_cuda_function.h 
@@ -1,131 +0,0 @@-/* ------------------------------------------------------------------------------ *- * Module      : Function- * Copyright   : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell- * License     : BSD3- *- * Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>- * Stability   : experimental- *- * ---------------------------------------------------------------------------*/--#ifndef __ACCELERATE_CUDA_FUNCTION_H__-#define __ACCELERATE_CUDA_FUNCTION_H__--#include <stdint.h>-#include <cuda_runtime.h>--#ifdef __cplusplus--/* ------------------------------------------------------------------------------ * Device functions required to support generated code- * -------------------------------------------------------------------------- */--/*- * Left/Right bitwise rotation- */-template <typename T>-static __inline__ __device__ T rotateL(const T x, const int32_t i)-{-    const int32_t i8 = i & 8 * sizeof(x) - 1;-    return i8 == 0 ? x : x << i8 | x >> 8 * sizeof(x) - i8;-}--template <typename T>-static __inline__ __device__ T rotateR(const T x, const int32_t i)-{-    const int32_t i8 = i & 8 * sizeof(x) - 1;-    return i8 == 0 ? x : x >> i8 | x << 8 * sizeof(x) - i8;-}--/*- * Integer division, truncated towards negative infinity- */-template <typename T>-static __inline__ __device__ T idiv(const T x, const T y)-{-    return x > 0 && y < 0 ? (x - y - 1) / y : (x < 0 && y > 0 ? (x - y + 1) / y : x / y);-}--/*- * Integer modulus, Haskell style- */-template <typename T>-static __inline__ __device__ T mod(const T x, const T y)-{-    const T r = x % y;-    return x > 0 && y < 0 || x < 0 && y > 0 ? (r != 0 ? r + y : 0) : r;-}---#if 0-/* ------------------------------------------------------------------------------ * Additional helper functions- * -------------------------------------------------------------------------- */--/*- * Determine if the input is a power of two- */-template <typename T>-static __inline__ __host__ __device__ T isPow2(const T x)-{-    return ((x&(x-1)) == 0);-}--/*- * Compute the next highest power of two- */-template <typename T>-static __inline__ __host__ T ceilPow2(const T x)-{-#if 0-    --x;-    x |= x >> 1;-    x |= x >> 2;-    x |= x >> 4;-    x |= x >> 8;-    x |= x >> 16;-    return ++x;-#endif--    return (isPow2(x)) ? x : 1u << (int) ceil(log2((double)x));-}--/*- * Compute the next lowest power of two- */-template <typename T>-static __inline__ __host__ T floorPow2(const T x)-{-#if 0-    float nf = (float) n;-    return 1 << (((*(int*)&nf) >> 23) - 127);-#endif--    int exp;-    frexp(x, &exp);-    return 1 << (exp - 1);-}--/*- * computes next highest multiple of f from x- */-template <typename T>-static __inline__ __host__ T multiple(const T x, const T f)-{-    return ((x + (f-1)) / f);-}--/*- * MS Excel-style CEIL() function. Rounds x up to nearest multiple of f- */-template <typename T>-static __inline__ __host__ T ceiling(const T x, const T f)-{-    return multiple(x, f) * f;-}-#endif--#endif  // __cplusplus-#endif  // __ACCELERATE_CUDA_FUNCTION_H__-
− cubits/accelerate_cuda_shape.h 
@@ -1,328 +0,0 @@-/* ------------------------------------------------------------------------------ *- * Module      : Shape- * Copyright   : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell- * License     : BSD3- *- * Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>- * Stability   : experimental- *- * ---------------------------------------------------------------------------*/--#ifndef __ACCELERATE_CUDA_SHAPE_H__-#define __ACCELERATE_CUDA_SHAPE_H__--#include <stdint.h>-#include <cuda_runtime.h>--typedef int32_t                                   Ix;-typedef void*                                     DIM0;-typedef Ix                                        DIM1;-typedef struct { Ix a1,a0; }                      DIM2;-typedef struct { Ix a2,a1,a0; }                   DIM3;-typedef struct { Ix a3,a2,a1,a0; }                DIM4;-typedef struct { Ix a4,a3,a2,a1,a0; }             DIM5;-typedef struct { Ix a5,a4,a3,a2,a1,a0; }          DIM6;-typedef struct { Ix a6,a5,a4,a3,a2,a1,a0; }       DIM7;-typedef struct { Ix a7,a6,a5,a4,a3,a2,a1,a0; }    DIM8;-typedef struct { Ix a8,a7,a6,a5,a4,a3,a2,a1,a0; } DIM9;--#ifdef __cplusplus--/* ------------------------------------------------------------------------------ * Shape construction and destruction- */--/*- * Convert the individual dimensions of a linear array into a shape- */-static __inline__ __device__ DIM0 shape()-{-    return NULL;-}--static __inline__ __device__ DIM1 shape(const Ix a)-{-    return a;-}--static __inline__ __device__ DIM2 shape(const Ix b, const Ix a)-{-    DIM2 sh = { b, a };-    return sh;-}--static __inline__ __device__ DIM3 shape(const Ix c, const Ix b, const Ix a)-{-    DIM3 sh = { c, b, a };-    return sh;-}--static __inline__ __device__ DIM4 shape(const Ix d, const Ix c, const Ix b, const Ix a)-{-    DIM4 sh = { d, c, b, a };-    return sh;-}--static __inline__ __device__ DIM5 shape(const Ix e, const Ix d, const Ix c, const Ix b, const Ix a)-{-    DIM5 sh = { e, d, c, b, a };-    return sh;-}--static __inline__ __device__ DIM6 shape(const Ix f, const Ix e, const Ix d, const Ix c, const Ix b, const Ix a)-{-    DIM6 sh = { f, e, d, c, b, a };-    return sh;-}--static __inline__ __device__ DIM7 shape(const Ix g, const Ix f, const Ix e, const Ix d, const Ix c, const Ix b, const Ix a)-{-    DIM7 sh = { g, f, e, d, c, b, a };-    return sh;-}--static __inline__ __device__ DIM8 shape(const Ix h, const Ix g, const Ix f, const Ix e, const Ix d, const Ix c, const Ix b, const Ix a)-{-    DIM8 sh = { h, g, f, e, d, c, b, a };-    return sh;-}--static __inline__ __device__ DIM9 shape(const Ix i, const Ix h, const Ix g, const Ix f, const Ix e, const Ix d, const Ix c, const Ix b, const Ix a)-{-    DIM9 sh = { i, h, g, f, e, d, c, b, a };-    return sh;-}--/*- * Yield the inner-most dimension of a shape only- */-template <typename Shape>-static __inline__ __device__ Ix indexHead(const Shape ix)-{-    return ix.a0;-}--template <>-static __inline__ __device__ Ix indexHead(const DIM0 ix)-{-    return 0;-}--template <>-static __inline__ __device__ Ix indexHead(const DIM1 ix)-{-    return ix;-}---/*- * Yield all but the inner-most dimension of a shape- */-static __inline__ __device__ DIM0 indexTail(const DIM1 ix)-{-    return 0;-}--static __inline__ __device__ DIM1 indexTail(const DIM2 ix)-{-    return ix.a1;-}--static __inline__ __device__ DIM2 indexTail(const DIM3 ix)-{-    return shape(ix.a2, ix.a1);-}--static __inline__ __device__ DIM3 indexTail(const DIM4 ix)-{-    return shape(ix.a3, ix.a2, ix.a1);-}--static __inline__ __device__ DIM4 indexTail(const DIM5 ix)-{-    return shape(ix.a4, ix.a3, ix.a2, ix.a1);-}--static __inline__ __device__ DIM5 indexTail(const DIM6 ix)-{-    return shape(ix.a5, ix.a4, ix.a3, ix.a2, ix.a1);-}--static __inline__ __device__ DIM6 indexTail(const DIM7 ix)-{-    return shape(ix.a6, ix.a5, ix.a4, ix.a3, ix.a2, ix.a1);-}--static __inline__ __device__ DIM7 indexTail(const DIM8 ix)-{-    return shape(ix.a7, ix.a6, ix.a5, ix.a4, ix.a3, ix.a2, ix.a1);-}--static __inline__ __device__ DIM8 indexTail(const DIM9 ix)-{-    return shape(ix.a8, ix.a7, ix.a6, ix.a5, ix.a4, ix.a3, ix.a2, ix.a1);-}---/* ------------------------------------------------------------------------------ * Shape methods- */--/*- * Number of dimensions of a shape- */-template <typename Shape>-static __inline__ __device__ int dim(const Shape sh)-{-    return dim(indexTail(sh)) + 1;-}--template <>-static __inline__ __device__ int dim(const DIM0 sh)-{-    return 0;-}---/*- * Yield the total number of elements in a shape- */-template <typename Shape>-static __inline__ __device__ int size(const Shape sh)-{-    return size(indexTail(sh)) * indexHead(sh);-}--template <>-static __inline__ __device__ int size(const DIM0 sh)-{-    return 1;-}---/*- * Add an index to the head of a shape- */-static __inline__ __device__ DIM1 indexCons(const DIM0 sh, const Ix ix)-{-    return shape(ix);-}--static __inline__ __device__ DIM2 indexCons(const DIM1 sh, const Ix ix)-{-    return shape(sh, ix);-}--static __inline__ __device__ DIM3 indexCons(const DIM2 sh, const Ix ix)-{-    return shape(sh.a1, sh.a0, ix);-}--static __inline__ __device__ DIM4 indexCons(const DIM3 sh, const Ix ix)-{-    return shape(sh.a2, sh.a1, sh.a0, ix);-}--static __inline__ __device__ DIM5 indexCons(const DIM4 sh, const Ix ix)-{-    return shape(sh.a3, sh.a2, sh.a1, sh.a0, ix);-}--static __inline__ __device__ DIM6 indexCons(const DIM5 sh, const Ix ix)-{-    return shape(sh.a4, sh.a3, sh.a2, sh.a1, sh.a0, ix);-}--static __inline__ __device__ DIM7 indexCons(const DIM6 sh, const Ix ix)-{-    return shape(sh.a5, sh.a4, sh.a3, sh.a2, sh.a1, sh.a0, ix);-}--static __inline__ __device__ DIM8 indexCons(const DIM7 sh, const Ix ix)-{-    return shape(sh.a6, sh.a5, sh.a4, sh.a3, sh.a2, sh.a1, sh.a0, ix);-}--static __inline__ __device__ DIM9 indexCons(const DIM8 sh, const Ix ix)-{-    return shape(sh.a7, sh.a6, sh.a5, sh.a4, sh.a3, sh.a2, sh.a1, sh.a0, ix);-}---/*- * Yield the index position in a linear, row-major representation of the array.- * First argument is the shape of the array, the second the index- */-template <typename Shape>-static __inline__ __device__ Ix toIndex(const Shape sh, const Shape ix)-{-    return toIndex(indexTail(sh), indexTail(ix)) * indexHead(sh) + indexHead(ix);-}--template <>-static __inline__ __device__ Ix toIndex(const DIM0 sh, const DIM0 ix)-{-    return 0;-}--template <>-static __inline__ __device__ Ix toIndex(const DIM1 sh, const DIM1 ix)-{-    return ix;-}---/*- * Inverse of 'toIndex'- */-template <typename Shape>-static __inline__ __device__ Shape fromIndex(const Shape sh, const Ix ix)-{-    const Ix d = indexHead(sh);-    return indexCons(fromIndex(indexTail(sh), ix / d), ix % d);-}--template <>-static __inline__ __device__ DIM0 fromIndex(const DIM0 sh, const Ix ix)-{-    return 0;-}--template <>-static __inline__ __device__ DIM1 fromIndex(const DIM1 sh, const Ix ix)-{-    return ix;-}---/*- * Test for the magic index `ignore`- */-template <typename Shape>-static __inline__ __device__ int ignore(const Shape ix)-{-    return indexHead(ix) == -1 && ignore(indexTail(ix));-}--template <>-static __inline__ __device__ int ignore(const DIM0 ix)-{-    return 1;-}---#else--static __inline__ __device__ int dim(const Ix sh);-static __inline__ __device__ int size(const Ix sh);-static __inline__ __device__ int shape(const Ix sh);-static __inline__ __device__ int toIndex(const Ix sh, const Ix ix);-static __inline__ __device__ int fromIndex(const Ix sh, const Ix ix);-static __inline__ __device__ int indexHead(const Ix ix);-static __inline__ __device__ int indexTail(const Ix ix);-static __inline__ __device__ int indexCons(const Ix sh, const Ix ix);--#endif  // __cplusplus-#endif  // __ACCELERATE_CUDA_SHAPE_H__-
− cubits/accelerate_cuda_stencil.h 
@@ -1,91 +0,0 @@-/* ------------------------------------------------------------------------------ *- * Module      : Stencil- * Copyright   : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell- * License     : BSD3- *- * Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>- * Stability   : experimental- *- * ---------------------------------------------------------------------------*/--#ifndef __ACCELERATE_CUDA_STENCIL_H__-#define __ACCELERATE_CUDA_STENCIL_H__--#include <accelerate_cuda_shape.h>--#ifdef __cplusplus--/*- * Test if an index lies within the boundaries of a shape- */-template <typename Shape>-static __inline__ __device__ int inRange(const Shape sh, const Shape ix)-{-    return inRange(indexHead(sh), indexHead(ix)) && inRange(indexTail(sh), indexTail(ix));-}--template <>-static __inline__ __device__ int inRange(const DIM1 sz, const DIM1 i)-{-    return i >= 0 && i < sz;-}--template <>-static __inline__ __device__ int inRange(const DIM0 sz, const DIM0 i)-{-    return i == 0;-}---/*- * Boundary condition handlers- */-template <typename Shape>-static __inline__ __device__ Shape clamp(const Shape sh, const Shape ix)-{-    return indexCons( clamp(indexTail(sh), indexTail(ix))-                    , clamp(indexHead(sh), indexHead(ix)) );-}--template <>-static __inline__ __device__ DIM1 clamp(const DIM1 sz, const DIM1 i)-{-    return max(0, min(i, sz-1));-}---template <typename Shape>-static __inline__ __device__ Shape mirror(const Shape sh, const Shape ix)-{-    return indexCons( mirror(indexTail(sh), indexTail(ix))-                    , mirror(indexHead(sh), indexHead(ix)) );-}--template <>-static __inline__ __device__ DIM1 mirror(const DIM1 sz, const DIM1 i)-{-    if      (i <  0)  return -i;-    else if (i >= sz) return sz - (i-sz+2);-    else              return i;-}---template <typename Shape>-static __inline__ __device__ Shape wrap(const Shape sh, const Shape ix)-{-    return indexCons( wrap(indexTail(sh), indexTail(ix))-                    , wrap(indexHead(sh), indexHead(ix)) );-}--template <>-static __inline__ __device__ DIM1 wrap(const DIM1 sz, const DIM1 i)-{-    if      (i <  0)  return sz+i;-    else if (i >= sz) return i-sz;-    else              return i;-}--#endif--#endif
− cubits/accelerate_cuda_texture.h 
@@ -1,132 +0,0 @@-/* ------------------------------------------------------------------------------ *- * Module      : Texture- * Copyright   : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell- * License     : BSD3- *- * Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>- * Stability   : experimental- *- * CUDA texture definitions and access functions are defined in terms of- * templates, and hence only available through the C++ interface. Expose some- * dummy wrappers to enable parsing with language-c.- *- * We don't have a definition for `Int' or `Word', since the bitwidth of the- * Haskell and C types may be different.- *- * NOTE ON 64-BIT TYPES- *   The CUDA device uses little-endian arithmetic. We haven't accounted for the- *   fact that this may be different on the host, for both initial data transfer- *   and the unpacking below.- *- * ---------------------------------------------------------------------------*/--#ifndef __ACCELERATE_CUDA_TEXTURE_H__-#define __ACCELERATE_CUDA_TEXTURE_H__--#include <stdint.h>-#include <cuda_runtime.h>--#if defined(__cplusplus) && defined(__CUDACC__)--typedef texture<uint2,    1> TexWord64;-typedef texture<uint32_t, 1> TexWord32;-typedef texture<uint16_t, 1> TexWord16;-typedef texture<uint8_t,  1> TexWord8;-typedef texture<int2,     1> TexInt64;-typedef texture<int32_t,  1> TexInt32;-typedef texture<int16_t,  1> TexInt16;-typedef texture<int8_t,   1> TexInt8;-typedef texture<float,    1> TexFloat;-typedef texture<char,     1> TexCChar;--static __inline__ __device__ uint8_t  indexArray(TexWord8  t, const int x) { return tex1Dfetch(t,x); }-static __inline__ __device__ uint16_t indexArray(TexWord16 t, const int x) { return tex1Dfetch(t,x); }-static __inline__ __device__ uint32_t indexArray(TexWord32 t, const int x) { return tex1Dfetch(t,x); }-static __inline__ __device__ uint64_t indexArray(TexWord64 t, const int x)-{-  union { uint2 x; uint64_t y; } v;-  v.x = tex1Dfetch(t,x);-  return v.y;-}--static __inline__ __device__ int8_t  indexArray(TexInt8  t, const int x) { return tex1Dfetch(t,x); }-static __inline__ __device__ int16_t indexArray(TexInt16 t, const int x) { return tex1Dfetch(t,x); }-static __inline__ __device__ int32_t indexArray(TexInt32 t, const int x) { return tex1Dfetch(t,x); }-static __inline__ __device__ int64_t indexArray(TexInt64 t, const int x)-{-  union { int2 x; int64_t y; } v;-  v.x = tex1Dfetch(t,x);-  return v.y;-}--static __inline__ __device__ float indexArray(TexFloat  t, const int x) { return tex1Dfetch(t,x); }-static __inline__ __device__ char  indexArray(TexCChar  t, const int x) { return tex1Dfetch(t,x); }--#if defined(__LP64__)-typedef TexInt64  TexCLong;-typedef TexWord64 TexCULong;-#else-typedef TexInt32  TexCLong;-typedef TexWord32 TexCULong;-#endif--/*- * Synonyms for C-types. NVCC will force Ints to be 32-bits.- */-typedef TexInt8   TexCSChar;-typedef TexWord8  TexCUChar;-typedef TexInt16  TexCShort;-typedef TexWord16 TexCUShort;-typedef TexInt32  TexCInt;-typedef TexWord32 TexCUInt;-typedef TexInt64  TexCLLong;-typedef TexWord64 TexCULLong;-typedef TexFloat  TexCFloat;--/*- * Doubles, only available when compiled for Compute 1.3 and greater- */-typedef texture<int2, 1> TexDouble;-typedef TexDouble        TexCDouble;--#if !defined(CUDA_NO_SM_13_DOUBLE_INTRINSICS)-static __inline__ __device__ double indexDArray(TexDouble t, const int x)-{-  int2 v = tex1Dfetch(t,x);-  return __hiloint2double(v.y,v.x);-}-#endif--#else--typedef void* TexWord64;-typedef void* TexWord32;-typedef void* TexWord16;-typedef void* TexWord8;-typedef void* TexInt64;-typedef void* TexInt32;-typedef void* TexInt16;-typedef void* TexInt8;-typedef void* TexCShort;-typedef void* TexCUShort;-typedef void* TexCInt;-typedef void* TexCUInt;-typedef void* TexCLong;-typedef void* TexCULong;-typedef void* TexCLLong;-typedef void* TexCULLong;-typedef void* TexFloat;-typedef void* TexDouble;-typedef void* TexCFloat;-typedef void* TexCDouble;-typedef void* TexCChar;-typedef void* TexCSChar;-typedef void* TexCUChar;--void* indexArray(const void*, const int);-void* indexDArray(const void*, const int);--#endif  // defined(__cplusplus) && defined(__CUDACC__)-#endif  // __ACCELERATE_CUDA_TEXTURE_H__-
− cubits/accelerate_cuda_util.h 
@@ -1,69 +0,0 @@-/* ------------------------------------------------------------------------------ *- * Module      : Util- * Copyright   : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell- * License     : BSD3- *- * Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>- * Stability   : experimental- *- * ---------------------------------------------------------------------------*/--#ifndef __ACCELERATE_CUDA_UTIL_H__-#define __ACCELERATE_CUDA_UTIL_H__--#include <math.h>-#include <cuda_runtime.h>--/*- * Core assert function. Don't let this escape...- */-#if defined(__CUDACC__) || !defined(__DEVICE_EMULATION__)-#define __assert(e, file, line) ((void)0)-#else-#define __assert(e, file, line) \-    ((void) fprintf (stderr, "%s:%u: failed assertion `%s'\n", file, line, e), abort())-#endif--/*- * Test the given expression, and abort the program if it evaluates to false.- * Only available in debug mode.- */-#ifndef _DEBUG-#define assert(e)               ((void)0)-#else-#define assert(e)  \-    ((void) ((e) ? (void(0)) : __assert (#e, __FILE__, __LINE__)))-#endif--/*- * Macro to insert __syncthreads() in device emulation mode- */-#ifdef __DEVICE_EMULATION__-#define __EMUSYNC               __syncthreads()-#else-#define __EMUSYNC-#endif--/*- * Check the return status of CUDA API calls, and abort with an appropriate- * error string on failure.- */-#define CUDA_SAFE_CALL_NO_SYNC(call)                                           \-    do {                                                                       \-        cudaError err = call;                                                  \-        if(cudaSuccess != err) {                                               \-            const char *str = cudaGetErrorString(err);                         \-            __assert(str, __FILE__, __LINE__);                                 \-        }                                                                      \-    } while (0)--#define CUDA_SAFE_CALL(call)                                                   \-    do {                                                                       \-        CUDA_SAFE_CALL_NO_SYNC(call);                                          \-        CUDA_SAFE_CALL_NO_SYNC(cudaThreadSynchronize());                       \-    } while (0)--#undef __assert-#endif  // __ACCELERATE_CUDA_UTIL_H__-
− cubits/backpermute.inl 
@@ -1,39 +0,0 @@-/* ------------------------------------------------------------------------------ *- * Kernel      : Backpermute- * Copyright   : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell- * License     : BSD3- *- * Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>- * Stability   : experimental- *- * Backwards permutation (gather) an array according to the permutation- * function. The input `shape' is that of the output array.- *- *   bpermute :: [a] -> [Int] -> [a]- *   bpermute v is = [ v!i | i <- is ]- *- * ---------------------------------------------------------------------------*/--extern "C"-__global__ void-backpermute-(-    ArrOut              d_out,-    const ArrIn0        d_in0,-    const DimOut        shOut,-    const DimIn0        shIn0-)-{-    const Ix shapeSize = size(shOut);-    const Ix gridSize  = __umul24(blockDim.x, gridDim.x);--    for (Ix ix = __umul24(blockDim.x, blockIdx.x) + threadIdx.x; ix < shapeSize; ix += gridSize)-    {-        DimOut dst = fromIndex(shOut, ix);-        DimIn0 src = project(dst);--        set(d_out, ix, get0(d_in0, toIndex(shIn0, src)));-    }-}-
− cubits/fold.inl 
@@ -1,97 +0,0 @@-/* ------------------------------------------------------------------------------ *- * Kernel      : Fold- * Copyright   : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell- * License     : BSD3- *- * Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>- * Stability   : experimental- *- * Reduce the innermost dimension of a multidimensional array to a single value- * with a binary associative function- *- * ---------------------------------------------------------------------------*/--#include "reduce.inl"---extern "C"-__global__ void-fold-(-    ArrOut              d_out,-    const ArrIn0        d_in0,-    const DimOut        shOut,-    const DimIn0        shIn0-)-{-    extern volatile __shared__ void* s_ptr[];-    ArrOut s_data = partition(s_ptr, blockDim.x);--    const Ix num_elements = indexHead(shIn0);-    const Ix num_segments = size(shOut);--    const Ix num_vectors  = blockDim.x / warpSize * gridDim.x;-    const Ix thread_id    = blockDim.x * blockIdx.x + threadIdx.x;-    const Ix vector_id    = thread_id / warpSize;-    const Ix thread_lane  = threadIdx.x & (warpSize - 1);--    /*-     * Each warp reduces elements along a projection through an innermost-     * dimension to a single value-     */-    for (Ix seg = vector_id; seg < num_segments; seg += num_vectors)-    {-        const Ix    start = seg   * num_elements;-        const Ix    end   = start + num_elements;-              TyOut sum;--        if (num_elements > warpSize)-        {-            /*-             * Ensure aligned access to global memory, and that each thread-             * initialises its local sum.-             */-            Ix i = start - (start & (warpSize - 1)) + thread_lane;-            if (i >= start)-                sum = get0(d_in0, i);--            if (i + warpSize < end)-            {-                TyOut tmp = get0(d_in0, i + warpSize);--                if (i >= start) sum = apply(sum, tmp);-                else            sum = tmp;-            }--            /*-             * Now, iterate along the inner-most dimension collecting a local sum-             */-            for (i += 2 * warpSize; i < end; i += warpSize)-                sum = apply(sum, get0(d_in0, i));-        }-        else if (start + thread_lane < end)-        {-            sum = get0(d_in0, start + thread_lane);-        }--        /*-         * Each thread puts its local sum into shared memory, then cooperatively-         * reduce the shared array to a single value.-         */-        set(s_data, threadIdx.x, sum);-        sum = reduce_warp_n(s_data, sum, min(num_elements, warpSize));--        /*-         * Finally, the first thread writes the result for this segment-         */-        if (thread_lane == 0)-        {-#ifndef INCLUSIVE-            sum = num_elements > 0 ? apply(sum, identity()) : identity();-#endif-            set(d_out, seg, sum);-        }-    }-}-
− cubits/foldAll.inl 
@@ -1,80 +0,0 @@-/* ------------------------------------------------------------------------------ *- * Kernel      : FoldAll- * Copyright   : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell- * License     : BSD3- *- * Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>- * Stability   : experimental- *- * Reduce a *vector* to a single value with a binary associative function- *- * ---------------------------------------------------------------------------*/--#include "reduce.inl"--/*- * Compute multiple elements per thread sequentially. This reduces the overall- * cost of the algorithm while keeping the work complexity O(n) and the step- * complexity O(log n). c.f. Brent's Theorem optimisation.- */-extern "C"-__global__ void-fold-(-    ArrOut              d_out,-    const ArrIn0        d_in0,-    const Ix            shape-)-{-    extern volatile __shared__ void* s_ptr[];-    ArrOut s_data = partition(s_ptr, blockDim.x);--    /*-     * Calculate first level of reduction reading into shared memory-     */-    const Ix    tid      = threadIdx.x;-    const Ix    gridSize = blockDim.x * gridDim.x;-          Ix    i        = blockIdx.x * blockDim.x + tid;-          TyOut sum;--    /*-     * Reduce multiple elements per thread. The number is determined by the-     * number of active thread blocks (via gridDim). More blocks will result in-     * a larger `gridSize', and hence fewer elements per thread-     *-     * The loop stride of `gridSize' is used to maintain coalescing.-     */-    if (i < shape)-    {-        sum = get0(d_in0, i);-        for (i += gridSize; i < shape; i += gridSize)-            sum = apply(sum, get0(d_in0, i));-    }--    /*-     * Each thread puts its local sum into shared memory, then threads-     * cooperatively reduce the shared array to a single value.-     */-    set(s_data, tid, sum);-    __syncthreads();--    sum = reduce_block_n(s_data, sum, min(shape, blockDim.x));--    /*-     * Write the results of this block back to global memory. If we are the last-     * phase of a recursive multi-block reduction, include the seed element.-     */-    if (tid == 0)-    {-#ifdef INCLUSIVE-        set(d_out, blockIdx.x, sum);-#else-        if (shape > 0)-            set(d_out, blockIdx.x, gridDim.x == 1 ? apply(sum, identity()) : sum);-        else-            set(d_out, blockIdx.x, identity());-#endif-    }-}-
− cubits/foldSeg.inl 
@@ -1,132 +0,0 @@-/* ------------------------------------------------------------------------------ *- * Kernel      : FoldSeg- * Copyright   : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell- * License     : BSD3- *- * Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>- * Stability   : experimental- *- * Reduce segments along the innermost dimension of a multidimensional array to- * a single value for each segment, using a binary associative function- *- * ---------------------------------------------------------------------------*/--#include "reduce.inl"--/*- * Each segment of the vector is assigned to a warp, which computes the- * reduction of the i-th section, in parallel.- *- * This division of work implies that the data arrays are accessed in a- * contiguous manner (if not necessarily aligned). For devices of compute- * capability 1.2 and later, these accesses will be coalesced. A single- * transaction will be issued if all of the addresses for a half-warp happen to- * fall within a single 128-byte boundary. Extra transactions will be made to- * cover any spill. The same applies for 2.x devices, except that all widths are- * doubled since transactions occur on a per-warp basis.- *- * Since an entire 32-thread warp is assigned for each segment, many threads- * will remain idle when the segments are very small. This code relies on- * implicit synchronisation among threads in a warp.- *- * The offset array contains the starting index for each segment in the input- * array. The i-th warp reduces values in the input array at indices- * [d_offset[i], d_offset[i+1]).- */-extern "C"-__global__ void-foldSeg-(-    ArrOut              d_out,-    const ArrIn0        d_in0,-    const Int*          d_offset,-    const DimOut        shOut,-    const DimIn0        shIn0-)-{-    const Ix vectors_per_block = blockDim.x / warpSize;-    const Ix num_vectors       = vectors_per_block * gridDim.x;-    const Ix thread_id         = blockDim.x * blockIdx.x + threadIdx.x;-    const Ix vector_id         = thread_id / warpSize;-    const Ix thread_lane       = threadIdx.x & (warpSize - 1);-    const Ix vector_lane       = threadIdx.x / warpSize;--    const Ix num_segments      = indexHead(shOut);-    const Ix total_segments    = size(shOut);--    /*-     * Manually partition (dynamically-allocated) shared memory-     */-    extern volatile __shared__ Ix s_ptrs[][2];-    ArrOut s_data = partition((void*) &s_ptrs[vectors_per_block][2], blockDim.x);--    for (Ix seg = vector_id; seg < total_segments; seg += num_vectors)-    {-        const Ix s    =  seg % num_segments;-        const Ix base = (seg / num_segments) * indexHead(shIn0);--        /*-         * Use two threads to fetch the indices of the start and end of this-         * segment. This results in single coalesced global read, instead of two-         * separate transactions.-         */-        if (thread_lane < 2)-            s_ptrs[vector_lane][thread_lane] = d_offset[s + thread_lane];--        const Ix    start        = base + s_ptrs[vector_lane][0];-        const Ix    end          = base + s_ptrs[vector_lane][1];-        const Ix    num_elements = end - start;-              TyOut sum;--        /*-         * Each thread reads in values of this segment, accumulating a local sum-         */-        if (num_elements > warpSize)-        {-            /*-             * Ensure aligned access to global memory-             */-            Ix i = start - (start & (warpSize - 1)) + thread_lane;-            if (i >= start)-                sum = get0(d_in0, i);--            /*-             * Subsequent reads to global memory are aligned, but make sure all-             * threads have initialised their local sum.-             */-            if (i + warpSize < end)-            {-                TyOut tmp = get0(d_in0, i + warpSize);--                if (i >= start) sum = apply(sum, tmp);-                else            sum = tmp;-            }--            for (i += 2 * warpSize; i < end; i += warpSize)-                sum = apply(sum, get0(d_in0, i));-        }-        else if (start + thread_lane < end)-        {-            sum = get0(d_in0, start + thread_lane);-        }--        /*-         * Store local sums into shared memory and reduce to a single value-         */-        set(s_data, threadIdx.x, sum);-        sum = reduce_warp_n(s_data, sum, min(num_elements, warpSize));--        /*-         * Finally, the first thread writes the result for this segment-         */-        if (thread_lane == 0)-        {-#ifndef INCLUSIVE-            sum = num_elements > 0 ? apply(sum, identity()) : identity();-#endif-            set(d_out, seg, sum);-        }-    }-}-
− cubits/generate.inl 
@@ -1,32 +0,0 @@-/* ------------------------------------------------------------------------------ *- * Kernel      : Generate- * Copyright   : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell- * License     : BSD3- *- * Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>- * Stability   : experimental- *- * Apply the function to each element of the array. Each thread processes- * multiple elements, striding the array by the grid size.- *- * ---------------------------------------------------------------------------*/--extern "C"-__global__ void-generate-(-    ArrOut              d_out,-    const DimOut        shOut-)-{-    Ix       idx;-    const Ix n        = size(shOut);-    const Ix gridSize = __umul24(blockDim.x, gridDim.x);--    for (idx = __umul24(blockDim.x, blockIdx.x) + threadIdx.x; idx < n; idx += gridSize)-    {-        set(d_out, idx, apply(fromIndex(shOut, idx)));-    }-}-
− cubits/map.inl 
@@ -1,32 +0,0 @@-/* ------------------------------------------------------------------------------ *- * Kernel      : Map- * Copyright   : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell- * License     : BSD3- *- * Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>- * Stability   : experimental- *- * Apply the function to each element of the array. Each thread processes- * multiple elements, striding the array by the grid size.- *- * ---------------------------------------------------------------------------*/--extern "C"-__global__ void-map-(-    ArrOut              d_out,-    const ArrIn0        d_in0,-    const Ix            shape-)-{-    Ix       idx;-    const Ix gridSize = __umul24(blockDim.x, gridDim.x);--    for (idx = __umul24(blockDim.x, blockIdx.x) + threadIdx.x; idx < shape; idx += gridSize)-    {-        set(d_out, idx, apply(get0(d_in0, idx)));-    }-}-
− cubits/permute.inl 
@@ -1,45 +0,0 @@-/* ------------------------------------------------------------------------------ *- * Kernel      : Permute- * Copyright   : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell- * License     : BSD3- *- * Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>- * Stability   : experimental- *- * Forward permutation, characterised by a function that determines for each- * element in the source array where it should go in the target. The output- * array should be initialised with a default value, as the permutation may be- * between arrays of different sizes and some positions may never be touched.- *- * Elements from the source array are dropped for which the permutation function- * yields the magic index `ignore`.- *- * ---------------------------------------------------------------------------*/--extern "C"-__global__ void-permute-(-    ArrOut              d_out,-    const ArrIn0        d_in0,-    const DimOut        shOut,-    const DimIn0        shIn0-)-{-    const Ix shapeSize = size(shIn0);-    const Ix gridSize  = __umul24(blockDim.x, gridDim.x);--    for (Ix ix = __umul24(blockDim.x, blockIdx.x) + threadIdx.x; ix < shapeSize; ix += gridSize)-    {-        DimIn0 src = fromIndex(shIn0, ix);-        DimOut dst = project(src);--        if (!ignore(dst))-        {-            Ix j = toIndex(shOut, dst);-            set(d_out, j, apply(get0(d_in0, ix), get0(d_out, j)));-        }-    }-}-
− cubits/reduce.inl 
@@ -1,72 +0,0 @@-/* ------------------------------------------------------------------------------ *- * Kernel      : Reduce- * Copyright   : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell- * License     : BSD3- *- * Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>- * Stability   : experimental- *- * ---------------------------------------------------------------------------*/--#ifndef __REDUCE__-#define __REDUCE__---/*- * Cooperatively reduce a single warp's segment of an array to a single value- */-static __inline__ __device__ TyOut-reduce_warp_n-(-    ArrOut      s_data,-    TyOut       sum,-    Ix          n-)-{-    const Ix tid  = threadIdx.x;-    const Ix lane = threadIdx.x & (warpSize - 1);--    if (n > 16 && lane + 16 < n) { sum = apply(sum, get0(s_data, tid+16)); set(s_data, tid, sum); }-    if (n >  8 && lane +  8 < n) { sum = apply(sum, get0(s_data, tid+ 8)); set(s_data, tid, sum); }-    if (n >  4 && lane +  4 < n) { sum = apply(sum, get0(s_data, tid+ 4)); set(s_data, tid, sum); }-    if (n >  2 && lane +  2 < n) { sum = apply(sum, get0(s_data, tid+ 2)); set(s_data, tid, sum); }-    if (n >  1 && lane +  1 < n) { sum = apply(sum, get0(s_data, tid+ 1)); }--    return sum;-}---/*- * Block reduction to a single value- */-static __inline__ __device__ TyOut-reduce_block_n-(-    ArrOut      s_data,-    TyOut       sum,-    Ix          n-)-{-    const Ix tid = threadIdx.x;--    if (n > 512) { if (tid < 512 && tid + 512 < n) { sum = apply(sum, get0(s_data, tid+512)); set(s_data, tid, sum); } __syncthreads(); }-    if (n > 256) { if (tid < 256 && tid + 256 < n) { sum = apply(sum, get0(s_data, tid+256)); set(s_data, tid, sum); } __syncthreads(); }-    if (n > 128) { if (tid < 128 && tid + 128 < n) { sum = apply(sum, get0(s_data, tid+128)); set(s_data, tid, sum); } __syncthreads(); }-    if (n >  64) { if (tid <  64 && tid +  64 < n) { sum = apply(sum, get0(s_data, tid+ 64)); set(s_data, tid, sum); } __syncthreads(); }--    if (tid < 32)-    {-        if (n > 32) { if (tid + 32 < n) { sum = apply(sum, get0(s_data, tid+32)); set(s_data, tid, sum); }}-        if (n > 16) { if (tid + 16 < n) { sum = apply(sum, get0(s_data, tid+16)); set(s_data, tid, sum); }}-        if (n >  8) { if (tid +  8 < n) { sum = apply(sum, get0(s_data, tid+ 8)); set(s_data, tid, sum); }}-        if (n >  4) { if (tid +  4 < n) { sum = apply(sum, get0(s_data, tid+ 4)); set(s_data, tid, sum); }}-        if (n >  2) { if (tid +  2 < n) { sum = apply(sum, get0(s_data, tid+ 2)); set(s_data, tid, sum); }}-        if (n >  1) { if (tid +  1 < n) { sum = apply(sum, get0(s_data, tid+ 1)); }}-    }--    return sum;-}--#endif-
− cubits/replicate.inl 
@@ -1,33 +0,0 @@-/* ------------------------------------------------------------------------------ *- * Kernel      : Replicate- * Copyright   : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell- * License     : BSD3- *- * Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>- * Stability   : experimental- *- * ---------------------------------------------------------------------------*/--extern "C"-__global__ void-replicate-(-    ArrOut              d_out,-    const ArrIn0        d_in0,-    const Slice         slice,-    const SliceDim      sliceDim-)-{-    const Ix shapeSize = size(sliceDim);-    const Ix gridSize  = __umul24(blockDim.x, gridDim.x);--    for (Ix ix = __umul24(blockDim.x, blockIdx.x) + threadIdx.x; ix < shapeSize; ix += gridSize)-    {-        SliceDim dst = fromIndex(sliceDim, ix);-        Slice    src = sliceIndex(dst);--        set(d_out, ix, get0(d_in0, toIndex(slice, src)));-    }-}-
− cubits/scan.inl 
@@ -1,23 +0,0 @@-/* ------------------------------------------------------------------------------ *- * Kernel      : Scan- * Copyright   : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell- * License     : BSD3- *- * Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>- * Stability   : experimental- *- * Data.List-style exclusive scans with an associative binary function, and a- * variant where the final reduction result is returned separately:- *- * > scanl' f z xs =- * >   let r = Data.List.scanl f z xs- * >   in  (init r, last r)- *- * This variant is generated by defining HASKELL_STYLE as zero.- *- * ---------------------------------------------------------------------------*/--#include <thrust/safe_scan_intervals.inl>-#include <thrust/exclusive_scan.inl>-
− cubits/scan1.inl 
@@ -1,17 +0,0 @@-/* ------------------------------------------------------------------------------ *- * Kernel      : Scan1- * Copyright   : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell- * License     : BSD3- *- * Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>- * Stability   : experimental- *- * A Data.List-style scan without an initial value (i.e. inclusive scan) and an- * associative binary function- *- * ---------------------------------------------------------------------------*/--#include <thrust/safe_scan_intervals.inl>-#include <thrust/inclusive_scan.inl>-
− cubits/slice.inl 
@@ -1,34 +0,0 @@-/* ------------------------------------------------------------------------------ *- * Kernel      : Slice- * Copyright   : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell- * License     : BSD3- *- * Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>- * Stability   : experimental- *- * ---------------------------------------------------------------------------*/--extern "C"-__global__ void-slice-(-    ArrOut              d_out,-    const ArrIn0        d_in0,-    const Slice         slice,-    const CoSlice       slix,-    const SliceDim      sliceDim-)-{-    const Ix shapeSize = size(slice);-    const Ix gridSize  = __umul24(blockDim.x, gridDim.x);--    for (Ix ix = __umul24(blockDim.x, blockIdx.x) + threadIdx.x; ix < shapeSize; ix += gridSize)-    {-        Slice    dst = fromIndex(slice, ix);-        SliceDim src = sliceIndex(dst, slix);--        set(d_out, ix, get0(d_in0, toIndex(sliceDim, src)));-    }-}-
− cubits/stencil.inl 
@@ -1,33 +0,0 @@-/* ------------------------------------------------------------------------------ *- * Kernel      : Stencil- * Copyright   : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell- * License     : BSD3- *- * Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>- * Stability   : experimental- *- * Apply the function to each element of the array that takes a neighborhood of- * elements as its input. Each thread processes multiple elements, striding the- * array by the grid size. To improve performance, the input array is bound as- * a texture reference so that reads are cached.- *- * ---------------------------------------------------------------------------*/--extern "C"-__global__ void-stencil-(-    ArrOut        d_out,-    const DimOut  shOut-)-{-    const Ix shapeSize = size(shOut);-    const Ix gridSize  = __umul24(blockDim.x, gridDim.x);--    for (Ix ix = __umul24(blockDim.x, blockIdx.x) + threadIdx.x; ix < shapeSize; ix += gridSize)-    {-        set(d_out, ix, apply(gather0(shOut, fromIndex(shOut, ix))));-    }-}-
− cubits/stencil2.inl 
@@ -1,36 +0,0 @@-/* ------------------------------------------------------------------------------ *- * Kernel      : Stencil2- * Copyright   : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell- * License     : BSD3- *- * Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>- * Stability   : experimental- *- * Apply the function to each element of the array that takes a neighborhood of- * elements from two input arrays. Each thread processes multiple elements,- * striding the array by the grid size. To improve performance, both input- * arrays are bound as texture references so that reads are cached.- *- * ---------------------------------------------------------------------------*/--extern "C"-__global__ void-stencil2-(-    ArrOut        d_out,-    const DimOut  shOut,-    const DimIn1  shIn1,-    const DimIn0  shIn0-)-{-    const Ix shapeSize = size(shOut);-    const Ix gridSize  = __umul24(blockDim.x, gridDim.x);--    for (Ix i = __umul24(blockDim.x, blockIdx.x) + threadIdx.x; i < shapeSize; i += gridSize)-    {-        DimOut ix = fromIndex(shOut, i);-        set(d_out, i, apply(gather1(shIn1, ix), gather0(shIn0, ix)));-    }-}-
− cubits/thrust/exclusive_scan.inl 
@@ -1,124 +0,0 @@-/*- *  Copyright 2008-2010 NVIDIA Corporation- *- *  Licensed under the Apache License, Version 2.0 (the "License");- *  you may not use this file except in compliance with the License.- *  You may obtain a copy of the License at- *- *      http://www.apache.org/licenses/LICENSE-2.0- *- *  Unless required by applicable law or agreed to in writing, software- *  distributed under the License is distributed on an "AS IS" BASIS,- *  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.- *  See the License for the specific language governing permissions and- *  limitations under the License.- */---extern "C"-__global__ void-inclusive_scan-(-    ArrOut              d_out,-    const ArrIn0        d_in0,-    ArrIn0              d_block_results,-    const Ix            N,-    const Ix            interval_size-)-{-    extern __shared__ TyOut sdata[];-    scan_intervals(sdata, d_out, d_in0, d_block_results, N, interval_size);-}---/*- * Haskell-style scans increase the array length by one, so the indices of where- * to update results changes slightly. Additionally, the final reduction value- * is written to d_out, rather than updating the input partial block sums d_sum.- */-extern "C"-__global__ void-exclusive_update-(-    ArrOut              d_out,-    ArrIn0              d_in0,-    ArrIn0              d_sum,-    const Ix            N,-    const Ix            interval_size-)-{-    extern __shared__ TyOut sdata[];--    const Ix interval_begin = interval_size * blockIdx.x;-    const Ix interval_end   = min(interval_begin + interval_size, N);--    // value to add to this segment-    TyOut carry = identity();--#if REVERSE-    if (blockIdx.x != gridDim.x - 1)-    {-      TyOut tmp = get0(d_in0, blockIdx.x + 1);-      carry     = apply(carry, tmp);-    }-#else-    if (blockIdx.x != 0)-    {-      TyOut tmp = get0(d_in0, blockIdx.x - 1);-      carry     = apply(carry, tmp);-    }-#endif--    // advance result iterator-    Ix output = REVERSE ? interval_end - threadIdx.x - 1 : interval_begin + threadIdx.x;-    TyOut val = carry;--    for (Ix base = interval_begin; base < interval_end; base += blockDim.x)-    {-        const Ix i = base + threadIdx.x;--        if (i < interval_end)-        {-            TyOut tmp          = get0(d_out, output);-            sdata[threadIdx.x] = apply(carry, tmp);-        }-        __syncthreads();--        if (threadIdx.x != 0)-            val = sdata[threadIdx.x - 1];--        if (i < interval_end)-        {-#if REVERSE && HASKELL_STYLE-            set(d_out, output + 1, val);-#else-            set(d_out, output, val);-#endif-        }--        if (threadIdx.x == 0)-            val = sdata[blockDim.x - 1];--        __syncthreads();--        // update output iterator-#if REVERSE-        output -= blockDim.x;-#else-        output += blockDim.x;-#endif-    }--    // Use a single thread to set the overall scan result.-    if (blockIdx.x == 0 && threadIdx.x == 0)-    {-        TyOut sum = apply(identity(), get0(d_sum, 0));--#if HASKELL_STYLE-        set(d_out, REVERSE ? 0 : N, sum);-#else-        set(d_sum, 0, sum);-#endif-    }-}-
− cubits/thrust/inclusive_scan.inl 
@@ -1,74 +0,0 @@-/*- *  Copyright 2008-2010 NVIDIA Corporation- *- *  Licensed under the Apache License, Version 2.0 (the "License");- *  you may not use this file except in compliance with the License.- *  You may obtain a copy of the License at- *- *      http://www.apache.org/licenses/LICENSE-2.0- *- *  Unless required by applicable law or agreed to in writing, software- *  distributed under the License is distributed on an "AS IS" BASIS,- *  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.- *  See the License for the specific language governing permissions and- *  limitations under the License.- */---extern "C"-__global__ void-inclusive_scan-(-    ArrOut              d_out,-    const ArrIn0        d_in0,-    ArrIn0              d_block_results,-    const Ix            N,-    const Ix            interval_size-)-{-    extern __shared__ TyOut sdata[];-    scan_intervals(sdata, d_out, d_in0, d_block_results, N, interval_size);-}---extern "C"-__global__ void-inclusive_update-(-    ArrOut              d_out,-    ArrIn0              d_in0,-    const Ix            N,-    const Ix            interval_size-)-{-    const Ix interval_begin = interval_size * blockIdx.x;-    const Ix interval_end   = min(interval_begin + interval_size, N);-    TyOut sum;--    // ignore first block and get value to add to this segment-#if REVERSE-    if (blockIdx.x == gridDim.x - 1)-      return;--    sum = get0(d_in0, blockIdx.x + 1);-#else-    if (blockIdx.x == 0)-      return;--    sum = get0(d_in0, blockIdx.x - 1);-#endif--    // advance result iterator-    for(Ix base = interval_begin; base < interval_end; base += blockDim.x)-    {-        const Ix i = base + threadIdx.x;--        if (i < interval_end)-        {-            TyOut tmp = get0(d_out, i);-            set(d_out, i, apply(sum, tmp));-        }-        __syncthreads();-    }-}-
− cubits/thrust/safe_scan_intervals.inl 
@@ -1,128 +0,0 @@-/*- *  Copyright 2008-2010 NVIDIA Corporation- *- *  Licensed under the Apache License, Version 2.0 (the "License");- *  you may not use this file except in compliance with the License.- *  You may obtain a copy of the License at- *- *      http://www.apache.org/licenses/LICENSE-2.0- *- *  Unless required by applicable law or agreed to in writing, software- *  distributed under the License is distributed on an "AS IS" BASIS,- *  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.- *  See the License for the specific language governing permissions and- *  limitations under the License.- */--/* ------------------------------------------------------------------------------ * A robust scan for general types- * ---------------------------------------------------------------------------*/--template <typename T>-static __inline__ __device__ T-scan_block(T* array, T val)-{-    array[threadIdx.x] = val;--    __syncthreads();--    // copy to temporary so val and tmp have the same memory space-    if (blockDim.x >   1) { if(threadIdx.x >=   1) { T tmp = array[threadIdx.x -   1]; val = apply(tmp, val); } __syncthreads(); array[threadIdx.x] = val; __syncthreads(); }-    if (blockDim.x >   2) { if(threadIdx.x >=   2) { T tmp = array[threadIdx.x -   2]; val = apply(tmp, val); } __syncthreads(); array[threadIdx.x] = val; __syncthreads(); }-    if (blockDim.x >   4) { if(threadIdx.x >=   4) { T tmp = array[threadIdx.x -   4]; val = apply(tmp, val); } __syncthreads(); array[threadIdx.x] = val; __syncthreads(); }-    if (blockDim.x >   8) { if(threadIdx.x >=   8) { T tmp = array[threadIdx.x -   8]; val = apply(tmp, val); } __syncthreads(); array[threadIdx.x] = val; __syncthreads(); }-    if (blockDim.x >  16) { if(threadIdx.x >=  16) { T tmp = array[threadIdx.x -  16]; val = apply(tmp, val); } __syncthreads(); array[threadIdx.x] = val; __syncthreads(); }-    if (blockDim.x >  32) { if(threadIdx.x >=  32) { T tmp = array[threadIdx.x -  32]; val = apply(tmp, val); } __syncthreads(); array[threadIdx.x] = val; __syncthreads(); }-    if (blockDim.x >  64) { if(threadIdx.x >=  64) { T tmp = array[threadIdx.x -  64]; val = apply(tmp, val); } __syncthreads(); array[threadIdx.x] = val; __syncthreads(); }-    if (blockDim.x > 128) { if(threadIdx.x >= 128) { T tmp = array[threadIdx.x - 128]; val = apply(tmp, val); } __syncthreads(); array[threadIdx.x] = val; __syncthreads(); }-    if (blockDim.x > 256) { if(threadIdx.x >= 256) { T tmp = array[threadIdx.x - 256]; val = apply(tmp, val); } __syncthreads(); array[threadIdx.x] = val; __syncthreads(); }-    if (blockDim.x > 512) { if(threadIdx.x >= 512) { T tmp = array[threadIdx.x - 512]; val = apply(tmp, val); } __syncthreads(); array[threadIdx.x] = val; __syncthreads(); }--    return val;-}--#if 0-template <bool inclusive, typename T>-__device__-T scan_block_n(T* array, const unsigned int n, T val)-{-    array[threadIdx.x] = val;--    __syncthreads();--    if (blockDim.x >   1) { if(threadIdx.x < n && threadIdx.x >=   1) { T tmp = array[threadIdx.x -   1]; val = apply(tmp, val); } __syncthreads(); array[threadIdx.x] = val; __syncthreads(); }-    if (blockDim.x >   2) { if(threadIdx.x < n && threadIdx.x >=   2) { T tmp = array[threadIdx.x -   2]; val = apply(tmp, val); } __syncthreads(); array[threadIdx.x] = val; __syncthreads(); }-    if (blockDim.x >   4) { if(threadIdx.x < n && threadIdx.x >=   4) { T tmp = array[threadIdx.x -   4]; val = apply(tmp, val); } __syncthreads(); array[threadIdx.x] = val; __syncthreads(); }-    if (blockDim.x >   8) { if(threadIdx.x < n && threadIdx.x >=   8) { T tmp = array[threadIdx.x -   8]; val = apply(tmp, val); } __syncthreads(); array[threadIdx.x] = val; __syncthreads(); }-    if (blockDim.x >  16) { if(threadIdx.x < n && threadIdx.x >=  16) { T tmp = array[threadIdx.x -  16]; val = apply(tmp, val); } __syncthreads(); array[threadIdx.x] = val; __syncthreads(); }-    if (blockDim.x >  32) { if(threadIdx.x < n && threadIdx.x >=  32) { T tmp = array[threadIdx.x -  32]; val = apply(tmp, val); } __syncthreads(); array[threadIdx.x] = val; __syncthreads(); }-    if (blockDim.x >  64) { if(threadIdx.x < n && threadIdx.x >=  64) { T tmp = array[threadIdx.x -  64]; val = apply(tmp, val); } __syncthreads(); array[threadIdx.x] = val; __syncthreads(); }-    if (blockDim.x > 128) { if(threadIdx.x < n && threadIdx.x >= 128) { T tmp = array[threadIdx.x - 128]; val = apply(tmp, val); } __syncthreads(); array[threadIdx.x] = val; __syncthreads(); }-    if (blockDim.x > 256) { if(threadIdx.x < n && threadIdx.x >= 256) { T tmp = array[threadIdx.x - 256]; val = apply(tmp, val); } __syncthreads(); array[threadIdx.x] = val; __syncthreads(); }-    if (blockDim.x > 512) { if(threadIdx.x < n && threadIdx.x >= 512) { T tmp = array[threadIdx.x - 512]; val = apply(tmp, val); } __syncthreads(); array[threadIdx.x] = val; __syncthreads(); }--    if (inclusive) return val;-    else           return threadIdx.x > 0 ? array[threadIdx.x - 1] : identity();-}-#endif---static __inline__ __device__ void-scan_intervals-(-    TyOut               *sdata,-    ArrOut              d_out,-    const ArrIn0        d_in0,-    ArrIn0              d_block_results,-    const Ix            N,-    const Ix            interval_size-)-{-    const Ix interval_begin = interval_size * blockIdx.x;-    const Ix interval_end   = min(interval_begin + interval_size, N);--    TyOut val;-    Ix output = REVERSE ? interval_end - threadIdx.x - 1 : interval_begin + threadIdx.x;--    // process intervals-    for(Ix base = interval_begin + threadIdx.x; base < interval_end; base += blockDim.x)-    {-        // read data-        val = get0(d_in0, output);--        // carry in-        if (threadIdx.x == 0 && base != interval_begin)-        {-            TyOut tmp = sdata[blockDim.x - 1];-            val       = apply(tmp, val);-        }-        __syncthreads();--        // scan block-        val = scan_block(sdata, val);--        // write data-        set(d_out, output, val);--        // update output iterator-#if REVERSE-        output -= blockDim.x;-#else-        output += blockDim.x;-#endif-    }-    __syncthreads();--    // write block sum-    if (threadIdx.x == 0)-    {-#if REVERSE-      TyOut tmp = get0(d_out, interval_begin);-      set(d_block_results, blockIdx.x, tmp);-#else-      TyOut tmp = get0(d_out, interval_end - 1);-      set(d_block_results, blockIdx.x, tmp);-#endif-    }-}-
− cubits/zipWith.inl 
@@ -1,38 +0,0 @@-/* ------------------------------------------------------------------------------ *- * Kernel      : ZipWith- * Copyright   : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell- * License     : BSD3- *- * Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>- * Stability   : experimental- *- * Combine two arrays using the given binary operator. Each thread processes- * multiple elements, striding the array by the grid size.- *- * ---------------------------------------------------------------------------*/--extern "C"-__global__ void-zipWith-(-    ArrOut              d_out,-    const ArrIn1        d_in1,-    const ArrIn0        d_in0,-    const DimOut        shOut,-    const DimIn1        shIn1,-    const DimIn0        shIn0-)-{-    const Ix shapeSize = size(shOut);-    const Ix gridSize  = __umul24(blockDim.x, gridDim.x);--    for (Ix ix = __umul24(blockDim.x, blockIdx.x) + threadIdx.x; ix < shapeSize; ix += gridSize)-    {-        Ix i1 = toIndex(shIn1, fromIndex(shOut, ix));-        Ix i0 = toIndex(shIn0, fromIndex(shOut, ix));--        set(d_out, ix, apply(get1(d_in1, i1), get0(d_in0, i0)));-    }-}-
− utils/Paths_accelerate.hs 
@@ -1,11 +0,0 @@--- Helper script to shadow that automatically generated by cabal, but pointing--- to our local development directory.-----module Paths_accelerate where--import System.Directory--getDataDir :: IO FilePath-getDataDir = getCurrentDirectory-
− utils/README 
@@ -1,2 +0,0 @@-To use the CUDA backend from within GHCi, copy the file 'dot_ghci' to '.ghci' -in the root directory of the accelerate source tree.
− utils/dot_ghci 
@@ -1,5 +0,0 @@-:set -DACCELERATE_CUDA_BACKEND-:set -DACCELERATE_BOUNDS_CHECKS-:set -DACCELERATE_INTERNAL_CHECKS-:set -iutils-:set -Iinclude