accelerate 0.8.1.0 → 0.9.0.0
raw patch · 92 files changed
+11054/−6284 lines, 92 filesdep +blaze-htmldep +mtldep +textdep −QuickCheckdep −haskell98dep −monads-fddep ~arraydep ~binarydep ~bytestring
Dependencies added: blaze-html, mtl, text, zlib
Dependencies removed: QuickCheck, haskell98, monads-fd
Dependency ranges changed: array, binary, bytestring, containers, cuda, directory, fclabels, filepath, ghc-prim, language-c, pretty, unix
Files
- Data/Array/Accelerate.hs +50/−8
- Data/Array/Accelerate/AST.hs +499/−300
- Data/Array/Accelerate/Analysis/Shape.hs +83/−24
- Data/Array/Accelerate/Analysis/Stencil.hs +77/−0
- Data/Array/Accelerate/Analysis/Type.hs +141/−53
- Data/Array/Accelerate/Array/Data.hs +99/−52
- Data/Array/Accelerate/Array/Delayed.hs +17/−17
- Data/Array/Accelerate/Array/Representation.hs +79/−62
- Data/Array/Accelerate/Array/Sugar.hs +867/−875
- Data/Array/Accelerate/CUDA.hs +58/−18
- Data/Array/Accelerate/CUDA/Analysis/Device.hs +1/−1
- Data/Array/Accelerate/CUDA/Analysis/Hash.hs +101/−55
- Data/Array/Accelerate/CUDA/Analysis/Launch.hs +81/−28
- Data/Array/Accelerate/CUDA/Array/Data.hs +450/−197
- Data/Array/Accelerate/CUDA/Array/Device.hs +0/−42
- Data/Array/Accelerate/CUDA/CodeGen.hs +386/−278
- Data/Array/Accelerate/CUDA/CodeGen/Data.hs +13/−6
- Data/Array/Accelerate/CUDA/CodeGen/Skeleton.hs +161/−56
- Data/Array/Accelerate/CUDA/CodeGen/Stencil.hs +124/−0
- Data/Array/Accelerate/CUDA/CodeGen/Tuple.hs +21/−15
- Data/Array/Accelerate/CUDA/CodeGen/Util.hs +43/−15
- Data/Array/Accelerate/CUDA/Compile.hs +660/−116
- Data/Array/Accelerate/CUDA/Execute.hs +834/−478
- Data/Array/Accelerate/CUDA/Smart.hs +0/−77
- Data/Array/Accelerate/CUDA/State.hs +138/−113
- Data/Array/Accelerate/Debug.hs +56/−8
- Data/Array/Accelerate/IO.hs +32/−0
- Data/Array/Accelerate/IO/BlockCopy.hs +189/−0
- Data/Array/Accelerate/IO/ByteString.hs +49/−0
- Data/Array/Accelerate/IO/Ptr.hs +100/−0
- Data/Array/Accelerate/Internal/Check.hs +11/−9
- Data/Array/Accelerate/Interpreter.hs +421/−192
- Data/Array/Accelerate/Language.hs +655/−230
- Data/Array/Accelerate/Prelude.hs +376/−0
- Data/Array/Accelerate/Pretty.hs +12/−260
- Data/Array/Accelerate/Pretty/Graphviz.hs +152/−0
- Data/Array/Accelerate/Pretty/HTML.hs +200/−0
- Data/Array/Accelerate/Pretty/Print.hs +362/−0
- Data/Array/Accelerate/Pretty/Traverse.hs +211/−0
- Data/Array/Accelerate/Smart.hs +2003/−930
- Data/Array/Accelerate/Test.hs +0/−18
- Data/Array/Accelerate/Test/QuickCheck.hs +0/−18
- Data/Array/Accelerate/Test/QuickCheck/Arbitrary.hs +0/−236
- Data/Array/Accelerate/Tuple.hs +12/−6
- Data/Array/Accelerate/Type.hs +18/−7
- INSTALL +2/−7
- accelerate.cabal +121/−74
- cubits/accelerate_cuda_extras.h +2/−1
- cubits/accelerate_cuda_function.h +3/−1
- cubits/accelerate_cuda_shape.h +156/−132
- cubits/accelerate_cuda_stencil.h +91/−0
- cubits/accelerate_cuda_texture.h +1/−1
- cubits/accelerate_cuda_util.h +1/−1
- cubits/backpermute.inl +1/−1
- cubits/fold.inl +60/−57
- cubits/foldAll.inl +80/−0
- cubits/foldSeg.inl +132/−0
- cubits/fold_segmented.inl +0/−120
- cubits/generate.inl +32/−0
- cubits/map.inl +1/−1
- cubits/permute.inl +1/−1
- cubits/reduce.inl +72/−0
- cubits/replicate.inl +1/−1
- cubits/scan.inl +23/−0
- cubits/scan1.inl +17/−0
- cubits/slice.inl +1/−1
- cubits/stencil.inl +33/−0
- cubits/stencil2.inl +36/−0
- cubits/thrust/exclusive_scan.inl +124/−0
- cubits/thrust/inclusive_scan.inl +74/−0
- cubits/thrust/safe_scan_intervals.inl +128/−0
- cubits/thrust/scan_safe.inl +0/−264
- cubits/zipWith.inl +1/−1
- examples/rasterize/RasterizeAcc.hs +0/−244
- examples/rasterize/rasterize-test1.txt +0/−4
- examples/rasterize/rasterize-test2.txt +0/−4
- examples/rasterize/rasterize-test3.txt +0/−4
- examples/rasterize/rasterize-test4.txt +0/−4
- examples/rasterize/rasterize.hs +0/−111
- examples/simple/Makefile +0/−17
- examples/simple/src/DotP.hs +0/−22
- examples/simple/src/Filter.hs +0/−40
- examples/simple/src/Main.hs +0/−127
- examples/simple/src/Random.hs +0/−60
- examples/simple/src/SAXPY.hs +0/−21
- examples/simple/src/SMVM.hs +0/−39
- examples/simple/src/Square.hs +0/−23
- examples/simple/src/Stencil.hs +0/−77
- examples/simple/src/Sum.hs +0/−23
- utils/Paths_accelerate.hs +11/−0
- utils/README +2/−0
- utils/dot_ghci +5/−0
Data/Array/Accelerate.hs view
@@ -1,6 +1,9 @@+{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}+ -- only for the deprecated class aliases+ -- | -- Module : Data.Array.Accelerate--- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee+-- 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>@@ -44,42 +47,81 @@ IsScalar, IsNum, IsBounded, IsIntegral, IsFloating, IsNonNum, -- * Array data types- Array, Scalar, Vector, Segments,+ Arrays, Array, Scalar, Vector, Segments, -- * Array element types- Elem,+ Elt, -- * Array shapes & indices- Ix(dim, size), All(..), SliceIx(..), DIM0, DIM1, DIM2, DIM3, DIM4, DIM5,+ Z(..), (:.)(..), Shape, All(..), Any(..), Slice(..),+ DIM0, DIM1, DIM2, DIM3, DIM4, DIM5, DIM6, DIM7, DIM8, DIM9, -- * Operations to use Accelerate arrays from plain Haskell- arrayShape, indexArray, fromIArray, toIArray, fromList, toList,+ 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 ) where -- friends import Data.Array.Accelerate.Type-import Data.Array.Accelerate.Array.Sugar hiding ((!), shape)+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+import Data.Array.Accelerate.Prelude -- Renamings -- +-- FIXME: these all need to go into a separate module for separate importing!+ -- rename as '(!)' is already used by the EDSL for indexing -- |Array indexing in plain Haskell code ---indexArray :: Array dim e -> dim -> e+indexArray :: Array sh e -> sh -> e indexArray = (Sugar.!) -- rename as 'shape' is already used by the EDSL to query an array's shape -- |Array shape in plain Haskell code ---arrayShape :: Ix dim => Array dim e -> dim+arrayShape :: Shape sh => Array sh e -> sh arrayShape = Sugar.shape++-- FIXME: Rename to rank+arrayDim :: Shape sh => sh -> Int+arrayDim = Sugar.dim++arraySize :: Shape sh => sh -> Int+arraySize = Sugar.size++-- Deprecated aliases for backwards compatibility+--++{-# DEPRECATED Elem "Use 'Elt' instead" #-}+class Elt e => Elem e+instance Elt e => Elem e++{-# DEPRECATED Ix "Use 'Shape' instead" #-}+class Shape sh => Ix sh+instance Shape sh => Ix sh++{-# DEPRECATED SliceIx "Use 'Slice' instead" #-}+class Slice sh => SliceIx sh+instance Slice sh => SliceIx sh++{-#DEPRECATED tuple "Use 'lift' instead" #-}+tuple :: Lift e => e -> Exp (Plain e)+tuple = lift++{-#DEPRECATED untuple "Use 'unlift' instead" #-}+untuple :: Unlift e => Exp (Plain e) -> e+untuple = unlift
Data/Array/Accelerate/AST.hs view
@@ -1,8 +1,9 @@-{-# LANGUAGE GADTs, EmptyDataDecls, FlexibleContexts, TypeFamilies, TypeOperators #-}-{-# LANGUAGE CPP, FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-}-+{-# LANGUAGE BangPatterns, CPP, GADTs, DeriveDataTypeable, StandaloneDeriving #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, TypeFamilies, TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances, ScopedTypeVariables #-}+-- | -- Module : Data.Array.Accelerate.AST--- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee+-- Copyright : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee -- License : BSD3 -- -- Maintainer : Manuel M T Chakravarty <chak@cse.unsw.edu.au>@@ -61,6 +62,7 @@ -- available for all supported types. In contrast, reified dictionaries are -- used for functionality that is only available for certain types, such as -- arithmetic operations.+-- module Data.Array.Accelerate.AST ( @@ -68,21 +70,28 @@ Idx(..), -- * Valuation environment- Val(..), prj,+ Val(..), prj, idxToInt, -- * Accelerated array expressions- OpenAcc(..), Acc, Stencil(..),+ Arrays(..), ArraysR(..), + PreOpenAfun(..), OpenAfun, PreAfun, Afun, PreOpenAcc(..), OpenAcc(..), Acc,+ Stencil(..), StencilR(..), -- * Scalar expressions- OpenFun(..), Fun, OpenExp(..), Exp, PrimConst(..), PrimFun(..)+ PreOpenFun(..), OpenFun, PreFun, Fun, PreOpenExp(..), OpenExp, PreExp, Exp, PrimConst(..),+ PrimFun(..) ) where- ++--standard library+import Data.Typeable+ -- friends import Data.Array.Accelerate.Type-import Data.Array.Accelerate.Array.Representation (SliceIndex)-import Data.Array.Accelerate.Array.Sugar 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" @@ -91,7 +100,7 @@ -- ----------------------- -- De Bruijn variable index projecting a specific type from a type--- environment. Type envionments are nested pairs (..((), t1), t2, ..., tn). +-- environment. Type environments are nested pairs (..((), t1), t2, ..., tn). -- data Idx env t where ZeroIdx :: Idx (env, t) t@@ -107,25 +116,71 @@ Empty :: Val () Push :: Val env -> t -> Val (env, t) +deriving instance Typeable1 Val++ -- Projection of a value from a valuation using a de Bruijn index -- prj :: Idx env t -> Val env -> t prj ZeroIdx (Push _ v) = v prj (SuccIdx idx) (Push val _) = prj idx val-prj _ _ =- INTERNAL_ERROR(error) "prj" "inconsistent valuation"+prj _ _ = INTERNAL_ERROR(error) "prj" "inconsistent valuation" +-- Convert a typed de Bruijn index to the corresponding integer+--+idxToInt :: Idx env t -> Int+idxToInt = go 0+ where go :: Int -> Idx env t -> Int+ go !n ZeroIdx = n+ go !n (SuccIdx idx) = go (n+1) idx + -- 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+ Abody :: acc aenv t -> PreOpenAfun acc aenv t+ Alam :: (Arrays as, Arrays t)+ => PreOpenAfun acc (aenv, as) t -> PreOpenAfun acc aenv (as -> t)++-- Function abstraction over vanilla open array computations+--+type OpenAfun = PreOpenAfun OpenAcc++-- |Parametrised array-computation function without free array variables+--+type PreAfun acc = PreOpenAfun acc ()++-- |Vanilla array-computation function without free array variables+--+type Afun = OpenAfun ()+ -- |Collective array computations parametrised over array variables -- represented with de Bruijn indices. ----- * We have no fold, only scan which returns the fold result and scan array.--- We assume that the code generator is clever enough to eliminate any dead--- code, when only one of the two values is needed.--- -- * Scalar functions and expressions embedded in well-formed array -- computations cannot contain free scalar variable indices. The latter -- cannot be bound in array computations, and hence, cannot appear in any@@ -136,119 +191,182 @@ -- need to hoist array expressions out of scalar expressions - they occur in -- scalar indexing and in determining an arrays shape.) ----- The data type is parametrised over the surface types (not the representation+-- The data type is parameterised over the surface types (not the representation -- type). ---data OpenAcc aenv a where- +-- We use a non-recursive variant parametrised over the recursive closure, to facilitate attribute+-- calculation in the backend.+--+data PreOpenAcc acc aenv a where+ -- Local binding to represent sharing and demand explicitly; this is an -- eager(!) binding- Let :: OpenAcc aenv (Array dim e) -- bound expression- -> OpenAcc (aenv, Array dim e) - (Array dim' e') -- the bound expr's scope - -> OpenAcc aenv (Array dim' e')+ Let :: (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 (and decomposing) a pair- Let2 :: OpenAcc aenv (Array dim1 e1, - Array dim2 e2) -- bound expressions - -> OpenAcc ((aenv, Array dim1 e1), - Array dim2 e2)- (Array dim' e') -- the bound expr's scope - -> OpenAcc aenv (Array dim' e')+ Let2 :: (Arrays bndArrs1, Arrays bndArrs2, Arrays bodyArrs)+ => acc aenv (bndArrs1, bndArrs2) -- bound expressions+ -> acc ((aenv, bndArrs1), bndArrs2)+ bodyArrs -- the bound expr's scope+ -> PreOpenAcc acc aenv bodyArrs - -- Variable bound by a 'Let', represented by a de Bruijn index - Avar :: (Ix dim, Elem e)- => Idx aenv (Array dim e)- -> OpenAcc aenv (Array dim e)- + 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++ -- Array-function application (to keep things simple for the moment, the function must be closed)+ Apply :: (Arrays arrs1, Arrays arrs2)+ => PreAfun acc (arrs1 -> arrs2)+ -> acc aenv arrs1+ -> PreOpenAcc acc aenv arrs2++ -- If-then-else for array-level computations+ Acond :: (Arrays arrs)+ => PreExp acc aenv Bool+ -> acc aenv arrs+ -> acc aenv arrs+ -> PreOpenAcc acc aenv arrs+ -- Array inlet (triggers async host->device transfer if necessary)- Use :: Array dim e - -> OpenAcc aenv (Array dim e)+ Use :: Array dim e+ -> PreOpenAcc acc aenv (Array dim e) - -- Capture a scalar (or a tuple of scalars) in a singleton array - Unit :: Elem e- => Exp aenv e - -> OpenAcc aenv (Scalar e)+ -- Capture a scalar (or a tuple of scalars) in a singleton array+ Unit :: Elt e+ => PreExp acc aenv e+ -> PreOpenAcc acc aenv (Scalar e) -- Change the shape of an array without altering its contents -- > precondition: size dim == size dim'- Reshape :: Ix dim- => Exp aenv dim -- new shape- -> OpenAcc aenv (Array dim' e) -- array to be reshaped- -> OpenAcc aenv (Array dim e)+ Reshape :: (Shape sh, Shape sh', Elt e)+ => PreExp acc aenv sh -- new shape+ -> 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.+ Generate :: (Shape sh, Elt e)+ => PreExp acc aenv sh -- output shape+ -> PreFun acc aenv (sh -> e) -- representation function+ -> PreOpenAcc acc aenv (Array sh e)+ -- Replicate an array across one or more dimensions as given by the first -- argument- Replicate :: (Ix dim, Elem slix)- => SliceIndex (ElemRepr slix) -- slice type specification- (ElemRepr sl) + Replicate :: (Shape sh, Shape sl, Elt slix, Elt e)+ => SliceIndex (EltRepr slix) -- slice type specification+ (EltRepr sl) co'- (ElemRepr dim)- -> Exp aenv slix -- slice value specification- -> OpenAcc aenv (Array sl e) -- data to be replicated- -> OpenAcc aenv (Array dim e)+ (EltRepr sh)+ -> PreExp acc aenv slix -- slice value specification+ -> acc aenv (Array sl e) -- data to be replicated+ -> PreOpenAcc acc aenv (Array sh e) - -- Index a subarray out of an array; i.e., the dimensions not indexed are + -- Index a subarray out of an array; i.e., the dimensions not indexed are -- returned whole- Index :: (Ix sl, Elem slix)- => SliceIndex (ElemRepr slix) -- slice type specification- (ElemRepr sl) + Index :: (Shape sh, Shape sl, Elt slix, Elt e)+ => SliceIndex (EltRepr slix) -- slice type specification+ (EltRepr sl) co'- (ElemRepr dim)- -> OpenAcc aenv (Array dim e) -- array to be indexed- -> Exp aenv slix -- slice value specification- -> OpenAcc aenv (Array sl e)+ (EltRepr sh)+ -> acc aenv (Array sh e) -- array to be indexed+ -> PreExp acc aenv slix -- slice value specification+ -> PreOpenAcc acc aenv (Array sl e) -- Apply the given unary function to all elements of the given array- Map :: Elem e'- => Fun aenv (e -> e') - -> OpenAcc aenv (Array dim e) - -> OpenAcc aenv (Array dim e')- -- FIXME: generalise to mapFold+ Map :: (Shape sh, Elt e, Elt e')+ => PreFun acc aenv (e -> e')+ -> acc aenv (Array sh e)+ -> PreOpenAcc acc aenv (Array sh e') -- Apply a given binary function pairwise to all elements of the given arrays. -- The length of the result is the length of the shorter of the two argument -- arrays.- ZipWith :: Elem e3- => Fun aenv (e1 -> e2 -> e3) - -> OpenAcc aenv (Array dim e1)- -> OpenAcc aenv (Array dim e2)- -> OpenAcc aenv (Array dim e3)+ ZipWith :: (Shape sh, Elt e1, Elt e2, Elt e3)+ => PreFun acc aenv (e1 -> e2 -> e3)+ -> acc aenv (Array sh e1)+ -> acc aenv (Array sh e2)+ -> PreOpenAcc acc aenv (Array sh e3) - -- Fold of an array with a given *associative* function and its neutral- -- element- Fold :: Fun aenv (e -> e -> e) -- combination function- -> Exp aenv e -- default value- -> OpenAcc aenv (Array dim e) -- folded array- -> OpenAcc aenv (Scalar e)- -- FIXME: generalise to Gabi's mapFold+ -- Fold along the innermost dimension of an array with a given /associative/ function.+ Fold :: (Shape sh, Elt e)+ => PreFun acc aenv (e -> e -> e) -- combination function+ -> PreExp acc aenv e -- default value+ -> acc aenv (Array (sh:.Int) e) -- folded array+ -> PreOpenAcc acc aenv (Array sh e) - -- Segmented fold of an array with a given *associative* function and its- -- neutral element- FoldSeg :: Fun aenv (e -> e -> e) -- combination function- -> Exp aenv e -- default value- -> OpenAcc aenv (Vector e) -- folded array- -> OpenAcc aenv Segments -- segment descriptor- -> OpenAcc aenv (Vector e)- -- FIXME: Can we generalise this to multi-dimensional arrays and also- -- to Gabi's mapFold+ -- 'Fold' without a default value+ Fold1 :: (Shape sh, Elt e)+ => PreFun acc aenv (e -> e -> e) -- combination function+ -> acc aenv (Array (sh:.Int) e) -- folded array+ -> PreOpenAcc acc aenv (Array sh e) - -- Left-to-right prescan of a linear array with a given *associative*- -- function and its neutral element; produces a rightmost fold value and a- -- linear of the same shape (the fold value would be the rightmost element- -- in a scan, as opposed to a prescan)- Scanl :: Fun aenv (e -> e -> e) -- combination function- -> Exp aenv e -- default value- -> OpenAcc aenv (Vector e) -- linear array- -> OpenAcc aenv (Vector e, Scalar e)- -- FIXME: generalised multi-dimensional scan? And/or a generalised mapScan?+ -- Segmented fold along the innermost dimension of an array with a given /associative/ function+ FoldSeg :: (Shape sh, Elt e)+ => PreFun acc aenv (e -> e -> e) -- combination function+ -> PreExp acc aenv e -- default value+ -> acc aenv (Array (sh:.Int) e) -- folded array+ -> acc aenv Segments -- segment descriptor+ -> PreOpenAcc acc aenv (Array (sh:.Int) e) - -- Right-to-left prescan of a linear array- Scanr :: Fun aenv (e -> e -> e) -- combination function- -> Exp aenv e -- default value- -> OpenAcc aenv (Vector e) -- linear array- -> OpenAcc aenv (Vector e, Scalar e)+ -- 'FoldSeg' without a default value+ Fold1Seg :: (Shape sh, Elt e)+ => PreFun acc aenv (e -> e -> e) -- combination function+ -> acc aenv (Array (sh:.Int) e) -- folded array+ -> acc aenv Segments -- segment descriptor+ -> PreOpenAcc acc aenv (Array (sh:.Int) e) + -- Left-to-right Haskell-style scan of a linear array with a given *associative*+ -- function and an initial element (which does not need to be the neutral of the+ -- associative operations)+ Scanl :: Elt e+ => PreFun acc aenv (e -> e -> e) -- combination function+ -> PreExp acc aenv e -- initial value+ -> acc aenv (Vector e) -- linear array+ -> PreOpenAcc acc aenv (Vector e)+ -- FIXME: Make the scans rank-polymorphic?++ -- Like 'Scan', but produces a rightmost fold value and an array with the same length as the input+ -- array (the fold value would be the rightmost element in a Haskell-style scan)+ Scanl' :: Elt e+ => PreFun acc aenv (e -> e -> e) -- combination function+ -> PreExp acc aenv e -- initial value+ -> acc aenv (Vector e) -- linear array+ -> PreOpenAcc acc aenv (Vector e, Scalar e)++ -- Haskell-style scan without an initial value+ Scanl1 :: Elt e+ => PreFun acc aenv (e -> e -> e) -- combination function+ -> acc aenv (Vector e) -- linear array+ -> PreOpenAcc acc aenv (Vector e)++ -- Right-to-left version of 'Scanl'+ Scanr :: Elt e+ => PreFun acc aenv (e -> e -> e) -- combination function+ -> PreExp acc aenv e -- initial value+ -> acc aenv (Vector e) -- linear array+ -> PreOpenAcc acc aenv (Vector e)++ -- Right-to-left version of 'Scanl\''+ Scanr' :: Elt e+ => PreFun acc aenv (e -> e -> e) -- combination function+ -> PreExp acc aenv e -- initial value+ -> acc aenv (Vector e) -- linear array+ -> PreOpenAcc acc aenv (Vector e, Scalar e)++ -- Right-to-left version of 'Scanl1'+ Scanr1 :: Elt e+ => PreFun acc aenv (e -> e -> e) -- combination function+ -> acc aenv (Vector e) -- linear array+ -> PreOpenAcc acc aenv (Vector e)+ -- Generalised forward permutation is characterised by a permutation -- function that determines for each element of the source array where it -- should go in the target; the permutation can be between arrays of varying@@ -261,252 +379,334 @@ -- permutation functions). The combination function needs to be -- /associative/ and /commutative/ . We drop every element for which the -- permutation function yields -1 (i.e., a tuple of -1 values).- Permute :: Fun aenv (e -> e -> e) -- combination function- -> OpenAcc aenv (Array dim' e) -- default values- -> Fun aenv (dim -> dim') -- permutation function- -> OpenAcc aenv (Array dim e) -- source array- -> OpenAcc aenv (Array dim' e)+ Permute :: (Shape sh, Elt e)+ => PreFun acc aenv (e -> e -> e) -- combination function+ -> acc aenv (Array sh' e) -- default values+ -> PreFun acc aenv (sh -> sh') -- permutation function+ -> acc aenv (Array sh e) -- source array+ -> PreOpenAcc acc aenv (Array sh' e) -- Generalised multi-dimensional backwards permutation; the permutation can -- be between arrays of varying shape; the permutation function must be total- Backpermute :: Ix dim'- => Exp aenv dim' -- dimensions of the result- -> Fun aenv (dim' -> dim) -- permutation function- -> OpenAcc aenv (Array dim e) -- source array- -> OpenAcc aenv (Array dim' e)+ Backpermute :: (Shape sh, Shape sh', Elt e)+ => PreExp acc aenv sh' -- dimensions of the result+ -> PreFun acc aenv (sh' -> sh) -- permutation function+ -> acc aenv (Array sh e) -- source array+ -> PreOpenAcc acc aenv (Array sh' e) -- Map a stencil over an array. In contrast to 'map', the domain of a stencil function is an -- entire /neighbourhood/ of each array element.- Stencil :: (Elem e, Elem e', Stencil dim e stencil)- => Fun aenv (stencil -> e') -- stencil function- -> Boundary (ElemRepr e) -- boundary condition- -> OpenAcc aenv (Array dim e) -- source array- -> OpenAcc aenv (Array dim e')+ Stencil :: (Elt e, Elt e', Stencil sh e stencil)+ => PreFun acc aenv (stencil -> e') -- stencil function+ -> Boundary (EltRepr e) -- boundary condition+ -> acc aenv (Array sh e) -- source array+ -> PreOpenAcc acc aenv (Array sh e') -- Map a binary stencil over an array.- Stencil2 :: (Elem e1, Elem e2, Elem e', - Stencil dim e1 stencil1,- Stencil dim e2 stencil2)- => Fun aenv (stencil1 -> - stencil2 -> e') -- stencil function- -> Boundary (ElemRepr e1) -- boundary condition #1- -> OpenAcc aenv (Array dim e1) -- source array #1- -> Boundary (ElemRepr e2) -- boundary condition #2- -> OpenAcc aenv (Array dim e2) -- source array #2- -> OpenAcc aenv (Array dim e')+ Stencil2 :: (Elt e1, Elt e2, Elt e',+ Stencil sh e1 stencil1,+ Stencil sh e2 stencil2)+ => PreFun acc aenv (stencil1 ->+ stencil2 -> e') -- stencil function+ -> Boundary (EltRepr e1) -- boundary condition #1+ -> acc aenv (Array sh e1) -- source array #1+ -> Boundary (EltRepr e2) -- boundary condition #2+ -> acc aenv (Array sh e2) -- source array #2+ -> PreOpenAcc acc aenv (Array sh e') +-- Vanilla open array computations+--+newtype OpenAcc aenv t = OpenAcc (PreOpenAcc OpenAcc aenv t)++-- deriving instance Typeable3 PreOpenAcc+deriving instance Typeable2 OpenAcc+ -- |Closed array expression aka an array program ---type Acc a = OpenAcc () a+type Acc = OpenAcc () -class IsTuple stencil => Stencil dim e stencil where- stencilAccess :: (dim -> e) -> dim -> stencil --- DIM1-instance Stencil DIM1 a (a, a, a) where- stencilAccess rf ix = (rf (ix - 1), rf ix, rf (ix + 1))-instance Stencil DIM1 a (a, a, a, a, a) where- stencilAccess rf ix = (rf (ix - 2), rf (ix - 1), rf ix, rf (ix + 1), rf (ix + 2))-instance Stencil DIM1 a (a, a, a, a, a, a, a) where- stencilAccess rf ix = (rf (ix - 3), rf (ix - 2), rf (ix - 1), rf ix, - rf (ix + 1), rf (ix + 2), rf (ix + 3))-instance Stencil DIM1 a (a, a, a, a, a, a, a, a, a) where- stencilAccess rf ix = (rf (ix - 4), rf (ix - 3), rf (ix - 2), rf (ix - 1), rf ix, - rf (ix + 1), rf (ix + 2), rf (ix + 3), rf (ix + 4))+-- | Operations on stencils.+--+class (Shape sh, Elt e, IsTuple stencil) => Stencil sh e stencil where+ stencil :: StencilR sh e stencil+ stencilAccess :: (sh -> e) -> sh -> stencil --- DIM2-instance (Stencil DIM1 a row2, - Stencil DIM1 a row1,- Stencil DIM1 a row0) => Stencil DIM2 a (row2, row1, row0) where- stencilAccess rf (x, y) = (stencilAccess (rf' (y - 1)) x, - stencilAccess (rf' y ) x,- stencilAccess (rf' (y + 1)) x)++-- |GADT reifying the 'Stencil' class.+--+data StencilR sh e pat where+ StencilRunit3 :: (Elt e)+ => StencilR DIM1 e (e,e,e)+ StencilRunit5 :: (Elt e)+ => StencilR DIM1 e (e,e,e,e,e)+ StencilRunit7 :: (Elt e)+ => StencilR DIM1 e (e,e,e,e,e,e,e)+ StencilRunit9 :: (Elt e)+ => StencilR DIM1 e (e,e,e,e,e,e,e,e,e)+ StencilRtup3 :: (Shape sh, Elt e)+ => StencilR sh e pat1+ -> StencilR sh e pat2+ -> StencilR sh e pat3+ -> StencilR (sh:.Int) e (pat1,pat2,pat3)+ StencilRtup5 :: (Shape sh, Elt e)+ => StencilR sh e pat1+ -> StencilR sh e pat2+ -> StencilR sh e pat3+ -> StencilR sh e pat4+ -> StencilR sh e pat5+ -> StencilR (sh:.Int) e (pat1,pat2,pat3,pat4,pat5)+ StencilRtup7 :: (Shape sh, Elt e)+ => StencilR sh e pat1+ -> StencilR sh e pat2+ -> StencilR sh e pat3+ -> StencilR sh e pat4+ -> StencilR sh e pat5+ -> StencilR sh e pat6+ -> StencilR sh e pat7+ -> StencilR (sh:.Int) e (pat1,pat2,pat3,pat4,pat5,pat6,pat7)+ StencilRtup9 :: (Shape sh, Elt e)+ => StencilR sh e pat1+ -> StencilR sh e pat2+ -> StencilR sh e pat3+ -> StencilR sh e pat4+ -> StencilR sh e pat5+ -> StencilR sh e pat6+ -> StencilR sh e pat7+ -> StencilR sh e pat8+ -> StencilR sh e pat9+ -> StencilR (sh:.Int) e (pat1,pat2,pat3,pat4,pat5,pat6,pat7,pat8,pat9)+++-- NB: We cannot start with 'DIM0'. The 'IsTuple stencil' superclass would at 'DIM0' imply that+-- the types of individual array elements are in 'IsTuple'. (That would only possible if we+-- could have (degenerate) 1-tuple, but we can't as we can't distinguish between a 1-tuple of a+-- pair and a simple pair.) Hence, we need to start from 'DIM1' and use 'sh:.Int:.Int' in the+-- recursive case (to avoid overlapping instances).++-- DIM1+instance Elt e => Stencil DIM1 e (e, e, e) where+ stencil = StencilRunit3+ stencilAccess rf (Z:.y) = (rf' (y - 1),+ rf' y ,+ rf' (y + 1)) where- rf' y x = rf (x, y)-instance (Stencil DIM1 a row1,- Stencil DIM1 a row2,- Stencil DIM1 a row3,- Stencil DIM1 a row4,- Stencil DIM1 a row5) => Stencil DIM2 a (row1, row2, row3, row4, row5) where- stencilAccess rf (x, y) = (stencilAccess (rf' (y - 2)) x, - stencilAccess (rf' (y - 1)) x, - stencilAccess (rf' y ) x,- stencilAccess (rf' (y + 1)) x,- stencilAccess (rf' (y + 2)) x)+ rf' d = rf (Z:.d)+instance Elt e => Stencil DIM1 e (e, e, e, e, e) where+ stencil = StencilRunit5+ stencilAccess rf (Z:.y) = (rf' (y - 2),+ rf' (y - 1),+ rf' y ,+ rf' (y + 1),+ rf' (y + 2)) where- rf' y x = rf (x, y)-instance (Stencil DIM1 a row1,- Stencil DIM1 a row2,- Stencil DIM1 a row3,- Stencil DIM1 a row4,- Stencil DIM1 a row5,- Stencil DIM1 a row6,- Stencil DIM1 a row7) => Stencil DIM2 a (row1, row2, row3, row4, row5, row6, row7) where- stencilAccess rf (x, y) = (stencilAccess (rf' (y - 3)) x, - stencilAccess (rf' (y - 2)) x, - stencilAccess (rf' (y - 1)) x, - stencilAccess (rf' y ) x,- stencilAccess (rf' (y + 1)) x,- stencilAccess (rf' (y + 2)) x,- stencilAccess (rf' (y + 3)) x)+ rf' d = rf (Z:.d)+instance Elt e => Stencil DIM1 e (e, e, e, e, e, e, e) where+ stencil = StencilRunit7+ stencilAccess rf (Z:.y) = (rf' (y - 3),+ rf' (y - 2),+ rf' (y - 1),+ rf' y ,+ rf' (y + 1),+ rf' (y + 2),+ rf' (y + 3)) where- rf' y x = rf (x, y)-instance (Stencil DIM1 a row1,- Stencil DIM1 a row2,- Stencil DIM1 a row3,- Stencil DIM1 a row4,- Stencil DIM1 a row5,- Stencil DIM1 a row6,- Stencil DIM1 a row7,- Stencil DIM1 a row8,- Stencil DIM1 a row9) - => Stencil DIM2 a (row1, row2, row3, row4, row5, row6, row7, row8, row9) where- stencilAccess rf (x, y) = (stencilAccess (rf' (y - 4)) x, - stencilAccess (rf' (y - 3)) x, - stencilAccess (rf' (y - 2)) x, - stencilAccess (rf' (y - 1)) x, - stencilAccess (rf' y ) x,- stencilAccess (rf' (y + 1)) x,- stencilAccess (rf' (y + 2)) x,- stencilAccess (rf' (y + 3)) x,- stencilAccess (rf' (y + 4)) x)+ rf' d = rf (Z:.d)+instance Elt e => Stencil DIM1 e (e, e, e, e, e, e, e, e, e) where+ stencil = StencilRunit9+ stencilAccess rf (Z:.y) = (rf' (y - 4),+ rf' (y - 3),+ rf' (y - 2),+ rf' (y - 1),+ rf' y ,+ rf' (y + 1),+ rf' (y + 2),+ rf' (y + 3),+ rf' (y + 4)) where- rf' y x = rf (x, y)+ rf' d = rf (Z:.d) --- DIM3-instance (Stencil DIM2 a row1, - Stencil DIM2 a row2,- Stencil DIM2 a row3) => Stencil DIM3 a (row1, row2, row3) where- stencilAccess rf (x, y, z) = (stencilAccess (rf' (z - 1)) (x, y), - stencilAccess (rf' z ) (x, y),- stencilAccess (rf' (z + 1)) (x, y))+-- DIM(n+1), where n>0+instance (Stencil (sh:.Int) a row1,+ Stencil (sh:.Int) a row2,+ Stencil (sh:.Int) a row3) => Stencil (sh:.Int:.Int) a (row1, row2, row3) where+ stencil = StencilRtup3 stencil stencil stencil+ stencilAccess rf (ix:.i) = (stencilAccess (rf' (i - 1)) ix,+ stencilAccess (rf' i ) ix,+ stencilAccess (rf' (i + 1)) ix)+ where- rf' z (x, y) = rf (x, y, z)-instance (Stencil DIM2 a row1,- Stencil DIM2 a row2,- Stencil DIM2 a row3,- Stencil DIM2 a row4,- Stencil DIM2 a row5) => Stencil DIM3 a (row1, row2, row3, row4, row5) where- stencilAccess rf (x, y, z) = (stencilAccess (rf' (z - 2)) (x, y), - stencilAccess (rf' (z - 1)) (x, y), - stencilAccess (rf' z ) (x, y),- stencilAccess (rf' (z + 1)) (x, y),- stencilAccess (rf' (z + 2)) (x, y))+ rf' d ds = rf (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) where- rf' z (x, y) = rf (x, y, z)-instance (Stencil DIM2 a row1,- Stencil DIM2 a row2,- Stencil DIM2 a row3,- Stencil DIM2 a row4,- Stencil DIM2 a row5,- Stencil DIM2 a row6,- Stencil DIM2 a row7) => Stencil DIM3 a (row1, row2, row3, row4, row5, row6, row7) where- stencilAccess rf (x, y, z) = (stencilAccess (rf' (z - 3)) (x, y), - stencilAccess (rf' (z - 2)) (x, y), - stencilAccess (rf' (z - 1)) (x, y), - stencilAccess (rf' z ) (x, y),- stencilAccess (rf' (z + 1)) (x, y),- stencilAccess (rf' (z + 2)) (x, y),- stencilAccess (rf' (z + 3)) (x, y))+ rf' d ds = rf (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) a row6,+ 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) where- rf' z (x, y) = rf (x, y, z)-instance (Stencil DIM2 a row1,- Stencil DIM2 a row2,- Stencil DIM2 a row3,- Stencil DIM2 a row4,- Stencil DIM2 a row5,- Stencil DIM2 a row6,- Stencil DIM2 a row7,- Stencil DIM2 a row8,- Stencil DIM2 a row9) - => Stencil DIM3 a (row1, row2, row3, row4, row5, row6, row7, row8, row9) where- stencilAccess rf (x, y, z) = (stencilAccess (rf' (z - 4)) (x, y), - stencilAccess (rf' (z - 3)) (x, y), - stencilAccess (rf' (z - 2)) (x, y), - stencilAccess (rf' (z - 1)) (x, y), - stencilAccess (rf' z ) (x, y),- stencilAccess (rf' (z + 1)) (x, y),- stencilAccess (rf' (z + 2)) (x, y),- stencilAccess (rf' (z + 3)) (x, y),- stencilAccess (rf' (z + 4)) (x, y))+ rf' d ds = rf (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) a row6,+ Stencil (sh:.Int) a row7,+ Stencil (sh:.Int) a row8,+ Stencil (sh:.Int) a row9)+ => Stencil (sh:.Int:.Int) a (row1, row2, row3, row4, row5, row6, row7, row8, row9) where+ 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) where- rf' z (x, y) = rf (x, y, z)+ rf' d ds = rf (ds :. d) - + -- Embedded expressions -- -------------------- --- |Function abstraction+-- |Parametrised open function abstraction ---data OpenFun env aenv t where- Body :: OpenExp env aenv t -> OpenFun env aenv t- Lam :: Elem a- => OpenFun (env, ElemRepr a) aenv t -> OpenFun env aenv (a -> t)+data PreOpenFun (acc :: * -> * -> *) env aenv t where+ Body :: PreOpenExp acc env aenv t -> PreOpenFun acc env aenv t+ Lam :: Elt a+ => PreOpenFun acc (env, EltRepr a) aenv t -> PreOpenFun acc env aenv (a -> t) --- |Function without free scalar variables+-- |Vanilla open function abstraction ---type Fun aenv t = OpenFun () aenv t+type OpenFun = PreOpenFun OpenAcc --- |Open expressions using de Bruijn indices for variables ranging over tuples+-- |Parametrised function without free scalar variables+--+type PreFun acc = PreOpenFun acc ()++-- |Vanilla function without free scalar variables+--+type Fun = OpenFun ()++-- |Parametrised open expressions using de Bruijn indices for variables ranging over tuples -- of scalars and arrays of tuples. All code, except Cond, is evaluated -- eagerly. N-tuples are represented as nested pairs. -- -- The data type is parametrised over the surface types (not the representation -- type). ---data OpenExp env aenv t where+data PreOpenExp (acc :: * -> * -> *) env aenv t where -- Variable index, ranging only over tuples or scalars- Var :: Elem t- => Idx env (ElemRepr t)- -> OpenExp env aenv t+ Var :: Elt t+ => Idx env (EltRepr t)+ -> PreOpenExp acc env aenv t -- Constant values- Const :: Elem t- => ElemRepr t- -> OpenExp env aenv t+ Const :: Elt t+ => EltRepr t+ -> PreOpenExp acc env aenv t -- Tuples- Tuple :: (Elem t, IsTuple t)- => Tuple (OpenExp env aenv) (TupleRepr t)- -> OpenExp env aenv t- Prj :: (Elem t, IsTuple t)+ Tuple :: (Elt t, IsTuple t)+ => Tuple (PreOpenExp acc env aenv) (TupleRepr t)+ -> PreOpenExp acc env aenv t+ Prj :: (Elt t, IsTuple t) => TupleIdx (TupleRepr t) e- -> OpenExp env aenv t- -> OpenExp env aenv e+ -> PreOpenExp acc env aenv t+ -> PreOpenExp acc env aenv e + -- Array indices & shapes+ IndexNil :: PreOpenExp acc env aenv Z+ IndexCons :: (Slice sl, Elt a)+ => PreOpenExp acc env aenv sl+ -> PreOpenExp acc env aenv a+ -> PreOpenExp acc env aenv (sl:.a)+ IndexHead :: (Slice sl, Elt a)+ => PreOpenExp acc env aenv (sl:.a)+ -> PreOpenExp acc env aenv a+ IndexTail :: (Slice sl, Elt a)+ => PreOpenExp acc env aenv (sl:.a)+ -> PreOpenExp acc env aenv sl+ IndexAny :: Shape sh => PreOpenExp acc env aenv (Any sh)+ -- Conditional expression (non-strict in 2nd and 3rd argument)- Cond :: OpenExp env aenv Bool- -> OpenExp env aenv t - -> OpenExp env aenv t - -> OpenExp env aenv t+ Cond :: PreOpenExp acc env aenv Bool+ -> PreOpenExp acc env aenv t + -> PreOpenExp acc env aenv t + -> PreOpenExp acc env aenv t -- Primitive constants- PrimConst :: Elem t- => PrimConst t -> OpenExp env aenv t+ PrimConst :: Elt t+ => PrimConst t + -> PreOpenExp acc env aenv t -- Primitive scalar operations- PrimApp :: (Elem a, Elem r)+ PrimApp :: (Elt a, Elt r) => PrimFun (a -> r) - -> OpenExp env aenv a- -> OpenExp env aenv r+ -> PreOpenExp acc env aenv a+ -> PreOpenExp acc env aenv r -- Project a single scalar from an array- -- the array expression cannot contain any free scalar variables- IndexScalar :: OpenAcc aenv (Array dim t)- -> OpenExp env aenv dim - -> OpenExp env aenv t+ -- the array expression can not contain any free scalar variables+ IndexScalar :: (Shape dim, Elt t)+ => acc aenv (Array dim t)+ -> PreOpenExp acc env aenv dim + -> PreOpenExp acc env aenv t -- Array shape- -- the array expression cannot contain any free scalar variables- Shape :: Elem dim- => OpenAcc aenv (Array dim e) - -> OpenExp env aenv dim+ -- the array expression can not contain any free scalar variables+ Shape :: (Shape dim, Elt e)+ => acc aenv (Array dim e) + -> PreOpenExp acc env aenv dim --- |Expression without free scalar variables+ -- 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)+ -> PreOpenExp acc env aenv Int++-- |Vanilla open expression ---type Exp aenv t = OpenExp () aenv t+type OpenExp = PreOpenExp OpenAcc +-- |Parametrised expression without free scalar variables+--+type PreExp acc = PreOpenExp acc ()++-- |Vanilla expression without free scalar variables+--+type Exp = OpenExp ()+ -- |Primitive GPU constants -- data PrimConst ty where@@ -560,10 +760,14 @@ PrimExpFloating :: FloatingType a -> PrimFun (a -> a) PrimSqrt :: FloatingType a -> PrimFun (a -> a) PrimLog :: FloatingType a -> PrimFun (a -> a)- PrimFPow :: FloatingType a -> PrimFun ((a,a) -> a)- PrimLogBase :: FloatingType a -> PrimFun ((a,a) -> a)- PrimAtan2 :: FloatingType a -> PrimFun ((a,a) -> a)- -- FIXME: add operations from Floating, RealFrac & RealFloat+ PrimFPow :: FloatingType a -> PrimFun ((a, a) -> a)+ PrimLogBase :: FloatingType a -> PrimFun ((a, a) -> a)+ PrimAtan2 :: FloatingType a -> PrimFun ((a, a) -> a)+ PrimTruncate :: FloatingType a -> IntegralType b -> PrimFun (a -> b)+ PrimRound :: FloatingType a -> IntegralType b -> PrimFun (a -> b)+ PrimFloor :: FloatingType a -> IntegralType b -> PrimFun (a -> b)+ PrimCeiling :: FloatingType a -> IntegralType b -> PrimFun (a -> b)+ -- FIXME: add missing operations from RealFrac & RealFloat -- relational and equality operators PrimLt :: ScalarType a -> PrimFun ((a, a) -> Bool)@@ -585,18 +789,13 @@ PrimChr :: PrimFun (Int -> Char) -- FIXME: use IntegralType? - -- floating point conversions- PrimRoundFloatInt :: PrimFun (Float -> Int)- PrimTruncFloatInt :: PrimFun (Float -> Int)- PrimIntFloat :: PrimFun (Int -> Float)- -- FIXME: variants for other integer types (and also for Double)- -- ALSO: need to use overloading- -- FIXME: conversions between various integer types -- should we have an overloaded functions like 'toInt'? -- (or 'fromEnum' for enums?)- PrimBoolToInt :: PrimFun (Bool -> Int)+ PrimBoolToInt :: PrimFun (Bool -> Int)+ PrimFromIntegral :: IntegralType a -> NumType b -> PrimFun (a -> b) -- FIXME: what do we want to do about Enum? succ and pred are only -- moderatly useful without user-defined enumerations, but we want -- the range constructs for arrays (but that's not scalar primitives)+
Data/Array/Accelerate/Analysis/Shape.hs view
@@ -1,7 +1,7 @@-{-# LANGUAGE ScopedTypeVariables, GADTs #-}+{-# LANGUAGE ScopedTypeVariables, GADTs, RankNTypes #-} -- | -- Module : Data.Array.Accelerate.Analysis.Shape--- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell+-- 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>@@ -9,40 +9,99 @@ -- Portability : non-portable (GHC extensions) -- -module Data.Array.Accelerate.Analysis.Shape (accDim, accDim2)- where+module Data.Array.Accelerate.Analysis.Shape ( + -- * query AST dimensionality+ AccDim, AccDim2,+ accDim, accDim2,+ preAccDim, preAccDim2++) where+ import Data.Array.Accelerate.AST import Data.Array.Accelerate.Type import Data.Array.Accelerate.Array.Sugar +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 ---accDim :: forall aenv dim e. OpenAcc aenv (Array dim e) -> Int-accDim (Let _ acc) = accDim acc-accDim (Let2 _ acc) = accDim acc-accDim (Avar _) = ndim (elemType (undefined::dim))-accDim (Use (Array _ _)) = ndim (elemType (undefined::dim))-accDim (Unit _) = 0-accDim (Reshape _ _) = ndim (elemType (undefined::dim))-accDim (Replicate _ _ _) = ndim (elemType (undefined::dim))-accDim (Index _ _ _) = ndim (elemType (undefined::dim))-accDim (Map _ acc) = accDim acc-accDim (ZipWith _ _ acc) = accDim acc-accDim (Fold _ _ _) = 0-accDim (FoldSeg _ _ _ _) = 1-accDim (Permute _ acc _ _) = accDim acc-accDim (Backpermute _ _ _) = ndim (elemType (undefined::dim))-accDim (Stencil _ _ acc) = accDim acc-accDim (Stencil2 _ _ acc _ _) = accDim acc+accDim :: AccDim OpenAcc+accDim (OpenAcc acc) = preAccDim accDim acc +-- |Reify dimensionality of a computation parameterised over a recursive closure+--+preAccDim :: forall acc aenv sh e. AccDim acc -> PreOpenAcc acc aenv (Array sh e) -> Int+preAccDim k pacc =+ case pacc of+ Let _ acc -> k acc+ Let2 _ acc -> k acc+ Avar _ -> -- ndim (eltType (undefined::sh)) -- should work - GHC 6.12 bug?+ case arrays :: ArraysR (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+ ArraysRarray -> ndim (eltType (undefined::sh))+ Acond _ acc _ -> k acc+ Use (Array _ _) -> ndim (eltType (undefined::sh))+ Unit _ -> 0+ Generate _ _ -> ndim (eltType (undefined::sh))+ Reshape _ _ -> ndim (eltType (undefined::sh))+ Replicate _ _ _ -> ndim (eltType (undefined::sh))+ Index _ _ _ -> ndim (eltType (undefined::sh))+ 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+ Scanl _ _ acc -> k acc+ Scanl1 _ acc -> k acc+ Scanr _ _ acc -> k acc+ Scanr1 _ acc -> k acc+ Permute _ acc _ _ -> k acc+ Backpermute _ _ _ -> ndim (eltType (undefined::sh))+ Stencil _ _ acc -> k acc+ Stencil2 _ _ acc _ _ -> k acc++ -- |Reify the dimensionality of the results of a computation that yields two -- arrays ---accDim2 :: OpenAcc aenv (Array dim1 e1, Array dim2 e2) -> (Int,Int)-accDim2 (Scanl _ _ acc) = (accDim acc, 0)-accDim2 (Scanr _ _ acc) = (accDim acc, 0)+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+ Let _ acc -> k2 acc+ Let2 _ 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
@@ -0,0 +1,77 @@+{-# LANGUAGE GADTs, ScopedTypeVariables #-}+-- |+-- Module : Data.Array.Accelerate.CUDA.Analysis.Stencil+-- Copyright : [2010..2011] Ben Lever, 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.Analysis.Stencil (offsets, offsets2) where++import Data.Array.Accelerate.AST+import Data.Array.Accelerate.Array.Sugar+++-- |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.+--+offsets :: forall a b sh aenv stencil. Stencil sh a stencil+ => {- dummy -} Fun aenv (stencil -> b)+ -> {- dummy -} OpenAcc aenv (Array sh a)+ -> [sh]+offsets _ _ = positionsR (stencil :: StencilR sh a stencil)++offsets2 :: forall a b c sh aenv stencil1 stencil2. (Stencil sh a stencil1, Stencil sh b stencil2)+ => {- dummy -} Fun aenv (stencil1 -> stencil2 -> c)+ -> {- dummy -} OpenAcc aenv (Array sh a)+ -> {- dummy -} OpenAcc aenv (Array sh b)+ -> ([sh], [sh])+offsets2 _ _ _ =+ ( positionsR (stencil :: StencilR sh a stencil1)+ , positionsR (stencil :: StencilR sh b stencil2) )+++-- |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 (StencilRtup3 a b c) = concat+ [ map (:.(-1)) $ positionsR a+ , map (:. 0 ) $ positionsR b+ , map (:. 1 ) $ positionsR c ]++positionsR (StencilRtup5 a b c d e) = concat+ [ map (:.(-2)) $ positionsR a+ , map (:.(-1)) $ positionsR b+ , map (:. 0 ) $ positionsR c+ , map (:. 1 ) $ positionsR d+ , map (:. 2 ) $ positionsR e ]++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+ , map (:. 2 ) $ positionsR f+ , map (:. 3 ) $ positionsR g ]++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+ , map (:. 3 ) $ positionsR h+ , map (:. 4 ) $ positionsR i ]+
Data/Array/Accelerate/Analysis/Type.hs view
@@ -1,85 +1,173 @@-{-# LANGUAGE ScopedTypeVariables, GADTs, TypeFamilies, PatternGuards #-}---- |Embedded array processing language: type analysis------ Copyright (c) 2009 Manuel M T Chakravarty, Gabriele Keller, Sean Lee+{-# LANGUAGE RankNTypes, ScopedTypeVariables #-}+{-# LANGUAGE GADTs, TypeFamilies, PatternGuards #-}+-- |+-- Module : Data.Array.Accelerate.Analysis.Type+-- Copyright : [2009..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell+-- License : BSD3 ----- License: BSD3+-- Maintainer : Manuel M T Chakravarty <chak@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions) ------ Description ---------------------------------------------------------------+-- The Accelerate AST does not explicitly store much type information. Most of+-- it is only indirectly through type class constraints -especially, 'Elt'+-- constraints- available. This module provides functions that reify that+-- type information in the form of a 'TupleType' value. This is, for example,+-- needed to emit type information in a backend. ----- The Accelerate AST does not explicitly store much type information. Most of--- it is only indirectly through type class constraints -especially, Elem--- constraints- available. This module provides functions that reify that --- type information in the form of a 'TupleType' value. This is, for example,--- needed to emit type information in a backend. module Data.Array.Accelerate.Analysis.Type ( -- * Query AST types- accType, accType2, expType, sizeOf- + AccType, AccType2,+ arrayType, accType, accType2, expType, sizeOf,+ preAccType, preAccType2, preExpType+ ) where- ++-- standard library+import qualified Foreign.Storable as F+ -- friends import Data.Array.Accelerate.Type import Data.Array.Accelerate.Tuple import Data.Array.Accelerate.Array.Sugar import Data.Array.Accelerate.AST --- neighbours-import qualified Foreign.Storable as F --- Determine the type of an expressions--- ------------------------------------+-- |Determine an array type+-- ------------------------ +-- |Reify the element type of an array.+--+arrayType :: forall sh e. Array sh e -> TupleType (EltRepr e)+arrayType (Array _ _) = eltType (undefined::e)+++-- |Determine the type of an expressions+-- -------------------------------------++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. ---accType :: forall aenv dim e.- OpenAcc aenv (Array dim e) -> TupleType (ElemRepr e)-accType (Let _ acc) = accType acc-accType (Let2 _ acc) = accType acc-accType (Avar _) = elemType (undefined::e)-accType (Use arr) = arrayType arr-accType (Unit _) = elemType (undefined::e)-accType (Reshape _ acc) = accType acc-accType (Replicate _ _ acc) = accType acc-accType (Index _ acc _) = accType acc-accType (Map _ _) = elemType (undefined::e)-accType (ZipWith _ _ _) = elemType (undefined::e)-accType (Fold _ _ acc) = accType acc-accType (FoldSeg _ _ acc _) = accType acc-accType (Permute _ _ _ acc) = accType acc-accType (Backpermute _ _ acc) = accType acc-accType (Stencil _ _ _) = elemType (undefined::e)-accType (Stencil2 _ _ _ _ _) = elemType (undefined::e)+accType :: AccType OpenAcc+accType (OpenAcc acc) = preAccType accType acc +-- |Reify the element type of the result of an array computation using the array computation AST+-- before tying the knot.+--+preAccType :: forall acc aenv sh e.+ AccType acc+ -> PreOpenAcc acc aenv (Array sh e)+ -> TupleType (EltRepr e)+preAccType k pacc =+ case pacc of+ Let _ acc -> k acc+ Let2 _ acc -> k acc+ Avar _ -> -- eltType (undefined::e) -- should work - GHC 6.12 bug?+ case arrays :: ArraysR (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+ ArraysRarray -> eltType (undefined::e)+ Acond _ acc _ -> k acc+ Use arr -> arrayType arr+ Unit _ -> eltType (undefined::e)+ Generate _ _ -> eltType (undefined::e)+ Reshape _ acc -> k acc+ Replicate _ _ acc -> k acc+ Index _ acc _ -> k acc+ Map _ _ -> eltType (undefined::e)+ ZipWith _ _ _ -> eltType (undefined::e)+ Fold _ _ acc -> k acc+ FoldSeg _ _ acc _ -> k acc+ Fold1 _ acc -> k acc+ Fold1Seg _ acc _ -> k acc+ Scanl _ _ acc -> k acc+ Scanl1 _ acc -> k acc+ Scanr _ _ acc -> k acc+ Scanr1 _ acc -> k acc+ Permute _ _ _ acc -> k acc+ Backpermute _ _ acc -> k acc+ Stencil _ _ _ -> eltType (undefined::e)+ Stencil2 _ _ _ _ _ -> eltType (undefined::e)+ -- |Reify the element types of the results of an array computation that yields -- two arrays. ---accType2 :: OpenAcc aenv (Array dim1 e1, Array dim2 e2)- -> (TupleType (ElemRepr e1), TupleType (ElemRepr e2))-accType2 (Scanl _ e acc) = (accType acc, expType e)-accType2 (Scanr _ e acc) = (accType acc, expType e)+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+ Let _ acc -> k2 acc+ Let2 _ 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 :: forall aenv env t. OpenExp aenv env t -> TupleType (ElemRepr t)-expType (Var _) = elemType (undefined::t)-expType (Const _) = elemType (undefined::t)-expType (Tuple _) = elemType (undefined::t)-expType (Prj idx _) = tupleIdxType idx-expType (Cond _ t _) = expType t-expType (PrimConst _) = elemType (undefined::t)-expType (PrimApp _ _) = elemType (undefined::t)-expType (IndexScalar acc _) = accType acc-expType (Shape _) = elemType (undefined::t)+expType :: OpenExp aenv env t -> TupleType (EltRepr t)+expType = preExpType accType +-- |Reify the result types of of a scalar expression using the expression AST before tying the+-- knot.+--+preExpType :: forall acc aenv env t.+ AccType acc+ -> PreOpenExp acc aenv env t+ -> TupleType (EltRepr t)+preExpType k e =+ case e of+ Var _ -> eltType (undefined::t)+ Const _ -> eltType (undefined::t)+ Tuple _ -> eltType (undefined::t)+ Prj idx _ -> tupleIdxType idx+ IndexNil -> eltType (undefined::t)+ IndexCons _ _ -> eltType (undefined::t)+ IndexHead _ -> eltType (undefined::t)+ IndexTail _ -> eltType (undefined::t)+ IndexAny -> eltType (undefined::t)+ Cond _ t _ -> preExpType k t+ PrimConst _ -> eltType (undefined::t)+ 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 (ElemRepr e)-tupleIdxType ZeroTupIdx = elemType (undefined::e)+tupleIdxType :: forall t e. TupleIdx t e -> TupleType (EltRepr e)+tupleIdxType ZeroTupIdx = eltType (undefined::e) tupleIdxType (SuccTupIdx idx) = tupleIdxType idx
Data/Array/Accelerate/Array/Data.hs view
@@ -1,8 +1,9 @@-{-# LANGUAGE GADTs, TypeFamilies, FlexibleContexts, FlexibleInstances #-}+{-# LANGUAGE CPP, GADTs, TypeFamilies, FlexibleContexts, FlexibleInstances #-} {-# LANGUAGE RankNTypes, MagicHash, UnboxedTuples #-}+{-# OPTIONS_GHC -fno-warn-missing-methods #-} -- | -- Module : Data.Array.Accelerate.Array.Data--- Copyright : [2009..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee+-- Copyright : [2009..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee -- License : BSD3 -- -- Maintainer : Manuel M T Chakravarty <chak@cse.unsw.edu.au>@@ -13,12 +14,14 @@ -- allocate all arrays using pinned memory to enable safe direct-access by -- non-Haskell code in multi-threaded code. In particular, we can safely pass -- pointers to an array's payload to foreign code.+-- module Data.Array.Accelerate.Array.Data ( -- * Array operations and representations- ArrayElem(..), ArrayData, MutableArrayData, runArrayData,- + ArrayElt(..), ArrayData, MutableArrayData, runArrayData,+ ArrayEltR(..), GArrayData(..),+ -- * Array tuple operations fstArrayData, sndArrayData, pairArrayData @@ -35,6 +38,11 @@ import Control.Monad.ST import qualified Data.Array.IArray as IArray import qualified Data.Array.MArray as MArray hiding (newArray)+#if __GLASGOW_HASKELL__ == 700+import qualified Data.Array.MArray as Unsafe+#else+import qualified Data.Array.Unsafe as Unsafe+#endif import Data.Array.ST (STUArray) import Data.Array.Unboxed (UArray) import Data.Array.Base (UArray(UArray), STUArray(STUArray), bOOL_SCALE,@@ -58,7 +66,7 @@ -- Array representation in dependence on the element type, but abstracting -- over the basic array type (in particular, abstracting over mutability) ---data family GArrayData ba e+data family GArrayData :: (* -> *) -> * -> * data instance GArrayData ba () = AD_Unit data instance GArrayData ba Int = AD_Int (ba Int) data instance GArrayData ba Int8 = AD_Int8 (ba Int8)@@ -87,14 +95,34 @@ -- data instance GArrayData ba CChar = AD_CChar (ba CChar) -- data instance GArrayData ba CSChar = AD_CSChar (ba CSChar) -- data instance GArrayData ba CUChar = AD_CUChar (ba CUChar)-data instance GArrayData ba (a, b) = AD_Pair (GArrayData ba a) +data instance GArrayData ba (a, b) = AD_Pair (GArrayData ba a) (GArrayData ba b) +-- | GADT to reify the 'ArrayElt' class.+--+data ArrayEltR a where+ ArrayEltRunit :: ArrayEltR ()+ ArrayEltRint :: ArrayEltR Int+ ArrayEltRint8 :: ArrayEltR Int8+ ArrayEltRint16 :: ArrayEltR Int16+ ArrayEltRint32 :: ArrayEltR Int32+ ArrayEltRint64 :: ArrayEltR Int64+ ArrayEltRword :: ArrayEltR Word+ ArrayEltRword8 :: ArrayEltR Word8+ ArrayEltRword16 :: ArrayEltR Word16+ ArrayEltRword32 :: ArrayEltR Word32+ ArrayEltRword64 :: ArrayEltR Word64+ ArrayEltRfloat :: ArrayEltR Float+ ArrayEltRdouble :: ArrayEltR Double+ ArrayEltRbool :: ArrayEltR Bool+ ArrayEltRchar :: ArrayEltR Char+ ArrayEltRpair :: (ArrayElt a, ArrayElt b)+ => ArrayEltR a -> ArrayEltR b -> ArrayEltR (a,b) -- Array operations -- ---------------- -class ArrayElem e where+class ArrayElt e where type ArrayPtrs e -- indexArrayData :: ArrayData e -> Int -> e@@ -105,8 +133,10 @@ writeArrayData :: MutableArrayData s e -> Int -> e -> ST s () unsafeFreezeArrayData :: MutableArrayData s e -> ST s (ArrayData e) ptrsOfMutableArrayData :: MutableArrayData s e -> ST s (ArrayPtrs e)+ --+ arrayElt :: ArrayEltR e -instance ArrayElem () where+instance ArrayElt () where type ArrayPtrs () = () indexArrayData AD_Unit i = i `seq` () ptrsOfArrayData AD_Unit = ()@@ -115,110 +145,121 @@ writeArrayData AD_Unit i () = i `seq` return () unsafeFreezeArrayData AD_Unit = return AD_Unit ptrsOfMutableArrayData AD_Unit = return ()+ arrayElt = ArrayEltRunit -instance ArrayElem Int where+instance ArrayElt Int where type ArrayPtrs Int = Ptr Int indexArrayData (AD_Int ba) i = ba IArray.! i ptrsOfArrayData (AD_Int ba) = uArrayPtr ba newArrayData size = liftM AD_Int $ unsafeNewArray_ size wORD_SCALE readArrayData (AD_Int ba) i = MArray.readArray ba i writeArrayData (AD_Int ba) i e = MArray.writeArray ba i e- unsafeFreezeArrayData (AD_Int ba) = liftM AD_Int $ MArray.unsafeFreeze ba+ unsafeFreezeArrayData (AD_Int ba) = liftM AD_Int $ Unsafe.unsafeFreeze ba ptrsOfMutableArrayData (AD_Int ba) = sTUArrayPtr ba+ arrayElt = ArrayEltRint -instance ArrayElem Int8 where+instance ArrayElt Int8 where type ArrayPtrs Int8 = Ptr Int8 indexArrayData (AD_Int8 ba) i = ba IArray.! i ptrsOfArrayData (AD_Int8 ba) = uArrayPtr ba newArrayData size = liftM AD_Int8 $ unsafeNewArray_ size (\x -> x) readArrayData (AD_Int8 ba) i = MArray.readArray ba i writeArrayData (AD_Int8 ba) i e = MArray.writeArray ba i e- unsafeFreezeArrayData (AD_Int8 ba) = liftM AD_Int8 $ MArray.unsafeFreeze ba+ unsafeFreezeArrayData (AD_Int8 ba) = liftM AD_Int8 $ Unsafe.unsafeFreeze ba ptrsOfMutableArrayData (AD_Int8 ba) = sTUArrayPtr ba+ arrayElt = ArrayEltRint8 -instance ArrayElem Int16 where+instance ArrayElt Int16 where type ArrayPtrs Int16 = Ptr Int16 indexArrayData (AD_Int16 ba) i = ba IArray.! i ptrsOfArrayData (AD_Int16 ba) = uArrayPtr ba newArrayData size = liftM AD_Int16 $ unsafeNewArray_ size (*# 2#) readArrayData (AD_Int16 ba) i = MArray.readArray ba i writeArrayData (AD_Int16 ba) i e = MArray.writeArray ba i e- unsafeFreezeArrayData (AD_Int16 ba) = liftM AD_Int16 $ MArray.unsafeFreeze ba+ unsafeFreezeArrayData (AD_Int16 ba) = liftM AD_Int16 $ Unsafe.unsafeFreeze ba ptrsOfMutableArrayData (AD_Int16 ba) = sTUArrayPtr ba+ arrayElt = ArrayEltRint16 -instance ArrayElem Int32 where+instance ArrayElt Int32 where type ArrayPtrs Int32 = Ptr Int32 indexArrayData (AD_Int32 ba) i = ba IArray.! i ptrsOfArrayData (AD_Int32 ba) = uArrayPtr ba newArrayData size = liftM AD_Int32 $ unsafeNewArray_ size (*# 4#) readArrayData (AD_Int32 ba) i = MArray.readArray ba i writeArrayData (AD_Int32 ba) i e = MArray.writeArray ba i e- unsafeFreezeArrayData (AD_Int32 ba) = liftM AD_Int32 $ MArray.unsafeFreeze ba+ unsafeFreezeArrayData (AD_Int32 ba) = liftM AD_Int32 $ Unsafe.unsafeFreeze ba ptrsOfMutableArrayData (AD_Int32 ba) = sTUArrayPtr ba+ arrayElt = ArrayEltRint32 -instance ArrayElem Int64 where+instance ArrayElt Int64 where type ArrayPtrs Int64 = Ptr Int64 indexArrayData (AD_Int64 ba) i = ba IArray.! i ptrsOfArrayData (AD_Int64 ba) = uArrayPtr ba newArrayData size = liftM AD_Int64 $ unsafeNewArray_ size (*# 8#) readArrayData (AD_Int64 ba) i = MArray.readArray ba i writeArrayData (AD_Int64 ba) i e = MArray.writeArray ba i e- unsafeFreezeArrayData (AD_Int64 ba) = liftM AD_Int64 $ MArray.unsafeFreeze ba+ unsafeFreezeArrayData (AD_Int64 ba) = liftM AD_Int64 $ Unsafe.unsafeFreeze ba ptrsOfMutableArrayData (AD_Int64 ba) = sTUArrayPtr ba+ arrayElt = ArrayEltRint64 -instance ArrayElem Word where+instance ArrayElt Word where type ArrayPtrs Word = Ptr Word indexArrayData (AD_Word ba) i = ba IArray.! i ptrsOfArrayData (AD_Word ba) = uArrayPtr ba newArrayData size = liftM AD_Word $ unsafeNewArray_ size wORD_SCALE readArrayData (AD_Word ba) i = MArray.readArray ba i writeArrayData (AD_Word ba) i e = MArray.writeArray ba i e- unsafeFreezeArrayData (AD_Word ba) = liftM AD_Word $ MArray.unsafeFreeze ba+ unsafeFreezeArrayData (AD_Word ba) = liftM AD_Word $ Unsafe.unsafeFreeze ba ptrsOfMutableArrayData (AD_Word ba) = sTUArrayPtr ba+ arrayElt = ArrayEltRword -instance ArrayElem Word8 where+instance ArrayElt Word8 where type ArrayPtrs Word8 = Ptr Word8 indexArrayData (AD_Word8 ba) i = ba IArray.! i ptrsOfArrayData (AD_Word8 ba) = uArrayPtr ba newArrayData size = liftM AD_Word8 $ unsafeNewArray_ size (\x -> x) readArrayData (AD_Word8 ba) i = MArray.readArray ba i writeArrayData (AD_Word8 ba) i e = MArray.writeArray ba i e- unsafeFreezeArrayData (AD_Word8 ba) = liftM AD_Word8 $ MArray.unsafeFreeze ba+ unsafeFreezeArrayData (AD_Word8 ba) = liftM AD_Word8 $ Unsafe.unsafeFreeze ba ptrsOfMutableArrayData (AD_Word8 ba) = sTUArrayPtr ba+ arrayElt = ArrayEltRword8 -instance ArrayElem Word16 where+instance ArrayElt Word16 where type ArrayPtrs Word16 = Ptr Word16 indexArrayData (AD_Word16 ba) i = ba IArray.! i ptrsOfArrayData (AD_Word16 ba) = uArrayPtr ba newArrayData size = liftM AD_Word16 $ unsafeNewArray_ size (*# 2#) readArrayData (AD_Word16 ba) i = MArray.readArray ba i writeArrayData (AD_Word16 ba) i e = MArray.writeArray ba i e- unsafeFreezeArrayData (AD_Word16 ba) - = liftM AD_Word16 $ MArray.unsafeFreeze ba+ unsafeFreezeArrayData (AD_Word16 ba)+ = liftM AD_Word16 $ Unsafe.unsafeFreeze ba ptrsOfMutableArrayData (AD_Word16 ba) = sTUArrayPtr ba+ arrayElt = ArrayEltRword16 -instance ArrayElem Word32 where+instance ArrayElt Word32 where type ArrayPtrs Word32 = Ptr Word32 indexArrayData (AD_Word32 ba) i = ba IArray.! i ptrsOfArrayData (AD_Word32 ba) = uArrayPtr ba newArrayData size = liftM AD_Word32 $ unsafeNewArray_ size (*# 4#) readArrayData (AD_Word32 ba) i = MArray.readArray ba i writeArrayData (AD_Word32 ba) i e = MArray.writeArray ba i e- unsafeFreezeArrayData (AD_Word32 ba) - = liftM AD_Word32 $ MArray.unsafeFreeze ba+ unsafeFreezeArrayData (AD_Word32 ba)+ = liftM AD_Word32 $ Unsafe.unsafeFreeze ba ptrsOfMutableArrayData (AD_Word32 ba) = sTUArrayPtr ba+ arrayElt = ArrayEltRword32 -instance ArrayElem Word64 where+instance ArrayElt Word64 where type ArrayPtrs Word64 = Ptr Word64 indexArrayData (AD_Word64 ba) i = ba IArray.! i ptrsOfArrayData (AD_Word64 ba) = uArrayPtr ba newArrayData size = liftM AD_Word64 $ unsafeNewArray_ size (*# 8#) readArrayData (AD_Word64 ba) i = MArray.readArray ba i writeArrayData (AD_Word64 ba) i e = MArray.writeArray ba i e- unsafeFreezeArrayData (AD_Word64 ba) - = liftM AD_Word64 $ MArray.unsafeFreeze ba+ unsafeFreezeArrayData (AD_Word64 ba)+ = liftM AD_Word64 $ Unsafe.unsafeFreeze ba ptrsOfMutableArrayData (AD_Word64 ba) = sTUArrayPtr ba- + arrayElt = ArrayEltRword64+ -- FIXME: -- CShort -- CUShort@@ -229,32 +270,34 @@ -- CLLong -- CULLong -instance ArrayElem Float where+instance ArrayElt Float where type ArrayPtrs Float = Ptr Float indexArrayData (AD_Float ba) i = ba IArray.! i ptrsOfArrayData (AD_Float ba) = uArrayPtr ba newArrayData size = liftM AD_Float $ unsafeNewArray_ size fLOAT_SCALE readArrayData (AD_Float ba) i = MArray.readArray ba i writeArrayData (AD_Float ba) i e = MArray.writeArray ba i e- unsafeFreezeArrayData (AD_Float ba) = liftM AD_Float $ MArray.unsafeFreeze ba+ unsafeFreezeArrayData (AD_Float ba) = liftM AD_Float $ Unsafe.unsafeFreeze ba ptrsOfMutableArrayData (AD_Float ba) = sTUArrayPtr ba+ arrayElt = ArrayEltRfloat -instance ArrayElem Double where+instance ArrayElt Double where type ArrayPtrs Double = Ptr Double indexArrayData (AD_Double ba) i = ba IArray.! i ptrsOfArrayData (AD_Double ba) = uArrayPtr ba newArrayData size = liftM AD_Double $ unsafeNewArray_ size dOUBLE_SCALE readArrayData (AD_Double ba) i = MArray.readArray ba i writeArrayData (AD_Double ba) i e = MArray.writeArray ba i e- unsafeFreezeArrayData (AD_Double ba) - = liftM AD_Double $ MArray.unsafeFreeze ba+ unsafeFreezeArrayData (AD_Double ba)+ = liftM AD_Double $ Unsafe.unsafeFreeze ba ptrsOfMutableArrayData (AD_Double ba) = sTUArrayPtr ba+ arrayElt = ArrayEltRdouble -- FIXME: -- CFloat -- CDouble -instance ArrayElem Bool where+instance ArrayElt Bool where type ArrayPtrs Bool = Ptr Word8 indexArrayData (AD_Bool ba) i = ba IArray.! i -- ptrsOfArrayData (AD_Bool ba) = uArrayPtr ba???currently wrong@@ -266,35 +309,37 @@ newArrayData size = liftM AD_Bool $ unsafeNewArray_ size bOOL_SCALE readArrayData (AD_Bool ba) i = MArray.readArray ba i writeArrayData (AD_Bool ba) i e = MArray.writeArray ba i e- unsafeFreezeArrayData (AD_Bool ba) = liftM AD_Bool $ MArray.unsafeFreeze ba+ unsafeFreezeArrayData (AD_Bool ba) = liftM AD_Bool $ Unsafe.unsafeFreeze ba -- ptrsOfMutableArrayData (AD_Bool ba) = sTUArrayPtr ba??? -- see ptrsOfArrayData+ arrayElt = ArrayEltRbool -instance ArrayElem Char where+instance ArrayElt Char where -- type ArrayPtrs Char = ???unicode??? indexArrayData (AD_Char ba) i = ba IArray.! i -- ptrsOfArrayData (AD_Char ba) = ??? newArrayData size = liftM AD_Char $ unsafeNewArray_ size (*# 4#) readArrayData (AD_Char ba) i = MArray.readArray ba i writeArrayData (AD_Char ba) i e = MArray.writeArray ba i e- unsafeFreezeArrayData (AD_Char ba) = liftM AD_Char $ MArray.unsafeFreeze ba+ unsafeFreezeArrayData (AD_Char ba) = liftM AD_Char $ Unsafe.unsafeFreeze ba -- ptrsOfMutableArrayData (AD_Char ba) = ???+ arrayElt = ArrayEltRchar -- FIXME: -- CChar -- CSChar -- CUChar -instance (ArrayElem a, ArrayElem b) => ArrayElem (a, b) where+instance (ArrayElt a, ArrayElt b) => ArrayElt (a, b) where type ArrayPtrs (a, b) = (ArrayPtrs a, ArrayPtrs b) indexArrayData (AD_Pair a b) i = (indexArrayData a i, indexArrayData b i) ptrsOfArrayData (AD_Pair a b) = (ptrsOfArrayData a, ptrsOfArrayData b)- newArrayData size - = do + newArrayData size+ = do a <- newArrayData size b <- newArrayData size return $ AD_Pair a b- readArrayData (AD_Pair a b) i + readArrayData (AD_Pair a b) i = do x <- readArrayData a i y <- readArrayData b i@@ -303,26 +348,27 @@ = do writeArrayData a i x writeArrayData b i y- unsafeFreezeArrayData (AD_Pair a b) + unsafeFreezeArrayData (AD_Pair a b) = do a' <- unsafeFreezeArrayData a b' <- unsafeFreezeArrayData b return $ AD_Pair a' b'- ptrsOfMutableArrayData (AD_Pair a b) + ptrsOfMutableArrayData (AD_Pair a b) = do aptr <- ptrsOfMutableArrayData a bptr <- ptrsOfMutableArrayData b return (aptr, bptr)+ arrayElt = ArrayEltRpair arrayElt arrayElt -- |Safe combination of creating and fast freezing of array data. ---runArrayData :: ArrayElem e+runArrayData :: ArrayElt e => (forall s. ST s (MutableArrayData s e, e)) -> (ArrayData e, e) runArrayData st = runST $ do (mad, r) <- st ad <- unsafeFreezeArrayData mad return (ad, r)- + -- Array tuple operations -- ---------------------- @@ -337,8 +383,8 @@ --- Auxilliary functions--- --------------------+-- Auxiliary functions+-- ------------------- -- Our own version of the 'STUArray' allocation that uses /pinned/ memory, -- which is aligned to 16 bytes.@@ -364,4 +410,5 @@ sTUArrayPtr :: STUArray s Int a -> ST s (Ptr a) sTUArrayPtr (STUArray _ _ _ mba) = ST $ \s -> case unsafeFreezeByteArray# mba s of- (# s, ba #) -> (# s, Ptr (byteArrayContents# ba) #)+ (# s', ba #) -> (# s', Ptr (byteArrayContents# ba) #)+
Data/Array/Accelerate/Array/Delayed.hs view
@@ -1,15 +1,16 @@-{-# LANGUAGE TypeFamilies, RankNTypes #-}---- |Embedded array processing language: delayed arrays------ Copyright (c) 2009 Manuel M T Chakravarty, Gabriele Keller, Sean Lee+{-# LANGUAGE TypeFamilies #-}+-- |+-- Module : Data.Array.Accelerate+-- Copyright : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee+-- License : BSD3 ----- License: BSD3+-- Maintainer : Manuel M T Chakravarty <chak@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions) ------ Description ---------------------------------------------------------------+-- Delayed arrays are represented by their representation function, which enables the simple+-- composition of many array operations. ----- Delayed arrays are represented by their representation function, which--- enables the simple composition of many array operations. module Data.Array.Accelerate.Array.Delayed ( @@ -36,18 +37,17 @@ delay () = DelayedUnit force DelayedUnit = () -instance Delayable (Array dim e) where- data Delayed (Array dim e) - = (Ix dim, Elem e) => - DelayedArray { shapeDA :: ElemRepr dim- , repfDA :: ElemRepr dim -> ElemRepr e+instance Delayable (Array sh e) where+ data Delayed (Array sh e) + = (Shape sh, Elt e) => + DelayedArray { shapeDA :: EltRepr sh+ , repfDA :: EltRepr sh -> EltRepr e }- delay arr@(Array sh _) = DelayedArray sh (fromElem . (arr!) . toElem)- force (DelayedArray sh f) = newArray (toElem sh) (toElem . f . fromElem)+ delay arr@(Array sh _) = DelayedArray sh (fromElt . (arr!) . toElt)+ force (DelayedArray sh f) = newArray (toElt sh) (toElt . f . fromElt) instance (Delayable a1, Delayable a2) => Delayable (a1, a2) where data Delayed (a1, a2) = DelayedPair (Delayed a1) (Delayed a2) delay (a1, a2) = DelayedPair (delay a1) (delay a2) force (DelayedPair a1 a2) = (force a1, force a2)-
Data/Array/Accelerate/Array/Representation.hs view
@@ -1,18 +1,19 @@-{-# LANGUAGE CPP, GADTs, TypeFamilies, FlexibleContexts, FlexibleInstances #-}---- |Embedded array processing language: array representation------ Copyright (c) [2008..2009] Manuel M T Chakravarty, Gabriele Keller, Sean Lee------ License: BSD3+{-# LANGUAGE CPP, GADTs, FlexibleContexts, FlexibleInstances #-}+{-# LANGUAGE TypeOperators, TypeFamilies #-}+-- |+-- Module : Data.Array.Accelerate.Array.Representation+-- Copyright : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell+-- License : BSD3 ------ Description ---------------------------------------------------------------+-- Maintainer : Manuel M T Chakravarty <chak@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions) -- module Data.Array.Accelerate.Array.Representation ( - -- * Array indexing and slicing- Ix(..), SliceIx(..), SliceIndex(..),+ -- * Array shapes, indices, and slices+ Shape(..), Slice(..), SliceIndex(..), ) where @@ -27,78 +28,91 @@ -- |Class of index representations (which are nested pairs) ---class Eq ix => Ix ix where- dim :: ix -> Int -- number of dimensions (>= 0)- size :: ix -> Int -- for a *shape* yield the total number of - -- elements in that array- intersect :: ix -> ix -> ix -- yield the intersection of two shapes- ignore :: ix -- identifies ignored elements in 'permute'- index :: ix -> ix -> Int -- yield the index position in a linear, - -- row-major representation of the array- -- (first argument is the shape)- bound :: ix -> ix -> Boundary e -> Either e ix+class (Eq sh, Slice sh) => Shape sh where+ -- user-facing methods+ dim :: sh -> Int -- ^number of dimensions (>= 0); rank of the array+ size :: sh -> Int -- ^total number of elements in an array of this /shape/++ -- internal methods+ intersect :: sh -> sh -> sh -- yield the intersection of two shapes+ ignore :: sh -- identifies ignored elements in 'permute'+ index :: sh -> sh -> Int -- yield the index position in a linear, row-major representation of+ -- the array (first argument is the shape)+ bound :: sh -> sh -> Boundary e -> Either e sh -- apply a boundary condition to an index - iter :: ix -> (ix -> a) -> (a -> a -> a) -> a -> a- -- iterate through the entire shape, applying- -- the function; third argument combines results- -- and fourth is returned in case of an empty- -- iteration space; the index space is traversed- -- in row-major order+ iter :: sh -> (sh -> a) -> (a -> a -> a) -> a -> a+ -- iterate through the entire shape, applying the function in the+ -- second argument; third argument combines results and fourth is an+ -- initial value that is combined with the results; the index space+ -- is traversed in row-major order + iter1 :: sh -> (sh -> a) -> (a -> a -> a) -> a+ -- variant of 'iter' without an initial value+ -- operations to facilitate conversion with IArray- rangeToShape :: (ix, ix) -> ix -- convert a minpoint-maxpoint index+ rangeToShape :: (sh, sh) -> sh -- convert a minpoint-maxpoint index -- into a shape- shapeToRange :: ix -> (ix, ix) -- ...the converse+ shapeToRange :: sh -> (sh, sh) -- ...the converse -- other conversions- shapeToList :: ix -> [Int] -- convert a shape into its list of dimensions- listToShape :: [Int] -> ix -- convert a list of dimensions into a shape+ shapeToList :: sh -> [Int] -- convert a shape into its list of dimensions+ listToShape :: [Int] -> sh -- convert a list of dimensions into a shape -instance Ix () where+instance Shape () where dim () = 0 size () = 1+ () `intersect` () = () ignore = () index () () = 0 bound () () _ = Right ()- iter () f _ _ = f ()+ iter () f c e = e `c` f ()+ iter1 () f _ = f () rangeToShape ((), ()) = () shapeToRange () = ((), ()) shapeToList () = [] listToShape [] = ()- listToShape _ = error "Data.Array.Accelerate.Array: non-empty list when converting to unit"+ listToShape _ = INTERNAL_ERROR(error) "listToShape" "non-empty list when converting to unit" -instance Ix ix => Ix (ix, Int) where+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 + size sh * i+ $ index sh ix * sz + i bound (sh, sz) (ix, i) bndy | i < 0 = case bndy of Clamp -> bound sh ix bndy `addDim` 0 Mirror -> bound sh ix bndy `addDim` (-i)- Wrap -> bound sh ix bndy `addDim` (sz-i)+ Wrap -> bound sh ix bndy `addDim` (sz+i) Constant e -> Left e | i >= sz = case bndy of Clamp -> bound sh ix bndy `addDim` (sz-1)- Mirror -> bound sh ix bndy `addDim` (sz-(i-sz+1))+ Mirror -> bound sh ix bndy `addDim` (sz-(i-sz+2)) Wrap -> bound sh ix bndy `addDim` (i-sz) Constant e -> Left e | otherwise = bound sh ix bndy `addDim` i where- Right ix `addDim` i = Right (ix, i)+ Right ds `addDim` d = Right (ds, d) Left e `addDim` _ = Left e- iter (sh, sz) f c r = iter' 0++ iter (sh, sz) f c r = iter sh (\ix -> iter' (ix,0)) c r where- iter' i | i >= sz = r- | otherwise = iter sh (\ix -> f (ix, i)) c r `c` iter' (i + 1)+ iter' (ix,i) | i >= sz = r+ | otherwise = f (ix,i) `c` iter' (ix,i+1) + iter1 (_, 0) _ _ = BOUNDS_ERROR(error) "iter1" "empty iteration space"+ iter1 (sh, sz) f c = iter1 sh (\ix -> iter1' (ix,0)) c+ where+ iter1' (ix,i) | i == sz-1 = f (ix,i)+ | otherwise = f (ix,i) `c` iter1' (ix,i+1)+ rangeToShape ((sh1, sz1), (sh2, sz2)) = (rangeToShape (sh1, sh2), sz2 - sz1 + 1) shapeToRange (sh, sz) @@ -107,7 +121,7 @@ ((low, 0), (high, sz - 1)) shapeToList (sh,sz) = sz : shapeToList sh- listToShape [] = error "Data.Array.Accelerate.Array: empty list when converting to Ix"+ listToShape [] = INTERNAL_ERROR(error) "listToShape" "empty list when converting to Ix" listToShape (x:xs) = (listToShape xs,x) @@ -116,32 +130,29 @@ -- |Class of slice representations (which are nested pairs) ---class SliceIx sl where- type Slice sl -- the projected slice- type CoSlice sl -- the complement of the slice- type SliceDim sl -- the combined dimension+class Slice sl where+ type SliceShape sl -- the projected slice+ type CoSliceShape sl -- the complement of the slice+ type FullShape sl -- the combined dimension -- argument *value* not used; it's just a phantom value to fix the type- sliceIndex :: sl -> SliceIndex sl - (Slice sl) - (CoSlice sl) - (SliceDim sl)+ sliceIndex :: {-dummy-} sl -> SliceIndex sl (SliceShape sl) (CoSliceShape sl) (FullShape sl) -instance SliceIx () where- type Slice () = ()- type CoSlice () = ()- type SliceDim () = ()+instance Slice () where+ type SliceShape () = ()+ type CoSliceShape () = ()+ type FullShape () = () sliceIndex _ = SliceNil -instance SliceIx sl => SliceIx (sl, ()) where- type Slice (sl, ()) = (Slice sl, Int)- type CoSlice (sl, ()) = CoSlice sl- type SliceDim (sl, ()) = (SliceDim sl, Int)+instance Slice sl => Slice (sl, ()) where+ type SliceShape (sl, ()) = (SliceShape sl, Int)+ type CoSliceShape (sl, ()) = CoSliceShape sl+ type FullShape (sl, ()) = (FullShape sl, Int) sliceIndex _ = SliceAll (sliceIndex (undefined::sl)) -instance SliceIx sl => SliceIx (sl, Int) where- type Slice (sl, Int) = Slice sl- type CoSlice (sl, Int) = (CoSlice sl, Int)- type SliceDim (sl, Int) = (SliceDim sl, Int)+instance Slice sl => Slice (sl, Int) where+ type SliceShape (sl, Int) = SliceShape sl+ type CoSliceShape (sl, Int) = (CoSliceShape sl, Int)+ type FullShape (sl, Int) = (FullShape sl, Int) sliceIndex _ = SliceFixed (sliceIndex (undefined::sl)) -- |Generalised array index, which may index only in a subset of the dimensions@@ -153,3 +164,9 @@ SliceIndex ix slice co dim -> SliceIndex (ix, ()) (slice, Int) co (dim, Int) SliceFixed :: SliceIndex ix slice co dim -> SliceIndex (ix, Int) slice (co, Int) (dim, Int)++instance Show (SliceIndex ix slice coSlice sliceDim) where+ show SliceNil = "SliceNil"+ show (SliceAll rest) = "SliceAll ("++ show rest ++ ")"+ show (SliceFixed rest) = "SliceFixed (" ++ show rest ++ ")"+
Data/Array/Accelerate/Array/Sugar.hs view
@@ -1,875 +1,867 @@-{-# LANGUAGE GADTs, TypeFamilies, FlexibleContexts, FlexibleInstances #-}-{-# LANGUAGE CPP, ScopedTypeVariables, DeriveDataTypeable #-}-{-# LANGUAGE UndecidableInstances #-} -- for instance SliceIxConv sl---- |Embedded array processing language: user-visible array operations------ Copyright (c) 2009 Manuel M T Chakravarty, Gabriele Keller, Sean Lee------ License: BSD3------- Description --------------------------------------------------------------------module Data.Array.Accelerate.Array.Sugar (-- -- * Array representation- Array(..), Scalar, Vector, Segments,-- -- * Class of element types and of array shapes- Elem(..), ElemRepr, ElemRepr', FromShapeRepr,- - -- * Derived functions- liftToElem, liftToElem2, sinkFromElem, sinkFromElem2,-- -- * Array shapes- DIM0, DIM1, DIM2, DIM3, DIM4, DIM5, DIM6, DIM7, DIM8, DIM9,-- -- * Array indexing and slicing- ShapeBase, Shape, Ix(..), All(..), SliceIx(..), convertSliceIndex,- - -- * Array shape query, indexing, and conversions- shape, (!), newArray, fromIArray, toIArray, fromList, toList,- - -- * Array analysis- arrayType--) where---- standard library-import Data.Array.IArray (IArray)-import qualified Data.Array.IArray as IArray-import Data.Typeable-import Unsafe.Coerce---- friends-import Data.Array.Accelerate.Type-import Data.Array.Accelerate.Array.Data-import qualified Data.Array.Accelerate.Array.Representation as Repr--#ifdef ACCELERATE_CUDA_BACKEND-import qualified Data.Array.Accelerate.CUDA.Array.Data as CUDA-#endif----- |Representation change for array element types--- -------------------------------------------------- |Type representation mapping------ The idea is to use '()' and '(,)' as type-level nil and snoc to construct --- snoc-lists of types.----type family ElemRepr a :: *-type instance ElemRepr () = ()-type instance ElemRepr All = ((), ())-type instance ElemRepr Int = ((), Int)-type instance ElemRepr Int8 = ((), Int8)-type instance ElemRepr Int16 = ((), Int16)-type instance ElemRepr Int32 = ((), Int32)-type instance ElemRepr Int64 = ((), Int64)-type instance ElemRepr Word = ((), Word)-type instance ElemRepr Word8 = ((), Word8)-type instance ElemRepr Word16 = ((), Word16)-type instance ElemRepr Word32 = ((), Word32)-type instance ElemRepr Word64 = ((), Word64)-type instance ElemRepr CShort = ((), CShort)-type instance ElemRepr CUShort = ((), CUShort)-type instance ElemRepr CInt = ((), CInt)-type instance ElemRepr CUInt = ((), CUInt)-type instance ElemRepr CLong = ((), CLong)-type instance ElemRepr CULong = ((), CULong)-type instance ElemRepr CLLong = ((), CLLong)-type instance ElemRepr CULLong = ((), CULLong)-type instance ElemRepr Float = ((), Float)-type instance ElemRepr Double = ((), Double)-type instance ElemRepr CFloat = ((), CFloat)-type instance ElemRepr CDouble = ((), CDouble)-type instance ElemRepr Bool = ((), Bool)-type instance ElemRepr Char = ((), Char)-type instance ElemRepr CChar = ((), CChar)-type instance ElemRepr CSChar = ((), CSChar)-type instance ElemRepr CUChar = ((), CUChar)-type instance ElemRepr (a, b) = (ElemRepr a, ElemRepr' b)-type instance ElemRepr (a, b, c) = (ElemRepr (a, b), ElemRepr' c)-type instance ElemRepr (a, b, c, d) = (ElemRepr (a, b, c), ElemRepr' d)-type instance ElemRepr (a, b, c, d, e) = (ElemRepr (a, b, c, d), ElemRepr' e)-type instance ElemRepr (a, b, c, d, e, f) = (ElemRepr (a, b, c, d, e), ElemRepr' f)-type instance ElemRepr (a, b, c, d, e, f, g) = (ElemRepr (a, b, c, d, e, f), ElemRepr' g)-type instance ElemRepr (a, b, c, d, e, f, g, h) = (ElemRepr (a, b, c, d, e, f, g), ElemRepr' h)-type instance ElemRepr (a, b, c, d, e, f, g, h, i) - = (ElemRepr (a, b, c, d, e, f, g, h), ElemRepr' i)---- To avoid overly nested pairs, we use a flattened representation at the--- leaves.----type family ElemRepr' a :: *-type instance ElemRepr' () = ()-type instance ElemRepr' All = ()-type instance ElemRepr' Int = Int-type instance ElemRepr' Int8 = Int8-type instance ElemRepr' Int16 = Int16-type instance ElemRepr' Int32 = Int32-type instance ElemRepr' Int64 = Int64-type instance ElemRepr' Word = Word-type instance ElemRepr' Word8 = Word8-type instance ElemRepr' Word16 = Word16-type instance ElemRepr' Word32 = Word32-type instance ElemRepr' Word64 = Word64-type instance ElemRepr' CShort = CShort-type instance ElemRepr' CUShort = CUShort-type instance ElemRepr' CInt = CInt-type instance ElemRepr' CUInt = CUInt-type instance ElemRepr' CLong = CLong-type instance ElemRepr' CULong = CULong-type instance ElemRepr' CLLong = CLLong-type instance ElemRepr' CULLong = CULLong-type instance ElemRepr' Float = Float-type instance ElemRepr' Double = Double-type instance ElemRepr' CFloat = CFloat-type instance ElemRepr' CDouble = CDouble-type instance ElemRepr' Bool = Bool-type instance ElemRepr' Char = Char-type instance ElemRepr' CChar = CChar-type instance ElemRepr' CSChar = CSChar-type instance ElemRepr' CUChar = CUChar-type instance ElemRepr' (a, b) = (ElemRepr a, ElemRepr' b)-type instance ElemRepr' (a, b, c) = (ElemRepr (a, b), ElemRepr' c)-type instance ElemRepr' (a, b, c, d) = (ElemRepr (a, b, c), ElemRepr' d)-type instance ElemRepr' (a, b, c, d, e) = (ElemRepr (a, b, c, d), ElemRepr' e)-type instance ElemRepr' (a, b, c, d, e, f) = (ElemRepr (a, b, c, d, e), ElemRepr' f)-type instance ElemRepr' (a, b, c, d, e, f, g) = (ElemRepr (a, b, c, d, e, f), ElemRepr' g)-type instance ElemRepr' (a, b, c, d, e, f, g, h) = (ElemRepr (a, b, c, d, e, f, g), ElemRepr' h)-type instance ElemRepr' (a, b, c, d, e, f, g, h, i) - = (ElemRepr (a, b, c, d, e, f, g, h), ElemRepr' i)----- Array elements (tuples of scalars)--- -------------------------------------- |Identifier for entire dimensions in slice descriptors----data All = All deriving (Typeable, Show)---- |Class that characterises the types of values that can be array elements.----class (Show a, Typeable a, -#ifdef ACCELERATE_CUDA_BACKEND- CUDA.ArrayElem (ElemRepr a), CUDA.ArrayElem (ElemRepr' a),-#endif- Typeable (ElemRepr a), Typeable (ElemRepr' a),- ArrayElem (ElemRepr a), ArrayElem (ElemRepr' a))- => Elem a where- elemType :: {-dummy-} a -> TupleType (ElemRepr a)- fromElem :: a -> ElemRepr a- toElem :: ElemRepr a -> a-- elemType' :: {-dummy-} a -> TupleType (ElemRepr' a)- fromElem' :: a -> ElemRepr' a- toElem' :: ElemRepr' a -> a--instance Elem () where- elemType _ = UnitTuple- fromElem = id- toElem = id-- elemType' _ = UnitTuple- fromElem' = id- toElem' = id--instance Elem All where- elemType _ = PairTuple UnitTuple UnitTuple- fromElem All = ((), ())- toElem ((), ()) = All-- elemType' _ = UnitTuple- fromElem' All = ()- toElem' () = All--instance Elem Int where- elemType = singletonScalarType- fromElem v = ((), v)- toElem ((), v) = v-- elemType' _ = SingleTuple scalarType- fromElem' = id- toElem' = id--instance Elem Int8 where- elemType = singletonScalarType- fromElem v = ((), v)- toElem ((), v) = v-- elemType' _ = SingleTuple scalarType- fromElem' = id- toElem' = id--instance Elem Int16 where- elemType = singletonScalarType- fromElem v = ((), v)- toElem ((), v) = v-- elemType' _ = SingleTuple scalarType- fromElem' = id- toElem' = id--instance Elem Int32 where- elemType = singletonScalarType- fromElem v = ((), v)- toElem ((), v) = v-- elemType' _ = SingleTuple scalarType- fromElem' = id- toElem' = id--instance Elem Int64 where- elemType = singletonScalarType- fromElem v = ((), v)- toElem ((), v) = v-- elemType' _ = SingleTuple scalarType- fromElem' = id- toElem' = id--instance Elem Word where- elemType = singletonScalarType- fromElem v = ((), v)- toElem ((), v) = v-- elemType' _ = SingleTuple scalarType- fromElem' = id- toElem' = id--instance Elem Word8 where- elemType = singletonScalarType- fromElem v = ((), v)- toElem ((), v) = v-- elemType' _ = SingleTuple scalarType- fromElem' = id- toElem' = id--instance Elem Word16 where- elemType = singletonScalarType- fromElem v = ((), v)- toElem ((), v) = v-- elemType' _ = SingleTuple scalarType- fromElem' = id- toElem' = id--instance Elem Word32 where- elemType = singletonScalarType- fromElem v = ((), v)- toElem ((), v) = v-- elemType' _ = SingleTuple scalarType- fromElem' = id- toElem' = id--instance Elem Word64 where- elemType = singletonScalarType- fromElem v = ((), v)- toElem ((), v) = v-- elemType' _ = SingleTuple scalarType- fromElem' = id- toElem' = id--{--instance Elem CShort where- --elemType = singletonScalarType- fromElem v = ((), v)- toElem ((), v) = v-- --elemType' _ = SingleTuple scalarType- fromElem' = id- toElem' = id--instance Elem CUShort where- --elemType = singletonScalarType- fromElem v = ((), v)- toElem ((), v) = v-- --elemType' _ = SingleTuple scalarType- fromElem' = id- toElem' = id--instance Elem CInt where- --elemType = singletonScalarType- fromElem v = ((), v)- toElem ((), v) = v-- --elemType' _ = SingleTuple scalarType- fromElem' = id- toElem' = id--instance Elem CUInt where- --elemType = singletonScalarType- fromElem v = ((), v)- toElem ((), v) = v-- --elemType' _ = SingleTuple scalarType- fromElem' = id- toElem' = id--instance Elem CLong where- --elemType = singletonScalarType- fromElem v = ((), v)- toElem ((), v) = v-- --elemType' _ = SingleTuple scalarType- fromElem' = id- toElem' = id--instance Elem CULong where- --elemType = singletonScalarType- fromElem v = ((), v)- toElem ((), v) = v-- --elemType' _ = SingleTuple scalarType- fromElem' = id- toElem' = id--instance Elem CLLong where- --elemType = singletonScalarType- fromElem v = ((), v)- toElem ((), v) = v-- --elemType' _ = SingleTuple scalarType- fromElem' = id- toElem' = id--instance Elem CULLong where- --elemType = singletonScalarType- fromElem v = ((), v)- toElem ((), v) = v-- --elemType' _ = SingleTuple scalarType- fromElem' = id- toElem' = id--}--instance Elem Float where- elemType = singletonScalarType- fromElem v = ((), v)- toElem ((), v) = v-- elemType' _ = SingleTuple scalarType- fromElem' = id- toElem' = id--instance Elem Double where- elemType = singletonScalarType- fromElem v = ((), v)- toElem ((), v) = v-- elemType' _ = SingleTuple scalarType- fromElem' = id- toElem' = id--{--instance Elem CFloat where- --elemType = singletonScalarType- fromElem v = ((), v)- toElem ((), v) = v-- --elemType' _ = SingleTuple scalarType- fromElem' = id- toElem' = id--instance Elem CDouble where- --elemType = singletonScalarType- fromElem v = ((), v)- toElem ((), v) = v-- --elemType' _ = SingleTuple scalarType- fromElem' = id- toElem' = id--}--instance Elem Bool where- elemType = singletonScalarType- fromElem v = ((), v)- toElem ((), v) = v-- elemType' _ = SingleTuple scalarType- fromElem' = id- toElem' = id--instance Elem Char where- elemType = singletonScalarType- fromElem v = ((), v)- toElem ((), v) = v-- elemType' _ = SingleTuple scalarType- fromElem' = id- toElem' = id--{--instance Elem CChar where- --elemType = singletonScalarType- fromElem v = ((), v)- toElem ((), v) = v-- --elemType' _ = SingleTuple scalarType- fromElem' = id- toElem' = id--instance Elem CSChar where- --elemType = singletonScalarType- fromElem v = ((), v)- toElem ((), v) = v-- --elemType' _ = SingleTuple scalarType- fromElem' = id- toElem' = id--instance Elem CUChar where- --elemType = singletonScalarType- fromElem v = ((), v)- toElem ((), v) = v-- --elemType' _ = SingleTuple scalarType- fromElem' = id- toElem' = id--}--instance (Elem a, Elem b) => Elem (a, b) where- elemType (_::(a, b)) - = PairTuple (elemType (undefined :: a)) (elemType' (undefined :: b))- fromElem (a, b) = (fromElem a, fromElem' b)- toElem (a, b) = (toElem a, toElem' b)-- elemType' (_::(a, b)) - = PairTuple (elemType (undefined :: a)) (elemType' (undefined :: b))- fromElem' (a, b) = (fromElem a, fromElem' b)- toElem' (a, b) = (toElem a, toElem' b)--instance (Elem a, Elem b, Elem c) => Elem (a, b, c) where- elemType (_::(a, b, c)) - = PairTuple (elemType (undefined :: (a, b))) (elemType' (undefined :: c))- fromElem (a, b, c) = (fromElem (a, b), fromElem' c)- toElem (ab, c) = let (a, b) = toElem ab in (a, b, toElem' c)- - elemType' (_::(a, b, c)) - = PairTuple (elemType (undefined :: (a, b))) (elemType' (undefined :: c))- fromElem' (a, b, c) = (fromElem (a, b), fromElem' c)- toElem' (ab, c) = let (a, b) = toElem ab in (a, b, toElem' c)- -instance (Elem a, Elem b, Elem c, Elem d) => Elem (a, b, c, d) where- elemType (_::(a, b, c, d)) - = PairTuple (elemType (undefined :: (a, b, c))) (elemType' (undefined :: d))- fromElem (a, b, c, d) = (fromElem (a, b, c), fromElem' d)- toElem (abc, d) = let (a, b, c) = toElem abc in (a, b, c, toElem' d)-- elemType' (_::(a, b, c, d)) - = PairTuple (elemType (undefined :: (a, b, c))) (elemType' (undefined :: d))- fromElem' (a, b, c, d) = (fromElem (a, b, c), fromElem' d)- toElem' (abc, d) = let (a, b, c) = toElem abc in (a, b, c, toElem' d)--instance (Elem a, Elem b, Elem c, Elem d, Elem e) => Elem (a, b, c, d, e) where- elemType (_::(a, b, c, d, e)) - = PairTuple (elemType (undefined :: (a, b, c, d))) - (elemType' (undefined :: e))- fromElem (a, b, c, d, e) = (fromElem (a, b, c, d), fromElem' e)- toElem (abcd, e) = let (a, b, c, d) = toElem abcd in (a, b, c, d, toElem' e)-- elemType' (_::(a, b, c, d, e)) - = PairTuple (elemType (undefined :: (a, b, c, d))) - (elemType' (undefined :: e))- fromElem' (a, b, c, d, e) = (fromElem (a, b, c, d), fromElem' e)- toElem' (abcd, e) = let (a, b, c, d) = toElem abcd in (a, b, c, d, toElem' e)--instance (Elem a, Elem b, Elem c, Elem d, Elem e, Elem f) => Elem (a, b, c, d, e, f) where- elemType (_::(a, b, c, d, e, f)) - = PairTuple (elemType (undefined :: (a, b, c, d, e))) - (elemType' (undefined :: f))- fromElem (a, b, c, d, e, f) = (fromElem (a, b, c, d, e), fromElem' f)- toElem (abcde, f) = let (a, b, c, d, e) = toElem abcde in (a, b, c, d, e, toElem' f)-- elemType' (_::(a, b, c, d, e, f)) - = PairTuple (elemType (undefined :: (a, b, c, d, e))) - (elemType' (undefined :: f))- fromElem' (a, b, c, d, e, f) = (fromElem (a, b, c, d, e), fromElem' f)- toElem' (abcde, f) = let (a, b, c, d, e) = toElem abcde in (a, b, c, d, e, toElem' f)--instance (Elem a, Elem b, Elem c, Elem d, Elem e, Elem f, Elem g) - => Elem (a, b, c, d, e, f, g) where- elemType (_::(a, b, c, d, e, f, g)) - = PairTuple (elemType (undefined :: (a, b, c, d, e, f))) - (elemType' (undefined :: g))- fromElem (a, b, c, d, e, f, g) = (fromElem (a, b, c, d, e, f), fromElem' g)- toElem (abcdef, g) = let (a, b, c, d, e, f) = toElem abcdef in (a, b, c, d, e, f, toElem' g)-- elemType' (_::(a, b, c, d, e, f, g)) - = PairTuple (elemType (undefined :: (a, b, c, d, e, f))) - (elemType' (undefined :: g))- fromElem' (a, b, c, d, e, f, g) = (fromElem (a, b, c, d, e, f), fromElem' g)- toElem' (abcdef, g) = let (a, b, c, d, e, f) = toElem abcdef in (a, b, c, d, e, f, toElem' g)--instance (Elem a, Elem b, Elem c, Elem d, Elem e, Elem f, Elem g, Elem h) - => Elem (a, b, c, d, e, f, g, h) where- elemType (_::(a, b, c, d, e, f, g, h)) - = PairTuple (elemType (undefined :: (a, b, c, d, e, f, g))) - (elemType' (undefined :: h))- fromElem (a, b, c, d, e, f, g, h) = (fromElem (a, b, c, d, e, f, g), fromElem' h)- toElem (abcdefg, h) = let (a, b, c, d, e, f, g) = toElem abcdefg - in (a, b, c, d, e, f, g, toElem' h)-- elemType' (_::(a, b, c, d, e, f, g, h)) - = PairTuple (elemType (undefined :: (a, b, c, d, e, f, g))) - (elemType' (undefined :: h))- fromElem' (a, b, c, d, e, f, g, h) = (fromElem (a, b, c, d, e, f, g), fromElem' h)- toElem' (abcdefg, h) = let (a, b, c, d, e, f, g) = toElem abcdefg - in (a, b, c, d, e, f, g, toElem' h)--instance (Elem a, Elem b, Elem c, Elem d, Elem e, Elem f, Elem g, Elem h, Elem i) - => Elem (a, b, c, d, e, f, g, h, i) where- elemType (_::(a, b, c, d, e, f, g, h, i)) - = PairTuple (elemType (undefined :: (a, b, c, d, e, f, g, h))) - (elemType' (undefined :: i))- fromElem (a, b, c, d, e, f, g, h, i) = (fromElem (a, b, c, d, e, f, g, h), fromElem' i)- toElem (abcdefgh, i) = let (a, b, c, d, e, f, g, h) = toElem abcdefgh- in (a, b, c, d, e, f, g, h, toElem' i)-- elemType' (_::(a, b, c, d, e, f, g, h, i)) - = PairTuple (elemType (undefined :: (a, b, c, d, e, f, g, h))) - (elemType' (undefined :: i))- fromElem' (a, b, c, d, e, f, g, h, i) = (fromElem (a, b, c, d, e, f, g, h), fromElem' i)- toElem' (abcdefgh, i) = let (a, b, c, d, e, f, g, h) = toElem abcdefgh- in (a, b, c, d, e, f, g, h, toElem' i)---- |Convenience functions-----singletonScalarType :: IsScalar a => a -> TupleType ((), a)-singletonScalarType _ = PairTuple UnitTuple (SingleTuple scalarType)--liftToElem :: (Elem a, Elem b) - => (ElemRepr a -> ElemRepr b)- -> (a -> b)-{-# INLINE liftToElem #-}-liftToElem f = toElem . f . fromElem--liftToElem2 :: (Elem a, Elem b, Elem c) - => (ElemRepr a -> ElemRepr b -> ElemRepr c)- -> (a -> b -> c)-{-# INLINE liftToElem2 #-}-liftToElem2 f = \x y -> toElem $ f (fromElem x) (fromElem y)--sinkFromElem :: (Elem a, Elem b) - => (a -> b)- -> (ElemRepr a -> ElemRepr b)-{-# INLINE sinkFromElem #-}-sinkFromElem f = fromElem . f . toElem--sinkFromElem2 :: (Elem a, Elem b, Elem c) - => (a -> b -> c)- -> (ElemRepr a -> ElemRepr b -> ElemRepr c)-{-# INLINE sinkFromElem2 #-}-sinkFromElem2 f = \x y -> fromElem $ f (toElem x) (toElem y)--{-# RULES--"fromElem/toElem" forall e.- fromElem (toElem e) = e---- FIXME: Won't type like that (it's ambiguous due to the ElemRepr family): --- "toElem/fromElem" forall e.--- toElem (fromElem e) = e- - #-}----- Surface arrays--- ------------------ |Multi-dimensional arrays for array processing------ * If device and host memory are separate, arrays will be transferred to the--- device when necessary (if possible asynchronously and in parallel with--- other tasks) and cached on the device if sufficient memory is available.----data Array dim e where- Array :: (Ix dim, Elem e) - => ElemRepr dim -- extent of dimensions = shape- -> ArrayData (ElemRepr e) -- data, same layout as in- -> Array dim e---- |Scalars----type Scalar e = Array DIM0 e---- |Vectors----type Vector e = Array DIM1 e---- |Segment descriptor----type Segments = Vector Int---- Shorthand for common shape types----type DIM0 = ()-type DIM1 = (Int)-type DIM2 = (Int, Int)-type DIM3 = (Int, Int, Int)-type DIM4 = (Int, Int, Int, Int)-type DIM5 = (Int, Int, Int, Int, Int)-type DIM6 = (Int, Int, Int, Int, Int, Int)-type DIM7 = (Int, Int, Int, Int, Int, Int, Int)-type DIM8 = (Int, Int, Int, Int, Int, Int, Int, Int)-type DIM9 = (Int, Int, Int, Int, Int, Int, Int, Int, Int)---- Shape constraints and indexing--- ---- Shape elements----class Elem shb => ShapeBase shb-instance ShapeBase Int-instance ShapeBase All--class Elem sh => Shape sh--instance Shape ()-instance Shape Int-instance Shape All-instance (ShapeBase a, ShapeBase b) => Shape (a, b)-instance (ShapeBase a, ShapeBase b, ShapeBase c) => Shape (a, b, c)-instance (ShapeBase a, ShapeBase b, ShapeBase c, ShapeBase d) - => Shape (a, b, c, d)-instance (ShapeBase a, ShapeBase b, ShapeBase c, ShapeBase d, ShapeBase e) - => Shape (a, b, c, d, e)-instance (ShapeBase a, ShapeBase b, ShapeBase c, ShapeBase d, ShapeBase e, ShapeBase f) - => Shape (a, b, c, d, e, f)-instance (ShapeBase a, ShapeBase b, ShapeBase c, ShapeBase d, ShapeBase e, ShapeBase f, - ShapeBase g) - => Shape (a, b, c, d, e, f, g)-instance (ShapeBase a, ShapeBase b, ShapeBase c, ShapeBase d, ShapeBase e, ShapeBase f, - ShapeBase g, ShapeBase h) - => Shape (a, b, c, d, e, f, g, h)-instance (ShapeBase a, ShapeBase b, ShapeBase c, ShapeBase d, ShapeBase e, ShapeBase f, - ShapeBase g, ShapeBase h, ShapeBase i) - => Shape (a, b, c, d, e, f, g, h, i)--type family FromShapeBase shb :: *-type instance FromShapeBase Int = Int-type instance FromShapeBase () = All--type family FromShapeRepr shr :: *-type instance FromShapeRepr () = ()-type instance FromShapeRepr ((), a) = FromShapeBase a-type instance FromShapeRepr (((), a), b) = (FromShapeBase a, FromShapeBase b)-type instance FromShapeRepr ((((), a), b), c) - = (FromShapeBase a, FromShapeBase b, FromShapeBase c)-type instance FromShapeRepr (((((), a), b), c), d) - = (FromShapeBase a, FromShapeBase b, FromShapeBase c, FromShapeBase d)-type instance FromShapeRepr ((((((), a), b), c), d), e) - = (FromShapeBase a, FromShapeBase b, FromShapeBase c, FromShapeBase d, - FromShapeBase e)-type instance FromShapeRepr (((((((), a), b), c), d), e), f) - = (FromShapeBase a, FromShapeBase b, FromShapeBase c, FromShapeBase d, - FromShapeBase e, FromShapeBase f)-type instance FromShapeRepr ((((((((), a), b), c), d), e), f), g) - = (FromShapeBase a, FromShapeBase b, FromShapeBase c, FromShapeBase d, - FromShapeBase e, FromShapeBase f, FromShapeBase g)-type instance FromShapeRepr (((((((((), a), b), c), d), e), f), g), h) - = (FromShapeBase a, FromShapeBase b, FromShapeBase c, FromShapeBase d, - FromShapeBase e, FromShapeBase f, FromShapeBase g, FromShapeBase h)-type instance FromShapeRepr ((((((((((), a), b), c), d), e), f), g), h), i) - = (FromShapeBase a, FromShapeBase b, FromShapeBase c, FromShapeBase d, - FromShapeBase e, FromShapeBase f, FromShapeBase g, FromShapeBase h,- FromShapeBase i)---- |Shapes and indices of multi-dimensional arrays----class (Shape ix, Repr.Ix (ElemRepr ix)) => Ix ix where-- -- |Number of dimensions of a /shape/ or /index/ (>= 0)- dim :: ix -> Int-- -- Total number of elements in an array of the given /shape/- size :: ix -> Int-- -- |Magic value identifying elements ignored in 'permute'- ignore :: ix- - -- |Map a multi-dimensional index into one in a linear, row-major - -- representation of the array (first argument is the /shape/, second - -- argument is the index)- index :: ix -> ix -> Int-- -- |Apply a boundary condition to an index- bound :: ix -> ix -> Boundary a -> Either a ix-- -- |Iterate through the entire shape, applying the function; third argument- -- combines results and fourth is returned in case of an empty iteration- -- space; the index space is traversed in row-major order- iter :: ix -> (ix -> a) -> (a -> a -> a) -> a -> a-- -- |Convert a minpoint-maxpoint index into a /shape/- rangeToShape :: (ix, ix) -> ix- - -- |Convert a /shape/ into a minpoint-maxpoint index- shapeToRange :: ix -> (ix, ix)-- -- |Convert a shape to a list of dimensions- shapeToList :: ix -> [Int]-- -- |Convert a list of dimensions into a shape- listToShape :: [Int] -> ix-- dim = Repr.dim . fromElem- size = Repr.size . fromElem- ignore = toElem Repr.ignore- index sh ix = Repr.index (fromElem sh) (fromElem ix)- bound sh ix bndy = case Repr.bound (fromElem sh) (fromElem ix) bndy of- Left v -> Left v- Right ix' -> Right $ toElem ix'-- iter sh f c r = Repr.iter (fromElem sh) (f . toElem) c r-- rangeToShape (low, high) - = toElem (Repr.rangeToShape (fromElem low, fromElem high))- shapeToRange ix- = let (low, high) = Repr.shapeToRange (fromElem ix)- in- (toElem low, toElem high)-- shapeToList = Repr.shapeToList . fromElem- listToShape = toElem . Repr.listToShape--instance Ix ()-instance Ix (Int)-instance Ix (Int, Int)-instance Ix (Int, Int, Int)-instance Ix (Int, Int, Int, Int)-instance Ix (Int, Int, Int, Int, Int)-instance Ix (Int, Int, Int, Int, Int, Int)-instance Ix (Int, Int, Int, Int, Int, Int, Int)-instance Ix (Int, Int, Int, Int, Int, Int, Int, Int)-instance Ix (Int, Int, Int, Int, Int, Int, Int, Int, Int)----- |Slices -aka generalised indices- as n-tuples and mappings of slice--- indicies to slices, co-slices, and slice dimensions----class (Shape sl, - Repr.SliceIx (ElemRepr sl), - Ix (Slice sl), Ix (CoSlice sl), Ix (SliceDim sl), - SliceIxConv sl) - => SliceIx sl where- type Slice sl :: *- type CoSlice sl :: *- type SliceDim sl :: *- sliceIndex :: sl -> Repr.SliceIndex (ElemRepr sl)- (Repr.Slice (ElemRepr sl))- (Repr.CoSlice (ElemRepr sl))- (Repr.SliceDim (ElemRepr sl))--instance (Shape sl, - Repr.SliceIx (ElemRepr sl), - Ix (Slice sl), Ix (CoSlice sl), Ix (SliceDim sl), - SliceIxConv sl)- => SliceIx sl where- type Slice sl = FromShapeRepr (Repr.Slice (ElemRepr sl))- type CoSlice sl = FromShapeRepr (Repr.CoSlice (ElemRepr sl))- type SliceDim sl = FromShapeRepr (Repr.SliceDim (ElemRepr sl))- sliceIndex = Repr.sliceIndex . fromElem--class SliceIxConv slix where- convertSliceIndex :: slix {- dummy to fix the type variable -}- -> Repr.SliceIndex (ElemRepr slix)- (Repr.Slice (ElemRepr slix))- (Repr.CoSlice (ElemRepr slix))- (Repr.SliceDim (ElemRepr slix))- -> Repr.SliceIndex (ElemRepr slix)- (ElemRepr (Slice slix))- (ElemRepr (CoSlice slix))- (ElemRepr (SliceDim slix))--instance SliceIxConv slix where- convertSliceIndex _ = unsafeCoerce- -- FIXME: the coercion is safe given the definition of the involved- -- families, but we really ought to code a proof for that instead----- Array operations--- -------------------- |Yield an array's shape----shape :: Ix dim => Array dim e -> dim-shape (Array sh _) = toElem sh---- |Array indexing----infixl 9 !-(!) :: Array dim e -> dim -> e-{-# INLINE (!) #-}--- (Array sh adata) ! ix = toElem (adata `indexArrayData` index sh ix)--- FIXME: using this due to a bug in 6.10.x-(!) (Array sh adata) ix = toElem (adata `indexArrayData` index (toElem sh) ix)---- |Create an array from its representation function----newArray :: (Ix dim, Elem e) => dim -> (dim -> e) -> Array dim e-{-# INLINE newArray #-}-newArray sh f - = adata `seq` Array (fromElem sh) adata- where - (adata, _) = runArrayData $ do- arr <- newArrayData (1024 `max` size sh)- let write ix = writeArrayData arr (index sh ix) - (fromElem (f ix))- iter sh write (>>) (return ())- return (arr, undefined)---- |Convert an 'IArray' to an accelerated array.----fromIArray :: (IArray a e, IArray.Ix dim, Ix dim, Elem e) - => a dim e -> Array dim e-fromIArray iarr = newArray sh (iarr IArray.!)- where- sh = rangeToShape (IArray.bounds iarr)---- |Convert an accelerated array to an 'IArray'--- -toIArray :: (IArray a e, IArray.Ix dim, Ix dim, Elem e) - => Array dim e -> a dim e-toIArray arr@(Array sh _) - = let bnds = shapeToRange (toElem sh)- in- IArray.array bnds [(ix, arr!ix) | ix <- IArray.range bnds]- --- |Convert a list (with elements in row-major order) to an accelerated array.----fromList :: (Ix dim, Elem e) => dim -> [e] -> Array dim e-fromList sh l = newArray sh indexIntoList - where- indexIntoList ix = l!!index sh ix---- |Convert an accelerated array to a list in row-major order.----toList :: forall dim e. Array dim e -> [e]-toList (Array sh adata) = iter sh' idx (.) id []- where- sh' = toElem sh :: dim- idx ix = \l -> toElem (adata `indexArrayData` index sh' ix) : l---- Convert an array to a string----instance Show (Array dim e) where- show arr@(Array sh _adata) - = "Array " ++ show (toElem sh :: dim) ++ " " ++ show (toList arr)----- Array analysis--- ------------------ |Reify the element type of an array.----arrayType :: forall dim e. Array dim e -> TupleType (ElemRepr e)-arrayType (Array _ _) = elemType (undefined::e)+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeOperators, GADTs, TypeFamilies, FlexibleContexts, FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, StandaloneDeriving, TupleSections #-}+-- |+-- Module : Data.Array.Accelerate.Array.Sugar+-- 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.Array.Sugar (++ -- * Array representation+ Array(..), Scalar, Vector, Segments,++ -- * Class of supported surface element types and their mapping to representation types+ Elt(..), EltRepr, EltRepr',+ + -- * Derived functions+ liftToElt, liftToElt2, sinkFromElt, sinkFromElt2,++ -- * Array shapes+ DIM0, DIM1, DIM2, DIM3, DIM4, DIM5, DIM6, DIM7, DIM8, DIM9,++ -- * Array indexing and slicing+ Z(..), (:.)(..), All(..), Any(..), Shape(..), Slice(..),+ + -- * Array shape query, indexing, and conversions+ shape, (!), newArray, allocateArray, fromIArray, toIArray, fromList, toList,++) where++-- standard library+import Data.Array.IArray (IArray)+import qualified Data.Array.IArray as IArray+import Data.Typeable++-- friends+import Data.Array.Accelerate.Type+import Data.Array.Accelerate.Array.Data+import qualified Data.Array.Accelerate.Array.Representation as Repr+++-- |Surface types representing array indices and slices+-- ----------------------------------------------------++-- |Array indices are snoc type lists+--+-- For example, the type of a rank-2 array index is 'Z :.Int :. Int'.++-- |Rank-0 index+--+data Z = Z+ deriving (Typeable, Show)++-- |Increase an index rank by one dimension+--+infixl 3 :.+data tail :. head = tail :. head+ deriving (Typeable, Show)++-- |Marker for entire dimensions in slice descriptors+--+data All = All + deriving (Typeable, Show)++-- |Marker for arbitrary shapes in slice descriptors+--+data Any sh = Any+ deriving (Typeable, Show)++-- |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.+--+type family EltRepr a :: *+type instance EltRepr () = ()+type instance EltRepr Z = ()+type instance EltRepr (t:.h) = (EltRepr t, EltRepr' h)+type instance EltRepr All = ((), ())+type instance EltRepr (Any Z) = ()+type instance EltRepr (Any (sh:.Int)) = (EltRepr (Any sh), ())+type instance EltRepr Int = ((), Int)+type instance EltRepr Int8 = ((), Int8)+type instance EltRepr Int16 = ((), Int16)+type instance EltRepr Int32 = ((), Int32)+type instance EltRepr Int64 = ((), Int64)+type instance EltRepr Word = ((), Word)+type instance EltRepr Word8 = ((), Word8)+type instance EltRepr Word16 = ((), Word16)+type instance EltRepr Word32 = ((), Word32)+type instance EltRepr Word64 = ((), Word64)+type instance EltRepr CShort = ((), CShort)+type instance EltRepr CUShort = ((), CUShort)+type instance EltRepr CInt = ((), CInt)+type instance EltRepr CUInt = ((), CUInt)+type instance EltRepr CLong = ((), CLong)+type instance EltRepr CULong = ((), CULong)+type instance EltRepr CLLong = ((), CLLong)+type instance EltRepr CULLong = ((), CULLong)+type instance EltRepr Float = ((), Float)+type instance EltRepr Double = ((), Double)+type instance EltRepr CFloat = ((), CFloat)+type instance EltRepr CDouble = ((), CDouble)+type instance EltRepr Bool = ((), Bool)+type instance EltRepr Char = ((), Char)+type instance EltRepr CChar = ((), CChar)+type instance EltRepr CSChar = ((), CSChar)+type instance EltRepr CUChar = ((), CUChar)+type instance EltRepr (a, b) = (EltRepr a, EltRepr' b)+type instance EltRepr (a, b, c) = (EltRepr (a, b), EltRepr' c)+type instance EltRepr (a, b, c, d) = (EltRepr (a, b, c), EltRepr' d)+type instance EltRepr (a, b, c, d, e) = (EltRepr (a, b, c, d), EltRepr' e)+type instance EltRepr (a, b, c, d, e, f) = (EltRepr (a, b, c, d, e), EltRepr' f)+type instance EltRepr (a, b, c, d, e, f, g) = (EltRepr (a, b, c, d, e, f), EltRepr' g)+type instance EltRepr (a, b, c, d, e, f, g, h) = (EltRepr (a, b, c, d, e, f, g), EltRepr' h)+type instance EltRepr (a, b, c, d, e, f, g, h, i) + = (EltRepr (a, b, c, d, e, f, g, h), EltRepr' i)++-- To avoid overly nested pairs, we use a flattened representation at the+-- leaves.+--+type family EltRepr' a :: *+type instance EltRepr' () = ()+type instance EltRepr' Z = ()+type instance EltRepr' (t:.h) = (EltRepr t, EltRepr' h)+type instance EltRepr' All = ()+type instance EltRepr' (Any Z) = ()+type instance EltRepr' (Any (sh:.Int)) = (EltRepr' (Any sh), ())+type instance EltRepr' Int = Int+type instance EltRepr' Int8 = Int8+type instance EltRepr' Int16 = Int16+type instance EltRepr' Int32 = Int32+type instance EltRepr' Int64 = Int64+type instance EltRepr' Word = Word+type instance EltRepr' Word8 = Word8+type instance EltRepr' Word16 = Word16+type instance EltRepr' Word32 = Word32+type instance EltRepr' Word64 = Word64+type instance EltRepr' CShort = CShort+type instance EltRepr' CUShort = CUShort+type instance EltRepr' CInt = CInt+type instance EltRepr' CUInt = CUInt+type instance EltRepr' CLong = CLong+type instance EltRepr' CULong = CULong+type instance EltRepr' CLLong = CLLong+type instance EltRepr' CULLong = CULLong+type instance EltRepr' Float = Float+type instance EltRepr' Double = Double+type instance EltRepr' CFloat = CFloat+type instance EltRepr' CDouble = CDouble+type instance EltRepr' Bool = Bool+type instance EltRepr' Char = Char+type instance EltRepr' CChar = CChar+type instance EltRepr' CSChar = CSChar+type instance EltRepr' CUChar = CUChar+type instance EltRepr' (a, b) = (EltRepr a, EltRepr' b)+type instance EltRepr' (a, b, c) = (EltRepr (a, b), EltRepr' c)+type instance EltRepr' (a, b, c, d) = (EltRepr (a, b, c), EltRepr' d)+type instance EltRepr' (a, b, c, d, e) = (EltRepr (a, b, c, d), EltRepr' e)+type instance EltRepr' (a, b, c, d, e, f) = (EltRepr (a, b, c, d, e), EltRepr' f)+type instance EltRepr' (a, b, c, d, e, f, g) = (EltRepr (a, b, c, d, e, f), EltRepr' g)+type instance EltRepr' (a, b, c, d, e, f, g, h) = (EltRepr (a, b, c, d, e, f, g), EltRepr' h)+type instance EltRepr' (a, b, c, d, e, f, g, h, i) + = (EltRepr (a, b, c, d, e, f, g, h), EltRepr' i)+++-- Array elements (tuples of scalars)+-- ----------------------------------++-- |Class that characterises the types of values that can be array elements, and hence, appear in+-- scalar Accelerate expressions.+--+class (Show a, Typeable a, + Typeable (EltRepr a), Typeable (EltRepr' a),+ ArrayElt (EltRepr a), ArrayElt (EltRepr' a))+ => Elt a where+ eltType :: {-dummy-} a -> TupleType (EltRepr a)+ fromElt :: a -> EltRepr a+ toElt :: EltRepr a -> a++ eltType' :: {-dummy-} a -> TupleType (EltRepr' a)+ fromElt' :: a -> EltRepr' a+ toElt' :: EltRepr' a -> a+ +instance Elt () where+ eltType _ = UnitTuple+ fromElt = id+ toElt = id++ eltType' _ = UnitTuple+ fromElt' = id+ toElt' = id++instance Elt Z where+ eltType _ = UnitTuple+ fromElt Z = ()+ toElt () = Z++ eltType' _ = UnitTuple+ fromElt' Z = ()+ toElt' () = Z++instance (Elt t, Elt h) => Elt (t:.h) where+ eltType (_::(t:.h)) = PairTuple (eltType (undefined :: t)) (eltType' (undefined :: h))+ fromElt (t:.h) = (fromElt t, fromElt' h)+ toElt (t, h) = toElt t :. toElt' h++ eltType' (_::(t:.h)) = PairTuple (eltType (undefined :: t)) (eltType' (undefined :: h))+ fromElt' (t:.h) = (fromElt t, fromElt' h)+ toElt' (t, h) = toElt t :. toElt' h++instance Elt All where+ eltType _ = PairTuple UnitTuple UnitTuple+ fromElt All = ((), ())+ toElt ((), ()) = All++ eltType' _ = UnitTuple+ fromElt' All = ()+ toElt' () = All++instance Elt (Any Z) where+ eltType _ = UnitTuple+ fromElt _ = ()+ toElt _ = Any+ + eltType' _ = UnitTuple+ fromElt' _ = ()+ toElt' _ = Any++instance Shape sh => Elt (Any (sh:.Int)) where+ eltType _ = PairTuple (eltType (undefined::Any sh)) UnitTuple+ fromElt _ = (fromElt (undefined :: Any sh), ())+ toElt _ = Any++ eltType' _ = PairTuple (eltType' (undefined::Any sh)) UnitTuple+ fromElt' _ = (fromElt' (undefined :: Any sh), ())+ toElt' _ = Any++instance Elt Int where+ eltType = singletonScalarType+ fromElt v = ((), v)+ toElt ((), v) = v++ eltType' _ = SingleTuple scalarType+ fromElt' = id+ toElt' = id++instance Elt Int8 where+ eltType = singletonScalarType+ fromElt v = ((), v)+ toElt ((), v) = v++ eltType' _ = SingleTuple scalarType+ fromElt' = id+ toElt' = id++instance Elt Int16 where+ eltType = singletonScalarType+ fromElt v = ((), v)+ toElt ((), v) = v++ eltType' _ = SingleTuple scalarType+ fromElt' = id+ toElt' = id++instance Elt Int32 where+ eltType = singletonScalarType+ fromElt v = ((), v)+ toElt ((), v) = v++ eltType' _ = SingleTuple scalarType+ fromElt' = id+ toElt' = id++instance Elt Int64 where+ eltType = singletonScalarType+ fromElt v = ((), v)+ toElt ((), v) = v++ eltType' _ = SingleTuple scalarType+ fromElt' = id+ toElt' = id++instance Elt Word where+ eltType = singletonScalarType+ fromElt v = ((), v)+ toElt ((), v) = v++ eltType' _ = SingleTuple scalarType+ fromElt' = id+ toElt' = id++instance Elt Word8 where+ eltType = singletonScalarType+ fromElt v = ((), v)+ toElt ((), v) = v++ eltType' _ = SingleTuple scalarType+ fromElt' = id+ toElt' = id++instance Elt Word16 where+ eltType = singletonScalarType+ fromElt v = ((), v)+ toElt ((), v) = v++ eltType' _ = SingleTuple scalarType+ fromElt' = id+ toElt' = id++instance Elt Word32 where+ eltType = singletonScalarType+ fromElt v = ((), v)+ toElt ((), v) = v++ eltType' _ = SingleTuple scalarType+ fromElt' = id+ toElt' = id++instance Elt Word64 where+ eltType = singletonScalarType+ fromElt v = ((), v)+ toElt ((), v) = v++ eltType' _ = SingleTuple scalarType+ fromElt' = id+ toElt' = id++{-+instance Elt CShort where+ --eltType = singletonScalarType+ fromElt v = ((), v)+ toElt ((), v) = v++ --eltType' _ = SingleTuple scalarType+ fromElt' = id+ toElt' = id++instance Elt CUShort where+ --eltType = singletonScalarType+ fromElt v = ((), v)+ toElt ((), v) = v++ --eltType' _ = SingleTuple scalarType+ fromElt' = id+ toElt' = id++instance Elt CInt where+ --eltType = singletonScalarType+ fromElt v = ((), v)+ toElt ((), v) = v++ --eltType' _ = SingleTuple scalarType+ fromElt' = id+ toElt' = id++instance Elt CUInt where+ --eltType = singletonScalarType+ fromElt v = ((), v)+ toElt ((), v) = v++ --eltType' _ = SingleTuple scalarType+ fromElt' = id+ toElt' = id++instance Elt CLong where+ --eltType = singletonScalarType+ fromElt v = ((), v)+ toElt ((), v) = v++ --eltType' _ = SingleTuple scalarType+ fromElt' = id+ toElt' = id++instance Elt CULong where+ --eltType = singletonScalarType+ fromElt v = ((), v)+ toElt ((), v) = v++ --eltType' _ = SingleTuple scalarType+ fromElt' = id+ toElt' = id++instance Elt CLLong where+ --eltType = singletonScalarType+ fromElt v = ((), v)+ toElt ((), v) = v++ --eltType' _ = SingleTuple scalarType+ fromElt' = id+ toElt' = id++instance Elt CULLong where+ --eltType = singletonScalarType+ fromElt v = ((), v)+ toElt ((), v) = v++ --eltType' _ = SingleTuple scalarType+ fromElt' = id+ toElt' = id+-}++instance Elt Float where+ eltType = singletonScalarType+ fromElt v = ((), v)+ toElt ((), v) = v++ eltType' _ = SingleTuple scalarType+ fromElt' = id+ toElt' = id++instance Elt Double where+ eltType = singletonScalarType+ fromElt v = ((), v)+ toElt ((), v) = v++ eltType' _ = SingleTuple scalarType+ fromElt' = id+ toElt' = id++{-+instance Elt CFloat where+ --eltType = singletonScalarType+ fromElt v = ((), v)+ toElt ((), v) = v++ --eltType' _ = SingleTuple scalarType+ fromElt' = id+ toElt' = id++instance Elt CDouble where+ --eltType = singletonScalarType+ fromElt v = ((), v)+ toElt ((), v) = v++ --eltType' _ = SingleTuple scalarType+ fromElt' = id+ toElt' = id+-}++instance Elt Bool where+ eltType = singletonScalarType+ fromElt v = ((), v)+ toElt ((), v) = v++ eltType' _ = SingleTuple scalarType+ fromElt' = id+ toElt' = id++instance Elt Char where+ eltType = singletonScalarType+ fromElt v = ((), v)+ toElt ((), v) = v++ eltType' _ = SingleTuple scalarType+ fromElt' = id+ toElt' = id++{-+instance Elt CChar where+ --eltType = singletonScalarType+ fromElt v = ((), v)+ toElt ((), v) = v++ --eltType' _ = SingleTuple scalarType+ fromElt' = id+ toElt' = id++instance Elt CSChar where+ --eltType = singletonScalarType+ fromElt v = ((), v)+ toElt ((), v) = v++ --eltType' _ = SingleTuple scalarType+ fromElt' = id+ toElt' = id++instance Elt CUChar where+ --eltType = singletonScalarType+ fromElt v = ((), v)+ toElt ((), v) = v++ --eltType' _ = SingleTuple scalarType+ fromElt' = id+ toElt' = id+-}++instance (Elt a, Elt b) => Elt (a, b) where+ eltType (_::(a, b)) + = PairTuple (eltType (undefined :: a)) (eltType' (undefined :: b))+ fromElt (a, b) = (fromElt a, fromElt' b)+ toElt (a, b) = (toElt a, toElt' b)++ eltType' (_::(a, b)) + = PairTuple (eltType (undefined :: a)) (eltType' (undefined :: b))+ fromElt' (a, b) = (fromElt a, fromElt' b)+ toElt' (a, b) = (toElt a, toElt' b)++instance (Elt a, Elt b, Elt c) => Elt (a, b, c) where+ eltType (_::(a, b, c)) + = PairTuple (eltType (undefined :: (a, b))) (eltType' (undefined :: c))+ fromElt (a, b, c) = (fromElt (a, b), fromElt' c)+ toElt (ab, c) = let (a, b) = toElt ab in (a, b, toElt' c)+ + eltType' (_::(a, b, c)) + = PairTuple (eltType (undefined :: (a, b))) (eltType' (undefined :: c))+ fromElt' (a, b, c) = (fromElt (a, b), fromElt' c)+ toElt' (ab, c) = let (a, b) = toElt ab in (a, b, toElt' c)+ +instance (Elt a, Elt b, Elt c, Elt d) => Elt (a, b, c, d) where+ eltType (_::(a, b, c, d)) + = PairTuple (eltType (undefined :: (a, b, c))) (eltType' (undefined :: d))+ fromElt (a, b, c, d) = (fromElt (a, b, c), fromElt' d)+ toElt (abc, d) = let (a, b, c) = toElt abc in (a, b, c, toElt' d)++ eltType' (_::(a, b, c, d)) + = PairTuple (eltType (undefined :: (a, b, c))) (eltType' (undefined :: d))+ fromElt' (a, b, c, d) = (fromElt (a, b, c), fromElt' d)+ toElt' (abc, d) = let (a, b, c) = toElt abc in (a, b, c, toElt' d)++instance (Elt a, Elt b, Elt c, Elt d, Elt e) => Elt (a, b, c, d, e) where+ eltType (_::(a, b, c, d, e)) + = PairTuple (eltType (undefined :: (a, b, c, d))) + (eltType' (undefined :: e))+ fromElt (a, b, c, d, e) = (fromElt (a, b, c, d), fromElt' e)+ toElt (abcd, e) = let (a, b, c, d) = toElt abcd in (a, b, c, d, toElt' e)++ eltType' (_::(a, b, c, d, e)) + = PairTuple (eltType (undefined :: (a, b, c, d))) + (eltType' (undefined :: e))+ fromElt' (a, b, c, d, e) = (fromElt (a, b, c, d), fromElt' e)+ toElt' (abcd, e) = let (a, b, c, d) = toElt abcd in (a, b, c, d, toElt' e)++instance (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f) => Elt (a, b, c, d, e, f) where+ eltType (_::(a, b, c, d, e, f)) + = PairTuple (eltType (undefined :: (a, b, c, d, e))) + (eltType' (undefined :: f))+ fromElt (a, b, c, d, e, f) = (fromElt (a, b, c, d, e), fromElt' f)+ toElt (abcde, f) = let (a, b, c, d, e) = toElt abcde in (a, b, c, d, e, toElt' f)++ eltType' (_::(a, b, c, d, e, f)) + = PairTuple (eltType (undefined :: (a, b, c, d, e))) + (eltType' (undefined :: f))+ fromElt' (a, b, c, d, e, f) = (fromElt (a, b, c, d, e), fromElt' f)+ toElt' (abcde, f) = let (a, b, c, d, e) = toElt abcde in (a, b, c, d, e, toElt' f)++instance (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g) + => Elt (a, b, c, d, e, f, g) where+ eltType (_::(a, b, c, d, e, f, g)) + = PairTuple (eltType (undefined :: (a, b, c, d, e, f))) + (eltType' (undefined :: g))+ fromElt (a, b, c, d, e, f, g) = (fromElt (a, b, c, d, e, f), fromElt' g)+ toElt (abcdef, g) = let (a, b, c, d, e, f) = toElt abcdef in (a, b, c, d, e, f, toElt' g)++ eltType' (_::(a, b, c, d, e, f, g)) + = PairTuple (eltType (undefined :: (a, b, c, d, e, f))) + (eltType' (undefined :: g))+ fromElt' (a, b, c, d, e, f, g) = (fromElt (a, b, c, d, e, f), fromElt' g)+ toElt' (abcdef, g) = let (a, b, c, d, e, f) = toElt abcdef in (a, b, c, d, e, f, toElt' g)++instance (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h) + => Elt (a, b, c, d, e, f, g, h) where+ eltType (_::(a, b, c, d, e, f, g, h)) + = PairTuple (eltType (undefined :: (a, b, c, d, e, f, g))) + (eltType' (undefined :: h))+ fromElt (a, b, c, d, e, f, g, h) = (fromElt (a, b, c, d, e, f, g), fromElt' h)+ toElt (abcdefg, h) = let (a, b, c, d, e, f, g) = toElt abcdefg + in (a, b, c, d, e, f, g, toElt' h)++ eltType' (_::(a, b, c, d, e, f, g, h)) + = PairTuple (eltType (undefined :: (a, b, c, d, e, f, g))) + (eltType' (undefined :: h))+ fromElt' (a, b, c, d, e, f, g, h) = (fromElt (a, b, c, d, e, f, g), fromElt' h)+ toElt' (abcdefg, h) = let (a, b, c, d, e, f, g) = toElt abcdefg + in (a, b, c, d, e, f, g, toElt' h)++instance (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i) + => Elt (a, b, c, d, e, f, g, h, i) where+ eltType (_::(a, b, c, d, e, f, g, h, i)) + = PairTuple (eltType (undefined :: (a, b, c, d, e, f, g, h))) + (eltType' (undefined :: i))+ fromElt (a, b, c, d, e, f, g, h, i) = (fromElt (a, b, c, d, e, f, g, h), fromElt' i)+ toElt (abcdefgh, i) = let (a, b, c, d, e, f, g, h) = toElt abcdefgh+ in (a, b, c, d, e, f, g, h, toElt' i)++ eltType' (_::(a, b, c, d, e, f, g, h, i)) + = PairTuple (eltType (undefined :: (a, b, c, d, e, f, g, h))) + (eltType' (undefined :: i))+ fromElt' (a, b, c, d, e, f, g, h, i) = (fromElt (a, b, c, d, e, f, g, h), fromElt' i)+ toElt' (abcdefgh, i) = let (a, b, c, d, e, f, g, h) = toElt abcdefgh+ in (a, b, c, d, e, f, g, h, toElt' i)++-- |Convenience functions+--++singletonScalarType :: IsScalar a => a -> TupleType ((), a)+singletonScalarType _ = PairTuple UnitTuple (SingleTuple scalarType)++liftToElt :: (Elt a, Elt b) + => (EltRepr a -> EltRepr b)+ -> (a -> b)+{-# INLINE liftToElt #-}+liftToElt f = toElt . f . fromElt++liftToElt2 :: (Elt a, Elt b, Elt c) + => (EltRepr a -> EltRepr b -> EltRepr c)+ -> (a -> b -> c)+{-# INLINE liftToElt2 #-}+liftToElt2 f = \x y -> toElt $ f (fromElt x) (fromElt y)++sinkFromElt :: (Elt a, Elt b) + => (a -> b)+ -> (EltRepr a -> EltRepr b)+{-# INLINE sinkFromElt #-}+sinkFromElt f = fromElt . f . toElt++sinkFromElt2 :: (Elt a, Elt b, Elt c) + => (a -> b -> c)+ -> (EltRepr a -> EltRepr b -> EltRepr c)+{-# INLINE sinkFromElt2 #-}+sinkFromElt2 f = \x y -> fromElt $ f (toElt x) (toElt y)++{-# RULES++"fromElt/toElt" forall e.+ fromElt (toElt e) = e++ #-}++-- Surface arrays+-- --------------++-- |Multi-dimensional arrays for array processing+--+-- * If device and host memory are separate, arrays will be transferred to the+-- device when necessary (if possible asynchronously and in parallel with+-- other tasks) and cached on the device if sufficient memory is available.+--+data Array sh e where+ Array :: (Shape sh, Elt e) + => EltRepr sh -- extent of dimensions = shape+ -> ArrayData (EltRepr e) -- array payload+ -> Array sh e++deriving instance Typeable2 Array ++-- |Scalars+--+type Scalar e = Array DIM0 e++-- |Vectors+--+type Vector e = Array DIM1 e++-- |Segment descriptor+--+type Segments = Vector Int++-- Shorthand for common shape types+--+type DIM0 = Z+type DIM1 = DIM0:.Int+type DIM2 = DIM1:.Int+type DIM3 = DIM2:.Int+type DIM4 = DIM3:.Int+type DIM5 = DIM4:.Int+type DIM6 = DIM5:.Int+type DIM7 = DIM6:.Int+type DIM8 = DIM7:.Int+type DIM9 = DIM8:.Int++-- Shape constraints and indexing+-- ++-- |Shapes and indices of multi-dimensional arrays+--+class (Elt sh, Elt (Any sh), Repr.Shape (EltRepr sh)) => Shape sh where++ -- |Number of dimensions of a /shape/ or /index/ (>= 0).+ dim :: sh -> Int+ + -- |Total number of elements in an array of the given /shape/.+ size :: sh -> Int++ -- |Magic value identifying elements ignored in 'permute'.+ ignore :: sh+ + -- |Map a multi-dimensional index into one in a linear, row-major + -- representation of the array (first argument is the /shape/, second + -- argument is the index).+ index :: sh -> sh -> Int++ -- |Apply a boundary condition to an index.+ bound :: sh -> sh -> Boundary a -> Either a sh++ -- |Iterate through the entire shape, applying the function; third argument+ -- combines results and fourth is returned in case of an empty iteration+ -- space; the index space is traversed in row-major order.+ iter :: sh -> (sh -> a) -> (a -> a -> a) -> a -> a++ -- |Convert a minpoint-maxpoint index into a /shape/.+ rangeToShape :: (sh, sh) -> sh+ + -- |Convert a /shape/ into a minpoint-maxpoint index.+ shapeToRange :: sh -> (sh, sh)++ -- |Convert a shape to a list of dimensions.+ shapeToList :: sh -> [Int]++ -- |Convert a list of dimensions into a shape.+ listToShape :: [Int] -> sh++ -- | The slice index for slice specifier 'Any sh'+ sliceAnyIndex :: sh -> Repr.SliceIndex (EltRepr (Any sh)) (EltRepr sh) () (EltRepr sh)++ dim = Repr.dim . fromElt+ size = Repr.size . fromElt+ -- (#) must be individually defined, as it only hold for all instances *except* the one with the+ -- largest arity++ ignore = toElt Repr.ignore+ index sh ix = Repr.index (fromElt sh) (fromElt ix)+ bound sh ix bndy = case Repr.bound (fromElt sh) (fromElt ix) bndy of+ Left v -> Left v+ Right ix' -> Right $ toElt ix'++ iter sh f c r = Repr.iter (fromElt sh) (f . toElt) c r++ rangeToShape (low, high) + = toElt (Repr.rangeToShape (fromElt low, fromElt high))+ shapeToRange ix+ = let (low, high) = Repr.shapeToRange (fromElt ix)+ in+ (toElt low, toElt high)++ shapeToList = Repr.shapeToList . fromElt+ listToShape = toElt . Repr.listToShape++instance Shape Z where+ sliceAnyIndex _ = Repr.SliceNil+ +instance Shape sh => Shape (sh:.Int) where+ sliceAnyIndex _ = Repr.SliceAll (sliceAnyIndex (undefined :: sh))++-- |Slices -aka generalised indices- as n-tuples and mappings of slice+-- indicies to slices, co-slices, and slice dimensions+--+class (Elt sl, Shape (SliceShape sl), Shape (CoSliceShape sl), Shape (FullShape sl)) + => Slice sl where+ type SliceShape sl :: *+ type CoSliceShape sl :: *+ type FullShape sl :: *+ sliceIndex :: sl -> Repr.SliceIndex (EltRepr sl)+ (EltRepr (SliceShape sl))+ (EltRepr (CoSliceShape sl))+ (EltRepr (FullShape sl))++instance Slice Z where+ type SliceShape Z = Z+ type CoSliceShape Z = Z+ type FullShape Z = Z+ sliceIndex _ = Repr.SliceNil++instance Slice sl => Slice (sl:.All) where+ type SliceShape (sl:.All) = SliceShape sl :. Int+ type CoSliceShape (sl:.All) = CoSliceShape sl+ type FullShape (sl:.All) = FullShape sl :. Int+ sliceIndex _ = Repr.SliceAll (sliceIndex (undefined::sl))++instance Slice sl => Slice (sl:.Int) where+ type SliceShape (sl:.Int) = SliceShape sl+ type CoSliceShape (sl:.Int) = CoSliceShape sl :. Int+ type FullShape (sl:.Int) = FullShape sl :. Int+ sliceIndex _ = Repr.SliceFixed (sliceIndex (undefined::sl))++instance Shape sh => Slice (Any sh) where+ type SliceShape (Any sh) = sh+ type CoSliceShape (Any sh) = Z+ type FullShape (Any sh) = sh+ sliceIndex _ = sliceAnyIndex (undefined :: sh)++-- Array operations+-- ----------------++-- |Yield an array's shape+--+shape :: Shape sh => Array sh e -> sh+shape (Array sh _) = toElt sh++-- |Array indexing+--+infixl 9 !+(!) :: Array sh e -> sh -> e+{-# INLINE (!) #-}+-- (Array sh adata) ! ix = toElt (adata `indexArrayData` index sh ix)+-- FIXME: using this due to a bug in 6.10.x+(!) (Array sh adata) ix = toElt (adata `indexArrayData` index (toElt sh) ix)++-- |Create an array from its representation function+--+newArray :: (Shape sh, Elt e) => sh -> (sh -> e) -> Array sh e+{-# INLINE newArray #-}+newArray sh f = adata `seq` Array (fromElt sh) adata+ where + (adata, _) = runArrayData $ do+ arr <- newArrayData (1024 `max` size sh)+ let write ix = writeArrayData arr (index sh ix) + (fromElt (f ix))+ iter sh write (>>) (return ())+ return (arr, undefined)++-- | Creates a new, uninitialized Accelerate array.+--+allocateArray :: (Shape sh, Elt e) => sh -> Array sh e+{-# INLINE allocateArray #-}+allocateArray sh = adata `seq` Array (fromElt sh) adata+ where+ (adata, _) = runArrayData $ (,undefined) `fmap` newArrayData (1024 `max` size sh)+++-- |Convert an 'IArray' to an accelerated array.+--+fromIArray :: (EltRepr ix ~ EltRepr sh, IArray a e, IArray.Ix ix, Shape sh, Elt ix, Elt e)+ => a ix e -> Array sh e+fromIArray iarr = newArray (toElt sh) (\ix -> iarr IArray.! toElt (fromElt ix))+ where+ (lo,hi) = IArray.bounds iarr+ sh = Repr.rangeToShape (fromElt lo, fromElt hi)++-- |Convert an accelerated array to an 'IArray'+-- +toIArray :: (EltRepr ix ~ EltRepr sh, IArray a e, IArray.Ix ix, Shape sh, Elt ix, Elt e) + => Array sh e -> a ix e+toIArray arr = IArray.array bnds [(ix, arr ! toElt (fromElt ix)) | ix <- IArray.range bnds]+ where+ (lo,hi) = Repr.shapeToRange (fromElt (shape arr))+ bnds = (toElt lo, toElt hi)++-- |Convert a list (with elements in row-major order) to an accelerated array.+--+fromList :: (Shape sh, Elt e) => sh -> [e] -> Array sh e+fromList sh l = newArray sh indexIntoList + where+ indexIntoList ix = l!!index sh ix++-- |Convert an accelerated array to a list in row-major order.+--+toList :: forall sh e. Array sh e -> [e]+toList (Array sh adata) = iter sh' idx (.) id []+ where+ sh' = toElt sh :: sh+ idx ix = \l -> toElt (adata `indexArrayData` index sh' ix) : l++-- Convert an array to a string+--+instance Show (Array sh e) where+ show arr@(Array sh _adata) + = "Array " ++ show (toElt sh :: sh) ++ " " ++ show (toList arr)+
Data/Array/Accelerate/CUDA.hs view
@@ -1,52 +1,92 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP, GADTs #-} -- | -- Module : Data.Array.Accelerate.CUDA--- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell+-- 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 is the CUDA backend for the embedded array language.+-- 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+ -- * Generate and execute CUDA code for an array expression+ Arrays, run, stream - ) where+) 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 -import Data.Array.Accelerate.AST+-- 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-import Data.Array.Accelerate.CUDA.Array.Device-import qualified Data.Array.Accelerate.CUDA.Smart as Sugar #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 :: Arrays a => Sugar.Acc a -> a-run acc- = unsafePerformIO- $ evalCUDA (execute (Sugar.convertAcc acc) >>= collect)- `catch`- \e -> INTERNAL_ERROR(error) "unhandled" (show (e :: CUDAException))+run a = unsafePerformIO execute+ where+ acc = convertAcc a+ execute = evalCUDA (compileAcc acc >>= executeAcc >>= collect)+ `catch`+ \e -> INTERNAL_ERROR(error) "unhandled" (show (e :: CUDAException)) -execute :: Arrays a => Acc a -> CIO a-execute acc = compileAcc acc >> executeAcc acc++-- | 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 view
@@ -1,6 +1,6 @@ -- | -- Module : Data.Array.Accelerate.CUDA.Analysis.Device--- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell+-- 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>
Data/Array/Accelerate/CUDA/Analysis/Hash.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE CPP, GADTs #-} -- | -- Module : Data.Array.Accelerate.CUDA.Analysis.Hash--- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell+-- 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>@@ -9,89 +9,135 @@ -- Portability : non-partable (GHC extensions) -- -module Data.Array.Accelerate.CUDA.Analysis.Hash (accToKey)- where+module Data.Array.Accelerate.CUDA.Analysis.Hash ( + AccKey, accToKey, hashAccKey++) where+ import Data.Char import Language.C-import Control.Monad.State 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+import qualified Data.Array.Accelerate.Array.Sugar as Sugar #include "accelerate.h" --- |--- Generate a unique key for each kernel computation (not extensively tested...)+type AccKey = ByteString++-- | Reimplementation of Data.HashTable.hashString to fold over a lazy+-- bytestring rather than a list of characters. ---accToKey :: OpenAcc aenv a -> String-accToKey r@(Replicate s e a) = chr 17 : showTy (accType a) ++ showExp e ++ showSI s e a r-accToKey r@(Index s a e) = chr 29 : showTy (accType a) ++ showExp e ++ showSI s e r a-accToKey (Map f a) = chr 41 : showTy (accType a) ++ showFun f-accToKey (ZipWith f x y) = chr 53 : showTy (accType x) ++ showTy (accType y) ++ showFun f-accToKey (Fold f e a) = chr 67 : showTy (accType a) ++ showFun f ++ showExp e-accToKey (FoldSeg f e _ a) = chr 79 : showTy (accType a) ++ showFun f ++ showExp e-accToKey (Scanl f e a) = chr 97 : showTy (accType a) ++ showFun f ++ showExp e-accToKey (Scanr f e a) = chr 107 : showTy (accType a) ++ showFun f ++ showExp e-accToKey (Permute c _ p a) = chr 127 : showTy (accType a) ++ showFun c ++ showFun p-accToKey (Backpermute _ p a) = chr 139 : showTy (accType a) ++ showFun p-accToKey x =- INTERNAL_ERROR(error) "accToKey"- (unlines ["incomplete patterns for key generation", render . nest 2 $ text (show x)])+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) -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 f = render . hcat . map pretty $ evalState (codeGenFun f) []+-- | 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 -showExp :: OpenExp env aenv a -> String-showExp e = render . hcat . map pretty $ evalState (codeGenExp e) [] -showSI :: SliceIndex (Sugar.ElemRepr slix) (Sugar.ElemRepr sl) co (Sugar.ElemRepr 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+-- 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- 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)+ 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 -> Int-quad (c1:c2:c3:c4:s) = (( ord c4 * bits21- + ord c3 * bits14- + ord c2 * bits7- + ord c1)- `Prelude.mod` bits28)- + (quad s `Prelude.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 :: 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 -bits7, bits14, bits21, bits28 :: Int-bits7 = 2^(7 ::Int)-bits14 = 2^(14::Int)-bits21 = 2^(21::Int)-bits28 = 2^(28::Int)--}+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 view
@@ -1,7 +1,7 @@-{-# LANGUAGE GADTs #-}+{-# LANGUAGE CPP, GADTs, RankNTypes #-} -- | -- Module : Data.Array.Accelerate.CUDA.Analysis.Launch--- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell+-- 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>@@ -12,17 +12,43 @@ module Data.Array.Accelerate.CUDA.Analysis.Launch (launchConfig) where -import Control.Monad.IO.Class--import Data.Int+-- friends import Data.Array.Accelerate.AST-import Data.Array.Accelerate.Analysis.Type+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@@ -33,13 +59,11 @@ -- physically resident blocks. Hence, kernels may need to process multiple -- elements per thread. ----- TLM: this could probably be stored in the KernelEntry----launchConfig :: OpenAcc aenv a -> Int -> CUDA.Fun -> CIO (Int, Int, Integer)+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 <- getM deviceProps+ prop <- gets deviceProps let dyn = sharedMem prop acc (cta, occ) = blockSize prop acc regs ((stat+) . dyn)@@ -52,8 +76,9 @@ -- 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 -> OpenAcc aenv a -> Int -> (Int -> Int) -> (Int, CUDA.Occupancy)+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 @@ -64,14 +89,18 @@ -- -- foldSeg: 'size' is the number of segments, require one warp per segment ---gridSize :: CUDA.DeviceProperties -> OpenAcc aenv a -> Int -> Int -> Int-gridSize p (FoldSeg _ _ _ _) size cta = ((size * CUDA.warpSize p) + cta - 1) `div` cta-gridSize _ acc size cta =- let between arr n = (n+arr-1) `div` n- in 1 `max` ((cta - 1 + (size `between` elementsPerThread acc)) `div` cta)+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 -elementsPerThread :: OpenAcc aenv a -> Int-elementsPerThread _ = 1+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 -- |@@ -79,15 +108,39 @@ -- 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 -> OpenAcc aenv a -> Int -> Int-sharedMem _ (Fold _ x _) blockDim = sizeOf (expType x) * blockDim-sharedMem _ (Scanl _ x _) blockDim = sizeOf (expType x) * blockDim-sharedMem _ (Scanr _ x _) blockDim = sizeOf (expType x) * blockDim-sharedMem p (FoldSeg _ x _ _) blockDim =- let warp = CUDA.warpSize p- in- (blockDim `div` warp * 2) * F.sizeOf (undefined :: Int32) +- (blockDim + warp `div` 2) * sizeOf (expType x)+sharedMem :: CUDA.DeviceProperties -> PreOpenAcc ExecOpenAcc aenv a -> Int -> Int+-- non-computation forms+sharedMem _ (Let _ _) _ = INTERNAL_ERROR(error) "sharedMem" "Let"+sharedMem _ (Let2 _ _) _ = 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" -sharedMem _ _ _ = 0+-- 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 view
@@ -1,8 +1,7 @@-{-# LANGUAGE CPP, FlexibleContexts, TypeFamilies #-}-{-# LANGUAGE ExistentialQuantification, ScopedTypeVariables #-}+{-# LANGUAGE CPP, FlexibleContexts, PatternGuards, ScopedTypeVariables, GADTs, TypeFamilies #-} -- | -- Module : Data.Array.Accelerate.CUDA.Array.Data--- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell+-- 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>@@ -10,11 +9,19 @@ -- Portability : non-portable (GHC extensions) -- -module Data.Array.Accelerate.CUDA.Array.Data- (- ArrayElem(..)- ) where+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 @@ -25,13 +32,17 @@ 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 HT+import qualified Data.HashTable as Hash import Data.Array.Accelerate.CUDA.State-import qualified Data.Array.Accelerate.Array.Data as Acc+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@@ -39,84 +50,238 @@ #include "accelerate.h" --- Instances--- ~~~~~~~~~+-- Array Operations+-- ---------------- -class Acc.ArrayElem e => ArrayElem e where- type DevicePtrs e- type HostPtrs e- mallocArray :: Acc.ArrayData e -> Int -> CIO ()- indexArray :: Acc.ArrayData e -> Int -> CIO e- copyArray :: Acc.ArrayData e -> Acc.ArrayData e -> Int -> CIO ()- peekArray :: Acc.ArrayData e -> Int -> CIO ()- pokeArray :: Acc.ArrayData e -> Int -> CIO ()- peekArrayAsync :: Acc.ArrayData e -> Int -> Maybe CUDA.Stream -> CIO ()- pokeArrayAsync :: Acc.ArrayData e -> Int -> Maybe CUDA.Stream -> CIO ()- textureRefs :: Acc.ArrayData e -> CUDA.Module -> Int -> Int -> CIO [CUDA.FunParam]- devicePtrs :: Acc.ArrayData e -> CIO [CUDA.FunParam]- touchArray :: Acc.ArrayData e -> CIO ()- freeArray :: Acc.ArrayData e -> CIO ()+type family DevicePtrs e :: *+type family HostPtrs e :: * - -- FIXME: remove once all ArrayElem instances are concrete- mallocArray = undefined- indexArray = undefined- copyArray = undefined- peekArray = undefined- pokeArray = undefined- peekArrayAsync = undefined- pokeArrayAsync = undefined- textureRefs = undefined- devicePtrs = undefined- touchArray = undefined- freeArray = undefined+-- 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" -instance ArrayElem () where- type DevicePtrs () = CUDA.DevicePtr ()- type HostPtrs () = CUDA.HostPtr ()- mallocArray _ _ = return ()- indexArray _ _ = return ()- copyArray _ _ _ = return ()- peekArray _ _ = return ()- pokeArray _ _ = return ()- peekArrayAsync _ _ _ = return ()- pokeArrayAsync _ _ _ = return ()- textureRefs _ _ _ _ = return []- devicePtrs _ = return []- touchArray _ = return ()- freeArray _ = return ()+-- |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)+ } -#define primArrayElem_(ty,con) \-instance ArrayElem ty where { \- type DevicePtrs ty = CUDA.DevicePtr con \-; type HostPtrs ty = CUDA.HostPtr con \-; mallocArray = mallocArray' \-; indexArray = indexArray' \-; copyArray = copyArray' \-; peekArray = peekArray' \-; pokeArray = pokeArray' \-; peekArrayAsync = peekArrayAsync' \-; pokeArrayAsync = pokeArrayAsync' \-; textureRefs = textureRefs' \-; devicePtrs = devicePtrs' \-; touchArray = touchArray' \-; freeArray = freeArray' }+-- |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)+ } -#define primArrayElem(ty) primArrayElem_(ty,ty)+-- |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)+ } -primArrayElem(Int)-primArrayElem(Int8)-primArrayElem(Int16)-primArrayElem(Int32)-primArrayElem(Int64)+-- |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)+ } -primArrayElem(Word)-primArrayElem(Word8)-primArrayElem(Word16)-primArrayElem(Word32)-primArrayElem(Word64)+-- |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@@ -127,8 +292,8 @@ -- CLLong -- CULLong -primArrayElem(Float)-primArrayElem(Double)+primArrayElt(Float)+primArrayElt(Double) -- FIXME: -- CFloat@@ -137,42 +302,27 @@ -- FIXME: -- No concrete implementation in Data.Array.Accelerate.Array.Data ---instance ArrayElem Bool-instance ArrayElem Char+type instance HostPtrs Bool = ()+type instance DevicePtrs Bool = () +type instance HostPtrs Char = ()+type instance DevicePtrs Char = ()+ -- FIXME: -- CChar -- CSChar -- CUChar -instance (ArrayElem a, ArrayElem b) => ArrayElem (a,b) where- type DevicePtrs (a,b) = (DevicePtrs a, DevicePtrs b)- type HostPtrs (a,b) = (HostPtrs a, HostPtrs b)-- mallocArray ad n = mallocArray (fst' ad) n *> mallocArray (snd' ad) n- peekArray ad n = peekArray (fst' ad) n *> peekArray (snd' ad) n- pokeArray ad n = pokeArray (fst' ad) n *> pokeArray (snd' ad) n- copyArray src dst n = copyArray (fst' src) (fst' dst) n *> copyArray (snd' src) (snd' dst) n- peekArrayAsync ad n s = peekArrayAsync (fst' ad) n s *> peekArrayAsync (snd' ad) n s- pokeArrayAsync ad n s = pokeArrayAsync (fst' ad) n s *> pokeArrayAsync (snd' ad) n s- touchArray ad = touchArray (fst' ad) *> touchArray (snd' ad)- freeArray ad = freeArray (fst' ad) *> freeArray (snd' ad)- indexArray ad n = (,) <$> indexArray (fst' ad) n <*> indexArray (snd' ad) n- devicePtrs ad = (++) <$> devicePtrs (fst' ad) <*> devicePtrs (snd' ad)- textureRefs ad mdl n t = do -- PRETTY ME- t1 <- textureRefs (fst' ad) mdl n t- t2 <- textureRefs (snd' ad) mdl n (t+ length t1)- return (t1 ++ t2)+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. ----- FIXME: Code generation for 64-bit types.--- class TextureData a where format :: a -> (CUDA.Format, Int) @@ -200,160 +350,263 @@ _ -> error "we can never get here" --- Implementation--- ~~~~~~~~~~~~~~+-- 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 ---mallocArray' :: forall a e. (Acc.ArrayPtrs e ~ Ptr a, Storable a, Acc.ArrayElem e) => Acc.ArrayData e -> Int -> CIO ()-mallocArray' ad n = do- table <- getM memoryTable- exists <- isJust <$> liftIO (HT.lookup table key)- unless exists . liftIO $ insertArray ad table =<< CUDA.mallocArray n+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- insertArray :: (Acc.ArrayPtrs e ~ Ptr a, Acc.ArrayElem e) => Acc.ArrayData e -> MemTable -> CUDA.DevicePtr a -> IO ()- insertArray _ t = HT.insert t key . MemoryEntry 0 bytes . CUDA.devPtrToWordPtr- bytes = fromIntegral $ n * sizeOf (undefined :: a)- key = arrayToKey ad+ free v = case get refcount v of+ Nothing -> return ()+ Just x | x > 0 -> updateArray ad v+ _ -> deleteArray ad -- Array indexing ---indexArray' :: (Acc.ArrayPtrs e ~ Ptr a, Storable a, Acc.ArrayElem e) => Acc.ArrayData e -> Int -> CIO a-indexArray' ad n = do+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+-- Copy data between two device arrays. ---copyArray' :: forall a e. (Acc.ArrayPtrs e ~ Ptr a, Storable a, Acc.ArrayElem e) => Acc.ArrayData e -> Acc.ArrayData e -> Int -> CIO ()-copyArray' src' dst' n =- let bytes = n * sizeOf (undefined::a)- in do- src <- getArray src'- dst <- getArray dst'- liftIO $ CUDA.copyArrayAsync bytes src dst+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 ---peekArray' :: (Acc.ArrayPtrs e ~ Ptr a, Storable a, Acc.ArrayElem e) => Acc.ArrayData e -> Int -> CIO ()-peekArray' ad n =- let dst = Acc.ptrsOfArrayData ad- src = CUDA.wordPtrToDevPtr . getL arena+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 -peekArrayAsync' :: (Acc.ArrayPtrs e ~ Ptr a, Storable a, Acc.ArrayElem e) => Acc.ArrayData e -> Int -> Maybe CUDA.Stream -> CIO ()-peekArrayAsync' ad n st =- let dst = CUDA.HostPtr . Acc.ptrsOfArrayData- src = CUDA.wordPtrToDevPtr . getL arena+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 only be copied once, with subsequent invocations incrementing the--- reference counter.+-- will be copied from the host-side array each time this function is called; no+-- changes to the reference counter will be made. ---pokeArray' :: (Acc.ArrayPtrs e ~ Ptr a, Storable a, Acc.ArrayElem e) => Acc.ArrayData e -> Int -> CIO ()-pokeArray' ad n =- let src = Acc.ptrsOfArrayData ad- dst = CUDA.wordPtrToDevPtr . getL arena- in do- tab <- getM memoryTable- me <- modL refcount (+1) <$> lookupArray ad- when (getL refcount me <= 1) . liftIO $ CUDA.pokeArray n src (dst me)- liftIO $ HT.insert tab (arrayToKey ad) me+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) -pokeArrayAsync' :: (Acc.ArrayPtrs e ~ Ptr a, Storable a, Acc.ArrayElem e) => Acc.ArrayData e -> Int -> Maybe CUDA.Stream -> CIO ()-pokeArrayAsync' ad n st =- let src = CUDA.HostPtr . Acc.ptrsOfArrayData- dst = CUDA.wordPtrToDevPtr . getL arena- in do- tab <- getM memoryTable- me <- modL refcount (+1) <$> lookupArray ad- when (getL refcount me <= 1) . liftIO $ CUDA.pokeArrayAsync n (src ad) (dst me) st- liftIO $ HT.insert tab (arrayToKey ad) me+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 --- Release a device array, when its reference counter drops to zero+-- Wrap the device pointers corresponding to a host-side array into arguments+-- that can be passed to a kernel on invocation. ---freeArray' :: (Acc.ArrayPtrs e ~ Ptr a, Acc.ArrayElem e) => Acc.ArrayData e -> CIO ()-freeArray' ad = do- tab <- getM memoryTable- me <- modL refcount (subtract 1) <$> lookupArray ad- liftIO $ if getL refcount me > 0- then HT.insert tab (arrayToKey ad) me- else do CUDA.free . CUDA.wordPtrToDevPtr $ getL arena me- HT.delete tab (arrayToKey ad)+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 --- Increase the reference count of an array. You may wish to call this right--- before another method that will implicitly attempt to release the array.+-- Bind device memory to the given texture reference, setting appropriate type ---touchArray' :: (Acc.ArrayPtrs e ~ Ptr a, Acc.ArrayElem e) => Acc.ArrayData e -> CIO ()-touchArray' ad = do- tab <- getM memoryTable- liftIO . HT.insert tab (arrayToKey ad) . modL refcount (+1) =<< lookupArray ad+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)) --- Return the device pointers wrapped in a list of function parameters+-- Modify the internal memory reference for a host-side array. ---devicePtrs' :: (Acc.ArrayPtrs e ~ Ptr a, Acc.ArrayElem e) => Acc.ArrayData e -> CIO [CUDA.FunParam]-devicePtrs' ad = (: []) . CUDA.VArg . CUDA.wordPtrToDevPtr . getL arena <$> lookupArray ad+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 --- Retrieve texture references from the module (beginning with the given seed),--- bind device pointers, and return as a list of function arguments.+-- Return the device pointers ---textureRefs' :: forall a e. (Acc.ArrayPtrs e ~ Ptr a, Acc.ArrayElem e, Storable a, TextureData a)- => Acc.ArrayData e -> CUDA.Module -> Int -> Int -> CIO [CUDA.FunParam]-textureRefs' ad mdl n t = do- ptr <- getArray ad- tex <- liftIO $ CUDA.getTex mdl ("tex" ++ show t)- liftIO $ uncurry (CUDA.setFormat tex) (format (undefined :: a))- liftIO $ CUDA.bind tex ptr (fromIntegral $ n * sizeOf (undefined :: a))- return [CUDA.TArg tex]+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) --- Utilities--- ~~~~~~~~~+-- 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 :: (Acc.ArrayPtrs e ~ Ptr a, Acc.ArrayElem e) => Acc.ArrayData e -> WordPtr-arrayToKey = ptrToWordPtr . Acc.ptrsOfArrayData-{-# INLINE arrayToKey #-}+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 :: (Acc.ArrayPtrs e ~ Ptr a, Acc.ArrayElem e) => Acc.ArrayData e -> CIO MemoryEntry-{-# INLINE lookupArray #-}+lookupArray :: (AD.ArrayElt e, AD.ArrayPtrs e ~ Ptr a, Typeable a)+ => AD.ArrayData e+ -> CIO MemoryEntry lookupArray ad = do- t <- getM memoryTable- x <- liftIO $ HT.lookup t (arrayToKey ad)+ 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 :: (Acc.ArrayPtrs e ~ Ptr a, Acc.ArrayElem e) => Acc.ArrayData e -> CIO (CUDA.DevicePtr a)-getArray ad = CUDA.wordPtrToDevPtr . getL arena <$> lookupArray ad-{-# INLINE getArray #-}+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' :: Acc.ArrayData (a,b) -> Acc.ArrayData a-fst' = Acc.fstArrayData-{-# INLINE fst' #-}+fst' :: AD.ArrayData (a,b) -> AD.ArrayData a+fst' = AD.fstArrayData -snd' :: Acc.ArrayData (a,b) -> Acc.ArrayData b-snd' = Acc.sndArrayData-{-# INLINE snd' #-}+snd' :: AD.ArrayData (a,b) -> AD.ArrayData b+snd' = AD.sndArrayData
− Data/Array/Accelerate/CUDA/Array/Device.hs
@@ -1,42 +0,0 @@-{-# LANGUAGE TypeFamilies #-}--- |--- Module : Data.Array.Accelerate.CUDA--- Copyright : [2008..2010] 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)------- Description --------------------------------------------------------------------- Embedded array processing language: device arrays-----module Data.Array.Accelerate.CUDA.Array.Device- where--import Control.Applicative--import Data.Array.Accelerate.CUDA.State-import Data.Array.Accelerate.CUDA.Array.Data-import Data.Array.Accelerate.Array.Representation-import Data.Array.Accelerate.Array.Sugar (Array(..))----- |--- Characterises the types that may be retrieved from the CUDA device as the--- result of executing an array program----class Arrays as where- collect :: as -> CIO as -- ^ Copy from device to host, and decrement the usage counter--instance Arrays () where- collect () = return ()--instance Arrays (Array dim e) where- collect arr@(Array sh ad) = peekArray ad (size sh) >> freeArray ad >> return arr--instance (Arrays as1, Arrays as2) => Arrays (as1, as2) where- collect (a1,a2) = (,) <$> collect a1 <*> collect a2-
Data/Array/Accelerate/CUDA/CodeGen.hs view
@@ -1,7 +1,7 @@-{-# LANGUAGE CPP, GADTs, PatternGuards, ScopedTypeVariables #-}+{-# LANGUAGE CPP, GADTs, PatternGuards, ScopedTypeVariables, TemplateHaskell #-} -- | -- Module : Data.Array.Accelerate.CUDA.CodeGen--- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell+-- 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>@@ -9,28 +9,28 @@ -- Portability : non-portable (GHC extensions) -- -module Data.Array.Accelerate.CUDA.CodeGen- (- CUTranslSkel,- codeGenAcc, codeGenFun, codeGenExp- )- where+module Data.Array.Accelerate.CUDA.CodeGen ( -import Prelude hiding (mod)+ -- * types+ CUTranslSkel, AccBinding(..), + -- * code generation+ codeGenAcc, codeGenFun, codeGenExp++) where+ import Data.Char import Language.C-import Control.Applicative-import Control.Monad.State 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.AST as AST import qualified Data.Array.Accelerate.Array.Sugar as Sugar import qualified Foreign.Storable as F @@ -38,136 +38,256 @@ import Data.Array.Accelerate.CUDA.CodeGen.Util import Data.Array.Accelerate.CUDA.CodeGen.Skeleton + #include "accelerate.h" -type CG a = State [CExtDecl] a +-- 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 = idxToInt ix1 == idxToInt ix2+++ -- Array expressions--- ~~~~~~~~~~~~~~~~~+-- ----------------- --- | Generate CUDA device code for an array expression+-- | 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. ---codeGenAcc :: AST.OpenAcc aenv a -> CUTranslSkel-codeGenAcc acc =- let (CUTranslSkel code skel, fvar) = runState (codeGenAcc' acc) []- CTranslUnit decl node = code+-- 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 (fvar ++ decl) node) skel+ CUTranslSkel (CTranslUnit (fvars ++ decl) node) def skel+ where+ codeGen :: OpenAcc aenv a -> CUTranslSkel+ codeGen (OpenAcc pacc) =+ case pacc of+ -- non-computation forms+ --+ Let _ _ -> internalError+ Let2 _ _ -> internalError+ Avar _ -> internalError+ Apply _ _ -> internalError+ Acond _ _ _ -> internalError+ PairArrays _ _ -> internalError+ Use _ -> internalError+ Unit _ -> internalError+ Reshape _ _ -> internalError --- FIXME:--- The actual code generation workhorse. We run under a state which keeps track--- of the free array variables encountered so far. This is used to determine--- which reference to texture read from. Assumes the same traversal behaviour--- during execution.------ FRAGILE.------ TLM 2010-07-16:--- Make AST.Acc an instance of Traversable, and use mapAccumL to collect the--- types of free array variables ??----codeGenAcc' :: AST.OpenAcc aenv a -> CG CUTranslSkel-codeGenAcc' op@(AST.Replicate sl e1 a1) = codeGenReplicate sl e1 a1 op <* codeGenExp e1-codeGenAcc' op@(AST.Index sl a1 e1) = codeGenIndex sl a1 op e1 <* codeGenExp e1-codeGenAcc' (AST.Fold f1 e1 _) = mkFold (codeGenExpType e1) <$> codeGenExp e1 <*> codeGenFun f1-codeGenAcc' (AST.FoldSeg f1 e1 _ s) = mkFoldSeg (codeGenExpType e1) (codeGenAccType s) <$> codeGenExp e1 <*> codeGenFun f1-codeGenAcc' (AST.Scanl f1 e1 _) = mkScanl (codeGenExpType e1) <$> codeGenExp e1 <*> codeGenFun f1-codeGenAcc' (AST.Scanr f1 e1 _) = mkScanr (codeGenExpType e1) <$> codeGenExp e1 <*> codeGenFun f1-codeGenAcc' op@(AST.Map f1 a1) = mkMap (codeGenAccType op) (codeGenAccType a1) <$> codeGenFun f1-codeGenAcc' op@(AST.ZipWith f1 a1 a0)- = mkZipWith (codeGenAccType op) (accDim op)- (codeGenAccType a1) (accDim a1)- (codeGenAccType a0) (accDim a0)- <$> codeGenFun f1+ -- 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 -codeGenAcc' op@(AST.Permute f1 _ f2 a1)- = mkPermute (codeGenAccType a1) (accDim op) (accDim a1)- <$> codeGenFun f1- <*> codeGenFun f2+ 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) -codeGenAcc' op@(AST.Backpermute _ f1 a1)- = mkBackpermute (codeGenAccType a1) (accDim op) (accDim a1)- <$> codeGenFun f1+ 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) -codeGenAcc' x =- INTERNAL_ERROR(error) "codeGenAcc"- (unlines ["unsupported array primitive", render . nest 2 $ text (show x)])+ 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 $ idxToInt 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]) --- Embedded expressions--- ~~~~~~~~~~~~~~~~~~~~+ --+ -- 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 --- Function abstraction++-- code generation for stencil boundary conditions ---codeGenFun :: AST.OpenFun env aenv t -> CG [CExpr]-codeGenFun (AST.Lam lam) = codeGenFun lam-codeGenFun (AST.Body body) = codeGenExp body+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 -unit :: a -> [a]-unit x = [x] --- Implementation of 'IndexScalar' and 'Shape' demonstrate that array--- computations must be hoisted out of scalar expressions before code generation--- or execution: kernel functions can not invoke other array computations.+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 ----- TLM 2010-06-24:--- Shape for free array variables??+-- 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. ----- TLM 2010-09-03:--- We push a conditional expression into each component of a tuple, in order--- to support tuples as the result of a branch. However, I doubt nvcc is--- clever enough to do CSE on this expression.+codeGenFun :: OpenFun env aenv t -> [CExpr]+codeGenFun (Lam lam) = codeGenFun lam+codeGenFun (Body body) = codeGenExp body+++-- Embedded scalar computations ---codeGenExp :: forall env aenv t. AST.OpenExp env aenv t -> CG [CExpr]-codeGenExp (AST.Shape _) = return . unit $ CVar (internalIdent "shape") internalNode-codeGenExp (AST.PrimConst c) = return . unit $ codeGenPrimConst c-codeGenExp (AST.PrimApp f arg) = unit . codeGenPrim f <$> codeGenExp arg-codeGenExp (AST.Const c) = return $ codeGenConst (Sugar.elemType (undefined::t)) c-codeGenExp (AST.Tuple t) = codeGenTup t-codeGenExp prj@(AST.Prj idx e)+-- 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 prj))+ . take (length $ codeGenTupleType (expType p)) . drop (prjToInt idx (expType e)) . reverse- <$> codeGenExp e+ $ codeGenExp e -codeGenExp (AST.Var i) =- let var = CVar (internalIdent ('x' : show (idxToInt i))) internalNode- in case codeGenTupleType (Sugar.elemType (undefined::t)) of- [_] -> return [var]- cps -> return . reverse . take (length cps) . flip map (enumFrom 0 :: [Int]) $- \c -> CMember var (internalIdent ('a':show c)) False internalNode+codeGenExp IndexNil = []+codeGenExp IndexAny = INTERNAL_ERROR(error) "codeGenExp" "IndexAny: not implemented yet"+codeGenExp (IndexCons ix i) = codeGenExp ix ++ codeGenExp i -codeGenExp (AST.Cond p e1 e2) = do- [a] <- codeGenExp p- zipWith (\b c -> CCond a (Just b) c internalNode) <$> codeGenExp e1 <*> codeGenExp e2+codeGenExp (IndexHead sh@(Shape a)) =+ let [var] = codeGenExp sh+ in if accDim a > 1+ then [CMember var (internalIdent "a0") False internalNode]+ else [var] -codeGenExp (AST.IndexScalar a1 e1) = do- n <- length <$> get- [i] <- codeGenExp e1- let ty = codeGenTupleTex (accType a1)- fv = map (\x -> "tex" ++ show x) [n..]+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 - modify (++ zipWith globalDecl ty fv)- return (zipWith (indexArray i) fv ty)+codeGenExp (IndexHead ix) = return . last $ codeGenExp ix+codeGenExp (IndexTail ix) = init $ codeGenExp ix - where- globalDecl ty name = CDeclExt (CDecl (map CTypeSpec ty) [(Just (CDeclr (Just (internalIdent name)) [] Nothing [] internalNode),Nothing,Nothing)] internalNode)- indexArray idx name [CDoubleType _] = CCall (CVar (internalIdent "indexDArray") internalNode) [CVar (internalIdent name) internalNode, idx] internalNode- indexArray idx name _ = CCall (CVar (internalIdent "indexArray") internalNode) [CVar (internalIdent name) internalNode, idx] internalNode+codeGenExp (Var i) =+ let var = cvar ('x' : show (idxToInt 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) --- Tuples are defined as snoc-lists, so generate code right-to-left----codeGenTup :: Tuple (AST.OpenExp env aenv) t -> CG [CExpr]-codeGenTup NilTup = return []-codeGenTup (t `SnocTup` e) = (++) <$> codeGenTup t <*> codeGenExp e+codeGenExp (Size a) = return $ ccall "size" (codeGenExp (Shape a))+codeGenExp (Shape a)+ | OpenAcc (Avar var) <- a = return $ cvar ("sh" ++ show (idxToInt var))+ | otherwise = INTERNAL_ERROR(error) "codeGenExp" "expected array variable" --- Convert a typed de Brujin index to the corresponding integer+codeGenExp (IndexScalar a e)+ | OpenAcc (Avar var) <- a =+ let var' = show $ idxToInt 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 ---idxToInt :: AST.Idx env t -> Int-idxToInt AST.ZeroIdx = 0-idxToInt (AST.SuccIdx idx) = 1 + idxToInt idx+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@@ -180,73 +300,21 @@ INTERNAL_ERROR(error) "prjToInt" "inconsistent valuation" --- multidimensional array slice and index----codeGenIndex- :: SliceIndex (Sugar.ElemRepr slix)- (Sugar.ElemRepr sl)- co- (Sugar.ElemRepr dim)- -> AST.OpenAcc aenv (Sugar.Array dim e)- -> AST.OpenAcc aenv (Sugar.Array sl e)- -> AST.Exp aenv slix- -> CG CUTranslSkel-codeGenIndex sl acc acc' slix =- return . mkIndex ty dimSl dimCo dimIn0 $ restrict sl (dimCo-1,dimSl-1)- where- ty = codeGenAccType acc- dimCo = length (codeGenExpType slix)- dimSl = accDim acc'- dimIn0 = accDim acc-- 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)----- multidimensional replicate----codeGenReplicate- :: SliceIndex (Sugar.ElemRepr slix)- (Sugar.ElemRepr sl)- co- (Sugar.ElemRepr dim)- -> AST.Exp aenv slix -- dummy to fix type variables- -> AST.OpenAcc aenv (Sugar.Array sl e)- -> AST.OpenAcc aenv (Sugar.Array dim e)- -> CG CUTranslSkel-codeGenReplicate sl _slix acc acc' =- return . mkReplicate ty dimSl dimOut $ extend sl (dimOut-1)- where- ty = codeGenAccType acc- dimSl = accDim acc- 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)---mkPrj :: Int -> String -> Int -> CExpr-mkPrj ndim var c- | ndim <= 1 = CVar (internalIdent var) internalNode- | otherwise = CMember (CVar (internalIdent var) internalNode) (internalIdent ('a':show c)) False internalNode-- -- Types--- ~~~~~+-- ----- -- Generate types for the reified elements of an array computation ---codeGenAccType :: AST.OpenAcc aenv (Sugar.Array dim e) -> [CType]+codeGenAccType :: OpenAcc aenv (Sugar.Array dim e) -> [CType] codeGenAccType = codeGenTupleType . accType -codeGenExpType :: AST.OpenExp aenv env t -> [CType]+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]@@ -299,8 +367,8 @@ codeGenFloatingType (TypeCDouble _) = [CDoubleType internalNode] codeGenNonNumType :: NonNumType a -> CType-codeGenNonNumType (TypeBool _) = [CUnsigType internalNode, CCharType internalNode]-codeGenNonNumType (TypeChar _) = [CCharType internalNode]+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]@@ -370,115 +438,116 @@ -- Scalar Primitives--- ~~~~~~~~~~~~~~~~~+-- ----------------- -codeGenPrimConst :: AST.PrimConst a -> CExpr-codeGenPrimConst (AST.PrimMinBound ty) = codeGenMinBound ty-codeGenPrimConst (AST.PrimMaxBound ty) = codeGenMaxBound ty-codeGenPrimConst (AST.PrimPi ty) = codeGenPi ty+codeGenPrimConst :: PrimConst a -> CExpr+codeGenPrimConst (PrimMinBound ty) = codeGenMinBound ty+codeGenPrimConst (PrimMaxBound ty) = codeGenMaxBound ty+codeGenPrimConst (PrimPi ty) = codeGenPi ty -codeGenPrim :: AST.PrimFun p -> [CExpr] -> CExpr-codeGenPrim (AST.PrimAdd _) [a,b] = CBinary CAddOp a b internalNode-codeGenPrim (AST.PrimSub _) [a,b] = CBinary CSubOp a b internalNode-codeGenPrim (AST.PrimMul _) [a,b] = CBinary CMulOp a b internalNode-codeGenPrim (AST.PrimNeg _) [a] = CUnary CMinOp a internalNode-codeGenPrim (AST.PrimAbs ty) [a] = codeGenAbs ty a-codeGenPrim (AST.PrimSig ty) [a] = codeGenSig ty a-codeGenPrim (AST.PrimQuot _) [a,b] = CBinary CDivOp a b internalNode-codeGenPrim (AST.PrimRem _) [a,b] = CBinary CRmdOp a b internalNode-codeGenPrim (AST.PrimIDiv _) [a,b] = CCall (CVar (internalIdent "idiv") internalNode) [a,b] internalNode-codeGenPrim (AST.PrimMod _) [a,b] = CCall (CVar (internalIdent "mod") internalNode) [a,b] internalNode-codeGenPrim (AST.PrimBAnd _) [a,b] = CBinary CAndOp a b internalNode-codeGenPrim (AST.PrimBOr _) [a,b] = CBinary COrOp a b internalNode-codeGenPrim (AST.PrimBXor _) [a,b] = CBinary CXorOp a b internalNode-codeGenPrim (AST.PrimBNot _) [a] = CUnary CCompOp a internalNode-codeGenPrim (AST.PrimBShiftL _) [a,b] = CBinary CShlOp a b internalNode-codeGenPrim (AST.PrimBShiftR _) [a,b] = CBinary CShrOp a b internalNode-codeGenPrim (AST.PrimBRotateL _) [a,b] = CCall (CVar (internalIdent "rotateL") internalNode) [a,b] internalNode-codeGenPrim (AST.PrimBRotateR _) [a,b] = CCall (CVar (internalIdent "rotateR") internalNode) [a,b] internalNode-codeGenPrim (AST.PrimFDiv _) [a,b] = CBinary CDivOp a b internalNode-codeGenPrim (AST.PrimRecip ty) [a] = codeGenRecip ty a-codeGenPrim (AST.PrimSin ty) [a] = ccall (FloatingNumType ty) "sin" [a]-codeGenPrim (AST.PrimCos ty) [a] = ccall (FloatingNumType ty) "cos" [a]-codeGenPrim (AST.PrimTan ty) [a] = ccall (FloatingNumType ty) "tan" [a]-codeGenPrim (AST.PrimAsin ty) [a] = ccall (FloatingNumType ty) "asin" [a]-codeGenPrim (AST.PrimAcos ty) [a] = ccall (FloatingNumType ty) "acos" [a]-codeGenPrim (AST.PrimAtan ty) [a] = ccall (FloatingNumType ty) "atan" [a]-codeGenPrim (AST.PrimAsinh ty) [a] = ccall (FloatingNumType ty) "asinh" [a]-codeGenPrim (AST.PrimAcosh ty) [a] = ccall (FloatingNumType ty) "acosh" [a]-codeGenPrim (AST.PrimAtanh ty) [a] = ccall (FloatingNumType ty) "atanh" [a]-codeGenPrim (AST.PrimExpFloating ty) [a] = ccall (FloatingNumType ty) "exp" [a]-codeGenPrim (AST.PrimSqrt ty) [a] = ccall (FloatingNumType ty) "sqrt" [a]-codeGenPrim (AST.PrimLog ty) [a] = ccall (FloatingNumType ty) "log" [a]-codeGenPrim (AST.PrimFPow ty) [a,b] = ccall (FloatingNumType ty) "pow" [a,b]-codeGenPrim (AST.PrimLogBase ty) [a,b] = codeGenLogBase ty a b-codeGenPrim (AST.PrimAtan2 ty) [a,b] = ccall (FloatingNumType ty) "atan2" [a,b]-codeGenPrim (AST.PrimLt _) [a,b] = CBinary CLeOp a b internalNode-codeGenPrim (AST.PrimGt _) [a,b] = CBinary CGrOp a b internalNode-codeGenPrim (AST.PrimLtEq _) [a,b] = CBinary CLeqOp a b internalNode-codeGenPrim (AST.PrimGtEq _) [a,b] = CBinary CGeqOp a b internalNode-codeGenPrim (AST.PrimEq _) [a,b] = CBinary CEqOp a b internalNode-codeGenPrim (AST.PrimNEq _) [a,b] = CBinary CNeqOp a b internalNode-codeGenPrim (AST.PrimMax ty) [a,b] = codeGenMax ty a b-codeGenPrim (AST.PrimMin ty) [a,b] = codeGenMin ty a b-codeGenPrim AST.PrimLAnd [a,b] = CBinary CLndOp a b internalNode-codeGenPrim AST.PrimLOr [a,b] = CBinary CLorOp a b internalNode-codeGenPrim AST.PrimLNot [a] = CUnary CNegOp a internalNode-codeGenPrim AST.PrimOrd [a] = CCast (CDecl [CTypeSpec (CIntType internalNode)] [] internalNode) a internalNode-codeGenPrim AST.PrimChr [a] = CCast (CDecl [CTypeSpec (CCharType internalNode)] [] internalNode) a internalNode-codeGenPrim AST.PrimRoundFloatInt [a] = CCall (CVar (internalIdent "lroundf") internalNode) [a] internalNode -- TLM: (int) rintf(x) ??-codeGenPrim AST.PrimTruncFloatInt [a] = CCall (CVar (internalIdent "ltruncf") internalNode) [a] internalNode-codeGenPrim AST.PrimIntFloat [a] = CCast (CDecl [CTypeSpec (CFloatType internalNode)] [] internalNode) a internalNode -- TLM: __int2float_[rn,rz,ru,rd](a) ??-codeGenPrim AST.PrimBoolToInt [a] = CCast (CDecl [CTypeSpec (CIntType internalNode)] [] internalNode) a internalNode+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+-- 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 --- FIXME:--- Language-c isn't pretty printing float constants with a trailing 'f', so as--- per the C spec nvcc considers them to be double constants. This causes--- warnings on pre-1.3 series devices, and unnecessary runtime conversion and--- register pressure on later hardware. Work around this with an explicit type--- cast. This is quite ugly and should be fixed, but appears to work for now.+-- 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 (NumScalarType (IntegralNumType ty))- | IntegralDict <- integralDict ty- = CConst . flip CIntConst internalNode . cInteger . fromIntegral-codeGenScalar (NumScalarType (FloatingNumType (TypeFloat _)))- = flip (CCast (CDecl [CTypeSpec (CFloatType internalNode)] [] internalNode)) internalNode- . CConst . flip CFloatConst internalNode . cFloat . fromRational . toRational-codeGenScalar (NumScalarType (FloatingNumType (TypeDouble _)))- = CConst . flip CFloatConst internalNode . cFloat . fromRational . toRational-codeGenScalar (NumScalarType (FloatingNumType (TypeCFloat _)))- = flip (CCast (CDecl [CTypeSpec (CFloatType internalNode)] [] internalNode)) internalNode- . CConst . flip CFloatConst internalNode . cFloat . fromRational . toRational-codeGenScalar (NumScalarType (FloatingNumType (TypeCDouble _)))- = CConst . flip CFloatConst internalNode . cFloat . fromRational . toRational-codeGenScalar (NonNumScalarType (TypeBool _)) = fromBool-codeGenScalar (NonNumScalarType (TypeChar _)) =- CConst . flip CCharConst internalNode . cChar-codeGenScalar (NonNumScalarType (TypeCChar _)) =- CConst . flip CCharConst internalNode . cChar . chr . fromIntegral-codeGenScalar (NonNumScalarType (TypeCUChar _)) =- CConst . flip CCharConst internalNode . cChar . chr . fromIntegral-codeGenScalar (NonNumScalarType (TypeCSChar _)) =- CConst . flip CCharConst internalNode . cChar . chr . fromIntegral+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+codeGenPi ty+ | FloatingDict <- floatingDict ty = codeGenScalar (NumScalarType (FloatingNumType ty)) pi +-- Constant methods of bounded+ codeGenMinBound :: BoundedType a -> CExpr codeGenMinBound (IntegralBoundedType ty) | IntegralDict <- integralDict ty@@ -495,10 +564,11 @@ | 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 "abs" [x]-codeGenAbs ty@(FloatingNumType _) x = ccall ty "fabs" [x]+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@@ -519,31 +589,69 @@ = CBinary CDivOp (codeGenScalar (NumScalarType (FloatingNumType ty)) 1) x internalNode codeGenLogBase :: FloatingType a -> CExpr -> CExpr -> CExpr-codeGenLogBase ty x y = let a = ccall (FloatingNumType ty) "log" [x]- b = ccall (FloatingNumType ty) "log" [y]+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 "min" [a,b]-codeGenMin (NumScalarType ty@(FloatingNumType _)) a b = ccall ty "fmin" [a,b]-codeGenMin (NonNumScalarType _) _ _ = undefined+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 "max" [a,b]-codeGenMax (NumScalarType ty@(FloatingNumType _)) a b = ccall ty "fmax" [a,b]-codeGenMax (NonNumScalarType _) _ _ = undefined+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) --- Helper Functions--- ~~~~~~~~~~~~~~~~+-- Type coercions -ccall :: NumType a -> String -> [CExpr] -> CExpr-ccall (IntegralNumType _) fn args = CCall (CVar (internalIdent fn) internalNode) args internalNode-ccall (FloatingNumType ty) fn args = CCall (CVar (internalIdent (fn `postfix` ty)) internalNode) args internalNode- where- postfix :: String -> FloatingType a -> String- postfix x (TypeFloat _) = x ++ "f"- postfix x (TypeCFloat _) = x ++ "f"- postfix x _ = x+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 view
@@ -1,6 +1,6 @@ -- | -- Module : Data.Array.Accelerate.CUDA.CodeGen.Data--- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell+-- 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>@@ -12,7 +12,7 @@ module Data.Array.Accelerate.CUDA.CodeGen.Data (- CType, CUTranslSkel(..)+ CType, CMacro, CUTranslSkel(..) ) where @@ -20,15 +20,22 @@ import Text.PrettyPrint type CType = [CTypeSpec]-data CUTranslSkel = CUTranslSkel CTranslUnit FilePath+type CMacro = (Ident, Maybe CExpr)+data CUTranslSkel = CUTranslSkel CTranslUnit [CMacro] FilePath instance Pretty CUTranslSkel where- pretty (CUTranslSkel code skel) =+ pretty (CUTranslSkel code defs skel) = vcat [ include "accelerate_cuda_extras.h"+ , vcat (map macro defs) , pretty code- , include skel ]+ , include skel+ ] -include :: String -> Doc+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 view
@@ -1,6 +1,6 @@ -- | -- Module : Data.Array.Accelerate.CUDA.CodeGen.Skeleton--- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell+-- 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>@@ -12,51 +12,102 @@ module Data.Array.Accelerate.CUDA.CodeGen.Skeleton (- mkFold, mkFoldSeg, mkMap, mkZipWith, mkScanl, mkScanr,+ 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] -> [CExpr] -> [CExpr] -> CUTranslSkel-mkFold ty identity apply = CUTranslSkel code skel+mkFold :: ([CType],Int) -> [CExpr] -> [CExpr] -> CUTranslSkel+mkFold (ty,dim) identity apply = CUTranslSkel code [] skel where- skel = "fold.inl"+ skel | dim == 1 = "foldAll.inl"+ | otherwise = "fold.inl" code = CTranslUnit ( mkTupleTypeAsc 2 ty ++- [ mkTuplePartition ty+ [ mkTuplePartition "ArrOut" ty True , mkIdentity identity- , mkApply 2 apply ])+ , mkApply 2 apply+ , mkDim "DimIn0" dim+ , mkDim "DimOut" (dim-1) ]) (mkNodeInfo (initPos skel) (Name 0)) -mkFoldSeg :: [CType] -> [CType] -> [CExpr] -> [CExpr] -> CUTranslSkel-mkFoldSeg ty int identity apply = CUTranslSkel code skel+mkFold1 :: ([CType],Int) -> [CExpr] -> CUTranslSkel+mkFold1 (ty,dim) apply = CUTranslSkel code inc skel where- skel = "fold_segmented.inl"+ skel | dim == 1 = "foldAll.inl"+ | otherwise = "fold.inl"+ inc = [(internalIdent "INCLUSIVE", Just (fromBool True))] code = CTranslUnit ( mkTupleTypeAsc 2 ty ++- [ mkTuplePartition ty- , mkTypedef "Int" False (head int)+ [ 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 ])+ , 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+mkMap tyOut tyIn0 apply = CUTranslSkel code [] skel where skel = "map.inl" code = CTranslUnit@@ -66,8 +117,8 @@ (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+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@@ -81,48 +132,103 @@ (mkNodeInfo (initPos skel) (Name 0)) ------------------------------------------------------------------------------------ Scan---------------------------------------------------------------------------------+-- Stencil+-- ------- -mkScan :: Bool -> [CType] -> [CExpr] -> [CExpr] -> CUTranslSkel-mkScan isBackward ty identity apply =- CUTranslSkel code skel+mkStencil :: ([CType], Int)+ -> [CExtDecl] -> [CType] -> [[Int]] -> Boundary [CExpr]+ -> [CExpr]+ -> CUTranslSkel+mkStencil (tyOut, dim) stencil0 tyIn0 ixs0 boundary0 apply = CUTranslSkel code [] skel where- skel | length ty == 1 = "thrust" </> "scan_safe.inl" -- TODO: use fast scan for primitive types- | otherwise = "thrust" </> "scan_safe.inl"+ 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- , mkFlag "reverse" (fromBool isBackward) ])+ , 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 :: [CType] -> [CExpr] -> [CExpr] -> CUTranslSkel-mkScanl = mkScan False+mkScanl, mkScanr :: [CType] -> [CExpr] -> [CExpr] -> CUTranslSkel+mkScanl = mkExclusiveScan False True+mkScanr = mkExclusiveScan True True -mkScanr :: [CType] -> [CExpr] -> [CExpr] -> CUTranslSkel-mkScanr = mkScan True+mkScanl', mkScanr' :: [CType] -> [CExpr] -> [CExpr] -> CUTranslSkel+mkScanl' = mkExclusiveScan False False+mkScanr' = mkExclusiveScan True False --- TLM 2010-06-30:--- Test whether the compiler will use this to avoid branching----mkFlag :: String -> CExpr -> CExtDecl-mkFlag name val =- CDeclExt (CDecl- [CTypeQual (CAttrQual (CAttr (internalIdent "device") [] internalNode)), CStorageSpec (CStatic internalNode), CTypeQual (CConstQual internalNode), CTypeSpec (CIntType internalNode)]- [(Just (CDeclr (Just (internalIdent name)) [] Nothing [] internalNode),Just (CInitExpr val internalNode),Nothing)]- internalNode)+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+mkPermute ty dimOut dimIn0 combinefn indexfn = CUTranslSkel code [] skel where skel = "permute.inl" code = CTranslUnit@@ -134,7 +240,7 @@ (mkNodeInfo (initPos skel) (Name 0)) mkBackpermute :: [CType] -> Int -> Int -> [CExpr] -> CUTranslSkel-mkBackpermute ty dimOut dimIn0 indexFn = CUTranslSkel code skel+mkBackpermute ty dimOut dimIn0 indexFn = CUTranslSkel code [] skel where skel = "backpermute.inl" code = CTranslUnit@@ -145,12 +251,11 @@ (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+mkIndex ty dimSl dimCo dimIn0 slix = CUTranslSkel code [] skel where skel = "slice.inl" code = CTranslUnit@@ -163,13 +268,13 @@ mkReplicate :: [CType] -> Int -> Int -> [CExpr] -> CUTranslSkel-mkReplicate ty dimSl dimOut slix = CUTranslSkel code skel+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))+ ( mkTupleTypeAsc 1 ty +++ [ mkDim "Slice" dimSl+ , mkDim "SliceDim" dimOut+ , mkSliceReplicate slix ])+ (mkNodeInfo (initPos skel) (Name 0))
+ Data/Array/Accelerate/CUDA/CodeGen/Stencil.hs view
@@ -0,0 +1,124 @@+-- |+-- 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 view
@@ -1,6 +1,6 @@ -- | -- Module : Data.Array.Accelerate.CUDA.CodeGen.Tuple--- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell+-- 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>@@ -8,9 +8,13 @@ -- Portability : non-partable (GHC extensions) -- -module Data.Array.Accelerate.CUDA.CodeGen.Tuple (mkTupleType, mkTupleTypeAsc, mkTuplePartition)+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@@ -20,11 +24,12 @@ 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 (head ty), mkTypedef ("Arr" ++ base) True (head ty)]- | otherwise = [ mkStruct ("Ty" ++ base) False ty, mkStruct ("Arr" ++ base) True ty]+ | 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.@@ -32,13 +37,13 @@ mkTupleTypeAsc :: Int -> [CType] -> [CExtDecl] mkTupleTypeAsc syn ty = types ++ synonyms ++ [mkSet n, mkGet n 0] where- n = length ty+ n = length ty synonyms = concat . take syn . flip map ([0..] :: [Int]) $ \v ->- [ mkTypedef ("TyIn" ++ show v) False [CTypeDef (internalIdent "TyOut") internalNode]- , mkTypedef ("ArrIn" ++ show v) False [CTypeDef (internalIdent "ArrOut") internalNode] ]+ [ 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 (head ty), mkTypedef "ArrOut" True (head ty)]- | otherwise = [ mkStruct "TyOut" False ty, mkStruct "ArrOut" True ty]+ | 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@@ -86,21 +91,22 @@ 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 :: [CType] -> CExtDecl-mkTuplePartition ty =+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 "ArrOut") internalNode)]+ [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 "ArrOut") internalNode)] [(Just (CDeclr (Just (internalIdent "r")) [] Nothing [] internalNode),Just initp,Nothing)] internalNode) ,CBlockStmt (CReturn (Just (CVar (internalIdent "r") internalNode)) internalNode)]) 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)- stmts = zipWith (\l r -> CBlockDecl (CDecl (map CTypeSpec l) r internalNode)) ty+ 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+ $ var "s_data" : map (\v -> CUnary CAdrOp (CIndex (var v) (CVar (internalIdent "n") internalNode) internalNode) internalNode) names
Data/Array/Accelerate/CUDA/CodeGen/Util.hs view
@@ -1,6 +1,6 @@ -- | -- Module : Data.Array.Accelerate.CUDA.CodeGen.Util--- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell+-- 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>@@ -16,9 +16,8 @@ data Direction = Forward | Backward --------------------------------------------------------------------------------- -- Common device functions---------------------------------------------------------------------------------+-- ----------------------- mkIdentity :: [CExpr] -> CExtDecl mkIdentity = mkDeviceFun "identity" (typename "TyOut") []@@ -26,7 +25,7 @@ mkApply :: Int -> [CExpr] -> CExtDecl mkApply argc = mkDeviceFun "apply" (typename "TyOut")- $ map (\n -> (typename ("TyIn"++show n), 'x':show n)) [argc-1,argc-2..0]+ $ 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")]@@ -41,10 +40,15 @@ 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] @@ -54,15 +58,26 @@ mkDim :: String -> Int -> CExtDecl mkDim name n =- mkTypedef name False [CTypeDef (internalIdent ("DIM" ++ show n)) internalNode]+ mkTypedef name False False [CTypeDef (internalIdent ("DIM" ++ show n)) internalNode] -mkTypedef :: String -> Bool -> CType -> CExtDecl-mkTypedef var ptr ty =+mkTypedef :: String -> Bool -> Bool -> CType -> CExtDecl+mkTypedef var volatile ptr ty = CDeclExt $ CDecl- (CStorageSpec (CTypedef internalNode) : map CTypeSpec ty)+ (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@@ -70,21 +85,21 @@ -- typedef struct {--- ... ty1 (*?) a1; ty0 (*?) a0;+-- ... (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 -> [CType] -> CExtDecl-mkStruct name ptr types =+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 (map CTypeSpec ty)+ 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 @@ -112,11 +127,24 @@ -- 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 [] [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)] internalNode)+ (CCompound [] body internalNode) internalNode where argv = flip map args $ \(ty,var) ->
Data/Array/Accelerate/CUDA/Compile.hs view
@@ -1,7 +1,8 @@-{-# LANGUAGE GADTs #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE BangPatterns, CPP, GADTs, TupleSections, TypeSynonymInstances #-} -- | -- Module : Data.Array.Accelerate.CUDA.Compile--- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell+-- 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>@@ -9,167 +10,639 @@ -- Portability : non-partable (GHC extensions) -- -module Data.Array.Accelerate.CUDA.Compile (compileAcc)- where+module Data.Array.Accelerate.CUDA.Compile ( -import Prelude hiding (id, (.), mod)-import Control.Category+ -- * Types parameterising our annotated computation form+ ExecAcc, ExecOpenAcc(..),+ AccKernel, AccRefcount(..), -import Data.Maybe-import Control.Monad-import Control.Monad.IO.Class-import Control.Exception-import Control.Applicative hiding (Const)-import Language.C-import Text.PrettyPrint-import qualified Data.HashTable as HT+ -- * generate and compile kernels to realise a computation+ compileAcc, compileAfun1 -import System.Directory-import System.FilePath-import System.Posix.Process-import System.IO+) where -import Data.Array.Accelerate.AST+#include "accelerate.h"++-- friends+import Data.Array.Accelerate.Type import Data.Array.Accelerate.Tuple-import Data.Array.Accelerate.Array.Representation-import Data.Array.Accelerate.Array.Sugar (Array(..))+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 -import Foreign.CUDA.Analysis.Device+-- 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) --- | Initiate code generation, compilation, and data transfer for an array--- expression+-- A binary object that will be used to execute a kernel ---compileAcc :: OpenAcc aenv a -> CIO ()-compileAcc (Use (Array sh ad)) =- let n = size sh- in when (n > 0) $ do- mallocArray ad n- pokeArrayAsync ad n Nothing+type AccKernel a = (String, CIO CUDA.Module) -compileAcc (Let a1 a2) = compileAcc a1 >> compileAcc a2-compileAcc (Let2 a1 a2) = compileAcc a1 >> compileAcc a2-compileAcc (Avar _) = return ()-compileAcc (Unit e1) = compileExp e1-compileAcc (Reshape e1 a1) = compileExp e1 >> compileAcc a1+noKernel :: AccKernel a+noKernel = INTERNAL_ERROR(error) "ExecAcc" "no kernel module for this node" -compileAcc op@(Replicate _ e1 a1) = compileExp e1 >> compileAcc a1 >> compile op-compileAcc op@(Index _ a1 e1) = compileAcc a1 >> compileExp e1 >> compile op-compileAcc op@(Map f1 a1) = compileFun f1 >> compileAcc a1 >> compile op-compileAcc op@(ZipWith f1 a1 a2) = compileFun f1 >> compileAcc a1 >> compileAcc a2 >> compile op-compileAcc op@(Fold f1 e1 a1) = compileFun f1 >> compileExp e1 >> compileAcc a1 >> compile op-compileAcc op@(Scanl f1 e1 a1) = compileFun f1 >> compileExp e1 >> compileAcc a1 >> compile op-compileAcc op@(Scanr f1 e1 a1) = compileFun f1 >> compileExp e1 >> compileAcc a1 >> compile op-compileAcc op@(Backpermute e1 f1 a1) = compileExp e1 >> compileFun f1 >> compileAcc a1 >> compile op-compileAcc op@(Permute f1 a1 f2 a2) = compileFun f1 >> compileAcc a1 >> compileFun f2 >> compileAcc a2 >> compile op-compileAcc op@(FoldSeg f1 e1 a1 a2) = compileFun f1 >> compileExp e1 >> compileAcc a1 >> compileAcc a2 >> compile op-compileAcc (Stencil _ _ _) = - error "D.A.Accelerate.CUDA.Compile: the CUDA backend does not support 'stencil' operations yet"-compileAcc (Stencil2 _ _ _ _ _) = - error "D.A.Accelerate.CUDA.Compile: the CUDA backend does not support 'stencil2' operations yet"+-- 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) --- | Lift array expressions out of closed functions for code generation+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. ---compileFun :: OpenFun env aenv t -> CIO ()-compileFun (Body e) = compileExp e-compileFun (Lam f) = compileFun f+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) --- | Lift array computations out of scalar expressions for code generation. The--- array expression must not contain any free scalar variables.++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 ---compileExp :: OpenExp env aenv a -> CIO ()-compileExp (Tuple t) = compileTup t-compileExp (Prj _ e1) = compileExp e1-compileExp (PrimApp _ e1) = compileExp e1-compileExp (Cond e1 e2 e3) = compileExp e1 >> compileExp e2 >> compileExp e3-compileExp (IndexScalar a1 e1) = compileAcc a1 >> compileExp e1-compileExp (Shape a1) = compileAcc a1-compileExp _ = return ()+data ExecOpenAcc aenv a where+ ExecAfun :: AccRefcount -- reference count attached to an enclosed lambda+ -> PreOpenAfun ExecOpenAcc () t+ -> ExecOpenAcc aenv t -compileTup :: Tuple (OpenExp env aenv) a -> CIO ()-compileTup NilTup = return ()-compileTup (t `SnocTup` e) = compileExp e >> compileTup 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 --- | Generate and compile code for a single open array expression+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. ---compile :: OpenAcc aenv a -> CIO ()-compile acc = do- let key = accToKey acc- table <- getM kernelTable- compiled <- isJust <$> liftIO (HT.lookup table key)- unless compiled $ do- nvcc <- fromMaybe (error "nvcc: command not found") <$> liftIO (findExecutable "nvcc")- dir <- getM outputDir- cufile <- outputName acc (dir </> "dragon.cu") -- here be dragons!- flags <- compileFlags cufile- pid <- liftIO . withFilePath dir $ do- writeCode cufile (codeGenAcc acc)- forkProcess $ executeFile nvcc False flags Nothing+-- 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 - liftIO $ HT.insert table key (KernelEntry cufile (Left pid)) +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')) --- Write the generated code to file+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+ --+ Let2 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 (Let2 a' b'), env')++ Let2 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 (Let2 a' b'), env1)++ Let2 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 (Let2 (setref (R2 c1 c0) a') b'), env2)++ -- Let bindings to a single computation+ --+ Let a b | Let2 x y <- unAcc a+ , Avar u <- unAcc x+ , Avar v <- unAcc y ->+ let a' = node (Let2 (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 (Let a' b'), env1)++ Let a b | Let2 _ y <- unAcc a+ , Avar v <- unAcc y -> do+ (ExecAcc _ _ _ (Let2 x' y'), env1) <- travA a aenv+ (b', env2 `Push` Right (R1 c)) <- travA b (env1 `Push` Right (R1 0))+ --+ let a' = node (Let2 (setref (eitherIx v (R2 c 0) (R2 0 c)) x') y')+ return (node (Let a' b'), env2)++ Let a b | Let _ _ <- unAcc a -> do+ (ExecAcc _ _ _ (Let x' y'), env1) <- travA a aenv+ (b', env2 `Push` Right c) <- travA b (env1 `Push` Right (R1 0))+ return (node (Let (node (Let x' (setref c y'))) b'), env2)++ Let a b -> do+ (a', env1) <- travA a aenv+ (b', env2 `Push` Right c) <- travA b (env1 `Push` Right rc)+ return (node (Let (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+ 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. ---writeCode :: FilePath -> CUTranslSkel -> IO ()-writeCode f code =- withFile f WriteMode $ \hdl ->- printDoc PageMode hdl (pretty code)+-- 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 --- stolen from $fptools/ghc/compiler/utils/Pretty.lhs++-- 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. ----- This code has a BSD-style license+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 ---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+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)) - done = hPutChar hdl '\n'- cols = 100 +-- 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++-- 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 = do- arch <- computeCapability <$> getM deviceProps+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.", "-I", ddir </> "cubits"+ return [ "-I", ddir </> "cubits" , "-O2", "--compiler-options", "-fno-strict-aliasing" , "-arch=sm_" ++ show (round (arch * 10) :: Int) , "-DUNIX" , "-cubin"- , takeFileName cufile ]----- Execute the IO action under the given directory----withFilePath :: FilePath -> IO a -> IO a-withFilePath fp action =- bracket getCurrentDirectory setCurrentDirectory . const $ do- setCurrentDirectory fp- action+ , "-o", cufile `replaceExtension` "cubin"+ , machine+ , cufile ] --- Return the output filename of the generated CUDA code------ In future, we hope that this is a unique filename based on the function--- itself, but for now it is just a unique filename.+-- Return a unique output filename for the generated CUDA code -- outputName :: OpenAcc aenv a -> FilePath -> CIO FilePath outputName acc cufile = do@@ -181,4 +654,75 @@ (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+ Let _ _ -> base+ Let2 _ _ -> 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 (idxToInt ix))
Data/Array/Accelerate/CUDA/Execute.hs view
@@ -1,479 +1,835 @@-{-# LANGUAGE CPP, GADTs, TupleSections #-}--- |--- Module : Data.Array.Accelerate.CUDA.Execute--- Copyright : [2008..2010] 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 (executeAcc)- where--import Prelude hiding (id, (.), sum)-import Control.Category--import Data.Maybe-import Control.Monad-import Control.Monad.Trans-import Control.Applicative hiding (Const)-import qualified Data.HashTable as HT--import System.FilePath-import System.Posix.Process-import System.Exit (ExitCode(..))-import System.Posix.Types (ProcessID)-import Text.PrettyPrint--import Data.Array.Accelerate.AST-import Data.Array.Accelerate.Tuple-import Data.Array.Accelerate.Array.Data-import Data.Array.Accelerate.Array.Representation hiding (sliceIndex)-import Data.Array.Accelerate.Array.Sugar (Array(..))-import qualified Data.Array.Accelerate.Array.Sugar as Sugar-import qualified Data.Array.Accelerate.Interpreter as I--import Data.Array.Accelerate.CUDA.State-import Data.Array.Accelerate.CUDA.Array.Data-import Data.Array.Accelerate.CUDA.Analysis.Hash-import Data.Array.Accelerate.CUDA.Analysis.Launch--import qualified Foreign.CUDA.Driver as CUDA--#include "accelerate.h"----- Expression evaluation--- ~~~~~~~~~~~~~~~~~~~~~---- Evaluate a closed scalar expression. Expressions are evaluated on the host,--- but may require some interaction with the device (such as array indexing).------ TLM 2010-07-13:--- We sneakily use the Interpreter backend for primitive operations, but maybe--- we don't want to...?----executeExp :: Exp aenv t -> Val aenv -> CIO t-executeExp e = executeOpenExp e Empty--executeOpenExp :: OpenExp env aenv t -> Val env -> Val aenv -> CIO t-executeOpenExp (Var idx) env _ = return . Sugar.toElem $ prj idx env-executeOpenExp (Const c) _ _ = return $ Sugar.toElem c-executeOpenExp (PrimConst c) _ _ = return $ I.evalPrimConst c-executeOpenExp (PrimApp fun arg) env aenv = I.evalPrim fun <$> executeOpenExp arg env aenv-executeOpenExp (Prj idx e) env aenv = I.evalPrj idx . fromTuple <$> executeOpenExp e env aenv-executeOpenExp (Tuple tup) env aenv = toTuple <$> executeTuple tup env aenv-executeOpenExp (IndexScalar a e) env aenv = do- (Array sh ad) <- executeOpenAcc a aenv- ix <- executeOpenExp e env aenv- Sugar.toElem <$> ad `indexArray` index sh (Sugar.fromElem ix)--executeOpenExp (Shape a) _ aenv = do- (Array sh _) <- executeOpenAcc a aenv- return (Sugar.toElem 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---executeTuple :: Tuple (OpenExp env aenv) t -> Val env -> Val aenv -> CIO t-executeTuple NilTup _ _ = return ()-executeTuple (tup `SnocTup` e) env aenv = (,) <$> executeTuple tup env aenv <*> executeOpenExp e env aenv----- Array evaluation--- ~~~~~~~~~~~~~~~---- | Execute a closed array expression----executeAcc :: Acc a -> CIO a-executeAcc acc = executeOpenAcc acc Empty---- |--- Execute an embedded array program using the CUDA backend. The function will--- block if the compilation has not yet completed, but subsequent invocations of--- the same kernel will be able to extract the loaded kernel directly.----executeOpenAcc :: OpenAcc aenv a -> Val aenv -> CIO a-executeOpenAcc (Use xs) _env = return xs-executeOpenAcc (Avar ix) env = return $ prj ix env-executeOpenAcc (Let x y) env = do- ax <- executeOpenAcc x env- executeOpenAcc y (env `Push` ax)--executeOpenAcc (Let2 x y) env = do- (ax1,ax2) <- executeOpenAcc x env- executeOpenAcc y (env `Push` ax1 `Push` ax2)--executeOpenAcc (Reshape e a) env = do- ix <- executeExp e env- (Array sh ad) <- executeOpenAcc a env- BOUNDS_CHECK(check) "reshape" "shape mismatch" (Sugar.size ix == size sh)- $ return (Array (Sugar.fromElem ix) ad)--executeOpenAcc (Unit e) env = do- v <- executeExp e env- let ad = fst . runArrayData $ (,undefined) <$> do- arr <- newArrayData 1024 -- FIXME: small arrays moved by the GC- writeArrayData arr 0 (Sugar.fromElem v)- return arr- mallocArray ad 1- pokeArrayAsync ad 1 Nothing- return (Array (Sugar.fromElem ()) ad)---executeOpenAcc acc env = do- tab <- getM kernelTable- krn <- fromMaybe (error "code generation failed") <$> liftIO (HT.lookup tab key)- mdl <- either' (getL kernelStatus krn) return $ \pid -> do- liftIO (waitFor pid)- mdl <- liftIO $ CUDA.loadFile (getL kernelName krn `replaceExtension` ".cubin")- liftIO $ HT.insert tab key (setL kernelStatus (Right mdl) krn)- return mdl-- -- determine dispatch pattern, extract parameters, allocate storage, run- --- dispatch acc env mdl-- where- key = accToKey acc- either' e r l = either l r e----- Dispatch--- ~~~~~~~~--data FVar where- FArr :: Array dim e -> FVar---- Lift free array variables out of scalar computations. Returns a list of the--- arrays in the order that they are encountered, which also corresponds to the--- texture reference index they should be bound to.----liftFun :: OpenFun env aenv a -> Val aenv -> CIO [FVar]-liftFun (Body e) = liftExp e-liftFun (Lam f) = liftFun f--liftExp :: OpenExp env aenv a -> Val aenv -> CIO [FVar]-liftExp (Tuple t) aenv = liftTup t aenv-liftExp (Prj _ e) aenv = liftExp e aenv-liftExp (PrimApp _ e) aenv = liftExp e aenv-liftExp (Cond e1 e2 e3) aenv = concat <$> sequence [liftExp e1 aenv, liftExp e2 aenv, liftExp e3 aenv]-liftExp (IndexScalar a e) aenv = (:) . FArr <$> executeOpenAcc a aenv <*> liftExp e aenv-liftExp _ _ =- return []--liftTup :: Tuple (OpenExp env aenv) a -> Val aenv -> CIO [FVar]-liftTup NilTup _ = return []-liftTup (t `SnocTup` e) aenv = (++) <$> liftTup t aenv <*> liftExp e aenv----- Extract texture references from the compiled module and bind an array to it----bind :: CUDA.Module -> [FVar] -> CIO [CUDA.FunParam]-bind mdl var =- let tex n (FArr (Array sh ad)) = textureRefs ad mdl (size sh) n- in foldM (\texs farr -> (texs ++) <$> tex (length texs) farr) [] var--release :: [FVar] -> CIO ()-release = mapM_ (\(FArr (Array _ ad)) -> freeArray ad)----- Setup and initiate the computation. This may require several kernel launches.------ A NOTE ON TUPLES TYPES------ The astute reader may be wondering, if arrays of tuples are stored as a--- tuple of arrays, how exactly are we telling the kernel function about this?------ From Haskell land, the tuple components are passed to the kernel function--- individually. The C function, however, interprets these into a structure of--- pointers. While this is a nasty sleight-of-hand, it should indeed be safe.--- Pointer types will all have the same size and alignment, and C structures--- are defined to keep their fields adjacent in memory (modulo alignment--- restrictions, which don't concern us).----dispatch :: OpenAcc aenv a -> Val aenv -> CUDA.Module -> CIO a-dispatch acc@(Map f ad) env mdl = do- fn <- liftIO $ CUDA.getFun mdl "map"- (Array sh in0) <- executeOpenAcc ad env- let res@(Array sh' out) = newArray (Sugar.toElem sh)- n = size sh'-- mallocArray out n- d_out <- devicePtrs out- d_in0 <- devicePtrs in0- f_var <- liftFun f env- t_var <- bind mdl f_var-- launch acc n fn (d_out ++ d_in0 ++ t_var ++ [CUDA.IArg n])- freeArray in0- release f_var- return res--dispatch acc@(ZipWith f ad1 ad0) env mdl = do- fn <- liftIO $ CUDA.getFun mdl "zipWith"- (Array sh1 in1) <- executeOpenAcc ad1 env- (Array sh0 in0) <- executeOpenAcc ad0 env- let res@(Array sh' out) = newArray (Sugar.toElem (sh0 `intersect` sh1))- n = size sh'-- mallocArray out n- d_out <- devicePtrs out- d_in1 <- devicePtrs in1- d_in0 <- devicePtrs in0- f_var <- liftFun f env- t_var <- bind mdl f_var-- launch acc n fn (d_out ++ d_in1 ++ d_in0 ++ t_var ++ convertIx sh' ++ convertIx sh1 ++ convertIx sh0)- freeArray in0- freeArray in1- release f_var- return res--dispatch acc@(Fold f x ad) env mdl = do- fn <- liftIO $ CUDA.getFun mdl "fold"- (Array sh in0) <- executeOpenAcc ad env- (cta,grid,smem) <- launchConfig acc (size sh) fn- let res@(Array _ out) = newArray grid-- mallocArray out grid- d_out <- devicePtrs out- d_in0 <- devicePtrs in0- f_arr <- (++) <$> liftExp x env <*> liftFun f env- t_var <- bind mdl f_arr-- launch' (cta,grid,smem) fn (d_out ++ d_in0 ++ t_var ++ [CUDA.IArg (size sh)])- freeArray in0- release f_arr- if grid > 1 then dispatch (Fold f x (Use res)) env mdl- else return (Array (Sugar.fromElem ()) out)--dispatch acc@(FoldSeg f x ad sd) env mdl = do- fn <- liftIO $ CUDA.getFun mdl "fold_segmented"- (Array sh in0) <- executeOpenAcc ad env- (Array sh' seg) <- executeOpenAcc sd env- (cta,grid,smem) <- launchConfig acc (size sh') fn- let res@(Array _ out) = newArray (size sh')-- mallocArray out (size sh')- d_out <- devicePtrs out- d_in0 <- devicePtrs in0- d_seg <- devicePtrs seg- f_arr <- (++) <$> liftExp x env <*> liftFun f env- t_var <- bind mdl f_arr-- launch' (cta,grid,smem) fn (d_out ++ d_in0 ++ d_seg ++ t_var ++ map (CUDA.IArg . size) [sh', sh])- freeArray in0- freeArray seg- release f_arr- return res---- Unified dispatch handler for left/right scan.------ TLM 2010-07-02:--- This is a little awkward. At its core we have an inclusive scan routine,--- whereas accelerate actually returns an exclusive scan result. Multi-block--- arrays require the inclusive scan when calculating the partial block sums,--- which are then added to every element of an interval. Single-block arrays--- on the other hand need to be "converted" to an exclusive result in the--- second pass.------ This optimised could be implemented by enabling some some extra code to the--- skeleton, and dispatching accordingly.------ TLM 2010-08-19:--- On the other hand, the inclusive scan core provides a way in which we could--- add support for non-identic seed elements.----dispatch (Scanr f x ad) env mdl = dispatch (Scanl f x ad) env mdl-dispatch acc@(Scanl f x ad) env mdl = do- fscan <- liftIO $ CUDA.getFun mdl "inclusive_scan"- fadd <- liftIO $ CUDA.getFun mdl "exclusive_update"- (Array sh in0) <- executeOpenAcc ad env- (cta,grid,smem) <- launchConfig acc (size sh) fscan- let a_out@(Array _ out) = newArray (Sugar.toElem sh)- a_sum@(Array _ sum) = newArray ()- a_bks@(Array _ bks) = newArray grid- n = size sh- interval = (n + grid - 1) `div` grid-- unify :: Array dim e -> Array dim e -> CIO ()- unify _ _ = return ()-- unify a_out a_bks -- TLM: *cough*-- mallocArray out n- mallocArray sum 1- mallocArray bks grid- d_out <- devicePtrs out- d_in0 <- devicePtrs in0- d_bks <- devicePtrs bks- d_sum <- devicePtrs sum- f_arr <- (++) <$> liftExp x env <*> liftFun f env- t_var <- bind mdl f_arr-- launch' (cta,grid,smem) fscan (d_out ++ d_in0 ++ d_bks ++ t_var ++ map CUDA.IArg [n,interval])- launch' (cta,1,smem) fscan (d_bks ++ d_bks ++ d_sum ++ map CUDA.IArg [grid,interval])- launch' (cta,grid,smem) fadd (d_out ++ d_bks ++ map CUDA.IArg [n,interval])-- freeArray in0- freeArray bks- release f_arr- return (a_out, a_sum)--dispatch acc@(Permute f1 df f2 ad) env mdl = do- fn <- liftIO $ CUDA.getFun mdl "permute"- (Array sh def) <- executeOpenAcc df env- (Array sh0 in0) <- executeOpenAcc ad env- let res@(Array _ out) = newArray (Sugar.toElem sh)- n = size sh0-- mallocArray out n- copyArray def out n- d_out <- devicePtrs out- d_in0 <- devicePtrs in0- f_arr <- (++) <$> liftFun f1 env <*> liftFun f2 env- t_var <- bind mdl f_arr-- launch acc n fn (d_out ++ d_in0 ++ t_var ++ convertIx sh ++ convertIx sh0)- freeArray def- freeArray in0- release f_arr- return res--dispatch acc@(Backpermute e f ad) env mdl = do- fn <- liftIO $ CUDA.getFun mdl "backpermute"- sh <- executeExp e env- (Array sh0 in0) <- executeOpenAcc ad env- let res@(Array sh' out) = newArray sh- n = size sh'-- mallocArray out n- d_out <- devicePtrs out- d_in0 <- devicePtrs in0- f_arr <- liftFun f env- t_var <- bind mdl f_arr-- launch acc n fn (d_out ++ d_in0 ++ t_var ++ convertIx sh' ++ convertIx sh0)- freeArray in0- release f_arr- return res--dispatch acc@(Replicate sliceIndex e ad) env mdl = do- fn <- liftIO $ CUDA.getFun mdl "replicate"- slix <- executeExp e env- (Array sh0 in0) <- executeOpenAcc ad env-- let block = extend sliceIndex (Sugar.fromElem slix) sh0- res@(Array sh' out) = newArray (Sugar.toElem block)- n = size sh'-- 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)-- mallocArray out n- d_out <- devicePtrs out- d_in0 <- devicePtrs in0- f_arr <- liftExp e env- t_var <- bind mdl f_arr-- launch acc n fn (d_out ++ d_in0 ++ t_var ++ convertIx sh0 ++ convertIx sh')- freeArray in0- release f_arr- return res--dispatch acc@(Index sliceIndex ad e) env mdl = do- fn <- liftIO $ CUDA.getFun mdl "slice"- slix <- executeExp e env- (Array sh0 in0) <- executeOpenAcc ad env- let slice = restrict sliceIndex (Sugar.fromElem slix) sh0- slix' = convertSliceIndex sliceIndex (Sugar.fromElem slix)- res@(Array sh' out) = newArray (Sugar.toElem slice)- n = size sh'-- 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-- mallocArray out n- d_out <- devicePtrs out- d_in0 <- devicePtrs in0- f_arr <- liftExp e env- t_var <- bind mdl f_arr-- launch acc n fn (d_out ++ d_in0 ++ t_var ++ convertIx sh' ++ slix' ++ convertIx sh0)- freeArray in0- release f_arr- return res--dispatch x _ _ =- INTERNAL_ERROR(error) "dispatch"- (unlines ["unsupported array primitive", render . nest 2 $ text (show x)])----- Initiate the device computation. The first version selects launch parameters--- automatically, the second requires them explicitly. This tuple contains--- threads per block, grid size, and dynamic shared memory, respectively.----launch :: OpenAcc aenv a -> Int -> CUDA.Fun -> [CUDA.FunParam] -> CIO ()-launch acc n fn args =- launchConfig acc n fn >>= \cfg ->- launch' cfg fn args--launch' :: (Int,Int,Integer) -> CUDA.Fun -> [CUDA.FunParam] -> CIO ()-launch' (cta,grid,smem) fn args =- liftIO $ do- CUDA.setParams fn args- CUDA.setSharedSize fn smem- CUDA.setBlockShape fn (cta,1,1)- CUDA.launch fn (grid,1) Nothing----- Create a new array (obviously...)----{-# INLINE newArray #-}-newArray :: (Sugar.Ix dim, Sugar.Elem e) => dim -> Array dim e-newArray sh = ad `seq` Array (Sugar.fromElem sh) ad- where- -- FIXME: small arrays are relocated by the GC- ad = fst . runArrayData $ (,undefined) <$> newArrayData (1024 `max` Sugar.size sh)---- Extract shape dimensions as a list of function parameters. Note that this--- will convert to the base integer width of the device, namely, 32-bits.--- 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.----convertIx :: Ix dim => dim -> [CUDA.FunParam]-convertIx = post . map CUDA.IArg . shapeToList- where post [] = [CUDA.IArg 1]- post xs = reverse xs---- Convert a slice specification into storable index projection components.--- Note: implicit conversion Int -> Int32----convertSliceIndex :: SliceIndex slix sl co dim -> slix -> [CUDA.FunParam]-convertSliceIndex (SliceNil) () = []-convertSliceIndex (SliceAll sliceIdx) (s,()) = convertSliceIndex sliceIdx s-convertSliceIndex (SliceFixed sliceIdx) (s,i) = CUDA.IArg i : convertSliceIndex sliceIdx s---- | 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 (" ++ shows pid ") terminated abnormally"+{-# 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)++ Let a b -> do+ a0 <- executeOpenAcc a aenv+ executeOpenAcc b (aenv `Push` a0) <* applyArraysR deleteArray arrays a0++ Let2 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 (Var idx) env _ = return . toElt $ 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 $ idxToInt 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/Smart.hs
@@ -1,77 +0,0 @@-{-# LANGUAGE GADTs #-}--- |--- Module : Data.Array.Accelerate.CUDA.Smart--- Copyright : [2008..2010] 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.Smart (convertAcc, Sugar.Acc) where--import Prelude hiding (exp)--import Data.Array.Accelerate.AST-import qualified Data.Array.Accelerate.Smart as Sugar-import qualified Data.Array.Accelerate.Array.Sugar as Sugar----- Convert a closed array expression from HOAS to de Bruijn form AST----convertAcc :: Sugar.Acc a -> Acc a-convertAcc = refineAcc . Sugar.convertAcc----- Inject extra computational steps specific to the CUDA backend implementation.--- TODO: Implement array fusion----refineAcc :: Acc a -> Acc a-refineAcc = refineOpenAcc Empty--refineOpenAcc :: Val aenv -> OpenAcc aenv a -> OpenAcc aenv a-refineOpenAcc aenv (Let a1 a2)- = Let (refineOpenAcc aenv a1)- (refineOpenAcc (aenv `Push` undefined) a2)--refineOpenAcc aenv (Let2 a1 a2)- = Let2 (refineOpenAcc aenv a1)- (refineOpenAcc (aenv `Push` undefined `Push` undefined) a2)--refineOpenAcc aenv (Unit e) = Unit (refineExp aenv e)-refineOpenAcc aenv (Reshape e a) = Reshape (refineExp aenv e) (refineOpenAcc aenv a)-refineOpenAcc aenv (Replicate slix e a) = Replicate slix (refineExp aenv e) (refineOpenAcc aenv a)-refineOpenAcc aenv (Index slix a e) = Index slix (refineOpenAcc aenv a) (refineExp aenv e)-refineOpenAcc aenv (Map f a) = Map (refineFun aenv f) (refineOpenAcc aenv a)-refineOpenAcc aenv (ZipWith f a1 a2) = ZipWith (refineFun aenv f) (refineOpenAcc aenv a1) (refineOpenAcc aenv a2)-refineOpenAcc aenv (Fold f e a) = Fold (refineFun aenv f) (refineExp aenv e) (refineOpenAcc aenv a)-refineOpenAcc aenv (Scanl f e a) = Scanl (refineFun aenv f) (refineExp aenv e) (refineOpenAcc aenv a)-refineOpenAcc aenv (Scanr f e a) = Scanr (refineFun aenv f) (refineExp aenv e) (refineOpenAcc aenv a)-refineOpenAcc aenv (Permute f1 a1 f2 a2) = Permute (refineFun aenv f1) (refineOpenAcc aenv a1) (refineFun aenv f2) (refineOpenAcc aenv a2)-refineOpenAcc aenv (Backpermute e f a) = Backpermute (refineExp aenv e) (refineFun aenv f) (refineOpenAcc aenv a)-refineOpenAcc aenv (FoldSeg f e a s) = FoldSeg (refineFun aenv f) (refineExp aenv e) (refineOpenAcc aenv a) offsets- where- offsets = Let2 scanop (Avar (SuccIdx ZeroIdx))- scanop = Scanl (Sugar.convertFun2 undefined Sugar.mkAdd)- (Const (Sugar.fromElem (0::Int)))- (refineOpenAcc aenv s)--refineOpenAcc _ acc = acc---- Functions ??----refineFun :: Val aenv -> Fun aenv t -> Fun aenv t-refineFun _ = id----- Expressions----refineExp :: Val aenv -> Exp aenv a -> Exp aenv a-refineExp = refineOpenExp Empty--refineOpenExp :: Val env -> Val aenv -> OpenExp env aenv a -> OpenExp env aenv a-refineOpenExp env aenv (IndexScalar a e) = IndexScalar (refineOpenAcc aenv a) (refineOpenExp env aenv e)-refineOpenExp _ aenv (Shape a) = Shape (refineOpenAcc aenv a)-refineOpenExp _ _ exp = exp-
Data/Array/Accelerate/CUDA/State.hs view
@@ -1,7 +1,8 @@-{-# LANGUAGE CPP, TemplateHaskell, TupleSections, TypeOperators #-}+{-# LANGUAGE CPP, GADTs, PatternGuards, TemplateHaskell #-}+{-# LANGUAGE TupleSections, TypeFamilies, TypeOperators #-} -- | -- Module : Data.Array.Accelerate.CUDA.State--- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell+-- 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>@@ -13,119 +14,134 @@ -- processes. -- -module Data.Array.Accelerate.CUDA.State- (- evalCUDA, runCUDA, CIO, unique, outputDir, deviceProps, deviceContext, memoryTable, kernelTable,- AccTable, KernelEntry(KernelEntry), kernelName, kernelStatus,- MemTable, MemoryEntry(MemoryEntry), refcount, memsize, arena,+module Data.Array.Accelerate.CUDA.State ( - freshVar,- module Data.Record.Label- )- where+ evalCUDA, runCUDA, runCUDAWith, CIO,+ CUDAState, unique, deviceProps, deviceContext, memoryTable, kernelTable, -import Prelude hiding (id, (.))-import Control.Category+ 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.Record.Label+import Data.Maybe+import Data.Typeable+import Data.Label import Control.Applicative import Control.Monad-import Control.Monad.State (StateT(..))-import Data.HashTable (HashTable)-import Foreign.Ptr-import qualified Data.HashTable as HT-import qualified Foreign.CUDA.Driver as CUDA--import System.Directory-import System.FilePath-import System.Posix.Types (ProcessID)+import Control.Monad.State.Strict (StateT(..))+import System.Posix.Types (ProcessID) import System.Mem.Weak import System.IO.Unsafe--import Data.Array.Accelerate.CUDA.Analysis.Device+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)-#else-import System.Posix.Process (getProcessID)+import Data.Binary (encodeFile, decodeFile)+import Control.Arrow (second)+import Paths_accelerate (getDataDir) #endif +#include "accelerate.h" --- Types--- ~~~~~ -type AccTable = HashTable String KernelEntry-type MemTable = HashTable WordPtr MemoryEntry---- | The state token for accelerated CUDA array operations+-- 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. ---type CIO = StateT CUDAState IO-data CUDAState = CUDAState- {- _unique :: Int,- _outputDir :: FilePath,- _deviceProps :: CUDA.DeviceProperties,- _deviceContext :: CUDA.Context,- _memoryTable :: MemTable,- _kernelTable :: AccTable- }---- |--- Associate an array expression with an external compilation tool (nvcc) or the--- loaded function module+-- An Eq instance of Accelerate expressions does not facilitate persistent+-- caching. --+type KernelTable = Hash.HashTable AccKey KernelEntry data KernelEntry = KernelEntry {- _kernelName :: String,+ _kernelName :: FilePath, _kernelStatus :: Either ProcessID CUDA.Module } --- |--- Reference tracking for device memory allocations. Associates the products of--- an `Array dim e' with data stored on the graphics device. Facilitates reuse--- and delayed allocation at the cost of explicit release.+-- 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 pairs, for example, which are--- represented internally as pairs of arrays, will generate two entries.+-- This maps to a single concrete array. Arrays of tuples, which are represented+-- internally as tuples of arrays, will generate multiple entries. ---data MemoryEntry = MemoryEntry+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 {- _refcount :: Int,- _memsize :: Int64,- _arena :: WordPtr+ _unique :: Int,+ _deviceProps :: CUDA.DeviceProperties,+ _deviceContext :: CUDA.Context,+ _kernelTable :: KernelTable,+ _memoryTable :: MemoryTable } -$(mkLabels [''CUDAState, ''MemoryEntry, ''KernelEntry])+$(mkLabels [''CUDAState, ''KernelEntry]) -- Execution State--- ~~~~~~~~~~~~~~~+-- --------------- --- Return the output directory for compilation by-products, creating if it does--- not exist.----getOutputDir :: IO FilePath-getOutputDir = do #ifdef ACCELERATE_CUDA_PERSISTENT_CACHE- tmp <- getDataDir- dir <- canonicalizePath $ tmp </> "cache"-#else- tmp <- getTemporaryDirectory- pid <- getProcessID- dir <- canonicalizePath $ tmp </> "ac" ++ show pid+indexFileName :: IO FilePath+indexFileName = do+ tmp <- (</> "cache") `fmap` getDataDir+ dir <- createDirectoryIfMissing True tmp >> canonicalizePath tmp+ return (dir </> "_index") #endif- createDirectoryIfMissing True dir- return dir -- Store the kernel module map to file -- saveIndexFile :: CUDAState -> IO () #ifdef ACCELERATE_CUDA_PERSISTENT_CACHE-saveIndexFile s = encodeFile (_outputDir s </> "_index") . map (second _kernelName) =<< HT.toList (_kernelTable s)+saveIndexFile s = do+ ind <- indexFileName+ encodeFile ind . map (second _kernelName) =<< Hash.toList (_kernelTable s) #else saveIndexFile _ = return () #endif@@ -133,20 +149,22 @@ -- Read the kernel index map file (if it exists), loading modules into the -- current context ---loadIndexFile :: FilePath -> IO (AccTable, Int)+loadIndexFile :: IO (KernelTable, Int) #ifdef ACCELERATE_CUDA_PERSISTENT_CACHE-loadIndexFile f = do+loadIndexFile = do+ f <- indexFileName x <- doesFileExist f e <- if x then mapM reload =<< decodeFile f else return []- (,length e) <$> HT.fromList HT.hashString e+ (,length e) <$> Hash.fromList hashAccKey e where reload (k,n) = (k,) . KernelEntry n . Right <$> CUDA.loadFile (n `replaceExtension` ".cubin") #else-loadIndexFile _ = (,0) <$> HT.new (==) HT.hashString+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.@@ -161,51 +179,58 @@ CUDA.initialise [] (d,prp) <- selectBestDevice ctx <- CUDA.create d [CUDA.SchedAuto]- dir <- getOutputDir- mem <- HT.new (==) fromIntegral- (knl,n) <- loadIndexFile (dir </> "_index")+ (knl,n) <- loadIndexFile addFinalizer ctx (CUDA.destroy ctx)- return $ CUDAState n dir prp ctx mem knl+ return $ CUDAState n prp ctx knl undefined --- |--- Evaluate a CUDA array computation under a newly initialised environment,--- discarding the final state.+-- | 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 =- let- {-# NOINLINE ref #-} -- hic sunt dracones: truly unsafe use of unsafePerformIO- ref = unsafePerformIO (initialise >>= newIORef)- in do- state <- readIORef ref- clearMemTable state -- ugly kludge- (a,s) <- runStateT acc state- saveIndexFile s- writeIORef ref s- return (a,s)+runCUDA acc = readIORef onta >>= flip runCUDAWith acc --- In case of memory leaks, which we should fix, manually release any lingering--- device arrays. These would otherwise remain until the program exits.+-- | Execute a computation under the provided state, returning the updated+-- environment structure and replacing the global state. ---clearMemTable :: CUDAState -> IO ()-clearMemTable st = do- CUDA.sync -- TLM: not blocking??- entries <- HT.toList (_memoryTable st)- forM_ entries $ \(k,v) -> do- HT.delete (_memoryTable st) k- CUDA.free (CUDA.wordPtrToDevPtr (_arena v))+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) --- Utility--- ~~~~~~~+-- Nasty global statesses+-- ---------------------- --- | A unique name supply+{--+-- Execute an IO action at most once ---freshVar :: CIO Int-freshVar = getM unique <* modM unique (+1)+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/Debug.hs view
@@ -1,20 +1,68 @@--- |Embedded array processing language: debugging support (internal)------ Copyright (c) 2009 Manuel M T Chakravarty, Gabriele Keller, Sean Lee+-- |+-- Module : Data.Array.Accelerate.AST+-- Copyright : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee+-- License : BSD3 ----- License: BSD3+-- Maintainer : Manuel M T Chakravarty <chak@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions) ------ Description ---------------------------------------------------------------+-- Embedded array processing language: debugging support (internal). This module+-- provides functionality that is useful for developers of the library. It is+-- not meant for library users. ----- This module provides functionality that is useful for developers of the--- library. It is not meant for library users. module Data.Array.Accelerate.Debug ( - -- currently empty+ -- * Conditional tracing+ initTrace, queryTrace, traceLine, traceChunk ) where +-- standard libraries+import Control.Monad+import Data.IORef+import System.IO+import System.IO.Unsafe (unsafePerformIO)+ -- friends import Data.Array.Accelerate.Pretty () ++-- This flag indicates whether tracing messages should be emitted.+--+traceFlag :: IORef Bool+{-# NOINLINE traceFlag #-}+traceFlag = unsafePerformIO $ newIORef False+-- traceFlag = unsafePerformIO $ newIORef True++-- |Initialise the /trace flag/, which determines whether tracing messages should be emitted.+--+initTrace :: Bool -> IO ()+initTrace = writeIORef traceFlag++-- |Read the value of the /trace flag/.+--+queryTrace :: IO Bool+queryTrace = readIORef traceFlag++-- |Emit a trace message if the /trace flag/ is set. The first string indicates the location of+-- the message. The second one is the message itself. The output is formatted to be on one line.+--+traceLine :: String -> String -> IO ()+traceLine header msg+ = do { doTrace <- queryTrace+ ; when doTrace + $ hPutStrLn stderr (header ++ ": " ++ msg)+ }++-- |Emit a trace message if the /trace flag/ is set. The first string indicates the location of+-- the message. The second one is the message itself. The output is formatted over multiple+-- lines.+--+traceChunk :: String -> String -> IO ()+traceChunk header msg+ = do { doTrace <- queryTrace+ ; when doTrace + $ hPutStrLn stderr (header ++ "\n " ++ msg)+ }
+ Data/Array/Accelerate/IO.hs view
@@ -0,0 +1,32 @@+-- |+-- 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++) where++import Data.Array.Accelerate.IO.Ptr+import Data.Array.Accelerate.IO.ByteString+
+ Data/Array/Accelerate/IO/BlockCopy.hs view
@@ -0,0 +1,189 @@+{-# 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 view
@@ -0,0 +1,49 @@+-- |+-- 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 view
@@ -0,0 +1,100 @@+-- |+-- 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/Internal/Check.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE CPP #-} -- | -- Module : Data.Array.Accelerate.Internal.Check--- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell+-- Copyright : [2009..2011] Roman Lechinskiy, Trevor L. McDonell -- License : BSD3 -- -- Maintainer : Manuel M T Chakravarty <chak@cse.unsw.edu.au>@@ -10,16 +10,18 @@ -- -- Bounds checking infrastructure ----- Sstolen from the Vector package by Roman Leshchinskiy--- <http://hackage.haskell.org/package/vector>+-- Stolen from the Vector package by Roman Leshchinskiy. This code has a+-- BSD-style license. <http://hackage.haskell.org/package/vector> -- -module Data.Array.Accelerate.Internal.Check- (- Checks(..), doChecks,- error, check, assert, checkIndex, checkLength, checkSlice- ) where+module Data.Array.Accelerate.Internal.Check ( + -- * Bounds checking and assertion infrastructure+ Checks(..), doChecks,+ error, check, assert, checkIndex, checkLength, checkSlice++) where+ import Prelude hiding( error ) import qualified Prelude as P @@ -59,7 +61,7 @@ (if kind == Internal then (["" ,"*** Internal error in package accelerate ***"- ,"*** Please submit a bug report at http://trac.haskell.org/accelerate"]++)+ ,"*** Please submit a bug report at https://github.com/mchakravarty/accelerate/issues"]++) else id) [ file ++ ":" ++ show line ++ " (" ++ loc ++ "): " ++ msg ]
Data/Array/Accelerate/Interpreter.hs view
@@ -1,9 +1,9 @@ {-# OPTIONS_HADDOCK prune #-}-{-# LANGUAGE CPP, GADTs, BangPatterns, PatternGuards #-}+{-# LANGUAGE CPP, GADTs, BangPatterns, TypeOperators, PatternGuards #-} {-# LANGUAGE TypeFamilies, ScopedTypeVariables, FlexibleContexts #-} -- | -- Module : Data.Array.Accelerate.Interpreter--- Copyright : [2008..2009] Manuel M T Chakravarty, Gabriele Keller, Sean Lee+-- 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>@@ -22,28 +22,31 @@ -- the code by eliminating back and forth conversions is fine, but only where it doesn't -- negatively affects clarity — after all, the main purpose of the interpreter is to serve as an -- executable specification.+-- module Data.Array.Accelerate.Interpreter ( -- * Interpret an array expression- Arrays, run,+ Arrays, run, stream, - -- Internal+ -- Internal (hidden) evalPrim, evalPrimConst, evalPrj ) where -- standard libraries import Control.Monad+import Control.Monad.ST (ST) import Data.Bits-import Data.Char (chr, ord)+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+import Data.Array.Accelerate.Array.Representation hiding (sliceIndex) import Data.Array.Accelerate.Array.Sugar (- Array(..), Scalar, Vector, Segments)+ Z(..), (:.)(..), Array(..), Scalar, Vector, Segments) import Data.Array.Accelerate.Array.Delayed import Data.Array.Accelerate.AST import Data.Array.Accelerate.Tuple@@ -56,79 +59,119 @@ -- Program execution -- ----------------- --- |Characterises the types that may be returned when running an array program.----class Delayable as => Arrays as- -instance Arrays () -instance Arrays (Array dim e)-instance (Arrays as1, Arrays as2) => Arrays (as1, as2)- -- |Run a complete embedded array program using the reference interpreter. -- run :: Arrays a => Sugar.Acc a -> a run = force . evalAcc . Sugar.convertAcc +-- | Stream a lazily read list of input arrays through the given program,+-- collecting results as we go+--+stream :: (Arrays a, Arrays b) => (Sugar.Acc a -> Sugar.Acc b) -> [a] -> [b]+stream afun = map (run1 acc)+ where+ acc = Sugar.convertAccFun1 afun + run1 :: Delayable b => 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!"++ -- Array expression evaluation -- --------------------------- -- Evaluate an open array expression -- evalOpenAcc :: Delayable a => OpenAcc aenv a -> Val aenv -> Delayed a+evalOpenAcc (OpenAcc acc) = evalPreOpenAcc acc -evalOpenAcc (Let acc1 acc2) aenv +evalPreOpenAcc :: Delayable a => PreOpenAcc OpenAcc aenv a -> Val aenv -> Delayed a++evalPreOpenAcc (Let acc1 acc2) aenv = let !arr1 = force $ evalOpenAcc acc1 aenv in evalOpenAcc acc2 (aenv `Push` arr1) -evalOpenAcc (Let2 acc1 acc2) aenv +evalPreOpenAcc (Let2 acc1 acc2) aenv = let (!arr1, !arr2) = force $ evalOpenAcc acc1 aenv in evalOpenAcc acc2 (aenv `Push` arr1 `Push` arr2) -evalOpenAcc (Avar idx) aenv = delay $ prj idx aenv+evalPreOpenAcc (PairArrays acc1 acc2) aenv+ = DelayedPair (evalOpenAcc acc1 aenv) (evalOpenAcc acc2 aenv) -evalOpenAcc (Use arr) _aenv = delay arr+evalPreOpenAcc (Avar idx) aenv = delay $ prj idx aenv -evalOpenAcc (Unit e) aenv = unitOp (evalExp e aenv)+evalPreOpenAcc (Apply (Alam (Abody funAcc)) acc) aenv+ = let !arr = force $ evalOpenAcc acc aenv+ in evalOpenAcc funAcc (Empty `Push` arr)+evalPreOpenAcc (Apply _afun _acc) _aenv+ = error "GHC's pattern match checker is too dumb to figure that this case is impossible" -evalOpenAcc (Reshape e acc) aenv +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 (Unit e) aenv = unitOp (evalExp e aenv)++evalPreOpenAcc (Generate sh f) aenv+ = generateOp (evalExp sh aenv) (evalFun f aenv)++evalPreOpenAcc (Reshape e acc) aenv = reshapeOp (evalExp e aenv) (evalOpenAcc acc aenv) -evalOpenAcc (Replicate sliceIndex slix acc) aenv+evalPreOpenAcc (Replicate sliceIndex slix acc) aenv = replicateOp sliceIndex (evalExp slix aenv) (evalOpenAcc acc aenv) -evalOpenAcc (Index sliceIndex acc slix) aenv+evalPreOpenAcc (Index sliceIndex acc slix) aenv = indexOp sliceIndex (evalOpenAcc acc aenv) (evalExp slix aenv) -evalOpenAcc (Map f acc) aenv = mapOp (evalFun f aenv) (evalOpenAcc acc aenv)+evalPreOpenAcc (Map f acc) aenv = mapOp (evalFun f aenv) (evalOpenAcc acc aenv) -evalOpenAcc (ZipWith f acc1 acc2) aenv+evalPreOpenAcc (ZipWith f acc1 acc2) aenv = zipWithOp (evalFun f aenv) (evalOpenAcc acc1 aenv) (evalOpenAcc acc2 aenv) -evalOpenAcc (Fold f e acc) aenv+evalPreOpenAcc (Fold f e acc) aenv = foldOp (evalFun f aenv) (evalExp e aenv) (evalOpenAcc acc aenv) -evalOpenAcc (FoldSeg f e acc1 acc2) aenv+evalPreOpenAcc (Fold1 f acc) aenv+ = fold1Op (evalFun f aenv) (evalOpenAcc acc aenv)++evalPreOpenAcc (FoldSeg f e acc1 acc2) aenv = foldSegOp (evalFun f aenv) (evalExp e aenv) (evalOpenAcc acc1 aenv) (evalOpenAcc acc2 aenv) -evalOpenAcc (Scanl f e acc) aenv+evalPreOpenAcc (Fold1Seg f acc1 acc2) aenv+ = fold1SegOp (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) -evalOpenAcc (Scanr f e acc) aenv+evalPreOpenAcc (Scanl' f e acc) aenv+ = scanl'Op (evalFun f aenv) (evalExp e aenv) (evalOpenAcc acc aenv)++evalPreOpenAcc (Scanl1 f acc) aenv+ = scanl1Op (evalFun f aenv) (evalOpenAcc acc aenv)++evalPreOpenAcc (Scanr f e acc) aenv = scanrOp (evalFun f aenv) (evalExp e aenv) (evalOpenAcc acc aenv) -evalOpenAcc (Permute f dftAcc p acc) aenv+evalPreOpenAcc (Scanr' f e acc) aenv+ = scanr'Op (evalFun f aenv) (evalExp e aenv) (evalOpenAcc acc aenv)++evalPreOpenAcc (Scanr1 f acc) aenv+ = scanr1Op (evalFun f aenv) (evalOpenAcc acc aenv)++evalPreOpenAcc (Permute f dftAcc p acc) aenv = permuteOp (evalFun f aenv) (evalOpenAcc dftAcc aenv) (evalFun p aenv) (evalOpenAcc acc aenv) -evalOpenAcc (Backpermute e p acc) aenv+evalPreOpenAcc (Backpermute e p acc) aenv = backpermuteOp (evalExp e aenv) (evalFun p aenv) (evalOpenAcc acc aenv) -evalOpenAcc (Stencil sten bndy acc) aenv+evalPreOpenAcc (Stencil sten bndy acc) aenv = stencilOp (evalFun sten aenv) bndy (evalOpenAcc acc aenv) -evalOpenAcc (Stencil2 sten bndy1 acc1 bndy2 acc2) aenv+evalPreOpenAcc (Stencil2 sten bndy1 acc1 bndy2 acc2) aenv = stencil2Op (evalFun sten aenv) bndy1 (evalOpenAcc acc1 aenv) bndy2 (evalOpenAcc acc2 aenv) -- Evaluate a closed array expressions@@ -140,160 +183,305 @@ -- Array primitives -- ---------------- -unitOp :: Sugar.Elem e => e -> Delayed (Scalar e)-unitOp e = DelayedArray {shapeDA = (), repfDA = const (Sugar.fromElem e)}+unitOp :: Sugar.Elt e => e -> Delayed (Scalar e)+unitOp e = DelayedArray {shapeDA = (), repfDA = const (Sugar.fromElt e)} -reshapeOp :: Sugar.Ix dim +generateOp :: (Sugar.Shape dim, Sugar.Elt e)+ => dim+ -> (dim -> e)+ -> Delayed (Array dim e)+generateOp sh rf = DelayedArray (Sugar.fromElt sh) (Sugar.sinkFromElt rf)++reshapeOp :: Sugar.Shape dim => dim -> Delayed (Array dim' e) -> Delayed (Array dim e) reshapeOp newShape darr@(DelayedArray {shapeDA = oldShape}) = let Array _ adata = force darr in BOUNDS_CHECK(check) "reshape" "shape mismatch" (Sugar.size newShape == size oldShape)- $ delay $ Array (Sugar.fromElem newShape) adata+ $ delay $ Array (Sugar.fromElt newShape) adata -replicateOp :: (Sugar.Ix dim, Sugar.Elem slix)- => SliceIndex (Sugar.ElemRepr slix) - (Sugar.ElemRepr sl) +replicateOp :: (Sugar.Shape dim, Sugar.Elt slix)+ => SliceIndex (Sugar.EltRepr slix)+ (Sugar.EltRepr sl) co- (Sugar.ElemRepr dim)- -> slix + (Sugar.EltRepr dim)+ -> slix -> Delayed (Array sl e) -> Delayed (Array dim e) replicateOp sliceIndex slix (DelayedArray sh pf) = DelayedArray sh' (pf . pf') where- (sh', pf') = extend sliceIndex (Sugar.fromElem slix) sh- + (sh', pf') = extend sliceIndex (Sugar.fromElt slix) sh+ extend :: SliceIndex slix sl co dim- -> slix + -> slix -> sl -> (dim, dim -> sl)- extend SliceNil () () = ((), const ())- extend (SliceAll sliceIndex) (slix, ()) (sl, sz) - = let (dim', pf') = extend sliceIndex slix sl+ extend (SliceNil) () () = ((), const ())+ extend (SliceAll sliceIdx) (slx, ()) (sl, sz)+ = let (dim', f') = extend sliceIdx slx sl in- ((dim', sz), \(ix, i) -> (pf' ix, i))- extend (SliceFixed sliceIndex) (slix, sz) sl- = let (dim', pf') = extend sliceIndex slix sl+ ((dim', sz), \(ix, i) -> (f' ix, i))+ extend (SliceFixed sliceIdx) (slx, sz) sl+ = let (dim', f') = extend sliceIdx slx sl in- ((dim', sz), \(ix, _) -> pf' ix)- -indexOp :: (Sugar.Ix sl, Sugar.Elem slix)- => SliceIndex (Sugar.ElemRepr slix) - (Sugar.ElemRepr sl) + ((dim', sz), \(ix, _) -> f' ix)++indexOp :: (Sugar.Shape sl, Sugar.Elt slix)+ => SliceIndex (Sugar.EltRepr slix)+ (Sugar.EltRepr sl) co- (Sugar.ElemRepr dim)+ (Sugar.EltRepr dim) -> Delayed (Array dim e)- -> slix + -> slix -> Delayed (Array sl e)-indexOp sliceIndex (DelayedArray sh pf) slix +indexOp sliceIndex (DelayedArray sh pf) slix = DelayedArray sh' (pf . pf') where- (sh', pf') = restrict sliceIndex (Sugar.fromElem slix) sh+ (sh', pf') = restrict sliceIndex (Sugar.fromElt slix) sh restrict :: SliceIndex slix sl co dim -> slix -> dim -> (sl, sl -> dim)- restrict SliceNil () () = ((), const ())- restrict (SliceAll sliceIndex) (slix, ()) (sh, sz)- = let (sl', pf') = restrict sliceIndex slix sh+ restrict (SliceNil) () () = ((), const ())+ restrict (SliceAll sliceIdx) (slx, ()) (sl, sz)+ = let (sl', f') = restrict sliceIdx slx sl in- ((sl', sz), \(ix, i) -> (pf' ix, i))- restrict (SliceFixed sliceIndex) (slix, i) (sh, sz)- = let (sl', pf') = restrict sliceIndex slix sh+ ((sl', sz), \(ix, i) -> (f' ix, i))+ restrict (SliceFixed sliceIdx) (slx, i) (sl, sz)+ = let (sl', f') = restrict sliceIdx slx sl in- BOUNDS_CHECK(checkIndex) "index" i sz $ (sl', \ix -> (pf' ix, i))+ BOUNDS_CHECK(checkIndex) "index" i sz $ (sl', \ix -> (f' ix, i)) -mapOp :: Sugar.Elem e' +mapOp :: Sugar.Elt e' => (e -> e') -> Delayed (Array dim e) -> Delayed (Array dim e')-mapOp f (DelayedArray sh rf) = DelayedArray sh (Sugar.sinkFromElem f . rf)+mapOp f (DelayedArray sh rf) = DelayedArray sh (Sugar.sinkFromElt f . rf) -zipWithOp :: Sugar.Elem e3+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) - (\ix -> (Sugar.sinkFromElem2 f) (rf1 ix) (rf2 ix))+ (\ix -> (Sugar.sinkFromElt2 f) (rf1 ix) (rf2 ix)) -foldOp :: (e -> e -> e)+foldOp :: Sugar.Shape dim + => (e -> e -> e) -> e+ -> Delayed (Array (dim:.Int) e) -> Delayed (Array dim e)- -> Delayed (Scalar e)-foldOp f e (DelayedArray sh rf)- = unitOp $ - Sugar.toElem (iter sh rf (Sugar.sinkFromElem2 f) (Sugar.fromElem e))+foldOp f e (DelayedArray (sh, n) rf)+ = DelayedArray sh + (\ix -> iter ((), n) (\((), i) -> rf (ix, i)) (Sugar.sinkFromElt2 f) (Sugar.fromElt e)) -foldSegOp :: forall 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) -> e- -> Delayed (Vector e)+ -> Delayed (Array (dim:.Int) e) -> Delayed Segments- -> Delayed (Vector e)-foldSegOp f e (DelayedArray _sh rf) seg@(DelayedArray shSeg rfSeg)+ -> Delayed (Array (dim:.Int) e)+foldSegOp f e (DelayedArray (sh, _n) rf) seg@(DelayedArray shSeg rfSeg) = delay arr where- DelayedPair (DelayedArray _shSeg rfStarts) _ = scanlOp (+) 0 seg- arr = Sugar.newArray (Sugar.toElem shSeg) foldOne+ DelayedPair (DelayedArray _shSeg rfStarts) _ = scanl'Op (+) 0 seg+ arr = Sugar.newArray (Sugar.toElt (sh, Sugar.toElt shSeg)) foldOne --- foldOne :: Sugar.DIM1 -> e- foldOne i = let- start = (Sugar.liftToElem rfStarts) i- len = (Sugar.liftToElem rfSeg) i- in- fold e start (start + len)+ foldOne :: dim:.Int -> e+ foldOne ix = let+ (ix', i) = Sugar.fromElt ix+ start = (Sugar.liftToElt rfStarts) i+ len = (Sugar.liftToElt rfSeg) i+ in+ fold ix' e start (start + len)++ fold :: Sugar.EltRepr dim -> e -> Int -> Int -> e+ 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)+ -> Delayed (Array (dim:.Int) e)+ -> Delayed Segments+ -> Delayed (Array (dim:.Int) e)+fold1SegOp f (DelayedArray (sh, _n) rf) seg@(DelayedArray shSeg rfSeg)+ = delay arr+ where+ DelayedPair (DelayedArray _shSeg rfStarts) _ = scanl'Op (+) 0 seg+ arr = Sugar.newArray (Sugar.toElt (sh, Sugar.toElt shSeg)) foldOne --- fold :: e -> Sugar.DIM1 -> Sugar.DIM1 -> e- fold v j end+ foldOne :: dim:.Int -> e+ foldOne ix = let+ (ix', i) = Sugar.fromElt ix+ start = (Sugar.liftToElt rfStarts) i+ len = (Sugar.liftToElt rfSeg) i+ in+ if len == 0+ then+ BOUNDS_ERROR(error) "fold1Seg" "empty iteration space"+ else+ fold ix' (Sugar.toElt . rf $ (ix', start)) (start + 1) (start + len)++ fold :: Sugar.EltRepr dim -> e -> Int -> Int -> e+ fold ix' v j end | j >= end = v- | otherwise = fold (f v ((Sugar.liftToElem rf) j)) (j + 1) end+ | otherwise = fold ix' (f v (Sugar.toElt . rf $ (ix', j))) (j + 1) end -scanlOp :: (e -> e -> e)+scanlOp :: forall e. (e -> e -> e) -> e -> Delayed (Vector e)- -> Delayed (Vector e, Scalar e)+ -> Delayed (Vector e) scanlOp f e (DelayedArray sh rf)+ = delay $ adata `seq` Array ((), n + 1) adata+ where+ n = size sh+ f' = Sugar.sinkFromElt2 f+ --+ (adata, _) = runArrayData $ do+ arr <- newArrayData (n + 1)+ final <- traverse arr 0 (Sugar.fromElt e)+ writeArrayData arr n final+ return (arr, undefined)++ traverse :: MutableArrayData s (Sugar.EltRepr e) -> Int -> (Sugar.EltRepr e) -> ST s (Sugar.EltRepr e)+ traverse arr i v+ | i >= n = return v+ | otherwise = do+ writeArrayData arr i v+ traverse arr (i + 1) (f' v (rf ((), i)))++scanl'Op :: forall e. (e -> e -> e)+ -> e+ -> Delayed (Vector e)+ -> Delayed (Vector e, Scalar e)+scanl'Op f e (DelayedArray sh rf) = DelayedPair (delay $ adata `seq` Array sh adata) - (unitOp (Sugar.toElem final))+ (unitOp (Sugar.toElt final)) where n = size sh- f' = Sugar.sinkFromElem2 f+ f' = Sugar.sinkFromElt2 f -- (adata, final) = runArrayData $ do- arr <- newArrayData n- final <- traverse arr 0 (Sugar.fromElem e)- return (arr, final)+ 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 | otherwise = do writeArrayData arr i v traverse arr (i + 1) (f' v (rf ((), i))) -scanrOp :: (e -> e -> e)+scanl1Op :: forall e. (e -> e -> e)+ -> Delayed (Vector e)+ -> Delayed (Vector e)+scanl1Op f (DelayedArray sh rf)+ = delay $ adata `seq` Array sh adata+ where+ n = size sh+ f' = Sugar.sinkFromElt2 f+ --+ (adata, _) = runArrayData $ do+ arr <- newArrayData n+ traverse arr 0 undefined+ return (arr, undefined)++ traverse :: MutableArrayData s (Sugar.EltRepr e) -> Int -> (Sugar.EltRepr e) -> ST s ()+ traverse arr i v+ | i >= n = return ()+ | i == 0 = do+ let e = rf ((), i)+ writeArrayData arr i e+ traverse arr (i + 1) e+ | otherwise = do+ let e = f' v (rf ((), i))+ writeArrayData arr i e+ traverse arr (i + 1) e++scanrOp :: forall e. (e -> e -> e) -> e -> Delayed (Vector e)- -> Delayed (Vector e, Scalar e)+ -> Delayed (Vector e) scanrOp f e (DelayedArray sh rf)+ = delay $ adata `seq` Array ((), n + 1) adata+ where+ n = size sh+ f' = Sugar.sinkFromElt2 f+ --+ (adata, _) = runArrayData $ do+ arr <- newArrayData (n + 1)+ final <- traverse arr n (Sugar.fromElt e)+ writeArrayData arr 0 final+ return (arr, undefined)++ traverse :: MutableArrayData s (Sugar.EltRepr e) -> Int -> (Sugar.EltRepr e) -> ST s (Sugar.EltRepr e)+ traverse arr i v+ | i == 0 = return v+ | otherwise = do+ writeArrayData arr i v+ traverse arr (i - 1) (f' v (rf ((), i)))++scanr'Op :: forall e. (e -> e -> e)+ -> 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.toElem final))+ (unitOp (Sugar.toElt final)) where n = size sh- f' = Sugar.sinkFromElem2 f+ f' = Sugar.sinkFromElt2 f -- (adata, final) = runArrayData $ do- arr <- newArrayData n- final <- traverse arr (n-1) (Sugar.fromElem e)- return (arr, final)+ 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 | otherwise = do writeArrayData arr i v traverse arr (i - 1) (f' v (rf ((), i))) +scanr1Op :: forall e. (e -> e -> e)+ -> Delayed (Vector e)+ -> Delayed (Vector e)+scanr1Op f (DelayedArray sh rf)+ = delay $ adata `seq` Array sh adata+ where+ n = size sh+ f' = Sugar.sinkFromElt2 f+ --+ (adata, _) = runArrayData $ do+ arr <- newArrayData n+ traverse arr (n - 1) undefined+ return (arr, undefined)++ traverse :: MutableArrayData s (Sugar.EltRepr e) -> Int -> (Sugar.EltRepr e) -> ST s ()+ traverse arr i v+ | i < 0 = return ()+ | i == (n - 1) = do+ let e = rf ((), i)+ writeArrayData arr i e+ traverse arr (i - 1) e+ | otherwise = do+ let e = f' v (rf ((), i))+ writeArrayData arr i e+ traverse arr (i - 1) e+ permuteOp :: (e -> e -> e) -> Delayed (Array dim' e) -> (dim -> dim')@@ -302,7 +490,7 @@ permuteOp f (DelayedArray dftsSh dftsPf) p (DelayedArray sh pf) = delay $ adata `seq` Array dftsSh adata where - f' = Sugar.sinkFromElem2 f+ f' = Sugar.sinkFromElt2 f -- (adata, _) = runArrayData $ do@@ -318,7 +506,7 @@ -- the target dimension (where it gets combined with the current -- default) let update ix = do- let target = (Sugar.sinkFromElem p) ix+ let target = (Sugar.sinkFromElt p) ix unless (target == ignore) $ do let i = index dftsSh target e <- readArrayData arr i@@ -328,56 +516,56 @@ -- return the updated array return (arr, undefined) -backpermuteOp :: Sugar.Ix dim'+backpermuteOp :: Sugar.Shape dim' => dim' -> (dim' -> dim) -> Delayed (Array dim e) -> Delayed (Array dim' e) backpermuteOp sh' p (DelayedArray _sh rf)- = DelayedArray (Sugar.fromElem sh') (rf . Sugar.sinkFromElem p)+ = DelayedArray (Sugar.fromElt sh') (rf . Sugar.sinkFromElt p) -stencilOp :: forall dim e e' stencil. (Sugar.Elem e, Sugar.Elem e', Stencil dim e stencil)+stencilOp :: forall dim e e' stencil. (Sugar.Elt e, Sugar.Elt e', Stencil dim e stencil) => (stencil -> e')- -> Boundary (Sugar.ElemRepr e)+ -> Boundary (Sugar.EltRepr e) -> Delayed (Array dim e) -> Delayed (Array dim e') stencilOp sten bndy (DelayedArray sh rf) = DelayedArray sh rf' where- rf' = Sugar.sinkFromElem (sten . stencilAccess rfBounded)+ rf' = Sugar.sinkFromElt (sten . stencilAccess rfBounded) -- add a boundary to the source array as specified by the boundary condition rfBounded :: dim -> e- rfBounded ix = Sugar.toElem $ case Sugar.bound (Sugar.toElem sh) ix bndy of+ rfBounded ix = Sugar.toElt $ case Sugar.bound (Sugar.toElt sh) ix bndy of Left v -> v- Right ix' -> rf (Sugar.fromElem ix')+ Right ix' -> rf (Sugar.fromElt ix') stencil2Op :: forall dim e1 e2 e' stencil1 stencil2. - (Sugar.Elem e1, Sugar.Elem e2, Sugar.Elem e', + (Sugar.Elt e1, Sugar.Elt e2, Sugar.Elt e', Stencil dim e1 stencil1, Stencil dim e2 stencil2) => (stencil1 -> stencil2 -> e')- -> Boundary (Sugar.ElemRepr e1)+ -> Boundary (Sugar.EltRepr e1) -> Delayed (Array dim e1)- -> Boundary (Sugar.ElemRepr e2)+ -> 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' where- rf' = Sugar.sinkFromElem (\ix -> sten (stencilAccess rf1Bounded ix)- (stencilAccess rf2Bounded ix))+ 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.toElem $ case Sugar.bound (Sugar.toElem sh1) ix bndy1 of+ rf1Bounded ix = Sugar.toElt $ case Sugar.bound (Sugar.toElt sh1) ix bndy1 of Left v -> v- Right ix' -> rf1 (Sugar.fromElem ix')+ Right ix' -> rf1 (Sugar.fromElt ix') rf2Bounded :: dim -> e2- rf2Bounded ix = Sugar.toElem $ case Sugar.bound (Sugar.toElem sh2) ix bndy2 of+ rf2Bounded ix = Sugar.toElt $ case Sugar.bound (Sugar.toElt sh2) ix bndy2 of Left v -> v- Right ix' -> rf2 (Sugar.fromElem ix')+ Right ix' -> rf2 (Sugar.fromElt ix') -- Expression evaluation@@ -388,7 +576,7 @@ evalOpenFun :: OpenFun env aenv t -> Val env -> Val aenv -> t evalOpenFun (Body e) env aenv = evalOpenExp e env aenv evalOpenFun (Lam f) env aenv - = \x -> evalOpenFun f (env `Push` Sugar.fromElem x) aenv+ = \x -> evalOpenFun f (env `Push` Sugar.fromElt x) aenv -- Evaluate a closed function --@@ -405,9 +593,9 @@ -- evalOpenExp :: OpenExp env aenv a -> Val env -> Val aenv -> a -evalOpenExp (Var idx) env _ = Sugar.toElem $ prj idx env+evalOpenExp (Var idx) env _ = Sugar.toElt $ prj idx env -evalOpenExp (Const c) _ _ = Sugar.toElem c+evalOpenExp (Const c) _ _ = Sugar.toElt c evalOpenExp (Tuple tup) env aenv = toTuple $ evalTuple tup env aenv@@ -415,6 +603,21 @@ evalOpenExp (Prj idx e) env aenv = evalPrj idx (fromTuple $ evalOpenExp e env aenv) +evalOpenExp IndexNil _env _aenv + = Z++evalOpenExp (IndexCons sh i) env aenv + = evalOpenExp sh env aenv :. evalOpenExp i env aenv++evalOpenExp (IndexHead ix) env aenv + = case evalOpenExp ix env aenv of _:.h -> h++evalOpenExp (IndexTail ix) env aenv + = case evalOpenExp ix env aenv of t:._ -> t++evalOpenExp (IndexAny) _ _+ = Sugar.Any+ evalOpenExp (Cond c t e) env aenv = if evalOpenExp c env aenv then evalOpenExp t env aenv@@ -428,16 +631,20 @@ evalOpenExp (IndexScalar acc ix) env aenv = case evalOpenAcc acc aenv of DelayedArray sh pf -> - let ix' = Sugar.fromElem $ evalOpenExp ix env aenv+ let ix' = Sugar.fromElt $ evalOpenExp ix env aenv in- index sh ix' `seq` (Sugar.toElem $ pf ix')+ index sh ix' `seq` (Sugar.toElt $ pf ix') -- FIXME: This is ugly, but (possibly) needed to -- ensure bounds checking evalOpenExp (Shape acc) _ aenv = case force $ evalOpenAcc acc aenv of- Array sh _ -> Sugar.toElem sh+ Array sh _ -> Sugar.toElt sh +evalOpenExp (Size acc) _ aenv + = case force $ evalOpenAcc acc aenv of+ Array sh _ -> size sh+ -- Evaluate a closed expression -- evalExp :: Exp aenv t -> Val aenv -> t@@ -453,58 +660,60 @@ evalPrimConst (PrimPi ty) = evalPi ty evalPrim :: PrimFun p -> p-evalPrim (PrimAdd ty) = evalAdd ty-evalPrim (PrimSub ty) = evalSub ty-evalPrim (PrimMul ty) = evalMul ty-evalPrim (PrimNeg ty) = evalNeg ty-evalPrim (PrimAbs ty) = evalAbs ty-evalPrim (PrimSig ty) = evalSig ty-evalPrim (PrimQuot ty) = evalQuot ty-evalPrim (PrimRem ty) = evalRem ty-evalPrim (PrimIDiv ty) = evalIDiv ty-evalPrim (PrimMod ty) = evalMod ty-evalPrim (PrimBAnd ty) = evalBAnd ty-evalPrim (PrimBOr ty) = evalBOr ty-evalPrim (PrimBXor ty) = evalBXor ty-evalPrim (PrimBNot ty) = evalBNot ty-evalPrim (PrimBShiftL ty) = evalBShiftL ty-evalPrim (PrimBShiftR ty) = evalBShiftR ty-evalPrim (PrimBRotateL ty) = evalBRotateL ty-evalPrim (PrimBRotateR ty) = evalBRotateR ty-evalPrim (PrimFDiv ty) = evalFDiv ty-evalPrim (PrimRecip ty) = evalRecip ty-evalPrim (PrimSin ty) = evalSin ty-evalPrim (PrimCos ty) = evalCos ty-evalPrim (PrimTan ty) = evalTan ty-evalPrim (PrimAsin ty) = evalAsin ty-evalPrim (PrimAcos ty) = evalAcos ty-evalPrim (PrimAtan ty) = evalAtan ty-evalPrim (PrimAsinh ty) = evalAsinh ty-evalPrim (PrimAcosh ty) = evalAcosh ty-evalPrim (PrimAtanh ty) = evalAtanh ty-evalPrim (PrimExpFloating ty) = evalExpFloating ty-evalPrim (PrimSqrt ty) = evalSqrt ty-evalPrim (PrimLog ty) = evalLog ty-evalPrim (PrimFPow ty) = evalFPow ty-evalPrim (PrimLogBase ty) = evalLogBase ty-evalPrim (PrimAtan2 ty) = evalAtan2 ty-evalPrim (PrimLt ty) = evalLt ty-evalPrim (PrimGt ty) = evalGt ty-evalPrim (PrimLtEq ty) = evalLtEq ty-evalPrim (PrimGtEq ty) = evalGtEq ty-evalPrim (PrimEq ty) = evalEq ty-evalPrim (PrimNEq ty) = evalNEq ty-evalPrim (PrimMax ty) = evalMax ty-evalPrim (PrimMin ty) = evalMin ty-evalPrim PrimLAnd = evalLAnd-evalPrim PrimLOr = evalLOr-evalPrim PrimLNot = evalLNot-evalPrim PrimOrd = evalOrd-evalPrim PrimChr = evalChr-evalPrim PrimRoundFloatInt = evalRoundFloatInt-evalPrim PrimTruncFloatInt = evalTruncFloatInt-evalPrim PrimIntFloat = evalIntFloat-evalPrim PrimBoolToInt = evalBoolToInt+evalPrim (PrimAdd ty) = evalAdd ty+evalPrim (PrimSub ty) = evalSub ty+evalPrim (PrimMul ty) = evalMul ty+evalPrim (PrimNeg ty) = evalNeg ty+evalPrim (PrimAbs ty) = evalAbs ty+evalPrim (PrimSig ty) = evalSig ty+evalPrim (PrimQuot ty) = evalQuot ty+evalPrim (PrimRem ty) = evalRem ty+evalPrim (PrimIDiv ty) = evalIDiv ty+evalPrim (PrimMod ty) = evalMod ty+evalPrim (PrimBAnd ty) = evalBAnd ty+evalPrim (PrimBOr ty) = evalBOr ty+evalPrim (PrimBXor ty) = evalBXor ty+evalPrim (PrimBNot ty) = evalBNot ty+evalPrim (PrimBShiftL ty) = evalBShiftL ty+evalPrim (PrimBShiftR ty) = evalBShiftR ty+evalPrim (PrimBRotateL ty) = evalBRotateL ty+evalPrim (PrimBRotateR ty) = evalBRotateR ty+evalPrim (PrimFDiv ty) = evalFDiv ty+evalPrim (PrimRecip ty) = evalRecip ty+evalPrim (PrimSin ty) = evalSin ty+evalPrim (PrimCos ty) = evalCos ty+evalPrim (PrimTan ty) = evalTan ty+evalPrim (PrimAsin ty) = evalAsin ty+evalPrim (PrimAcos ty) = evalAcos ty+evalPrim (PrimAtan ty) = evalAtan ty+evalPrim (PrimAsinh ty) = evalAsinh ty+evalPrim (PrimAcosh ty) = evalAcosh ty+evalPrim (PrimAtanh ty) = evalAtanh ty+evalPrim (PrimExpFloating ty) = evalExpFloating ty+evalPrim (PrimSqrt ty) = evalSqrt ty+evalPrim (PrimLog ty) = evalLog ty+evalPrim (PrimFPow ty) = evalFPow ty+evalPrim (PrimLogBase ty) = evalLogBase ty+evalPrim (PrimTruncate ta tb) = evalTruncate ta tb+evalPrim (PrimRound ta tb) = evalRound ta tb+evalPrim (PrimFloor ta tb) = evalFloor ta tb+evalPrim (PrimCeiling ta tb) = evalCeiling ta tb+evalPrim (PrimAtan2 ty) = evalAtan2 ty+evalPrim (PrimLt ty) = evalLt ty+evalPrim (PrimGt ty) = evalGt ty+evalPrim (PrimLtEq ty) = evalLtEq ty+evalPrim (PrimGtEq ty) = evalGtEq ty+evalPrim (PrimEq ty) = evalEq ty+evalPrim (PrimNEq ty) = evalNEq ty+evalPrim (PrimMax ty) = evalMax ty+evalPrim (PrimMin ty) = evalMin ty+evalPrim PrimLAnd = evalLAnd+evalPrim PrimLOr = evalLOr+evalPrim PrimLNot = evalLNot+evalPrim PrimOrd = evalOrd+evalPrim PrimChr = evalChr+evalPrim PrimBoolToInt = evalBoolToInt+evalPrim (PrimFromIntegral ta tb) = evalFromIntegral ta tb -- Tuple construction and projection@@ -533,27 +742,26 @@ evalLOr (!x, !y) = x || y evalLNot :: Bool -> Bool-evalLNot x = not x+evalLNot = not evalOrd :: Char -> Int evalOrd = ord evalChr :: Int -> Char-evalChr = chr--evalRoundFloatInt :: Float -> Int-evalRoundFloatInt = round--evalTruncFloatInt :: Float -> Int-evalTruncFloatInt = truncate--evalIntFloat :: Int -> Float-evalIntFloat = fromIntegral+evalChr = chr evalBoolToInt :: Bool -> Int evalBoolToInt = fromEnum +evalFromIntegral :: IntegralType a -> NumType b -> a -> b+evalFromIntegral ta (IntegralNumType tb)+ | IntegralDict <- integralDict ta+ , IntegralDict <- integralDict tb = fromIntegral+evalFromIntegral ta (FloatingNumType tb)+ | IntegralDict <- integralDict ta+ , FloatingDict <- floatingDict tb = fromIntegral + -- Extract methods from reified dictionaries -- @@ -620,6 +828,26 @@ evalLogBase :: FloatingType a -> ((a, a) -> a) evalLogBase ty | FloatingDict <- floatingDict ty = uncurry logBase +evalTruncate :: FloatingType a -> IntegralType b -> (a -> b)+evalTruncate ta tb+ | FloatingDict <- floatingDict ta+ , IntegralDict <- integralDict tb = truncate++evalRound :: FloatingType a -> IntegralType b -> (a -> b)+evalRound ta tb+ | FloatingDict <- floatingDict ta+ , IntegralDict <- integralDict tb = round++evalFloor :: FloatingType a -> IntegralType b -> (a -> b)+evalFloor ta tb+ | FloatingDict <- floatingDict ta+ , IntegralDict <- integralDict tb = floor++evalCeiling :: FloatingType a -> IntegralType b -> (a -> b)+evalCeiling ta tb+ | FloatingDict <- floatingDict ta+ , IntegralDict <- integralDict tb = ceiling+ evalAtan2 :: FloatingType a -> ((a, a) -> a) evalAtan2 ty | FloatingDict <- floatingDict ty = uncurry atan2 @@ -758,3 +986,4 @@ | FloatingDict <- floatingDict ty = uncurry min evalMin (NonNumScalarType ty) | NonNumDict <- nonNumDict ty = uncurry min+
Data/Array/Accelerate/Language.hs view
@@ -1,9 +1,9 @@-{-# LANGUAGE FlexibleContexts, TypeFamilies, RankNTypes, ScopedTypeVariables #-}-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}-{-# OPTIONS_GHC -fno-warn-missing-methods #-}-+{-# LANGUAGE TypeOperators, FlexibleContexts, TypeFamilies, RankNTypes, ScopedTypeVariables #-}+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-}+{-# OPTIONS_GHC -fno-warn-missing-methods -fno-warn-orphans #-}+-- | -- Module : Data.Array.Accelerate.Language--- Copyright : [2009..2010] 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>@@ -16,6 +16,7 @@ -- operations (such as comparisons), we use the standard operator names with a -- '*' attached. We keep the standard alphanumeric names as they can be -- easily qualified.+-- module Data.Array.Accelerate.Language ( @@ -34,214 +35,322 @@ -- ** Scalar introduction constant, -- re-exporting from 'Smart' - -- ** Array introduction- use, unit,+ -- ** Array construction+ use, unit, replicate, generate,+ fstA, sndA, pairA, -- ** Shape manipulation reshape, - -- ** Collective array operations- slice, replicate, zip, unzip, map, zipWith, scanl, scanr, fold, foldSeg,- permute, backpermute, stencil, stencil2,+ -- ** Extraction of subarrays+ slice, + -- ** Map-like functions+ map, zipWith,+ + -- ** Reductions+ fold, fold1, foldSeg, fold1Seg,+ + -- ** Scan functions+ scanl, scanl', scanl1, scanr, scanr', scanr1,+ + -- ** Permutations+ 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- Tuple(..), fst, snd, curry, uncurry,+ fst, snd, curry, uncurry, + -- ** Index construction and destruction+ index0, index1, unindex1,+ -- ** Conditional expressions (?), -- ** Array operations with a scalar result- (!), shape,+ (!), the, shape, size, -- ** Methods of H98 classes that we need to redefine as their signatures change (==*), (/=*), (<*), (<=*), (>*), (>=*), max, min, bit, setBit, clearBit, complementBit, testBit, shift, shiftL, shiftR, rotate, rotateL, rotateR,+ truncate, round, floor, ceiling, -- ** Standard functions that we need to redefine as their signatures change (&&*), (||*), not, -- ** Conversions- boolToInt, intToFloat, roundFloatToInt, truncateFloatToInt,+ boolToInt, fromIntegral, -- ** Constants ignore - -- ** Instances of Bounded, Enum, Eq, Ord, Bits, Num, Real, Floating,- -- Fractional, RealFrac, RealFloat+ -- Instances of Bounded, Enum, Eq, Ord, Bits, Num, Real, Floating,+ -- Fractional, RealFrac, RealFloat ) where -- avoid clashes with Prelude functions-import Prelude hiding (replicate, zip, unzip, map, scanl, scanr, zipWith,- filter, max, min, not, const, fst, snd, curry, uncurry)+import Prelude hiding (replicate, zip, unzip, map, scanl, scanl1, scanr, scanr1, zipWith,+ filter, max, min, not, fst, snd, curry, uncurry,+ truncate, round, floor, ceiling, fromIntegral) -- standard libraries import Data.Bits (Bits((.&.), (.|.), xor, complement)) -- friends import Data.Array.Accelerate.Type-import Data.Array.Accelerate.Array.Sugar hiding ((!), ignore, shape)+import Data.Array.Accelerate.Tuple+import Data.Array.Accelerate.Array.Sugar hiding ((!), ignore, shape, size, index) import qualified Data.Array.Accelerate.Array.Sugar as Sugar import Data.Array.Accelerate.Smart+import Data.Array.Accelerate.AST (Arrays) --- Collective operations--- ---------------------+-- Array introduction+-- ------------------ -- |Array inlet: makes an array available for processing using the Accelerate -- language; triggers asynchronous host->device transfer if necessary. ---use :: (Ix dim, Elem e) => Array dim e -> Acc (Array dim e)-use = Use+use :: (Shape ix, Elt e) => Array ix e -> Acc (Array ix e)+use = Acc . Use -- |Scalar inlet: injects a scalar (or a tuple of scalars) into a singleton -- array for use in the Accelerate language. ---unit :: Elem e => Exp e -> Acc (Scalar e)-unit = Unit---- |Change the shape of an array without altering its contents, where------ > precondition: size dim == size dim'----reshape :: (Ix dim, Ix dim', Elem e) - => Exp dim - -> Acc (Array dim' e) - -> Acc (Array dim e)-reshape = Reshape+unit :: Elt e => Exp e -> Acc (Scalar e)+unit = Acc . Unit -- |Replicate an array across one or more dimensions as specified by the -- *generalised* array index provided as the first argument. -- -- For example, assuming 'arr' is a vector (one-dimensional array), ----- > replicate (2, All, 3) arr+-- > replicate (Z :.2 :.All :.3) arr -- -- yields a three dimensional array, where 'arr' is replicated twice across the -- first and three times across the third dimension. ---replicate :: (SliceIx slix, Elem e) +replicate :: (Slice slix, Elt e) => Exp slix - -> Acc (Array (Slice slix) e) - -> Acc (Array (SliceDim slix) e)-replicate = Replicate+ -> Acc (Array (SliceShape slix) e) + -> Acc (Array (FullShape slix) e)+replicate = Acc $$ Replicate +-- |Construct a new array by applying a function to each index.+--+generate :: (Shape ix, Elt a)+ => Exp ix+ -> (Exp ix -> Exp a)+ -> Acc (Array ix a)+generate = Acc $$ Generate++-- Shape manipulation+-- ------------------++-- |Change the shape of an array without altering its contents, where+--+-- > precondition: size ix == size ix'+--+reshape :: (Shape ix, Shape ix', Elt e) + => Exp ix + -> Acc (Array ix' e) + -> Acc (Array ix e)+reshape = Acc $$ Reshape++-- Extraction of subarrays+-- -----------------------+ -- |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 :: (SliceIx slix, Elem e) - => Acc (Array (SliceDim slix) e) +slice :: (Slice slix, Elt e) + => Acc (Array (FullShape slix) e) -> Exp slix - -> Acc (Array (Slice slix) e)-slice = Index---- |Combine the elements of two arrays pairwise. The shape of the result is --- the intersection of the two argument shapes.----zip :: (Ix dim, Elem a, Elem b) - => Acc (Array dim a)- -> Acc (Array dim b)- -> Acc (Array dim (a, b))-zip = zipWith (\x y -> tuple (x, y))+ -> Acc (Array (SliceShape slix) e)+slice = Acc $$ Index --- |The converse of 'zip', but the shape of the two results is identical to the--- shape of the argument.--- -unzip :: (Ix dim, Elem a, Elem b)- => Acc (Array dim (a, b))- -> (Acc (Array dim a), Acc (Array dim b))-unzip arr = (map fst arr, map snd arr)+-- Map-like functions+-- ------------------ -- |Apply the given function elementwise to the given array. -- -map :: (Ix dim, Elem a, Elem b) +map :: (Shape ix, Elt a, Elt b) => (Exp a -> Exp b) - -> Acc (Array dim a)- -> Acc (Array dim b)-map = Map+ -> 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 -- array is the intersection of the extents of the two source arrays. ---zipWith :: (Ix dim, Elem a, Elem b, Elem c)+zipWith :: (Shape ix, Elt a, Elt b, Elt c) => (Exp a -> Exp b -> Exp c) - -> Acc (Array dim a)- -> Acc (Array dim b)- -> Acc (Array dim c)-zipWith = ZipWith+ -> Acc (Array ix a)+ -> Acc (Array ix b)+ -> Acc (Array ix c)+zipWith = Acc $$$ ZipWith --- |Prescan of a vector. The type 'a' together with the binary function--- (first argument) and value (second argument) must form a monoid; i.e., the--- function must be /associative/ and the value must be its /neutral element/.+-- Reductions+-- ----------++-- |Reduction of the innermost dimension of an array of arbitrary rank. The first argument needs to+-- be an /associative/ function to enable an efficient parallel implementation.+-- +fold :: (Shape ix, Elt 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) + -> Acc (Array (ix:.Int) a)+ -> Acc (Array ix a)+fold1 = Acc $$ Fold1++-- |Segmented reduction along the innermost dimension. Performs one individual reduction per+-- segment of the source array. These reductions proceed in parallel. ----- The resulting vector of prescan values has the same size as the argument --- vector. The resulting scalar is the reduction value.+-- The source array must have at least rank 1. ---scanl :: Elem a+foldSeg :: (Shape ix, Elt a)+ => (Exp a -> Exp a -> Exp a) + -> Exp a + -> Acc (Array (ix:.Int) a)+ -> Acc Segments+ -> 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.+--+fold1Seg :: (Shape ix, Elt a)+ => (Exp a -> Exp a -> Exp a) + -> Acc (Array (ix:.Int) a)+ -> Acc Segments+ -> Acc (Array (ix:.Int) a)+fold1Seg = Acc $$$ Fold1Seg++-- Scan functions+-- --------------++-- |'Data.List'-style left-to-right scan, but with the additional restriction that the first+-- argument needs to be an /associative/ function to enable an efficient parallel implementation.+-- The initial value (second argument) may be arbitrary.+--+scanl :: Elt a => (Exp a -> Exp a -> Exp a) -> Exp a -> Acc (Vector a)- -> (Acc (Vector a), Acc (Scalar a))-scanl f e arr = unpair (Scanl f e arr)+ -> Acc (Vector a)+scanl = Acc $$$ Scanl --- |The right-to-left dual of 'scanl'.+-- |Variant of 'scanl', where the final result of the reduction is returned separately. +-- Denotationally, we have ---scanr :: Elem a+-- > scanl' f e arr = (crop 0 (len - 1) res, unit (res!len))+-- > where+-- > len = shape arr+-- > res = scanl f e arr+--+scanl' :: Elt a+ => (Exp a -> Exp a -> Exp a)+ -> Exp a+ -> Acc (Vector a)+ -> (Acc (Vector a), Acc (Scalar a))+scanl' = unpair . Acc $$$ Scanl'++-- |'Data.List' style left-to-right scan without an intial value (aka inclusive scan). Again, the+-- first argument needs to be an /associative/ function. Denotationally, we have+--+-- > scanl1 f e arr = crop 1 len res+-- > where+-- > len = shape arr+-- > res = scanl f e arr+--+scanl1 :: Elt a+ => (Exp a -> Exp a -> Exp a)+ -> Acc (Vector a)+ -> Acc (Vector a)+scanl1 = Acc $$ Scanl1++-- |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 f e arr = unpair (Scanr f e arr)+ -> Acc (Vector a)+scanr = Acc $$$ Scanr --- |Reduction of an array. The type 'a' together with the binary function--- (first argument) and value (second argument) must form a monoid; i.e., the --- function must be /associative/ and the value must be its /neutral element/.--- -fold :: (Ix dim, Elem a)- => (Exp a -> Exp a -> Exp a) - -> Exp a - -> Acc (Array dim a)- -> Acc (Scalar a)-fold = Fold+-- |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' --- |Segmented reduction.+-- |Right-to-left variant of 'scanl1'. ---foldSeg :: Elem a - => (Exp a -> Exp a -> Exp a) - -> Exp a - -> Acc (Vector a)- -> Acc Segments- -> Acc (Vector a)-foldSeg = FoldSeg+scanr1 :: Elt a+ => (Exp a -> Exp a -> Exp a)+ -> Acc (Vector a)+ -> Acc (Vector a)+scanr1 = Acc $$ Scanr1 +-- Permutations+-- ------------+ -- |Forward permutation specified by an index mapping. The result array is -- initialised with the given defaults and any further values that are permuted -- into the result array are added to the current value using the given -- combination function. ----- The combination function must be /associative/. Elements that are mapped to+-- The combination function must be /associative/. Eltents that are mapped to -- the magic value 'ignore' by the permutation function are being dropped. ---permute :: (Ix dim, Ix dim', Elem a)+permute :: (Shape ix, Shape ix', Elt a) => (Exp a -> Exp a -> Exp a) -- ^combination function- -> Acc (Array dim' a) -- ^array of default values- -> (Exp dim -> Exp dim') -- ^permutation- -> Acc (Array dim a) -- ^permuted array- -> Acc (Array dim' a)-permute = Permute+ -> Acc (Array ix' a) -- ^array of default values+ -> (Exp ix -> Exp ix') -- ^permutation+ -> Acc (Array ix a) -- ^permuted array+ -> Acc (Array ix' a)+permute = Acc $$$$ Permute -- |Backward permutation ---backpermute :: (Ix dim, Ix dim', Elem a)- => Exp dim' -- ^shape of the result array- -> (Exp dim' -> Exp dim) -- ^permutation- -> Acc (Array dim a) -- ^permuted array- -> Acc (Array dim' a)-backpermute = Backpermute+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)+backpermute = Acc $$$ Backpermute +-- Stencil operations+-- ------------------ -- Common stencil types --@@ -279,121 +388,420 @@ -- array, a boundary condition determines the contents of the out-of-bounds neighbourhood -- positions. ---stencil :: (Ix dim, Elem a, Elem b, Stencil dim a stencil)+stencil :: (Shape ix, Elt a, Elt b, Stencil ix a stencil) => (stencil -> Exp b) -- ^stencil function -> Boundary a -- ^boundary condition- -> Acc (Array dim a) -- ^source array- -> Acc (Array dim b) -- ^destination array-stencil = Stencil+ -> Acc (Array ix a) -- ^source array+ -> Acc (Array ix b) -- ^destination array+stencil = Acc $$$ Stencil -- |Map a binary stencil of an array. The extent of the resulting array is the intersection of -- the extents of the two source arrays. ---stencil2 :: (Ix dim, Elem a, Elem b, Elem c, - Stencil dim a stencil1, - Stencil dim b stencil2)+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- -> Acc (Array dim a) -- ^source array #1+ -> Acc (Array ix a) -- ^source array #1 -> Boundary b -- ^boundary condition #2- -> Acc (Array dim b) -- ^source array #2- -> Acc (Array dim c) -- ^destination array-stencil2 = Stencil2+ -> Acc (Array ix b) -- ^source array #2+ -> Acc (Array ix c) -- ^destination array+stencil2 = Acc $$$$$ Stencil2 --- Tuples--- ------+-- Composition of array computations+-- --------------------------------- -class Tuple tup where- type TupleT tup+-- |Pipelining of two array computations.+--+-- Denotationally, we have+--+-- > (acc1 >-> acc2) arrs = let tmp = acc1 arrs in acc2 tmp+--+-- Operationally, the array computations 'acc1' and 'acc2' will not share any subcomputations,+-- 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'.+--+infixl 1 >->+(>->) :: (Arrays a, Arrays b, Arrays c) => (Acc a -> Acc b) -> (Acc b -> Acc c) -> (Acc a -> Acc c)+(>->) = Acc $$$ Pipe - -- |Turn a tuple of scalar expressions into a scalar expressions that yields- -- a tuple.++-- Flow control constructs+-- -----------------------++-- |An array-level if-then-else construct.+--+cond :: (Arrays a)+ => Exp Bool -- ^if-condition+ -> Acc a -- ^then-array+ -> Acc a -- ^else-array+ -> Acc a+cond = Acc $$$ Acond++-- |Infix version of 'cond'.+--+infix 0 ?|+(?|) :: (Arrays a) => Exp Bool -> (Acc a, Acc a) -> Acc a+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+-- --------------------------++class Lift e where+ type Plain e++ -- |Lift the given value into 'Exp'. The value may already contain subexpressions in 'Exp'. -- - tuple :: tup -> TupleT tup+ lift :: e -> Exp (Plain e) - -- |Turn a scalar expression that yields a tuple into a tuple of scalar- -- expressions.- untuple :: TupleT tup -> tup+class Lift e => Unlift e where++ -- |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++-- instances for indices++instance Lift () where+ type Plain () = ()+ lift _ = Tuple NilTup++instance Unlift () where+ unlift _ = ()++instance Lift Z where+ type Plain Z = Z+ lift _ = IndexNil++instance Unlift Z where+ unlift _ = Z++instance (Slice (Plain ix), Lift ix) => Lift (ix :. Int) where+ type Plain (ix :. Int) = Plain ix :. Int+ lift (ix:.i) = IndexCons (lift ix) (Const i)++instance (Slice (Plain ix), Lift ix) => Lift (ix :. All) where+ type Plain (ix :. All) = Plain ix :. All+ lift (ix:.i) = IndexCons (lift ix) (Const i)++instance (Elt e, Slice (Plain ix), Lift ix) => Lift (ix :. Exp e) where+ type Plain (ix :. Exp e) = Plain ix :. e+ lift (ix:.i) = IndexCons (lift ix) i++instance (Elt e, Slice (Plain ix), Unlift ix) => Unlift (ix :. Exp e) where+ unlift e = unlift (IndexTail e) :. IndexHead e++instance Shape sh => Lift (Any sh) where+ type Plain (Any sh) = Any sh+ lift Any = IndexAny++-- instances for numeric types++instance Lift Int where+ type Plain Int = Int+ lift = Const -instance (Elem a, Elem b) => Tuple (Exp a, Exp b) where- type TupleT (Exp a, Exp b) = Exp (a, b)- tuple = tup2- untuple = untup2+instance Lift Int8 where+ type Plain Int8 = Int8+ lift = Const+ +instance Lift Int16 where+ type Plain Int16 = Int16+ lift = Const+ +instance Lift Int32 where+ type Plain Int32 = Int32+ lift = Const+ +instance Lift Int64 where+ type Plain Int64 = Int64+ lift = Const+ +instance Lift Word where+ type Plain Word = Word+ lift = Const+ +instance Lift Word8 where+ type Plain Word8 = Word8+ lift = Const+ +instance Lift Word16 where+ type Plain Word16 = Word16+ lift = Const+ +instance Lift Word32 where+ type Plain Word32 = Word32+ lift = Const+ +instance Lift Word64 where+ type Plain Word64 = Word64+ lift = Const -instance (Elem a, Elem b, Elem c) => Tuple (Exp a, Exp b, Exp c) where- type TupleT (Exp a, Exp b, Exp c) = Exp (a, b, c)- tuple = tup3- untuple = untup3+{- +instance Lift CShort where+ type Plain CShort = CShort+ lift = Const+ +instance Lift CUShort where+ type Plain CUShort = CUShort+ lift = Const+ +instance Lift CInt where+ type Plain CInt = CInt+ lift = Const+ +instance Lift CUInt where+ type Plain CUInt = CUInt+ lift = Const+ +instance Lift CLong where+ type Plain CLong = CLong+ lift = Const+ +instance Lift CULong where+ type Plain CULong = CULong+ lift = Const+ +instance Lift CLLong where+ type Plain CLLong = CLLong+ lift = Const+ +instance Lift CULLong where+ type Plain CULLong = CULLong+ lift = Const+ -}+ +instance Lift Float where+ type Plain Float = Float+ lift = Const -instance (Elem a, Elem b, Elem c, Elem d) - => Tuple (Exp a, Exp b, Exp c, Exp d) where- type TupleT (Exp a, Exp b, Exp c, Exp d) = Exp (a, b, c, d)- tuple = tup4- untuple = untup4+instance Lift Double where+ type Plain Double = Double+ lift = Const -instance (Elem a, Elem b, Elem c, Elem d, Elem e) - => Tuple (Exp a, Exp b, Exp c, Exp d, Exp e) where- type TupleT (Exp a, Exp b, Exp c, Exp d, Exp e) = Exp (a, b, c, d, e)- tuple = tup5- untuple = untup5+{-+instance Lift CFloat where+ type Plain CFloat = CFloat+ lift = Const -instance (Elem a, Elem b, Elem c, Elem d, Elem e, Elem f)- => Tuple (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f) where- type TupleT (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f)- = Exp (a, b, c, d, e, f)- tuple = tup6- untuple = untup6+instance Lift CDouble where+ type Plain CDouble = CDouble+ lift = Const+ -} -instance (Elem a, Elem b, Elem c, Elem d, Elem e, Elem f, Elem g)- => Tuple (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g) where- type TupleT (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g)- = Exp (a, b, c, d, e, f, g)- tuple = tup7- untuple = untup7+instance Lift Bool where+ type Plain Bool = Bool+ lift = Const -instance (Elem a, Elem b, Elem c, Elem d, Elem e, Elem f, Elem g, Elem h)- => Tuple (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h) where- type TupleT (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h)- = Exp (a, b, c, d, e, f, g, h)- tuple = tup8- untuple = untup8+instance Lift Char where+ type Plain Char = Char+ lift = Const -instance (Elem a, Elem b, Elem c, Elem d, Elem e, Elem f, Elem g, Elem h, Elem i)- => Tuple (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i) where- type TupleT (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i)- = Exp (a, b, c, d, e, f, g, h, i)- tuple = tup9- untuple = untup9+{-+instance Lift CChar where+ type Plain CChar = CChar+ lift = Const +instance Lift CSChar where+ type Plain CSChar = CSChar+ lift = Const --- |Extract the first component of a pair+instance Lift CUChar where+ type Plain CUChar = CUChar+ lift = Const+ -}++-- Instances for tuples++instance (Lift a, Lift b, Elt (Plain a), Elt (Plain b)) => Lift (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+ unlift = untup2++instance (Lift a, Lift b, Lift c, Elt (Plain a), Elt (Plain b), Elt (Plain c)) => Lift (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+ 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+ 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+ 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+ 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+ 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+ 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+ unlift = untup6++instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f, Lift 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+ 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+ unlift = untup7++instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f, Lift g, Lift 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) + = (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) + = 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+ 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) + = (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) + = 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+ unlift = untup9++-- Instance for scalar Accelerate expressions++instance Lift (Exp e) where+ type Plain (Exp e) = e+ lift = id++-- Helpers to lift functions++-- |Lift a unary function into 'Exp'. ---fst :: forall a b. (Elem a, Elem b) => Exp (a, b) -> Exp a-fst e = let (x, _:: Exp b) = untuple e in x+lift1 :: (Unlift e1, Lift e2) + => (e1 -> e2) -> Exp (Plain e1) -> Exp (Plain e2)+lift1 f = lift . f . unlift --- |Extract the second component of a pair-snd :: forall a b. (Elem a, Elem b) => Exp (a, b) -> Exp b-snd e = let (_ :: Exp a, y) = untuple e in y+-- |Lift a binary function into 'Exp'.+--+lift2 :: (Unlift e1, Unlift e2, Lift e3) + => (e1 -> e2 -> e3) -> Exp (Plain e1) -> Exp (Plain e2) -> Exp (Plain e3)+lift2 f x y = lift $ f (unlift x) (unlift y) --- |Converts an uncurried function to a curried function+-- |Lift a unary function to a computation over rank-1 indices. ---curry :: (Elem a, Elem b) => (Exp (a,b) -> Exp c) -> Exp a -> Exp b -> Exp c-curry f x y = f (tuple (x,y))+ilift1 :: (Exp Int -> Exp Int) -> Exp (Z :. Int) -> Exp (Z :. Int)+ilift1 f = lift1 (\(Z:.i) -> Z :. f i) --- |Converts a curried function to a function on pairs+-- |Lift a binary function to a computation over rank-1 indices. ---uncurry :: (Elem a, Elem b) => (Exp a -> Exp b -> Exp c) -> Exp (a,b) -> Exp c-uncurry f t = let (x,y) = untuple t in f x y+ilift2 :: (Exp Int -> Exp Int -> Exp Int) -> Exp (Z :. Int) -> Exp (Z :. Int) -> Exp (Z :. Int)+ilift2 f = lift2 (\(Z:.i) (Z:.j) -> Z :. f i j) +-- Helpers to lift tuples++-- |Extract the first component of a pair.+--+fst :: forall a b. (Elt a, Elt b) => Exp (a, b) -> Exp a+fst e = let (x, _:: Exp b) = unlift e in x++-- |Extract the second component of a pair.+--+snd :: forall a b. (Elt a, Elt b) => Exp (a, b) -> Exp b+snd e = let (_ :: Exp a, y) = unlift e in y++-- |Converts an uncurried function to a curried function.+--+curry :: (Elt a, Elt b) => (Exp (a, b) -> Exp c) -> Exp a -> Exp b -> Exp c+curry f x y = f (lift (x, y))++-- |Converts a curried function to a function on pairs.+--+uncurry :: (Elt a, Elt b) => (Exp a -> Exp b -> Exp c) -> Exp (a, b) -> Exp c+uncurry f t = let (x, y) = unlift t in f x y++-- Helpers to lift shapes and indices++-- |The one index for a rank-0 array.+--+index0 :: Exp Z+index0 = lift Z++-- |Turn an 'Int' expression into a rank-1 indexing expression.+--+index1 :: Exp Int -> Exp (Z:. Int)+index1 = lift . (Z:.)++-- |Turn an 'Int' expression into a rank-1 indexing expression.+--+unindex1 :: Exp (Z:. Int) -> Exp Int+unindex1 ix = let Z:.i = unlift ix in i+ + -- Conditional expressions -- ----------------------- -- |Conditional expression. -- infix 0 ?-(?) :: Elem t => Exp Bool -> (Exp t, Exp t) -> Exp t+(?) :: Elt t => Exp Bool -> (Exp t, Exp t) -> Exp t c ? (t, e) = Cond c t e @@ -403,63 +811,75 @@ -- |Expression form that extracts a scalar from an array. -- infixl 9 !-(!) :: (Ix dim, Elem e) => Acc (Array dim e) -> Exp dim -> Exp e+(!) :: (Shape ix, Elt e) => Acc (Array ix e) -> Exp ix -> Exp e (!) = IndexScalar -shape :: (Ix dim, Elem dim) => Acc (Array dim e) -> Exp dim+-- |Extraction of the element in a singleton array.+--+the :: Elt e => Acc (Scalar e) -> Exp e+the = (!index0)++-- |Expression form that yields the shape of an array.+--+shape :: (Shape ix, Elt e) => Acc (Array ix e) -> Exp ix shape = Shape +-- |Expression form that yields the size of an array.+--+size :: (Shape ix, Elt e) => Acc (Array ix e) -> Exp Int+size = Size + -- Instances of all relevant H98 classes -- ------------------------------------- -instance (Elem t, IsBounded t) => Bounded (Exp t) where+instance (Elt t, IsBounded t) => Bounded (Exp t) where minBound = mkMinBound maxBound = mkMaxBound -instance (Elem t, IsScalar t) => Enum (Exp t)+instance (Elt t, IsScalar t) => Enum (Exp t) -- succ = mkSucc -- pred = mkPred -- FIXME: ops -instance (Elem t, IsScalar t) => Prelude.Eq (Exp t) where+instance (Elt t, IsScalar t) => Prelude.Eq (Exp t) where -- FIXME: instance makes no sense with standard signatures (==) = error "Prelude.Eq.== applied to EDSL types" -instance (Elem t, IsScalar t) => Prelude.Ord (Exp t) where+instance (Elt t, IsScalar t) => Prelude.Ord (Exp t) where -- FIXME: instance makes no sense with standard signatures compare = error "Prelude.Ord.compare applied to EDSL types" -instance (Elem t, IsNum t, IsIntegral t) => Bits (Exp t) where+instance (Elt t, IsNum t, IsIntegral t) => Bits (Exp t) where (.&.) = mkBAnd (.|.) = mkBOr xor = mkBXor complement = mkBNot -- FIXME: argh, the rest have fixed types in their signatures -shift, shiftL, shiftR :: (Elem t, IsIntegral t) => Exp t -> Exp Int -> Exp t+shift, shiftL, shiftR :: (Elt t, IsIntegral t) => Exp t -> Exp Int -> Exp t shift x i = i ==* 0 ? (x, i <* 0 ? (x `shiftR` (-i), x `shiftL` i)) shiftL = mkBShiftL shiftR = mkBShiftR -rotate, rotateL, rotateR :: (Elem t, IsIntegral t) => Exp t -> Exp Int -> Exp t+rotate, rotateL, rotateR :: (Elt t, IsIntegral t) => Exp t -> Exp Int -> Exp t rotate x i = i ==* 0 ? (x, i <* 0 ? (x `rotateR` (-i), x `rotateL` i)) rotateL = mkBRotateL rotateR = mkBRotateR -bit :: (Elem t, IsIntegral t) => Exp Int -> Exp t+bit :: (Elt t, IsIntegral t) => Exp Int -> Exp t bit x = 1 `shiftL` x -setBit, clearBit, complementBit :: (Elem t, IsIntegral t) => Exp t -> Exp Int -> Exp t+setBit, clearBit, complementBit :: (Elt t, IsIntegral t) => Exp t -> Exp Int -> Exp t x `setBit` i = x .|. bit i x `clearBit` i = x .&. complement (bit i) x `complementBit` i = x `xor` bit i -testBit :: (Elem t, IsIntegral t) => Exp t -> Exp Int -> Exp Bool+testBit :: (Elt t, IsIntegral t) => Exp t -> Exp Int -> Exp Bool x `testBit` i = (x .&. bit i) /=* 0 -instance (Elem t, IsNum t) => Num (Exp t) where+instance (Elt t, IsNum t) => Num (Exp t) where (+) = mkAdd (-) = mkSub (*) = mkMul@@ -468,11 +888,11 @@ signum = mkSig fromInteger = constant . fromInteger -instance (Elem t, IsNum t) => Real (Exp t)+instance (Elt t, IsNum t) => Real (Exp t) -- FIXME: Why did we include this class? We won't need `toRational' until -- we support rational numbers in AP computations. -instance (Elem t, IsIntegral t) => Integral (Exp t) where+instance (Elt t, IsIntegral t) => Integral (Exp t) where quot = mkQuot rem = mkRem div = mkIDiv@@ -481,7 +901,7 @@ -- divMod = -- toInteger = -- makes no sense -instance (Elem t, IsFloating t) => Floating (Exp t) where+instance (Elt t, IsFloating t) => Floating (Exp t) where pi = mkPi sin = mkSin cos = mkCos@@ -497,20 +917,18 @@ log = mkLog (**) = mkFPow logBase = mkLogBase- -- FIXME: add other ops -instance (Elem t, IsFloating t) => Fractional (Exp t) where+instance (Elt t, IsFloating t) => Fractional (Exp t) where (/) = mkFDiv recip = mkRecip fromRational = constant . fromRational- -- FIXME: add other ops -instance (Elem t, IsFloating t) => RealFrac (Exp t)- -- FIXME: add ops+instance (Elt t, IsFloating t) => RealFrac (Exp t)+ -- FIXME: add other ops -instance (Elem t, IsFloating t) => RealFloat (Exp t) where+instance (Elt t, IsFloating t) => RealFloat (Exp t) where atan2 = mkAtan2- -- FIXME: add ops+ -- FIXME: add other ops -- Methods from H98 classes, where we need other signatures@@ -520,12 +938,12 @@ -- |Equality lifted into Accelerate expressions. ---(==*) :: (Elem t, IsScalar t) => Exp t -> Exp t -> Exp Bool+(==*) :: (Elt t, IsScalar t) => Exp t -> Exp t -> Exp Bool (==*) = mkEq -- |Inequality lifted into Accelerate expressions. ---(/=*) :: (Elem t, IsScalar t) => Exp t -> Exp t -> Exp Bool+(/=*) :: (Elt t, IsScalar t) => Exp t -> Exp t -> Exp Bool (/=*) = mkNEq -- compare :: a -> a -> Ordering -- we have no enumerations at the moment@@ -533,35 +951,49 @@ -- |Smaller-than lifted into Accelerate expressions. ---(<*) :: (Elem t, IsScalar t) => Exp t -> Exp t -> Exp Bool+(<*) :: (Elt t, IsScalar t) => Exp t -> Exp t -> Exp Bool (<*) = mkLt -- |Greater-or-equal lifted into Accelerate expressions. ---(>=*) :: (Elem t, IsScalar t) => Exp t -> Exp t -> Exp Bool+(>=*) :: (Elt t, IsScalar t) => Exp t -> Exp t -> Exp Bool (>=*) = mkGtEq -- |Greater-than lifted into Accelerate expressions. ---(>*) :: (Elem t, IsScalar t) => Exp t -> Exp t -> Exp Bool+(>*) :: (Elt t, IsScalar t) => Exp t -> Exp t -> Exp Bool (>*) = mkGt -- |Smaller-or-equal lifted into Accelerate expressions. ---(<=*) :: (Elem t, IsScalar t) => Exp t -> Exp t -> Exp Bool+(<=*) :: (Elt t, IsScalar t) => Exp t -> Exp t -> Exp Bool (<=*) = mkLtEq -- |Determine the maximum of two scalars. ---max :: (Elem t, IsScalar t) => Exp t -> Exp t -> Exp t+max :: (Elt t, IsScalar t) => Exp t -> Exp t -> Exp t max = mkMax -- |Determine the minimum of two scalars. ---min :: (Elem t, IsScalar t) => Exp t -> Exp t -> Exp t+min :: (Elt t, IsScalar t) => Exp t -> Exp t -> Exp t min = mkMin +-- |Conversions from the RealFrac class+--+truncate :: (Elt a, Elt b, IsFloating a, IsIntegral b) => Exp a -> Exp b+truncate = mkTruncate +round :: (Elt a, Elt b, IsFloating a, IsIntegral b) => Exp a -> Exp b+round = mkRound++floor :: (Elt a, Elt b, IsFloating a, IsIntegral b) => Exp a -> Exp b+floor = mkFloor++ceiling :: (Elt a, Elt b, IsFloating a, IsIntegral b) => Exp a -> Exp b+ceiling = mkCeiling++ -- Non-overloaded standard functions, where we need other signatures -- ----------------------------------------------------------------- @@ -592,17 +1024,10 @@ boolToInt :: Exp Bool -> Exp Int boolToInt = mkBoolToInt --- |Convert an Int to a Float-intToFloat :: Exp Int -> Exp Float-intToFloat = mkIntFloat---- |Round Float to Int-roundFloatToInt :: Exp Float -> Exp Int-roundFloatToInt = mkRoundFloatInt---- |Truncate Float to Int-truncateFloatToInt :: Exp Float -> Exp Int-truncateFloatToInt = mkTruncFloatInt+-- |General coercion from integral types+--+fromIntegral :: (Elt a, Elt b, IsIntegral a, IsNum b) => Exp a -> Exp b+fromIntegral = mkFromIntegral -- Constants@@ -610,5 +1035,5 @@ -- |Magic value identifying elements that are ignored in a forward permutation ---ignore :: Ix dim => Exp dim+ignore :: Shape ix => Exp ix ignore = constant Sugar.ignore
+ Data/Array/Accelerate/Prelude.hs view
@@ -0,0 +1,376 @@+-- |+-- Module : Data.Array.Accelerate.Prelude+-- Copyright : [2010..2011] Manuel M T Chakravarty, Ben Lever+-- License : BSD3+--+-- Maintainer : Manuel M T Chakravarty <chak@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--+-- Standard functions that are not part of the core set (directly represented in the AST), but are+-- instead implemented in terms of the core set.+--++module Data.Array.Accelerate.Prelude (++ -- ** Map-like+ zip, unzip,+ + -- ** Reductions+ foldAll, fold1All,+ + -- ** Scans+ prescanl, postscanl, prescanr, postscanr, ++ -- ** Segmented scans+ scanlSeg, scanlSeg', scanl1Seg, prescanlSeg, postscanlSeg, + scanrSeg, scanrSeg', scanr1Seg, prescanrSeg, postscanrSeg+ +) where++-- avoid clashes with Prelude functions+import Prelude hiding (replicate, zip, unzip, map, scanl, scanl1, scanr, scanr1, zipWith,+ filter, max, min, not, fst, snd, curry, uncurry)+import qualified Prelude++-- friends +import Data.Array.Accelerate.Array.Sugar hiding ((!), ignore, shape, size, index)+import Data.Array.Accelerate.Language+++-- Map-like composites+-- -------------------++-- |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) + => Acc (Array sh a)+ -> Acc (Array sh b)+ -> Acc (Array sh (a, b))+zip = zipWith (curry lift)++-- |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)+++-- 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 + -> 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) + -> Acc (Array sh a)+ -> Acc (Scalar a)+fold1All f arr = fold1 f (reshape (index1 $ size arr) arr)+++-- Composite scans+-- ---------------++-- |Left-to-right prescan (aka exclusive scan). As for 'scan', the first argument must be an+-- /associative/ function. Denotationally, we have+--+-- > prescanl f e = Prelude.fst . scanl' f e+--+prescanl :: Elt a+ => (Exp a -> Exp a -> Exp a)+ -> Exp a+ -> Acc (Vector a)+ -> Acc (Vector a)+prescanl f e = Prelude.fst . scanl' f e++-- |Left-to-right postscan, a variant of 'scanl1' with an initial value. Denotationally, we have+--+-- > postscanl f e = map (e `f`) . scanl1 f+--+postscanl :: Elt a+ => (Exp a -> Exp a -> Exp a)+ -> Exp a+ -> Acc (Vector a)+ -> Acc (Vector a)+postscanl f e = map (e `f`) . scanl1 f++-- |Right-to-left prescan (aka exclusive scan). As for 'scan', the first argument must be an+-- /associative/ function. Denotationally, we have+--+-- > prescanr f e = Prelude.fst . scanr' f e+--+prescanr :: Elt a+ => (Exp a -> Exp a -> Exp a)+ -> Exp a+ -> Acc (Vector a)+ -> Acc (Vector a)+prescanr f e = Prelude.fst . scanr' f e++-- |Right-to-left postscan, a variant of 'scanr1' with an initial value. Denotationally, we have+--+-- > postscanr f e = map (e `f`) . scanr1 f+--+postscanr :: Elt a+ => (Exp a -> Exp a -> Exp a)+ -> Exp a+ -> Acc (Vector a)+ -> Acc (Vector a)+postscanr f e = map (`f` e) . scanr1 f+++-- Segmented scans+-- ---------------++-- |Segmented version of 'scanl'.+--+scanlSeg :: Elt a+ => (Exp a -> Exp a -> Exp a)+ -> Exp a+ -> Acc (Vector a)+ -> Acc Segments+ -> Acc (Vector a)+scanlSeg f e arr seg = scans+ where+ -- Segmented scan implemented by performing segmented exclusive-scan (scan1)+ -- on a vector formed by injecting the identity element at the start of each+ -- segment.+ scans = scanl1Seg f idInjArr seg'+ idInjArr = zipWith (\h x -> h ==* 1 ? (fst x, snd x)) headFlags $ zip idsArr arrShifted++ headFlags = permute (+) zerosArr' (\ix -> index1 $ segOffsets' ! ix)+ $ generate (shape seg) (const 1)++ arrShifted = backpermute nSh (\ix -> index1 $ shiftCoords ! ix) arr++ idsArr = generate nSh (const e)++ -- As the identity elements are injected in to the vector for each segment, the+ -- remaining elements must be shifted forwarded (to the left). shiftCoords specifies+ -- how each element is backpermuted to its shifted position.+ shiftCoords = permute (+) zerosArr' (ilift1 $ \i -> i + (offsetArr ! index1 i) + 1) coords+ coords = Prelude.fst $ scanl' (+) 0 onesArr++ offsetArr = scanl1 max $ permute (+) zerosArr (\ix -> index1 $ segOffsets ! ix) segIxs+ segIxs = Prelude.fst $ scanl' (+) 0 $ generate (index1 $ size seg) (const 1)++ segOffsets' = Prelude.fst $ scanl' (+) 0 seg'+ segOffsets = Prelude.fst $ scanl' (+) 0 seg++ --+ 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\''.+--+-- 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+ => (Exp a -> Exp a -> Exp a)+ -> Exp a+ -> Acc (Vector a)+ -> Acc Segments+ -> (Acc (Vector a), Acc (Vector a))+scanlSeg' 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+ -- elements right, with the final element in the segment being removed.+ scans = scanl1Seg f idInjArr seg+ idInjArr = zipWith (\h x -> h ==* 1 ? (fst x, snd x)) headFlags $ zip idsArr arrShifted++ headFlags = permute (+) zerosArr (\ix -> index1 $ segOffsets ! ix)+ $ generate (shape seg) (const (1 :: Exp Int))+ segOffsets = Prelude.fst $ scanl' (+) 0 seg++ arrShifted = backpermute (shape arr) (ilift1 $ \i -> i ==* 0 ? (i, i - 1)) arr++ idsArr = generate (shape arr) (const e)+ zerosArr = generate (shape arr) (const 0)++ -- Sum of each segment is computed by performing a segmented postscan on+ -- the original vector and taking the tail elements.+ sums = map (`f` e)+ $ backpermute (shape seg) (\ix -> index1 $ sumOffsets ! ix)+ $ scanl1Seg f arr seg+ sumOffsets = map (subtract 1) $ scanl1 (+) seg++-- |Segmented version of 'scanl1'.+--+scanl1Seg :: Elt a+ => (Exp a -> Exp a -> Exp a)+ -> Acc (Vector a)+ -> Acc Segments+ -> Acc (Vector a)+scanl1Seg f arr seg = map snd $ scanl1 (mkSegApply f) $ zip (mkHeadFlags seg) arr++-- |Segmented version of 'prescanl'.+--+prescanlSeg :: Elt a+ => (Exp a -> Exp a -> Exp a)+ -> Exp a+ -> Acc (Vector a)+ -> Acc Segments+ -> Acc (Vector a)+prescanlSeg f e arr seg = Prelude.fst $ scanlSeg' f e arr seg++-- |Segmented version of 'postscanl'.+--+postscanlSeg :: Elt a+ => (Exp a -> Exp a -> Exp a)+ -> Exp a+ -> Acc (Vector a)+ -> Acc Segments+ -> Acc (Vector a)+postscanlSeg f e arr seg = map (e `f`) $ scanl1Seg f arr seg++-- |Segmented version of 'scanr'.+--+scanrSeg :: Elt a+ => (Exp a -> Exp a -> Exp a)+ -> Exp a+ -> Acc (Vector a)+ -> Acc Segments+ -> Acc (Vector a)+scanrSeg f e arr seg = scans+ where+ -- Using technique described for scanlSeg.+ scans = scanr1Seg f idInjArr seg'+ idInjArr = zipWith (\h x -> h ==* 1 ? (fst x, snd x)) tailFlags $ zip idsArr arrShifted++ tailFlags = permute (+) zerosArr' (\ix -> index1 $ (segOffsets' ! ix) - 1)+ $ generate (shape seg) (const 1)++ arrShifted = backpermute nSh (\ix -> index1 $ shiftCoords ! ix) arr++ idsArr = generate nSh (const e)++ --+ 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+ segIxs = Prelude.fst $ scanl' (+) 0 $ generate (shape seg) (const 1)++ segOffsets' = scanl1 (+) seg'+ segOffsets = Prelude.fst $ scanl' (+) 0 seg++ --+ nSh = index1 $ size arr + size seg+ seg' = map (+ 1) seg+ onesArr = generate (shape arr) (const 1)+ zerosArr = generate (shape arr) (const 0)+ zerosArr' = generate nSh (const 0)++-- |Segmented version of 'scanrSeg\''.+--+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)+ where+ -- Using technique described for scanlSeg'.+ 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))+ segOffsets = scanl1 (+) seg++ arrShifted = backpermute (shape arr) (ilift1 $ \i -> i ==* (size arr - 1) ? (i, i + 1)) arr++ idsArr = generate (shape arr) (const e)+ zerosArr = generate (shape arr) (const 0)++ --+ sums = map (`f` e) $ backpermute (shape seg) (\ix -> index1 $ sumOffsets ! ix)+ $ scanr1Seg f arr seg+ sumOffsets = Prelude.fst $ scanl' (+) 0 seg++-- |Segmented version of 'scanr1'.+--+scanr1Seg :: Elt a+ => (Exp a -> Exp a -> Exp a)+ -> Acc (Vector a)+ -> Acc Segments+ -> Acc (Vector a)+scanr1Seg f arr seg = map snd $ scanr1 (mkSegApply f) $ zip (mkTailFlags seg) arr++-- |Segmented version of 'prescanr'.+--+prescanrSeg :: Elt a+ => (Exp a -> Exp a -> Exp a)+ -> Exp a+ -> Acc (Vector a)+ -> Acc Segments+ -> Acc (Vector a)+prescanrSeg f e arr seg = Prelude.fst $ scanrSeg' f e arr seg++-- |Segmented version of 'postscanr'.+--+postscanrSeg :: Elt a+ => (Exp a -> Exp a -> Exp a)+ -> Exp a+ -> Acc (Vector a)+ -> Acc Segments+ -> Acc (Vector a)+postscanrSeg f e arr seg = map (`f` e) $ scanr1Seg f arr seg+++-- Segmented scan helpers+-- ----------------------++-- |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+ where+ (segOffsets, len) = scanl' (+) 0 seg+ 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 seg+ = permute (\_ _ -> 1) zerosArr (ilift1 $ \i -> (segOffsets ! index1 i) - 1) segOffsets+ where+ segOffsets = scanl1 (+) seg+ 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)+ => (Exp e -> Exp e -> Exp e)+ -> (Exp (Int, e) -> Exp (Int, e) -> Exp (Int, e))+mkSegApply op = apply+ where+ apply a b = lift (((aF ==* 1) ||* (bF ==* 1)) ? (1, 0), (bF ==* 1) ? (bV, aV `op` bV))+ where+ aF = fst a+ aV = snd a+ bF = fst b+ bV = snd b+
Data/Array/Accelerate/Pretty.hs view
@@ -1,13 +1,13 @@-{-# LANGUAGE GADTs, FlexibleInstances, PatternGuards, TypeOperators #-}-{-# LANGUAGE ScopedTypeVariables #-}---- |Embedded array processing language: pretty printing------ Copyright (c) 2009 Manuel M T Chakravarty, Gabriele Keller, Sean Lee------ License: BSD3+{-# LANGUAGE GADTs, FlexibleInstances, TypeSynonymInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- |+-- Module : Data.Array.Accelerate.Pretty+-- Copyright : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee+-- License : BSD3 ------ Description ---------------------------------------------------------------+-- Maintainer : Manuel M T Chakravarty <chak@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions) -- module Data.Array.Accelerate.Pretty (@@ -20,266 +20,18 @@ import Text.PrettyPrint -- friends-import Data.Array.Accelerate.Array.Sugar-import Data.Array.Accelerate.Tuple+import Data.Array.Accelerate.Pretty.Print import Data.Array.Accelerate.AST-import Data.Array.Accelerate.Type - -- |Show instances -- --------------- instance Show (OpenAcc aenv a) where- show c = render $ prettyAcc 0 c+ show c = render $ prettyAcc 0 noParens c instance Show (OpenFun env aenv f) where show f = render $ prettyFun 0 f instance Show (OpenExp env aenv t) where- show e = render $ prettyExp 0 noParens e----- Pretty printing--- ------------------- Pretty print an array expression----prettyAcc :: Int -> OpenAcc aenv a -> Doc-prettyAcc lvl (Let acc1 acc2) - = text "let a" <> int lvl <+> char '=' <+> prettyAcc lvl acc1 <+>- text " in " <+> prettyAcc (lvl + 1) acc2-prettyAcc lvl (Let2 acc1 acc2) - = text "let (a" <> int lvl <> text ", a" <> int (lvl + 1) <> char ')' <+> char '=' <+>- prettyAcc lvl acc1 <+>- text " in " <+> prettyAcc (lvl + 2) acc2-prettyAcc _ (Avar idx) = text $ "a" ++ show (idxToInt idx)-prettyAcc _ (Use arr) = prettyArrOp "use" [prettyArray arr]-prettyAcc lvl (Unit e) = prettyArrOp "unit" [prettyExp lvl parens e]-prettyAcc lvl (Reshape sh acc)- = prettyArrOp "reshape" [prettyExp lvl parens sh, prettyAccParens lvl acc]-prettyAcc lvl (Replicate _ty ix acc) - = prettyArrOp "replicate" [prettyExp lvl id ix, prettyAccParens lvl acc]-prettyAcc lvl (Index _ty acc ix) - = sep [prettyAccParens lvl acc, char '!', prettyExp lvl id ix]-prettyAcc lvl (Map f acc)- = prettyArrOp "map" [parens (prettyFun lvl f), prettyAccParens lvl acc]-prettyAcc lvl (ZipWith f acc1 acc2) - = prettyArrOp "zipWith"- [parens (prettyFun lvl f), prettyAccParens lvl acc1, - prettyAccParens lvl acc2]-prettyAcc lvl (Fold f e acc) - = prettyArrOp "fold" [parens (prettyFun lvl f), prettyExp lvl parens e,- prettyAccParens lvl acc]-prettyAcc lvl (FoldSeg f e acc1 acc2) - = prettyArrOp "foldSeg" [parens (prettyFun lvl f), prettyExp lvl parens e,- prettyAccParens lvl acc1, prettyAccParens lvl acc2]-prettyAcc lvl (Scanl f e acc)- = prettyArrOp "scanl" [parens (prettyFun lvl f), prettyExp lvl parens e,- prettyAccParens lvl acc]-prettyAcc lvl (Scanr f e acc)- = prettyArrOp "scanr" [parens (prettyFun lvl f), prettyExp lvl parens e,- prettyAccParens lvl acc]-prettyAcc lvl (Permute f dfts p acc) - = prettyArrOp "permute" [parens (prettyFun lvl f), prettyAccParens lvl dfts,- parens (prettyFun lvl p), prettyAccParens lvl acc]-prettyAcc lvl (Backpermute sh p acc) - = prettyArrOp "backpermute" [prettyExp lvl parens sh,- parens (prettyFun lvl p),- prettyAccParens lvl acc]- -prettyAcc lvl (Stencil sten bndy acc)- = prettyArrOp "stencil" [parens (prettyFun lvl sten),- prettyBoundary acc bndy,- prettyAccParens lvl acc]--prettyAcc lvl (Stencil2 sten bndy1 acc1 bndy2 acc2)- = prettyArrOp "stencil2" [parens (prettyFun lvl sten),- prettyBoundary acc1 bndy1,- prettyAccParens lvl acc1,- prettyBoundary acc2 bndy2,- prettyAccParens lvl acc2]--prettyBoundary :: forall aenv dim e. Elem e - => {-dummy-}OpenAcc aenv (Array dim e) -> Boundary (ElemRepr e) -> Doc-prettyBoundary _ Clamp = text "Clamp"-prettyBoundary _ Mirror = text "Mirror"-prettyBoundary _ Wrap = text "Wrap"-prettyBoundary _ (Constant e) = parens $ text "Constant" <+> text (show (toElem e :: e))- -prettyArrOp :: String -> [Doc] -> Doc-prettyArrOp name docs = hang (text name) 2 $ sep docs---- Wrap into parenthesis--- -prettyAccParens :: Int -> OpenAcc aenv a -> Doc-prettyAccParens lvl acc@(Avar _) = prettyAcc lvl acc-prettyAccParens lvl acc = parens (prettyAcc lvl acc)---- Pretty print a function over scalar expressions.----prettyFun :: Int -> OpenFun env aenv fun -> Doc-prettyFun lvl fun = - let (n, bodyDoc) = count fun- in- char '\\' <> hsep [text $ "x" ++ show idx | idx <- reverse [0..n]] <+> - text "->" <+> bodyDoc- where- count :: OpenFun env aenv fun -> (Int, Doc)- count (Body body) = (-1, prettyExp lvl noParens body)- count (Lam fun) = let (n, body) = count fun in (1 + n, body)---- Pretty print an expression.------ * Apply the wrapping combinator (1st argument) to any compound expressions.----prettyExp :: forall t env aenv. - Int -> (Doc -> Doc) -> OpenExp env aenv t -> Doc-prettyExp _ _ (Var idx) = text $ "x" ++ show (idxToInt idx)-prettyExp _ _ (Const v) = text $ show (toElem v :: t)-prettyExp lvl _ (Tuple tup) = prettyTuple lvl tup-prettyExp lvl wrap (Prj idx e) - = wrap $ prettyTupleIdx idx <+> prettyExp lvl parens e-prettyExp lvl wrap (Cond c t e) - = wrap $ sep [prettyExp lvl parens c <+> char '?', - parens (prettyExp lvl noParens t <> comma <+> - prettyExp lvl noParens e)]-prettyExp _ _ (PrimConst a) = prettyConst a-prettyExp lvl wrap (PrimApp p a) - = wrap $ prettyPrim p <+> prettyExp lvl parens a-prettyExp lvl wrap (IndexScalar idx i)- = wrap $ cat [prettyAccParens lvl idx, char '!', prettyExp lvl parens i]-prettyExp lvl wrap (Shape idx)- = wrap $ text "shape" <+> prettyAccParens lvl idx---- Pretty print nested pairs as a proper tuple.----prettyTuple :: Int -> Tuple (OpenExp env aenv) t -> Doc-prettyTuple lvl e = parens $ sep (map (<> comma) (init es) ++ [last es])- where- es = collect e- --- collect :: Tuple (OpenExp env aenv) t -> [Doc]- collect NilTup = []- collect (SnocTup tup e) = collect tup ++ [prettyExp lvl noParens e]- --- Pretty print an index for a tuple projection----prettyTupleIdx :: TupleIdx t e -> Doc-prettyTupleIdx = int . toInt- where- toInt :: TupleIdx t e -> Int- toInt ZeroTupIdx = 0- toInt (SuccTupIdx tup) = toInt tup + 1---- Pretty print a primitive constant----prettyConst :: PrimConst a -> Doc-prettyConst (PrimMinBound _) = text "minBound"-prettyConst (PrimMaxBound _) = text "maxBound"-prettyConst (PrimPi _) = text "pi"---- Pretty print a primitive operation----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 (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 PrimRoundFloatInt = text "round"-prettyPrim PrimTruncFloatInt = text "trunc"-prettyPrim PrimIntFloat = text "intFloat"-prettyPrim PrimBoolToInt = text "boolToInt"--{---- Pretty print type----prettyAnyType :: ScalarType a -> Doc-prettyAnyType ty = text $ show ty--}--prettyArray :: forall dim a. Array dim a -> Doc-prettyArray arr@(Array sh _) - = hang (text "Array") 2 $- sep [showDoc $ (toElem sh :: dim), dataDoc]- where- showDoc :: forall a. Show a => a -> Doc- showDoc = text . show- l = toList arr- dataDoc | length l <= 1000 = showDoc l- | otherwise = showDoc (take 1000 l) <+> - text "{truncated at 1000 elements}"----- Auxilliary pretty printing combinators--- --noParens :: Doc -> Doc-noParens = id---- Auxilliary ops------- Convert a typed de Brujin index to the corresponding integer----idxToInt :: Idx env t -> Int-idxToInt ZeroIdx = 0-idxToInt (SuccIdx idx) = 1 + idxToInt idx---- Auxilliary dictionary operations--- + show e = render $ prettyExp 0 0 noParens e -{---- Show scalar values----runScalarShow :: ScalarType a -> (a -> String)-runScalarShow (NumScalarType (IntegralNumType ty)) - | IntegralDict <- integralDict ty = show-runScalarShow (NumScalarType (FloatingNumType ty)) - | FloatingDict <- floatingDict ty = show-runScalarShow (NonNumScalarType ty) - | NonNumDict <- nonNumDict ty = show--}
+ Data/Array/Accelerate/Pretty/Graphviz.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE GADTs, TypeOperators, ScopedTypeVariables #-}+-- |+-- Module : Data.Array.Accelerate.Pretty.Graphviz+-- Copyright : [2010..2011] Sean Seefried+-- License : BSD3+--+-- Maintainer : Manuel M T Chakravarty <chak@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--+-- Functions for printing out Graphviz graphs in DOT format.+--++module Data.Array.Accelerate.Pretty.Graphviz (++ -- * Graphviz printing functions+ dumpAcc++) where++-- standard libraries+import Control.Exception (finally)+import Control.Monad.State+import System.Exit+import System.FilePath+import System.Directory+import System.Posix.Process+import System.IO+import System.IO.Error hiding (catch)+import Text.Printf++-- friends+import Data.Array.Accelerate.Pretty.Traverse+import Data.Array.Accelerate.AST++-- | Detects if the dot command line tool from the Graphviz package exists.+-- If it does outputs a Postscript file, otherwise a ".dot" file.+--+dumpAcc :: String -> OpenAcc aenv a -> IO ()+dumpAcc basename acc = do+ exists <- findExecutable "dot"+ case exists of+ Just dot -> withTempFile "ast.dot" (writePSFile dot)+ Nothing -> do+ putStrLn "Couldn't find `dot' tool. Just writing DOT file."+ writeDotFile+ where+ writePSFile dot file h = do+ hPutStr h (dotAcc acc)+ hFlush h+ let output = basename <.> "ps"+ flags = [file, "-Tps", "-o" ++ output]+ status <- getProcessStatus True True =<< forkProcess (executeFile dot False flags Nothing)+ case status of+ Just (Exited ExitSuccess) -> putStrLn $ "PS file successfully written to `" ++ output ++ "'"+ _ -> do+ putStrLn "dot failed to write Postscript file. Just writing the DOT file."+ writeDotFile -- fall back to writing the dot file+ --+ writeDotFile :: IO ()+ writeDotFile = catch writeDotFile' handler+ writeDotFile' = do+ let path = basename ++ ".dot"+ h <- openFile path WriteMode+ hPutStr h (dotAcc acc)+ putStrLn ("DOT file successfully written to `" ++ path ++ "'")+ hClose h+ handler :: IOError -> IO ()+ handler e =+ case True of+ _ | isAlreadyInUseError e -> putStrLn "isAlreadyInUseError"+ | isDoesNotExistError e -> putStrLn "isDoesNotExistError"+ | isFullError e -> putStrLn "isFullError"+ | isEOFError e -> putStrLn "isEOFError"+ | isPermissionError e -> putStrLn "isPermissionError"+ | isIllegalOperation e -> putStrLn "isIllegalOperation"+ | isUserError e -> putStrLn "isUserError"+ | otherwise -> putStrLn "Unknown error"+++withTempFile :: String -> (FilePath -> Handle -> IO a) -> IO a+withTempFile pattern f = do+ tempDir <- catch getTemporaryDirectory (\_ -> return ".")+ (tempFile, tempH) <- openTempFile tempDir pattern+ finally (f tempFile tempH) (hClose tempH >> removeFile tempFile)++dotAcc :: OpenAcc aenv a -> String+dotAcc = toDigraph (travAcc dotLabels combineDot leafDot)++data Node = Node { nodeId :: String, label :: String, childNodes :: [String], transitions :: [String] }+data DotState = DotState { counter :: Int }++mkNodeId :: Int -> String+mkNodeId = printf "node%03d"++mkNode :: String -> [String] -> [String] -> State DotState Node+mkNode lbl childNodes' transitions' = do+ s <- get+ let c = counter s+ put DotState { counter = c + 1 }+ return Node { nodeId = mkNodeId c, label = lbl, childNodes = childNodes', transitions = transitions' }++dotLabels :: Labels+dotLabels = Labels { accFormat = "yellow"+ , expFormat = "orange"+ , funFormat = "blue"+ , tupleFormat = "green"+ , primFunFormat = "red"+ , arrayFormat = "purple"+ , boundaryFormat = "cyan" }++++combineDot :: String -> String -> [State DotState Node] -> State DotState Node+combineDot color source targets = do+ targetNodes <- sequence targets+ s <- get+ let newNodeId = mkNodeId (counter s)+ childNodes1 = [nodeDef newNodeId source color ]+ childNodes2 = concatMap childNodes targetNodes+ lines1 = map (digraphLine newNodeId) targetNodes+ lines2 = concatMap transitions targetNodes+ mkNode source (childNodes1 ++ childNodes2) (lines1 ++ lines2)+ where+ digraphLine :: String -> Node -> String+ digraphLine sourceNodeId targetNode =+ sourceNodeId ++ " -> " ++ nodeId targetNode ++ ";"++leafDot :: String -> String -> State DotState Node+leafDot color lbl = do+ s <- get+ let c = counter s+ put DotState { counter = c + 1 }+ return Node { nodeId = mkNodeId c, label = lbl+ , childNodes = [ nodeDef (mkNodeId c) lbl color ]+ , transitions = [] }++nodeDef :: String -> String -> String -> String+nodeDef nodeId' label' color = printf "%s [ color=\"%s\", label=\"%s\" ];" nodeId' color label'++toDigraph :: (a -> State DotState Node) -> a -> String+toDigraph f e =+ header ++ unlines (childNodes node) ++ unlines (transitions node) ++ footer+ where+ node = evalState (f e) DotState { counter = 0 }+ header = unlines [ "/* Automatically generated by Accelerate */"+ , "digraph AST {"+ , "size=\"7.5,11\";"+ , "ratio=\"compress\";"+ , "node[color=lightblue2, style=filled];"]+ footer = "}"+
+ Data/Array/Accelerate/Pretty/HTML.hs view
@@ -0,0 +1,200 @@+{-# LANGUAGE GADTs, OverloadedStrings, ScopedTypeVariables, NoMonomorphismRestriction #-}+-- |+-- Module : Data.Array.Accelerate.Pretty.HTML+-- 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.Pretty.HTML (++ -- * HTML printing function+ dumpHtmlAST++) where+++-- standard libraries+import Data.String+import Data.Monoid+import qualified Data.Text as T+import Text.Blaze.Renderer.Utf8+import Text.Blaze.Html4.Transitional ((!))+import qualified Text.Blaze.Html4.Transitional as H+import qualified Text.Blaze.Html4.Transitional.Attributes as A++import System.IO+import System.IO.Error hiding (catch)+import qualified Data.ByteString.Lazy as BS++-- friends+import Data.Array.Accelerate.AST+import Data.Array.Accelerate.Pretty.Traverse++combineHtml :: String -> String -> [H.Html] -> H.Html+combineHtml cssClass label nodes = do+ let inner = foldl (>>) (return ()) nodes+ H.div ! A.class_ ("node " `mappend` fromString cssClass `mappend` " expanded") $ do+ H.span ! A.class_ "selector" $ H.text (fromString label)+ inner+leafHtml :: String -> String -> H.Html+leafHtml cssClass label =+ H.div ! A.class_ ("node " `mappend` fromString cssClass `mappend` " leaf") $+ H.span $ H.text (fromString label)++htmlLabels :: Labels+htmlLabels = Labels { accFormat = "array-node"+ , expFormat = "exp-node"+ , funFormat = "fun-node"+ , primFunFormat = "prim-fun-node"+ , tupleFormat = "tuple-node"+ , arrayFormat = "array-node"+ , boundaryFormat = "boundary-node" }+++-- combine :: Monad m => String -> String -> [m a] -> m a+-- combine = undefined+--+-- leafNode :: Monad m => String -> String -> m a+-- leafNode = undefined++htmlAST :: OpenAcc aenv a -> H.Html+htmlAST acc = H.docTypeHtml $+ H.head $ do+ H.meta ! A.httpEquiv "Content-Type" ! A.content "text/html; charset=UTF-8"+ H.script ! A.type_ "text/javascript" !+ A.src "https://ajax.googleapis.com/ajax/libs/jquery/1.4.4/jquery.min.js" $ mempty+ H.link ! A.rel "stylesheet" ! A.href "accelerate.css" ! A.type_ "text/css"+ H.script ! A.type_ "text/javascript" $ H.text $+ T.unlines ["function collapse() {"+ ," var parent=$(this).parent();"+ ," var that = $(this);"+ ," parent.addClass(\"collapsed\").removeClass(\"expanded\");"+ ," parent.children().each(function (i) {"+ ," if ($(this).get(0) != that.get(0)) {"+ ," $(this).hide(100);"+ ," }"+ ," });"+ ," $(this).unbind();"+ ," $(this).click(expand);"+ ,"}"+ , ""+ , "function expand() {"+ , "var parent=$(this).parent();"+ , "parent.removeClass(\"collapsed\").addClass(\"expanded\");"+ , "parent.children().show(100);"+ , "$(this).show();"+ , "$(this).unbind();"+ , "$(this).click(collapse);"+ , "}"+ , "$(document).ready(function () {"+ , " $('.expanded>.selector').click(collapse);"+ , " $('.collapsed>.selector').click(expand);"+ , "});"]+ H.body $ do+ H.table ! A.border "0" $+ H.tr $ do+ H.td ! A.class_ "acc-node" $ H.span "OpenAcc"+ H.td ! A.class_ "fun-node" $ H.span "OpenFun"+ H.td ! A.class_ "exp-node" $ H.span "OpenExp"+ H.td ! A.class_ "prim-fun-node" $ H.span "PrimFun"+ H.td ! A.class_ "tuple-node" $ H.span "Tuple"+ H.td ! A.class_ "boundary-node" $ H.span "Boundary"+ H.hr+ travAcc htmlLabels combineHtml leafHtml acc++accelerateCSS :: String+accelerateCSS =+ unlines+ [ "body {"+ , " font-family: Helvetica;"+ , " font-size: 10pt;"+ , "}"+ , ".node {"+ , " padding-left: 5px;"+ , ""+ , "}"+ , ""+ , ".expanded .node {"+ , " padding-left: 12px;"+ , "}"+ , ""+ , ".expanded .node.leaf {"+ , " padding-left: 23px;"+ , "}"+ , ""+ , ".acc-node>span { color: red; }"+ , ".exp-node>span { color: blue;}"+ , ".array-node>span { color: purple;}"+ , ".fun-node>span { color: orange;}"+ , ".prim-fun-node>span { color: magenta;}"+ , ".tuple-node>span { color: green;}"+ , ".boundary-node>span { color: darkcyan;} "+ , ""+ , ".selector, .leaf>span {"+ , " padding: 2px 7px 2px 5px; "+ , "}"+ , ""+ , ".selector:hover, .leaf>span:hover {"+ , " background: #FC9;"+ , " -webkit-border-radius: 10px;"+ , " -moz-border-radius: 10px;"+ , "}"+ , ""+ , ".leaf>span:hover {"+ , " cursor: default;"+ , "}"+ , ""+ , ".selector:hover {"+ , " cursor: pointer;"+ , "}"+ , ""+ , ".expanded .selector::before {"+ , " font-size: 8pt;"+ , " color: #999;"+ , " content: \"\\25bc\";"+ , "}"+ , ""+ , ".collapsed .selector::before {"+ , " font-size: 8pt;"+ , " color: #999;"+ , " content: \"\\25ba\";"+ , " position: relative;"+ , ""+ , "}"+ , ""+ , ".selector:hover::before {"+ , " color: orange;"+ , "}" ]+++dumpHtmlAST :: String -> OpenAcc aenv a -> IO ()+dumpHtmlAST basename acc =+ catch writeHtmlFile handler+ where+ writeHtmlFile = do+ let cssPath = "accelerate.css"+ h <- openFile cssPath WriteMode+ hPutStr h accelerateCSS+ hClose h+ let path = basename ++ ".html"+ h <- openFile path WriteMode+ BS.hPutStr h (renderHtml $ htmlAST acc)+ putStrLn ("HTML file successfully written to `" ++ path ++ "'\n" +++ "CSS file written to `" ++ cssPath ++ "'")+ hClose h+ handler :: IOError -> IO ()+ handler e =+ case True of+ _ | isAlreadyInUseError e -> putStrLn "isAlreadyInUseError"+ | isDoesNotExistError e -> putStrLn "isDoesNotExistError"+ | isFullError e -> putStrLn "isFullError"+ | isEOFError e -> putStrLn "isEOFError"+ | isPermissionError e -> putStrLn "isPermissionError"+ | isIllegalOperation e -> putStrLn "isIllegalOperation"+ | isUserError e -> putStrLn "isUserError"+ | otherwise -> putStrLn "Unknown error"+
+ Data/Array/Accelerate/Pretty/Print.hs view
@@ -0,0 +1,362 @@+{-# LANGUAGE GADTs, FlexibleInstances, TypeOperators, ScopedTypeVariables, RankNTypes #-}+-- |+-- Module : Data.Array.Accelerate.Pretty.Print+-- Copyright : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee+-- License : BSD3+--+-- Maintainer : Manuel M T Chakravarty <chak@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.Pretty.Print (++ -- * Pretty printing functions+ PrettyAcc,+ prettyPreAcc, prettyAcc, + prettyPreExp, prettyExp, + prettyPreAfun, prettyAfun, + prettyPreFun, prettyFun, + noParens++) where++-- standard libraries+import Text.PrettyPrint+import Prelude hiding (exp)++-- friends+import Data.Array.Accelerate.Array.Sugar+import Data.Array.Accelerate.Tuple+import Data.Array.Accelerate.AST+import Data.Array.Accelerate.Type++-- Pretty printing+-- ---------------++-- The type of pretty printing functions for array computations.+--+type PrettyAcc acc = forall aenv t. Int -> (Doc -> Doc) -> acc aenv t -> Doc++-- Pretty print an array expression+--+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 pp alvl wrap (Let 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 (Let2 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 - idxToInt idx - 1)+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]+prettyPreAcc pp alvl wrap (Unit e)+ = wrap $ prettyArrOp "unit" [prettyPreExp pp 0 alvl parens e]+prettyPreAcc pp alvl wrap (Generate sh f)+ = wrap + $ prettyArrOp "generate" [prettyPreExp pp 0 alvl parens sh, parens (prettyPreFun pp alvl f)]+prettyPreAcc pp alvl wrap (Reshape sh acc)+ = wrap $ prettyArrOp "reshape" [prettyPreExp pp 0 alvl parens sh, pp alvl parens acc]+prettyPreAcc pp alvl wrap (Replicate _ty ix acc)+ = wrap $ prettyArrOp "replicate" [prettyPreExp pp 0 alvl id ix, pp alvl parens acc]+prettyPreAcc pp alvl wrap (Index _ty acc ix)+ = wrap $ sep [pp alvl parens acc, char '!', prettyPreExp pp 0 alvl id ix]+prettyPreAcc pp alvl wrap (Map f acc)+ = wrap $ prettyArrOp "map" [parens (prettyPreFun pp alvl f), pp alvl parens acc]+prettyPreAcc pp alvl wrap (ZipWith f acc1 acc2)+ = wrap + $ prettyArrOp "zipWith"+ [parens (prettyPreFun pp alvl f), pp alvl parens acc1, pp alvl parens acc2]+prettyPreAcc pp alvl wrap (Fold f e acc)+ = wrap + $ prettyArrOp "fold" [parens (prettyPreFun pp alvl f), prettyPreExp pp 0 alvl parens e,+ pp alvl parens acc]+prettyPreAcc pp alvl wrap (Fold1 f acc)+ = wrap $ prettyArrOp "fold1" [parens (prettyPreFun pp alvl f), pp alvl parens acc]+prettyPreAcc pp alvl wrap (FoldSeg f e acc1 acc2)+ = wrap + $ prettyArrOp "foldSeg" [parens (prettyPreFun pp alvl f), prettyPreExp pp 0 alvl parens e,+ pp alvl parens acc1, pp alvl parens acc2]+prettyPreAcc pp alvl wrap (Fold1Seg f acc1 acc2)+ = wrap + $ prettyArrOp "fold1Seg" [parens (prettyPreFun pp alvl f), pp alvl parens acc1,+ pp alvl parens acc2]+prettyPreAcc pp alvl wrap (Scanl f e acc)+ = wrap + $ prettyArrOp "scanl" [parens (prettyPreFun pp alvl f), prettyPreExp pp 0 alvl parens e,+ pp alvl parens acc]+prettyPreAcc pp alvl wrap (Scanl' f e acc)+ = wrap + $ prettyArrOp "scanl'" [parens (prettyPreFun pp alvl f), prettyPreExp pp 0 alvl parens e,+ pp alvl parens acc]+prettyPreAcc pp alvl wrap (Scanl1 f acc)+ = wrap + $ prettyArrOp "scanl1" [parens (prettyPreFun pp alvl f), pp alvl parens acc]+prettyPreAcc pp alvl wrap (Scanr f e acc)+ = wrap + $ prettyArrOp "scanr" [parens (prettyPreFun pp alvl f), prettyPreExp pp 0 alvl parens e,+ pp alvl parens acc]+prettyPreAcc pp alvl wrap (Scanr' f e acc)+ = wrap + $ prettyArrOp "scanr'" [parens (prettyPreFun pp alvl f), prettyPreExp pp 0 alvl parens e,+ pp alvl parens acc]+prettyPreAcc pp alvl wrap (Scanr1 f acc)+ = wrap + $ prettyArrOp "scanr1" [parens (prettyPreFun pp alvl f), pp alvl parens acc]+prettyPreAcc pp alvl wrap (Permute f dfts p acc)+ = wrap + $ prettyArrOp "permute" [parens (prettyPreFun pp alvl f), pp alvl parens dfts,+ parens (prettyPreFun pp alvl p), pp alvl parens acc]+prettyPreAcc pp alvl wrap (Backpermute sh p acc)+ = wrap + $ prettyArrOp "backpermute" [prettyPreExp pp 0 alvl parens sh,+ parens (prettyPreFun pp alvl p),+ pp alvl parens acc]+prettyPreAcc pp alvl wrap (Stencil sten bndy acc)+ = wrap + $ prettyArrOp "stencil" [parens (prettyPreFun pp alvl sten),+ prettyBoundary acc bndy,+ pp alvl parens acc]+prettyPreAcc pp alvl wrap (Stencil2 sten bndy1 acc1 bndy2 acc2)+ = wrap + $ prettyArrOp "stencil2" [parens (prettyPreFun pp alvl sten),+ prettyBoundary acc1 bndy1,+ pp alvl parens acc1,+ prettyBoundary acc2 bndy2,+ pp alvl parens acc2]++prettyBoundary :: forall acc aenv dim e. Elt e+ => {-dummy-}acc aenv (Array dim e) -> Boundary (EltRepr e) -> Doc+prettyBoundary _ Clamp = text "Clamp"+prettyBoundary _ Mirror = text "Mirror"+prettyBoundary _ Wrap = text "Wrap"+prettyBoundary _ (Constant e) = parens $ text "Constant" <+> text (show (toElt e :: e))++prettyArrOp :: String -> [Doc] -> Doc+prettyArrOp name docs = hang (text name) 2 $ sep docs++-- Pretty print a function over array computations.+--+-- At the moment restricted to /closed/ functions.+--+prettyAfun :: Int -> Afun fun -> Doc+prettyAfun = prettyPreAfun prettyAcc++prettyPreAfun :: forall acc fun. PrettyAcc acc -> Int -> PreAfun acc fun -> Doc+prettyPreAfun pp _alvl fun =+ let (n, bodyDoc) = count n fun+ in+ char '\\' <> hsep [text $ 'a' : show idx | idx <- [0..n]] <+>+ text "->" <+> bodyDoc+ where+ count :: Int -> PreOpenAfun acc aenv' fun' -> (Int, Doc)+ count lvl (Abody body) = (-1, pp (lvl + 1) noParens body) -- 'lvl+1' ok as functions is closed!+ count lvl (Alam fun') = let (n, body) = count lvl fun' in (1 + n, body)++-- Pretty print a function over scalar expressions.+--+prettyFun :: Int -> OpenFun env aenv fun -> Doc+prettyFun = prettyPreFun prettyAcc++prettyPreFun :: forall acc env aenv fun. PrettyAcc acc -> Int -> PreOpenFun acc env aenv fun -> Doc+prettyPreFun pp alvl fun =+ let (n, bodyDoc) = count n fun+ in+ char '\\' <> hsep [text $ 'x' : show idx | idx <- [0..n]] <+>+ text "->" <+> bodyDoc+ where+ count :: Int -> PreOpenFun acc env' aenv' fun' -> (Int, Doc)+ count lvl (Body body) = (-1, prettyPreExp pp lvl alvl noParens body)+ count lvl (Lam fun') = let (n, body) = count lvl fun' in (1 + n, body)++-- Pretty print an expression.+--+-- * Apply the wrapping combinator (3rd argument) to any compound expressions.+--+prettyExp :: Int -> Int -> (Doc -> Doc) -> OpenExp env aenv t -> Doc+prettyExp = prettyPreExp prettyAcc++prettyPreExp :: forall acc t env aenv.+ PrettyAcc acc -> Int -> Int -> (Doc -> Doc) -> PreOpenExp acc env aenv t -> Doc+prettyPreExp _pp lvl _ _ (Var idx)+ = text $ 'x' : show (lvl - idxToInt idx)+prettyPreExp _pp _ _ _ (Const v)+ = text $ show (toElt v :: t)+prettyPreExp pp lvl alvl _ (Tuple tup)+ = prettyTuple pp lvl alvl tup+prettyPreExp pp lvl alvl wrap (Prj idx e)+ = wrap $ prettyTupleIdx idx <+> prettyPreExp pp lvl alvl parens e+prettyPreExp _pp _lvl _alvl wrap IndexNil+ = wrap $ text "index Z"+prettyPreExp pp lvl alvl wrap (IndexCons t h)+ = wrap $+ text "index" <+>+ parens (prettyPreExp pp lvl alvl parens t <+> text ":." <+> prettyPreExp pp lvl alvl parens h)+prettyPreExp pp lvl alvl wrap (IndexHead ix)+ = wrap $ text "indexHead" <+> prettyPreExp pp lvl alvl parens ix+prettyPreExp pp lvl alvl wrap (IndexTail ix)+ = wrap $ text "indexTail" <+> prettyPreExp pp lvl alvl parens ix+prettyPreExp _ _ _ wrap (IndexAny)+ = wrap $ text "indexAny"+prettyPreExp pp lvl alvl wrap (Cond c t e)+ = wrap $ sep [prettyPreExp pp lvl alvl parens c <+> char '?',+ parens (prettyPreExp pp lvl alvl noParens t <> comma <+>+ prettyPreExp pp lvl alvl noParens e)]+prettyPreExp _pp _ _ _ (PrimConst a)+ = prettyConst a+prettyPreExp pp lvl alvl wrap (PrimApp p a)+ = wrap $ prettyPrim p <+> prettyPreExp pp lvl alvl parens a+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++-- Pretty print nested pairs as a proper tuple.+--+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])+ 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+prettyTupleIdx = int . toInt+ where+ toInt :: TupleIdx t e -> Int+ toInt ZeroTupIdx = 0+ toInt (SuccTupIdx tup) = toInt tup + 1++-- Pretty print a primitive constant+--+prettyConst :: PrimConst a -> Doc+prettyConst (PrimMinBound _) = text "minBound"+prettyConst (PrimMaxBound _) = text "maxBound"+prettyConst (PrimPi _) = text "pi"++-- Pretty print a primitive operation+--+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"++{-+-- Pretty print type+--+prettyAnyType :: ScalarType a -> Doc+prettyAnyType ty = text $ show ty+-}++prettyArray :: forall dim e. Array dim e -> Doc+prettyArray arr@(Array sh _)+ = parens $+ hang (text "Array") 2 $+ sep [showDoc (toElt sh :: dim), dataDoc]+ where+ showDoc :: forall a. Show a => a -> Doc+ showDoc = text . show+ l = toList arr+ dataDoc | length l <= 1000 = showDoc l+ | otherwise = showDoc (take 1000 l) <+>+ text "{truncated at 1000 elements}"+++-- Auxiliary pretty printing combinators+--++noParens :: Doc -> Doc+noParens = id++-- Auxiliary ops+--++-- Auxiliary dictionary operations+--++{-+-- Show scalar values+--+runScalarShow :: ScalarType a -> (a -> String)+runScalarShow (NumScalarType (IntegralNumType ty))+ | IntegralDict <- integralDict ty = show+runScalarShow (NumScalarType (FloatingNumType ty))+ | FloatingDict <- floatingDict ty = show+runScalarShow (NonNumScalarType ty)+ | NonNumDict <- nonNumDict ty = show+-}
+ Data/Array/Accelerate/Pretty/Traverse.hs view
@@ -0,0 +1,211 @@+{-# LANGUAGE GADTs, ScopedTypeVariables, NoMonomorphismRestriction #-}+-- |+-- Module : Data.Array.Accelerate.Pretty.Traverse+-- 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.Pretty.Traverse+ where++-- friends+import Data.Array.Accelerate.Array.Sugar hiding ((!))+import Data.Array.Accelerate.AST+import Data.Array.Accelerate.Tuple+import Data.Array.Accelerate.Type+++cat :: Show s => String -> s -> String+cat t s = t ++ show s++data Labels = Labels { accFormat :: String+ , expFormat :: String+ , funFormat :: String+ , tupleFormat :: String+ , arrayFormat :: String+ , boundaryFormat :: String+ , primFunFormat :: String+ }++travAcc :: forall m b aenv a. Monad m => Labels -> (String -> String -> [m b] -> m b)+ -> (String -> String -> m b) -> OpenAcc aenv a -> m b+travAcc f c l (OpenAcc openAcc) = travAcc' openAcc+ where+ combine = c (accFormat f)+ leaf = l (accFormat f)+ travAcc' :: PreOpenAcc OpenAcc aenv a -> m b+ travAcc' (Let acc1 acc2) = combine "Let" [travAcc f c l acc1, travAcc f c l acc2]+ travAcc' (Let2 acc1 acc2) = combine "Let2" [ 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` 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' (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]++travExp :: forall m env aenv a b . Monad m => Labels+ -> (String -> String -> [m b] -> m b)+ -> (String -> String -> m b)+ -> OpenExp env aenv a -> m b+travExp f c l expr = travExp' expr+ where+ combine = c (expFormat f)+ leaf = l (expFormat f)+ travExp' :: OpenExp env aenv a -> m b+ travExp' (Var idx) = leaf ("Var " `cat` idxToInt idx)+ travExp' (Const v) = leaf ("Const " `cat` (toElt v :: a))+ travExp' (Tuple tup) = combine "Tuple" [ travTuple f c l tup ]+ travExp' (Prj idx e) = combine ("Prj " `cat` tupleIdxToInt idx) [ travExp f c l e ]+ travExp' (IndexNil) = leaf "IndexNil"+ travExp' (IndexCons t h) = combine "IndexCons" [ travExp f c l t, travExp f c l h]+ travExp' (IndexHead ix) = combine "IndexHead" [ travExp f c l ix ]+ travExp' (IndexTail ix) = combine "IndexTail" [ travExp f c l ix ]+ travExp' (IndexAny) = leaf "IndexAny"+ travExp' (Cond cond thn els) = combine "Cond" [travExp f c l cond, travExp f c l thn, travExp f c l els]+ travExp' (PrimConst a) = leaf ("PrimConst " `cat` labelForConst a)+ travExp' (PrimApp p a) = combine "PrimApp" [ l (primFunFormat f) (labelForPrimFun p), travExp f c l a ]+ travExp' (IndexScalar idx i) = combine "IndexScalar" [ travAcc f c l idx, travExp f c l i]+ travExp' (Shape idx) = combine "Shape" [ travAcc f c l idx ]+ travExp' (Size idx) = combine "Size" [ travAcc f c l idx ]+++travAfun :: forall m b aenv fun. Monad m => Labels -> (String -> String -> [m b] -> m b)+ -> (String -> String -> m b) -> OpenAfun aenv fun -> m b+travAfun f c l openAfun = travAfun' openAfun+ where+ combine = c (funFormat f)+ travAfun' :: OpenAfun aenv fun -> m b+ 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+ 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 ]++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))++travBoundary :: forall aenv dim e m b. (Monad m, Elt e) => Labels -> (String -> String -> m b)+ -> {-dummy-}OpenAcc aenv (Array dim e)+ -> Boundary (EltRepr e) -> m b+travBoundary f l boundary = travBoundary' boundary+ where+ leaf = l (boundaryFormat f)+ travBoundary' :: {-dummy-}OpenAcc aenv (Array dim e) -> Boundary (EltRepr e) -> m b+ travBoundary' _ Clamp = leaf "Clamp"+ travBoundary' _ Mirror = leaf "Mirror"+ travBoundary' _ Wrap = leaf "Wrap"+ travBoundary' _ (Constant e) = leaf ("Constant " `cat` (toElt e :: e))+++travTuple :: forall m b env aenv t. Monad m => Labels -> (String -> String -> [m b] -> m b)+ -> (String -> String -> m b) -> Tuple (OpenExp env aenv) t -> m b+travTuple f c l tuple = travTuple' tuple+ where+ leaf = l (tupleFormat f)+ combine = c (tupleFormat f)+ travTuple' :: Tuple (OpenExp env aenv) t -> m b+ travTuple' NilTup = leaf "NilTup"+ travTuple' (SnocTup tup e) = combine "SnocTup" [ travTuple f c l tup, travExp f c l e ]++labelForPrimFun :: PrimFun a -> String+labelForPrimFun (PrimAdd _) = "PrimAdd"+labelForPrimFun (PrimSub _) = "PrimSub"+labelForPrimFun (PrimMul _) = "PrimMul"+labelForPrimFun (PrimNeg _) = "PrimNeg"+labelForPrimFun (PrimAbs _) = "PrimAbs"+labelForPrimFun (PrimSig _) = "PrimSig"+labelForPrimFun (PrimQuot _) = "PrimQuot"+labelForPrimFun (PrimRem _) = "PrimRem"+labelForPrimFun (PrimIDiv _) = "PrimIDiv"+labelForPrimFun (PrimMod _) = "PrimMod"+labelForPrimFun (PrimBAnd _) = "PrimBAnd"+labelForPrimFun (PrimBOr _) = "PrimBOr"+labelForPrimFun (PrimBXor _) = "PrimBXor"+labelForPrimFun (PrimBNot _) = "PrimBNot"+labelForPrimFun (PrimBShiftL _) = "PrimBShiftL"+labelForPrimFun (PrimBShiftR _) = "PrimBShiftR"+labelForPrimFun (PrimBRotateL _) = "PrimBRotateL"+labelForPrimFun (PrimBRotateR _) = "PrimBRotateR"+labelForPrimFun (PrimFDiv _) = "PrimFDiv"+labelForPrimFun (PrimRecip _) = "PrimRecip"+labelForPrimFun (PrimSin _) = "PrimSin"+labelForPrimFun (PrimCos _) = "PrimCos"+labelForPrimFun (PrimTan _) = "PrimTan"+labelForPrimFun (PrimAsin _) = "PrimAsin"+labelForPrimFun (PrimAcos _) = "PrimAcos"+labelForPrimFun (PrimAtan _) = "PrimAtan"+labelForPrimFun (PrimAsinh _) = "PrimAsinh"+labelForPrimFun (PrimAcosh _) = "PrimAcosh"+labelForPrimFun (PrimAtanh _) = "PrimAtanh"+labelForPrimFun (PrimExpFloating _) = "PrimExpFloating"+labelForPrimFun (PrimSqrt _) = "PrimSqrt"+labelForPrimFun (PrimLog _) = "PrimLog"+labelForPrimFun (PrimFPow _) = "PrimFPow"+labelForPrimFun (PrimLogBase _) = "PrimLogBase"+labelForPrimFun (PrimTruncate _ _) = "PrimTruncate"+labelForPrimFun (PrimRound _ _) = "PrimRound"+labelForPrimFun (PrimFloor _ _) = "PrimFloor"+labelForPrimFun (PrimCeiling _ _) = "PrimCeiling"+labelForPrimFun (PrimAtan2 _) = "PrimAtan2"+labelForPrimFun (PrimLt _) = "PrimLt"+labelForPrimFun (PrimGt _) = "PrimGt"+labelForPrimFun (PrimLtEq _) = "PrimLtEq"+labelForPrimFun (PrimGtEq _) = "PrimGtEq"+labelForPrimFun (PrimEq _) = "PrimEq"+labelForPrimFun (PrimNEq _) = "PrimNEq"+labelForPrimFun (PrimMax _) = "PrimMax"+labelForPrimFun (PrimMin _) = "PrimMin"+labelForPrimFun PrimLAnd = "PrimLAnd"+labelForPrimFun PrimLOr = "PrimLOr"+labelForPrimFun PrimLNot = "PrimLNot"+labelForPrimFun PrimOrd = "PrimOrd"+labelForPrimFun PrimChr = "PrimChr"+labelForPrimFun PrimBoolToInt = "PrimBoolToInt"+labelForPrimFun (PrimFromIntegral _ _) = "PrimFromIntegral"++labelForConst :: PrimConst a -> String+labelForConst (PrimMinBound _) = "PrimMinBound"+labelForConst (PrimMaxBound _) = "PrimMaxBound"+labelForConst (PrimPi _) = "PrimPi"++tupleIdxToInt :: TupleIdx t e -> Int+tupleIdxToInt ZeroTupIdx = 0+tupleIdxToInt (SuccTupIdx n) = 1 + tupleIdxToInt n++-- Auxiliary ops+--+
Data/Array/Accelerate/Smart.hs view
@@ -1,930 +1,2003 @@-{-# LANGUAGE CPP, GADTs, TypeFamilies, ScopedTypeVariables, FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-}---- Module : Data.Array.Accelerate.Smart--- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee--- License : BSD3------ Maintainer : Manuel M T Chakravarty <chak@cse.unsw.edu.au>--- Stability : experimental--- Portability : non-portable (GHC extensions)------ This modules defines the AST of the user-visible embedded language using--- more convenient higher-order abstract syntax (instead of de Bruijn--- indices). Moreover, it defines smart constructors to construct programs.--module Data.Array.Accelerate.Smart (-- -- * HOAS AST- Acc(..), Exp(..), Boundary(..), Stencil(..),- - -- * HOAS -> de Bruijn conversion- convertAcc,- convertExp, convertFun1, convertFun2,-- -- * Smart constructors for unpairing- unpair,-- -- * Smart constructors for literals- constant,- - -- * Smart constructors and destructors for tuples- tup2, tup3, tup4, tup5, tup6, tup7, tup8, tup9,- untup2, untup3, untup4, untup5, untup6, untup7, untup8, untup9,-- -- * Smart constructors for constants- mkMinBound, mkMaxBound, mkPi, - mkSin, mkCos, mkTan,- mkAsin, mkAcos, mkAtan,- mkAsinh, mkAcosh, mkAtanh,- mkExpFloating, mkSqrt, mkLog,- mkFPow, mkLogBase,- mkAtan2,-- -- * Smart constructors for primitive functions- mkAdd, mkSub, mkMul, mkNeg, mkAbs, mkSig, mkQuot, mkRem, mkIDiv, mkMod,- mkBAnd, mkBOr, mkBXor, mkBNot, mkBShiftL, mkBShiftR, mkBRotateL, mkBRotateR,- mkFDiv, mkRecip, mkLt, mkGt, mkLtEq, mkGtEq,- mkEq, mkNEq, mkMax, mkMin, mkLAnd, mkLOr, mkLNot, mkBoolToInt, mkIntFloat,- mkRoundFloatInt, mkTruncFloatInt--) where---- standard library-import Data.Maybe-import Data.Typeable---- friends-import Data.Array.Accelerate.Type-import Data.Array.Accelerate.Array.Sugar-import Data.Array.Accelerate.Tuple hiding (Tuple)-import qualified Data.Array.Accelerate.Tuple as Tuple-import Data.Array.Accelerate.AST hiding (OpenAcc(..), Acc, Stencil, OpenExp(..), Exp)-import qualified Data.Array.Accelerate.AST as AST-import Data.Array.Accelerate.Pretty ()--#include "accelerate.h"----- Monadic array computations--- ------------------------------ |Array-valued collective computations----data Acc a where- - FstArray :: (Ix dim1, Elem e1, Elem e2)- => Acc (Array dim1 e1, Array dim2 e2)- -> Acc (Array dim1 e1)- SndArray :: (Ix dim2, Elem e1, Elem e2)- => Acc (Array dim1 e1, Array dim2 e2)- -> Acc (Array dim2 e2)-- Use :: Array dim e -> Acc (Array dim e)- Unit :: Elem e- => Exp e - -> Acc (Scalar e)- Reshape :: Ix dim- => Exp dim- -> Acc (Array dim' e)- -> Acc (Array dim e)- Replicate :: (SliceIx slix, Elem e)- => Exp slix- -> Acc (Array (Slice slix) e)- -> Acc (Array (SliceDim slix) e)- Index :: (SliceIx slix, Elem e)- => Acc (Array (SliceDim slix) e)- -> Exp slix- -> Acc (Array (Slice slix) e)- Map :: (Elem e, Elem e')- => (Exp e -> Exp e') - -> Acc (Array dim e)- -> Acc (Array dim e')- ZipWith :: (Elem e1, Elem e2, Elem e3)- => (Exp e1 -> Exp e2 -> Exp e3) - -> Acc (Array dim e1)- -> Acc (Array dim e2)- -> Acc (Array dim e3)- Fold :: Elem e- => (Exp e -> Exp e -> Exp e)- -> Exp e- -> Acc (Array dim e)- -> Acc (Scalar e)- FoldSeg :: Elem e- => (Exp e -> Exp e -> Exp e)- -> Exp e- -> Acc (Vector e)- -> Acc Segments- -> Acc (Vector e)- Scanl :: Elem e- => (Exp e -> Exp e -> Exp e)- -> Exp e- -> Acc (Vector e)- -> Acc (Vector e, Scalar e)- Scanr :: Elem e- => (Exp e -> Exp e -> Exp e)- -> Exp e- -> Acc (Vector e)- -> Acc (Vector e, Scalar e)- Permute :: (Ix dim, Ix dim', Elem e)- => (Exp e -> Exp e -> Exp e)- -> Acc (Array dim' e)- -> (Exp dim -> Exp dim')- -> Acc (Array dim e)- -> Acc (Array dim' e)- Backpermute :: (Ix dim, Ix dim', Elem e)- => Exp dim'- -> (Exp dim' -> Exp dim)- -> Acc (Array dim e)- -> Acc (Array dim' e)- Stencil :: (Ix dim, Elem a, Elem b, Stencil dim a stencil)- => (stencil -> Exp b)- -> Boundary a- -> Acc (Array dim a)- -> Acc (Array dim b)- Stencil2 :: (Ix dim, Elem a, Elem b, Elem c,- Stencil dim a stencil1, Stencil dim b stencil2)- => (stencil1 -> stencil2 -> Exp c)- -> Boundary a- -> Acc (Array dim a)- -> Boundary b- -> Acc (Array dim b)- -> Acc (Array dim c)----- |Conversion from HOAS to de Bruijn computation AST--- ----- |Convert an array expression with given array environment layout----convertOpenAcc :: Layout aenv aenv - -> Acc a - -> AST.OpenAcc aenv a-convertOpenAcc alyt (FstArray acc)- = AST.Let2 (convertOpenAcc alyt acc) (AST.Avar (AST.SuccIdx AST.ZeroIdx))-convertOpenAcc alyt (SndArray acc)- = AST.Let2 (convertOpenAcc alyt acc) (AST.Avar AST.ZeroIdx)-convertOpenAcc _ (Use array) = AST.Use array-convertOpenAcc alyt (Unit e) = AST.Unit (convertExp alyt e)-convertOpenAcc alyt (Reshape e acc) - = AST.Reshape (convertExp alyt e) (convertOpenAcc alyt acc)-convertOpenAcc alyt (Replicate ix acc)- = mkReplicate (convertExp alyt ix) (convertOpenAcc alyt acc)-convertOpenAcc alyt (Index acc ix)- = mkIndex (convertOpenAcc alyt acc) (convertExp alyt ix)-convertOpenAcc alyt (Map f acc) - = AST.Map (convertFun1 alyt f) (convertOpenAcc alyt acc)-convertOpenAcc alyt (ZipWith f acc1 acc2) - = AST.ZipWith (convertFun2 alyt f) - (convertOpenAcc alyt acc1)- (convertOpenAcc alyt acc2)-convertOpenAcc alyt (Fold f e acc) - = AST.Fold (convertFun2 alyt f) (convertExp alyt e) (convertOpenAcc alyt acc)-convertOpenAcc alyt (FoldSeg f e acc1 acc2) - = AST.FoldSeg (convertFun2 alyt f) (convertExp alyt e) - (convertOpenAcc alyt acc1) (convertOpenAcc alyt acc2)-convertOpenAcc alyt (Scanl f e acc)- = AST.Scanl (convertFun2 alyt f) (convertExp alyt e) (convertOpenAcc alyt acc)-convertOpenAcc alyt (Scanr f e acc)- = AST.Scanr (convertFun2 alyt f) (convertExp alyt e) (convertOpenAcc alyt acc)-convertOpenAcc alyt (Permute f dftAcc perm acc) - = AST.Permute (convertFun2 alyt f) - (convertOpenAcc alyt dftAcc)- (convertFun1 alyt perm) - (convertOpenAcc alyt acc)-convertOpenAcc alyt (Backpermute newDim perm acc) - = AST.Backpermute (convertExp alyt newDim)- (convertFun1 alyt perm)- (convertOpenAcc alyt acc)-convertOpenAcc alyt (Stencil stencil boundary acc) - = AST.Stencil (convertStencilFun acc alyt stencil) - (convertBoundary boundary) - (convertOpenAcc alyt acc)-convertOpenAcc alyt (Stencil2 stencil bndy1 acc1 bndy2 acc2) - = AST.Stencil2 (convertStencilFun2 acc1 acc2 alyt stencil) - (convertBoundary bndy1) - (convertOpenAcc alyt acc1)- (convertBoundary bndy2) - (convertOpenAcc alyt acc2)---- |Convert a boundary condition----convertBoundary :: Elem e => Boundary e -> Boundary (ElemRepr e)-convertBoundary Clamp = Clamp-convertBoundary Mirror = Mirror-convertBoundary Wrap = Wrap-convertBoundary (Constant e) = Constant (fromElem e)---- |Convert a closed array expression----convertAcc :: Acc a -> AST.Acc a-convertAcc = convertOpenAcc EmptyLayout----- Embedded expressions of the surface language--- ------------------------------------------------ HOAS expressions mirror the constructors of `AST.OpenExp', but with the--- `Tag' constructor instead of variables in the form of de Bruijn indices.--- Moreover, HOAS expression use n-tuples and the type class 'Elem' to--- constrain element types, whereas `AST.OpenExp' uses nested pairs and the --- GADT 'TupleType'.------- |Scalar expressions used to parametrise collective array operations----data Exp t where- -- Needed for conversion to de Bruijn form- Tag :: Elem t- => Int -> Exp t- -- environment size at defining occurrence-- -- All the same constructors as 'AST.Exp'- Const :: Elem t - => t -> Exp t-- Tuple :: (Elem t, IsTuple t)- => Tuple.Tuple Exp (TupleRepr t) -> Exp t- Prj :: (Elem t, IsTuple t)- => TupleIdx (TupleRepr t) e - -> Exp t -> Exp e - Cond :: Exp Bool -> Exp t -> Exp t -> Exp t- PrimConst :: Elem t - => PrimConst t -> Exp t- PrimApp :: (Elem a, Elem r) - => PrimFun (a -> r) -> Exp a -> Exp r- IndexScalar :: Acc (Array dim t) -> Exp dim -> Exp t- Shape :: Elem dim- => Acc (Array dim e) -> Exp dim----- |Conversion from HOAS to de Bruijn expression AST--- ----- A layout of an environment an entry for each entry of the environment.--- Each entry in the layout holds the deBruijn index that refers to the--- corresponding entry in the environment.----data Layout env env' where- EmptyLayout :: Layout env ()- PushLayout :: Typeable t - => Layout env env' -> Idx env t -> Layout env (env', t)---- Project the nth index out of an environment layout.----prjIdx :: Typeable t => Int -> Layout env env' -> Idx env t-prjIdx 0 (PushLayout _ ix) = fromJust (gcast ix)- -- can't go wrong unless the library is wrong!-prjIdx n (PushLayout l _) = prjIdx (n - 1) l-prjIdx _ EmptyLayout =- INTERNAL_ERROR(error) "prjIdx" "inconsistent valuation"---- |Convert an open expression with given environment layouts.----convertOpenExp :: forall t env aenv. - Layout env env -- scalar environment- -> Layout aenv aenv -- array environment- -> Exp t -- expression to be converted- -> AST.OpenExp env aenv t-convertOpenExp lyt alyt = cvt- where- cvt :: Exp t' -> AST.OpenExp env aenv t'- cvt (Tag i) = AST.Var (prjIdx i lyt)- cvt (Const v) = AST.Const (fromElem v)- cvt (Tuple tup) = AST.Tuple (convertTuple lyt alyt tup)- cvt (Prj idx e) = AST.Prj idx (cvt e)- cvt (Cond e1 e2 e3) = AST.Cond (cvt e1) (cvt e2) (cvt e3)- cvt (PrimConst c) = AST.PrimConst c- cvt (PrimApp p e) = AST.PrimApp p (cvt e)- cvt (IndexScalar a e) = AST.IndexScalar (convertOpenAcc alyt a) (cvt e)- cvt (Shape a) = AST.Shape (convertOpenAcc alyt a)---- |Convert a tuple expression----convertTuple :: Layout env env - -> Layout aenv aenv - -> Tuple.Tuple Exp t - -> Tuple.Tuple (AST.OpenExp env aenv) t-convertTuple _lyt _alyt NilTup = NilTup-convertTuple lyt alyt (es `SnocTup` e) - = convertTuple lyt alyt es `SnocTup` convertOpenExp lyt alyt e---- |Convert an expression closed wrt to scalar variables----convertExp :: Layout aenv aenv -- array environment- -> Exp t -- expression to be converted- -> AST.Exp aenv t-convertExp alyt = convertOpenExp EmptyLayout alyt---- |Convert a closed expression----convertClosedExp :: Exp t -> AST.Exp () t-convertClosedExp = convertExp EmptyLayout---- |Convert a unary functions----convertFun1 :: forall a b aenv. Elem a- => Layout aenv aenv - -> (Exp a -> Exp b) - -> AST.Fun aenv (a -> b)-convertFun1 alyt f = Lam (Body openF)- where- a = Tag 0- lyt = EmptyLayout - `PushLayout` - (ZeroIdx :: Idx ((), ElemRepr a) (ElemRepr a))- openF = convertOpenExp lyt alyt (f a)---- |Convert a binary functions----convertFun2 :: forall a b c aenv. (Elem a, Elem b) - => Layout aenv aenv - -> (Exp a -> Exp b -> Exp c) - -> AST.Fun aenv (a -> b -> c)-convertFun2 alyt f = Lam (Lam (Body openF))- where- a = Tag 1- b = Tag 0- lyt = EmptyLayout - `PushLayout`- (SuccIdx ZeroIdx :: Idx (((), ElemRepr a), ElemRepr b) (ElemRepr a))- `PushLayout`- (ZeroIdx :: Idx (((), ElemRepr a), ElemRepr b) (ElemRepr b))- openF = convertOpenExp lyt alyt (f a b)---- Convert a unary stencil function----convertStencilFun :: forall dim a stencil b aenv. (Elem a, Stencil dim a stencil)- => Acc (Array dim a) -- just passed to fix the type variables- -> Layout aenv aenv - -> (stencil -> Exp b)- -> AST.Fun aenv (StencilRepr dim stencil -> b)-convertStencilFun _ alyt stencilFun = Lam (Body openStencilFun)- where- stencil = Tag 0 :: Exp (StencilRepr dim stencil)- lyt = EmptyLayout - `PushLayout` - (ZeroIdx :: Idx ((), ElemRepr (StencilRepr dim stencil)) - (ElemRepr (StencilRepr dim stencil)))- openStencilFun = convertOpenExp lyt alyt $- stencilFun (stencilPrj (undefined::dim) (undefined::a) stencil)---- Convert a binary stencil function----convertStencilFun2 :: forall dim a b stencil1 stencil2 c aenv. - (Elem a, Stencil dim a stencil1,- Elem b, Stencil dim b stencil2)- => Acc (Array dim a) -- just passed to fix the type variables- -> Acc (Array dim b) -- just passed to fix the type variables- -> Layout aenv aenv - -> (stencil1 -> stencil2 -> Exp c)- -> AST.Fun aenv (StencilRepr dim stencil1 ->- StencilRepr dim stencil2 -> c)-convertStencilFun2 _ _ alyt stencilFun = Lam (Lam (Body openStencilFun))- where- stencil1 = Tag 1 :: Exp (StencilRepr dim stencil1)- stencil2 = Tag 0 :: Exp (StencilRepr dim stencil2)- lyt = EmptyLayout - `PushLayout` - (SuccIdx ZeroIdx :: Idx (((), ElemRepr (StencilRepr dim stencil1)),- ElemRepr (StencilRepr dim stencil2)) - (ElemRepr (StencilRepr dim stencil1)))- `PushLayout` - (ZeroIdx :: Idx (((), ElemRepr (StencilRepr dim stencil1)),- ElemRepr (StencilRepr dim stencil2)) - (ElemRepr (StencilRepr dim stencil2)))- openStencilFun = convertOpenExp lyt alyt $- stencilFun (stencilPrj (undefined::dim) (undefined::a) stencil1)- (stencilPrj (undefined::dim) (undefined::b) stencil2)----- Pretty printing-----instance Show (Acc as) where- show = show . convertAcc- -instance Show (Exp a) where- show = show . convertClosedExp----- |Smart constructors to construct representation AST forms--- -----------------------------------------------------------mkIndex :: forall slix e aenv. (SliceIx slix, Elem e) - => AST.OpenAcc aenv (Array (SliceDim slix) e)- -> AST.Exp aenv slix- -> AST.OpenAcc aenv (Array (Slice slix) e)-mkIndex arr e - = AST.Index (convertSliceIndex slix (sliceIndex slix)) arr e- where- slix = undefined :: slix--mkReplicate :: forall slix e aenv. (SliceIx slix, Elem e) - => AST.Exp aenv slix- -> AST.OpenAcc aenv (Array (Slice slix) e)- -> AST.OpenAcc aenv (Array (SliceDim slix) e)-mkReplicate e arr- = AST.Replicate (convertSliceIndex slix (sliceIndex slix)) e arr- where- slix = undefined :: slix----- |Smart constructors for stencil reification--- ----------------------------------------------- Stencil reification------ In the AST representation, we turn the stencil type from nested tuples of Accelerate expressions--- into an Accelerate expression whose type is a tuple nested in the same manner. This enables us--- to represent the stencil function as a unary function (which also only needs one de Bruijn--- index). The various positions in the stencil are accessed via tuple indices (i.e., projections).--class (Elem (StencilRepr dim stencil), AST.Stencil dim a (StencilRepr dim stencil)) - => Stencil dim a stencil where- type StencilRepr dim stencil :: *- stencilPrj :: dim{-dummy-} -> a{-dummy-} -> Exp (StencilRepr dim stencil) -> stencil- --- DIM1-instance Elem a => Stencil DIM1 a (Exp a, Exp a, Exp a) where- type StencilRepr DIM1 (Exp a, Exp a, Exp a) = (a, a, a)- stencilPrj _ _ s = (Prj tix2 s, Prj tix1 s, Prj tix0 s)-instance Elem a => Stencil DIM1 a (Exp a, Exp a, Exp a, Exp a, Exp a) where- type StencilRepr DIM1 (Exp a, Exp a, Exp a, Exp a, Exp a) = (a, a, a, a, a)- stencilPrj _ _ s = (Prj tix4 s, Prj tix3 s, Prj tix2 s, Prj tix1 s, Prj tix0 s)-instance Elem a => Stencil DIM1 a (Exp a, Exp a, Exp a, Exp a, Exp a, Exp a, Exp a) where- type StencilRepr DIM1 (Exp a, Exp a, Exp a, Exp a, Exp a, Exp a, Exp a) = (a, a, a, a, a, a, a)- stencilPrj _ _ s = (Prj tix6 s, Prj tix5 s, Prj tix4 s, Prj tix3 s, Prj tix2 s, Prj tix1 s, - Prj tix0 s)-instance Elem a - => Stencil DIM1 a (Exp a, Exp a, Exp a, Exp a, Exp a, Exp a, Exp a, Exp a, Exp a) where- type StencilRepr DIM1 (Exp a, Exp a, Exp a, Exp a, Exp a, Exp a, Exp a, Exp a, Exp a) - = (a, a, a, a, a, a, a, a, a)- stencilPrj _ _ s = (Prj tix8 s, Prj tix7 s, Prj tix6 s, Prj tix5 s, Prj tix4 s, Prj tix3 s,- Prj tix2 s, Prj tix1 s, Prj tix0 s)---- DIM2-instance (Stencil DIM1 a row2, - Stencil DIM1 a row1,- Stencil DIM1 a row0) => Stencil DIM2 a (row2, row1, row0) where- type StencilRepr DIM2 (row2, row1, row0) - = (StencilRepr DIM1 row2, StencilRepr DIM1 row1, StencilRepr DIM1 row0)- stencilPrj _ a s = (stencilPrj (undefined::DIM1) a (Prj tix2 s), - stencilPrj (undefined::DIM1) a (Prj tix1 s), - stencilPrj (undefined::DIM1) a (Prj tix0 s))-instance (Stencil DIM1 a row1,- Stencil DIM1 a row2,- Stencil DIM1 a row3,- Stencil DIM1 a row4,- Stencil DIM1 a row5) => Stencil DIM2 a (row1, row2, row3, row4, row5) where- type StencilRepr DIM2 (row1, row2, row3, row4, row5) - = (StencilRepr DIM1 row1, StencilRepr DIM1 row2, StencilRepr DIM1 row3, StencilRepr DIM1 row4,- StencilRepr DIM1 row5)- stencilPrj _ a s = (stencilPrj (undefined::DIM1) a (Prj tix4 s), - stencilPrj (undefined::DIM1) a (Prj tix3 s), - stencilPrj (undefined::DIM1) a (Prj tix2 s), - stencilPrj (undefined::DIM1) a (Prj tix1 s), - stencilPrj (undefined::DIM1) a (Prj tix0 s))-instance (Stencil DIM1 a row1,- Stencil DIM1 a row2,- Stencil DIM1 a row3,- Stencil DIM1 a row4,- Stencil DIM1 a row5,- Stencil DIM1 a row6,- Stencil DIM1 a row7) => Stencil DIM2 a (row1, row2, row3, row4, row5, row6, row7) where- type StencilRepr DIM2 (row1, row2, row3, row4, row5, row6, row7) - = (StencilRepr DIM1 row1, StencilRepr DIM1 row2, StencilRepr DIM1 row3, StencilRepr DIM1 row4,- StencilRepr DIM1 row5, StencilRepr DIM1 row6, StencilRepr DIM1 row7)- stencilPrj _ a s = (stencilPrj (undefined::DIM1) a (Prj tix6 s), - stencilPrj (undefined::DIM1) a (Prj tix5 s), - stencilPrj (undefined::DIM1) a (Prj tix4 s), - stencilPrj (undefined::DIM1) a (Prj tix3 s), - stencilPrj (undefined::DIM1) a (Prj tix2 s), - stencilPrj (undefined::DIM1) a (Prj tix1 s), - stencilPrj (undefined::DIM1) a (Prj tix0 s))-instance (Stencil DIM1 a row1,- Stencil DIM1 a row2,- Stencil DIM1 a row3,- Stencil DIM1 a row4,- Stencil DIM1 a row5,- Stencil DIM1 a row6,- Stencil DIM1 a row7,- Stencil DIM1 a row8,- Stencil DIM1 a row9) - => Stencil DIM2 a (row1, row2, row3, row4, row5, row6, row7, row8, row9) where- type StencilRepr DIM2 (row1, row2, row3, row4, row5, row6, row7, row8, row9) - = (StencilRepr DIM1 row1, StencilRepr DIM1 row2, StencilRepr DIM1 row3, StencilRepr DIM1 row4,- StencilRepr DIM1 row5, StencilRepr DIM1 row6, StencilRepr DIM1 row7, StencilRepr DIM1 row8,- StencilRepr DIM1 row9)- stencilPrj _ a s = (stencilPrj (undefined::DIM1) a (Prj tix8 s), - stencilPrj (undefined::DIM1) a (Prj tix7 s), - stencilPrj (undefined::DIM1) a (Prj tix6 s), - stencilPrj (undefined::DIM1) a (Prj tix5 s), - stencilPrj (undefined::DIM1) a (Prj tix4 s), - stencilPrj (undefined::DIM1) a (Prj tix3 s), - stencilPrj (undefined::DIM1) a (Prj tix2 s), - stencilPrj (undefined::DIM1) a (Prj tix1 s), - stencilPrj (undefined::DIM1) a (Prj tix0 s))---- DIM3-instance (Stencil DIM2 a row1, - Stencil DIM2 a row2,- Stencil DIM2 a row3) => Stencil DIM3 a (row1, row2, row3) where- type StencilRepr DIM3 (row1, row2, row3) - = (StencilRepr DIM2 row1, StencilRepr DIM2 row2, StencilRepr DIM2 row3)- stencilPrj _ a s = (stencilPrj (undefined::DIM2) a (Prj tix2 s), - stencilPrj (undefined::DIM2) a (Prj tix1 s), - stencilPrj (undefined::DIM2) a (Prj tix0 s))-instance (Stencil DIM2 a row1,- Stencil DIM2 a row2,- Stencil DIM2 a row3,- Stencil DIM2 a row4,- Stencil DIM2 a row5) => Stencil DIM3 a (row1, row2, row3, row4, row5) where- type StencilRepr DIM3 (row1, row2, row3, row4, row5) - = (StencilRepr DIM2 row1, StencilRepr DIM2 row2, StencilRepr DIM2 row3, StencilRepr DIM2 row4,- StencilRepr DIM2 row5)- stencilPrj _ a s = (stencilPrj (undefined::DIM2) a (Prj tix4 s), - stencilPrj (undefined::DIM2) a (Prj tix3 s), - stencilPrj (undefined::DIM2) a (Prj tix2 s), - stencilPrj (undefined::DIM2) a (Prj tix1 s), - stencilPrj (undefined::DIM2) a (Prj tix0 s))-instance (Stencil DIM2 a row1,- Stencil DIM2 a row2,- Stencil DIM2 a row3,- Stencil DIM2 a row4,- Stencil DIM2 a row5,- Stencil DIM2 a row6,- Stencil DIM2 a row7) => Stencil DIM3 a (row1, row2, row3, row4, row5, row6, row7) where- type StencilRepr DIM3 (row1, row2, row3, row4, row5, row6, row7) - = (StencilRepr DIM2 row1, StencilRepr DIM2 row2, StencilRepr DIM2 row3, StencilRepr DIM2 row4,- StencilRepr DIM2 row5, StencilRepr DIM2 row6, StencilRepr DIM2 row7)- stencilPrj _ a s = (stencilPrj (undefined::DIM2) a (Prj tix6 s), - stencilPrj (undefined::DIM2) a (Prj tix5 s), - stencilPrj (undefined::DIM2) a (Prj tix4 s), - stencilPrj (undefined::DIM2) a (Prj tix3 s), - stencilPrj (undefined::DIM2) a (Prj tix2 s), - stencilPrj (undefined::DIM2) a (Prj tix1 s), - stencilPrj (undefined::DIM2) a (Prj tix0 s))-instance (Stencil DIM2 a row1,- Stencil DIM2 a row2,- Stencil DIM2 a row3,- Stencil DIM2 a row4,- Stencil DIM2 a row5,- Stencil DIM2 a row6,- Stencil DIM2 a row7,- Stencil DIM2 a row8,- Stencil DIM2 a row9) - => Stencil DIM3 a (row1, row2, row3, row4, row5, row6, row7, row8, row9) where- type StencilRepr DIM3 (row1, row2, row3, row4, row5, row6, row7, row8, row9) - = (StencilRepr DIM2 row1, StencilRepr DIM2 row2, StencilRepr DIM2 row3, StencilRepr DIM2 row4,- StencilRepr DIM2 row5, StencilRepr DIM2 row6, StencilRepr DIM2 row7, StencilRepr DIM2 row8,- StencilRepr DIM2 row9)- stencilPrj _ a s = (stencilPrj (undefined::DIM2) a (Prj tix8 s), - stencilPrj (undefined::DIM2) a (Prj tix7 s), - stencilPrj (undefined::DIM2) a (Prj tix6 s), - stencilPrj (undefined::DIM2) a (Prj tix5 s), - stencilPrj (undefined::DIM2) a (Prj tix4 s), - stencilPrj (undefined::DIM2) a (Prj tix3 s), - stencilPrj (undefined::DIM2) a (Prj tix2 s), - stencilPrj (undefined::DIM2) a (Prj tix1 s), - stencilPrj (undefined::DIM2) a (Prj tix0 s))---- Auxilliary tuple index constants----tix0 :: Elem s => TupleIdx (t, s) s-tix0 = ZeroTupIdx-tix1 :: Elem s => TupleIdx ((t, s), s1) s-tix1 = SuccTupIdx tix0-tix2 :: Elem s => TupleIdx (((t, s), s1), s2) s-tix2 = SuccTupIdx tix1-tix3 :: Elem s => TupleIdx ((((t, s), s1), s2), s3) s-tix3 = SuccTupIdx tix2-tix4 :: Elem s => TupleIdx (((((t, s), s1), s2), s3), s4) s-tix4 = SuccTupIdx tix3-tix5 :: Elem s => TupleIdx ((((((t, s), s1), s2), s3), s4), s5) s-tix5 = SuccTupIdx tix4-tix6 :: Elem s => TupleIdx (((((((t, s), s1), s2), s3), s4), s5), s6) s-tix6 = SuccTupIdx tix5-tix7 :: Elem s => TupleIdx ((((((((t, s), s1), s2), s3), s4), s5), s6), s7) s-tix7 = SuccTupIdx tix6-tix8 :: Elem s => TupleIdx (((((((((t, s), s1), s2), s3), s4), s5), s6), s7), s8) s-tix8 = SuccTupIdx tix7---- Pushes the 'Acc' constructor through a pair----unpair :: (Ix dim1, Ix dim2, Elem e1, Elem e2)- => Acc (Array dim1 e1, Array dim2 e2) - -> (Acc (Array dim1 e1), Acc (Array dim2 e2))-unpair acc = (FstArray acc, SndArray acc)----- Smart constructor for literals--- ---- |Constant scalar expression----constant :: Elem t => t -> Exp t-constant = Const---- Smart constructor and destructors for tuples-----tup2 :: (Elem a, Elem b) => (Exp a, Exp b) -> Exp (a, b)-tup2 (x1, x2) = Tuple (NilTup `SnocTup` x1 `SnocTup` x2)--tup3 :: (Elem a, Elem b, Elem c) => (Exp a, Exp b, Exp c) -> Exp (a, b, c)-tup3 (x1, x2, x3) = Tuple (NilTup `SnocTup` x1 `SnocTup` x2 `SnocTup` x3)--tup4 :: (Elem a, Elem b, Elem c, Elem d) - => (Exp a, Exp b, Exp c, Exp d) -> Exp (a, b, c, d)-tup4 (x1, x2, x3, x4) - = Tuple (NilTup `SnocTup` x1 `SnocTup` x2 `SnocTup` x3 `SnocTup` x4)--tup5 :: (Elem a, Elem b, Elem c, Elem d, Elem e) - => (Exp a, Exp b, Exp c, Exp d, Exp e) -> Exp (a, b, c, d, e)-tup5 (x1, x2, x3, x4, x5)- = Tuple $- NilTup `SnocTup` x1 `SnocTup` x2 `SnocTup` x3 `SnocTup` x4 `SnocTup` x5--tup6 :: (Elem a, Elem b, Elem c, Elem d, Elem e, Elem f)- => (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f) -> Exp (a, b, c, d, e, f)-tup6 (x1, x2, x3, x4, x5, x6)- = Tuple $- NilTup `SnocTup` x1 `SnocTup` x2 `SnocTup` x3 `SnocTup` x4 `SnocTup` x5 `SnocTup` x6--tup7 :: (Elem a, Elem b, Elem c, Elem d, Elem e, Elem f, Elem g)- => (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g)- -> Exp (a, b, c, d, e, f, g)-tup7 (x1, x2, x3, x4, x5, x6, x7)- = Tuple $- NilTup `SnocTup` x1 `SnocTup` x2 `SnocTup` x3- `SnocTup` x4 `SnocTup` x5 `SnocTup` x6 `SnocTup` x7--tup8 :: (Elem a, Elem b, Elem c, Elem d, Elem e, Elem f, Elem g, Elem h)- => (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h)- -> Exp (a, b, c, d, e, f, g, h)-tup8 (x1, x2, x3, x4, x5, x6, x7, x8)- = Tuple $- NilTup `SnocTup` x1 `SnocTup` x2 `SnocTup` x3 `SnocTup` x4- `SnocTup` x5 `SnocTup` x6 `SnocTup` x7 `SnocTup` x8--tup9 :: (Elem a, Elem b, Elem c, Elem d, Elem e, Elem f, Elem g, Elem h, Elem i)- => (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i)- -> Exp (a, b, c, d, e, f, g, h, i)-tup9 (x1, x2, x3, x4, x5, x6, x7, x8, x9)- = Tuple $- NilTup `SnocTup` x1 `SnocTup` x2 `SnocTup` x3 `SnocTup` x4- `SnocTup` x5 `SnocTup` x6 `SnocTup` x7 `SnocTup` x8 `SnocTup` x9--untup2 :: (Elem a, Elem b) => Exp (a, b) -> (Exp a, Exp b)-untup2 e = ((SuccTupIdx ZeroTupIdx) `Prj` e, ZeroTupIdx `Prj` e)--untup3 :: (Elem a, Elem b, Elem c) => Exp (a, b, c) -> (Exp a, Exp b, Exp c)-untup3 e = (SuccTupIdx (SuccTupIdx ZeroTupIdx) `Prj` e, - SuccTupIdx ZeroTupIdx `Prj` e, - ZeroTupIdx `Prj` e)--untup4 :: (Elem a, Elem b, Elem c, Elem d) - => Exp (a, b, c, d) -> (Exp a, Exp b, Exp c, Exp d)-untup4 e = (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)) `Prj` e, - SuccTupIdx (SuccTupIdx ZeroTupIdx) `Prj` e, - SuccTupIdx ZeroTupIdx `Prj` e, - ZeroTupIdx `Prj` e)--untup5 :: (Elem a, Elem b, Elem c, Elem d, Elem e) - => Exp (a, b, c, d, e) -> (Exp a, Exp b, Exp c, Exp d, Exp e)-untup5 e = (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))) - `Prj` e, - SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)) `Prj` e, - SuccTupIdx (SuccTupIdx ZeroTupIdx) `Prj` e, - SuccTupIdx ZeroTupIdx `Prj` e, - ZeroTupIdx `Prj` e)--untup6 :: (Elem a, Elem b, Elem c, Elem d, Elem e, Elem f)- => Exp (a, b, c, d, e, f) -> (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f)-untup6 e = (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))) `Prj` e,- SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))) `Prj` e,- SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)) `Prj` e,- SuccTupIdx (SuccTupIdx ZeroTupIdx) `Prj` e,- SuccTupIdx ZeroTupIdx `Prj` e,- ZeroTupIdx `Prj` e)--untup7 :: (Elem a, Elem b, Elem c, Elem d, Elem e, Elem f, Elem g)- => Exp (a, b, c, d, e, f, g) -> (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g)-untup7 e = (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))))) `Prj` e,- SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))) `Prj` e,- SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))) `Prj` e,- SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)) `Prj` e,- SuccTupIdx (SuccTupIdx ZeroTupIdx) `Prj` e,- SuccTupIdx ZeroTupIdx `Prj` e,- ZeroTupIdx `Prj` e)--untup8 :: (Elem a, Elem b, Elem c, Elem d, Elem e, Elem f, Elem g, Elem h)- => Exp (a, b, c, d, e, f, g, h) -> (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h)-untup8 e = (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))))) `Prj` e,- SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))))) `Prj` e,- SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))) `Prj` e,- SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))) `Prj` e,- SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)) `Prj` e,- SuccTupIdx (SuccTupIdx ZeroTupIdx) `Prj` e,- SuccTupIdx ZeroTupIdx `Prj` e,- ZeroTupIdx `Prj` e)--untup9 :: (Elem a, Elem b, Elem c, Elem d, Elem e, Elem f, Elem g, Elem h, Elem i)- => Exp (a, b, c, d, e, f, g, h, i) -> (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i)-untup9 e = (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))))))) `Prj` e,- SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))))) `Prj` e,- SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))))) `Prj` e,- SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))) `Prj` e,- SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))) `Prj` e,- SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)) `Prj` e,- SuccTupIdx (SuccTupIdx ZeroTupIdx) `Prj` e,- SuccTupIdx ZeroTupIdx `Prj` e,- ZeroTupIdx `Prj` e)---- Smart constructor for constants--- --mkMinBound :: (Elem t, IsBounded t) => Exp t-mkMinBound = PrimConst (PrimMinBound boundedType)--mkMaxBound :: (Elem t, IsBounded t) => Exp t-mkMaxBound = PrimConst (PrimMaxBound boundedType)--mkPi :: (Elem r, IsFloating r) => Exp r-mkPi = PrimConst (PrimPi floatingType)---- Operators from Floating-----mkSin :: (Elem t, IsFloating t) => Exp t -> Exp t-mkSin x = PrimSin floatingType `PrimApp` x--mkCos :: (Elem t, IsFloating t) => Exp t -> Exp t-mkCos x = PrimCos floatingType `PrimApp` x--mkTan :: (Elem t, IsFloating t) => Exp t -> Exp t-mkTan x = PrimTan floatingType `PrimApp` x--mkAsin :: (Elem t, IsFloating t) => Exp t -> Exp t-mkAsin x = PrimAsin floatingType `PrimApp` x--mkAcos :: (Elem t, IsFloating t) => Exp t -> Exp t-mkAcos x = PrimAcos floatingType `PrimApp` x--mkAtan :: (Elem t, IsFloating t) => Exp t -> Exp t-mkAtan x = PrimAtan floatingType `PrimApp` x--mkAsinh :: (Elem t, IsFloating t) => Exp t -> Exp t-mkAsinh x = PrimAsinh floatingType `PrimApp` x--mkAcosh :: (Elem t, IsFloating t) => Exp t -> Exp t-mkAcosh x = PrimAcosh floatingType `PrimApp` x--mkAtanh :: (Elem t, IsFloating t) => Exp t -> Exp t-mkAtanh x = PrimAtanh floatingType `PrimApp` x--mkExpFloating :: (Elem t, IsFloating t) => Exp t -> Exp t-mkExpFloating x = PrimExpFloating floatingType `PrimApp` x--mkSqrt :: (Elem t, IsFloating t) => Exp t -> Exp t-mkSqrt x = PrimSqrt floatingType `PrimApp` x--mkLog :: (Elem t, IsFloating t) => Exp t -> Exp t-mkLog x = PrimLog floatingType `PrimApp` x--mkFPow :: (Elem t, IsFloating t) => Exp t -> Exp t -> Exp t-mkFPow x y = PrimFPow floatingType `PrimApp` tup2 (x, y)--mkLogBase :: (Elem t, IsFloating t) => Exp t -> Exp t -> Exp t-mkLogBase x y = PrimLogBase floatingType `PrimApp` tup2 (x, y)---- Smart constructors for primitive applications--- ---- Operators from Num--mkAdd :: (Elem t, IsNum t) => Exp t -> Exp t -> Exp t-mkAdd x y = PrimAdd numType `PrimApp` tup2 (x, y)--mkSub :: (Elem t, IsNum t) => Exp t -> Exp t -> Exp t-mkSub x y = PrimSub numType `PrimApp` tup2 (x, y)--mkMul :: (Elem t, IsNum t) => Exp t -> Exp t -> Exp t-mkMul x y = PrimMul numType `PrimApp` tup2 (x, y)--mkNeg :: (Elem t, IsNum t) => Exp t -> Exp t-mkNeg x = PrimNeg numType `PrimApp` x--mkAbs :: (Elem t, IsNum t) => Exp t -> Exp t-mkAbs x = PrimAbs numType `PrimApp` x--mkSig :: (Elem t, IsNum t) => Exp t -> Exp t-mkSig x = PrimSig numType `PrimApp` x---- Operators from Integral & Bits--mkQuot :: (Elem t, IsIntegral t) => Exp t -> Exp t -> Exp t-mkQuot x y = PrimQuot integralType `PrimApp` tup2 (x, y)--mkRem :: (Elem t, IsIntegral t) => Exp t -> Exp t -> Exp t-mkRem x y = PrimRem integralType `PrimApp` tup2 (x, y)--mkIDiv :: (Elem t, IsIntegral t) => Exp t -> Exp t -> Exp t-mkIDiv x y = PrimIDiv integralType `PrimApp` tup2 (x, y)--mkMod :: (Elem t, IsIntegral t) => Exp t -> Exp t -> Exp t-mkMod x y = PrimMod integralType `PrimApp` tup2 (x, y)--mkBAnd :: (Elem t, IsIntegral t) => Exp t -> Exp t -> Exp t-mkBAnd x y = PrimBAnd integralType `PrimApp` tup2 (x, y)--mkBOr :: (Elem t, IsIntegral t) => Exp t -> Exp t -> Exp t-mkBOr x y = PrimBOr integralType `PrimApp` tup2 (x, y)--mkBXor :: (Elem t, IsIntegral t) => Exp t -> Exp t -> Exp t-mkBXor x y = PrimBXor integralType `PrimApp` tup2 (x, y)--mkBNot :: (Elem t, IsIntegral t) => Exp t -> Exp t-mkBNot x = PrimBNot integralType `PrimApp` x--mkBShiftL :: (Elem t, IsIntegral t) => Exp t -> Exp Int -> Exp t-mkBShiftL x i = PrimBShiftL integralType `PrimApp` tup2 (x, i)--mkBShiftR :: (Elem t, IsIntegral t) => Exp t -> Exp Int -> Exp t-mkBShiftR x i = PrimBShiftR integralType `PrimApp` tup2 (x, i)--mkBRotateL :: (Elem t, IsIntegral t) => Exp t -> Exp Int -> Exp t-mkBRotateL x i = PrimBRotateL integralType `PrimApp` tup2 (x, i)--mkBRotateR :: (Elem t, IsIntegral t) => Exp t -> Exp Int -> Exp t-mkBRotateR x i = PrimBRotateR integralType `PrimApp` tup2 (x, i)---- Operators from Fractional, Floating, RealFrac & RealFloat--mkFDiv :: (Elem t, IsFloating t) => Exp t -> Exp t -> Exp t-mkFDiv x y = PrimFDiv floatingType `PrimApp` tup2 (x, y)--mkRecip :: (Elem t, IsFloating t) => Exp t -> Exp t-mkRecip x = PrimRecip floatingType `PrimApp` x--mkAtan2 :: (Elem t, IsFloating t) => Exp t -> Exp t -> Exp t-mkAtan2 x y = PrimAtan2 floatingType `PrimApp` tup2 (x, y)-- -- FIXME: add operations from Floating, RealFrac & RealFloat---- Relational and equality operators--mkLt :: (Elem t, IsScalar t) => Exp t -> Exp t -> Exp Bool-mkLt x y = PrimLt scalarType `PrimApp` tup2 (x, y)--mkGt :: (Elem t, IsScalar t) => Exp t -> Exp t -> Exp Bool-mkGt x y = PrimGt scalarType `PrimApp` tup2 (x, y)--mkLtEq :: (Elem t, IsScalar t) => Exp t -> Exp t -> Exp Bool-mkLtEq x y = PrimLtEq scalarType `PrimApp` tup2 (x, y)--mkGtEq :: (Elem t, IsScalar t) => Exp t -> Exp t -> Exp Bool-mkGtEq x y = PrimGtEq scalarType `PrimApp` tup2 (x, y)--mkEq :: (Elem t, IsScalar t) => Exp t -> Exp t -> Exp Bool-mkEq x y = PrimEq scalarType `PrimApp` tup2 (x, y)--mkNEq :: (Elem t, IsScalar t) => Exp t -> Exp t -> Exp Bool-mkNEq x y = PrimNEq scalarType `PrimApp` tup2 (x, y)--mkMax :: (Elem t, IsScalar t) => Exp t -> Exp t -> Exp t-mkMax x y = PrimMax scalarType `PrimApp` tup2 (x, y)--mkMin :: (Elem t, IsScalar t) => Exp t -> Exp t -> Exp t-mkMin x y = PrimMin scalarType `PrimApp` tup2 (x, y)---- Logical operators--mkLAnd :: Exp Bool -> Exp Bool -> Exp Bool-mkLAnd x y = PrimLAnd `PrimApp` tup2 (x, y)--mkLOr :: Exp Bool -> Exp Bool -> Exp Bool-mkLOr x y = PrimLOr `PrimApp` tup2 (x, y)--mkLNot :: Exp Bool -> Exp Bool-mkLNot x = PrimLNot `PrimApp` x---- FIXME: Character conversions---- FIXME: Numeric conversions---- FIXME: Other conversions--mkBoolToInt :: Exp Bool -> Exp Int-mkBoolToInt b = PrimBoolToInt `PrimApp` b--mkIntFloat :: Exp Int -> Exp Float-mkIntFloat x = PrimIntFloat `PrimApp` x--mkRoundFloatInt :: Exp Float -> Exp Int-mkRoundFloatInt x = PrimRoundFloatInt `PrimApp` x--mkTruncFloatInt :: Exp Float -> Exp Int-mkTruncFloatInt x = PrimTruncFloatInt `PrimApp` x-+{-# LANGUAGE CPP, GADTs, TypeOperators, TypeFamilies, ScopedTypeVariables, RankNTypes #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-}+{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, PatternGuards #-}+-- |+-- Module : Data.Array.Accelerate.Smart+-- Copyright : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee+-- License : BSD3+--+-- Maintainer : Manuel M T Chakravarty <chak@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--+-- This modules defines the AST of the user-visible embedded language using more+-- convenient higher-order abstract syntax (instead of de Bruijn indices).+-- Moreover, it defines smart constructors to construct programs.+--++module Data.Array.Accelerate.Smart (++ -- * HOAS AST+ Acc(..), PreAcc(..), Exp, PreExp(..), Boundary(..), Stencil(..),++ -- * HOAS -> de Bruijn conversion+ convertAcc, convertAccFun1,++ -- * Smart constructors for pairing and unpairing+ pair, unpair,++ -- * Smart constructors for literals+ constant,++ -- * Smart constructors and destructors for tuples+ tup2, tup3, tup4, tup5, tup6, tup7, tup8, tup9,+ untup2, untup3, untup4, untup5, untup6, untup7, untup8, untup9,++ -- * Smart constructors for constants+ mkMinBound, mkMaxBound, mkPi,+ mkSin, mkCos, mkTan,+ mkAsin, mkAcos, mkAtan,+ mkAsinh, mkAcosh, mkAtanh,+ mkExpFloating, mkSqrt, mkLog,+ mkFPow, mkLogBase,+ mkTruncate, mkRound, mkFloor, mkCeiling,+ mkAtan2,++ -- * Smart constructors for primitive functions+ mkAdd, mkSub, mkMul, mkNeg, mkAbs, mkSig, mkQuot, mkRem, mkIDiv, mkMod,+ mkBAnd, mkBOr, mkBXor, mkBNot, mkBShiftL, mkBShiftR, mkBRotateL, mkBRotateR,+ mkFDiv, mkRecip, mkLt, mkGt, mkLtEq, mkGtEq, mkEq, mkNEq, mkMax, mkMin,+ mkLAnd, mkLOr, mkLNot,++ -- * Smart constructors for type coercion functions+ mkBoolToInt, mkFromIntegral,++ -- * Auxiliary functions+ ($$), ($$$), ($$$$), ($$$$$)++) where++-- standard library+import Control.Applicative hiding (Const)+import Control.Monad+import Data.HashTable as Hash+import Data.List+import Data.Maybe+import qualified Data.IntMap as IntMap+import Data.Typeable+import System.Mem.StableName+import System.IO.Unsafe (unsafePerformIO)+import Prelude hiding (exp)++-- friends+import Data.Array.Accelerate.Debug+import Data.Array.Accelerate.Type+import Data.Array.Accelerate.Array.Sugar+import Data.Array.Accelerate.Tuple hiding (Tuple)+import Data.Array.Accelerate.AST hiding (+ PreOpenAcc(..), OpenAcc(..), Acc, Stencil(..), PreOpenExp(..), OpenExp, PreExp, Exp)+import qualified Data.Array.Accelerate.Tuple as Tuple+import qualified Data.Array.Accelerate.AST as AST+import Data.Array.Accelerate.Pretty ()++#include "accelerate.h"+++-- Configuration+-- -------------++-- Are array computations floated out of expressions irrespective of whether they are shared or +-- not? 'True' implies floating them out.+--+floatOutAccFromExp :: Bool+floatOutAccFromExp = True+++-- Layouts+-- -------++-- A layout of an environment has an entry for each entry of the environment.+-- Each entry in the layout holds the deBruijn index that refers to the+-- corresponding entry in the environment.+--+data Layout env env' where+ EmptyLayout :: Layout env ()+ PushLayout :: Typeable t+ => Layout env env' -> Idx env t -> Layout env (env', t)++-- Project the nth index out of an environment layout.+--+prjIdx :: Typeable t => Int -> Layout env env' -> Idx env t+prjIdx 0 (PushLayout _ ix) = case gcast ix of+ Just ix' -> ix'+ Nothing -> INTERNAL_ERROR(error) "prjIdx" "type mismatch"+prjIdx n (PushLayout l _) = prjIdx (n - 1) l+prjIdx _ EmptyLayout = INTERNAL_ERROR(error) "prjIdx" "inconsistent valuation"++-- Add an entry to a layout, incrementing all indices+--+incLayout :: Layout env env' -> Layout (env, t) env'+incLayout EmptyLayout = EmptyLayout+incLayout (PushLayout lyt ix) = PushLayout (incLayout lyt) (SuccIdx ix)+++-- Array computations+-- ------------------++-- |Array-valued collective computations without a recursive knot+--+-- Note [Pipe and sharing recovery]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- The 'Pipe' constructor is special. It is the only form that contains functions over array+-- computations and these functions are fixed to be over vanilla 'Acc' types. This enables us to+-- perform sharing recovery independently from the context for them.+--+data PreAcc acc a where + -- Needed for conversion to de Bruijn form+ Atag :: Arrays as+ => Int -- environment size at defining occurrence+ -> PreAcc acc as++ Pipe :: (Arrays as, Arrays bs, Arrays cs) + => (Acc as -> Acc bs) -- see comment above on why 'Acc' and not 'acc'+ -> (Acc bs -> Acc cs) + -> acc as + -> PreAcc acc cs+ Acond :: (Arrays as)+ => PreExp acc Bool+ -> acc as+ -> acc as+ -> PreAcc acc as+ FstArray :: (Shape sh1, Shape sh2, Elt e1, Elt e2)+ => acc (Array sh1 e1, Array sh2 e2)+ -> PreAcc acc (Array sh1 e1)+ SndArray :: (Shape sh1, Shape sh2, Elt e1, Elt e2)+ => acc (Array sh1 e1, Array sh2 e2)+ -> PreAcc acc (Array sh2 e2)+ PairArrays :: (Shape sh1, Shape sh2, Elt e1, Elt e2)+ => acc (Array sh1 e1)+ -> acc (Array sh2 e2)+ -> PreAcc acc (Array sh1 e1, Array sh2 e2)++ Use :: (Shape sh, Elt e)+ => Array sh e -> PreAcc acc (Array sh e)+ Unit :: Elt e+ => PreExp acc e + -> PreAcc acc (Scalar e)+ Generate :: (Shape sh, Elt e)+ => PreExp acc sh+ -> (Exp sh -> PreExp acc e)+ -> PreAcc acc (Array sh e)+ Reshape :: (Shape sh, Shape sh', Elt e)+ => PreExp acc sh+ -> acc (Array sh' e)+ -> PreAcc acc (Array sh e)+ Replicate :: (Slice slix, Elt e,+ Typeable (SliceShape slix), Typeable (FullShape slix))+ -- the Typeable constraints shouldn't be necessary as they are implied by + -- 'SliceIx slix' — unfortunately, the (old) type checker doesn't grok that+ => PreExp acc slix+ -> acc (Array (SliceShape slix) e)+ -> PreAcc acc (Array (FullShape slix) e)+ Index :: (Slice slix, Elt e, + Typeable (SliceShape slix), Typeable (FullShape slix))+ -- the Typeable constraints shouldn't be necessary as they are implied by + -- 'SliceIx slix' — unfortunately, the (old) type checker doesn't grok that+ => acc (Array (FullShape slix) e)+ -> PreExp acc slix+ -> PreAcc acc (Array (SliceShape slix) e)+ Map :: (Shape sh, Elt e, Elt e')+ => (Exp e -> PreExp acc e') + -> acc (Array sh e)+ -> PreAcc acc (Array sh e')+ ZipWith :: (Shape sh, Elt e1, Elt e2, Elt e3)+ => (Exp e1 -> Exp e2 -> PreExp acc e3) + -> acc (Array sh e1)+ -> acc (Array sh e2)+ -> PreAcc acc (Array sh e3)+ Fold :: (Shape sh, Elt e)+ => (Exp e -> Exp e -> PreExp acc e)+ -> PreExp acc e+ -> acc (Array (sh:.Int) e)+ -> PreAcc acc (Array sh e)+ Fold1 :: (Shape sh, Elt e)+ => (Exp e -> Exp e -> PreExp acc e)+ -> acc (Array (sh:.Int) e)+ -> PreAcc acc (Array sh e)+ FoldSeg :: (Shape sh, Elt e)+ => (Exp e -> Exp e -> PreExp acc e)+ -> PreExp acc e+ -> acc (Array (sh:.Int) e)+ -> acc Segments+ -> PreAcc acc (Array (sh:.Int) e)+ Fold1Seg :: (Shape sh, Elt e)+ => (Exp e -> Exp e -> PreExp acc e)+ -> acc (Array (sh:.Int) e)+ -> acc Segments+ -> PreAcc acc (Array (sh:.Int) e)+ Scanl :: Elt e+ => (Exp e -> Exp e -> PreExp acc e)+ -> PreExp acc e+ -> acc (Vector e)+ -> PreAcc acc (Vector e)+ Scanl' :: Elt e+ => (Exp e -> Exp e -> PreExp acc e)+ -> PreExp acc e+ -> acc (Vector e)+ -> PreAcc acc (Vector e, Scalar e)+ Scanl1 :: Elt e+ => (Exp e -> Exp e -> PreExp acc e)+ -> acc (Vector e)+ -> PreAcc acc (Vector e)+ Scanr :: Elt e+ => (Exp e -> Exp e -> PreExp acc e)+ -> PreExp acc e+ -> acc (Vector e)+ -> PreAcc acc (Vector e)+ Scanr' :: Elt e+ => (Exp e -> Exp e -> PreExp acc e)+ -> PreExp acc e+ -> acc (Vector e)+ -> PreAcc acc (Vector e, Scalar e)+ Scanr1 :: Elt e+ => (Exp e -> Exp e -> PreExp acc e)+ -> acc (Vector e)+ -> PreAcc acc (Vector e)+ Permute :: (Shape sh, Shape sh', Elt e)+ => (Exp e -> Exp e -> PreExp acc e)+ -> acc (Array sh' e)+ -> (Exp sh -> PreExp acc sh')+ -> acc (Array sh e)+ -> PreAcc acc (Array sh' e)+ Backpermute :: (Shape sh, Shape sh', Elt e)+ => PreExp acc sh'+ -> (Exp sh' -> PreExp acc sh)+ -> acc (Array sh e)+ -> PreAcc acc (Array sh' e)+ Stencil :: (Shape sh, Elt a, Elt b, Stencil sh a stencil)+ => (stencil -> PreExp acc b)+ -> Boundary a+ -> acc (Array sh a)+ -> PreAcc acc (Array sh b)+ Stencil2 :: (Shape sh, Elt a, Elt b, Elt c,+ Stencil sh a stencil1, Stencil sh b stencil2)+ => (stencil1 -> stencil2 -> PreExp acc c)+ -> Boundary a+ -> acc (Array sh a)+ -> Boundary b+ -> acc (Array sh b)+ -> PreAcc acc (Array sh c)++-- |Array-valued collective computations+--+newtype Acc a = Acc (PreAcc Acc a)++deriving instance Typeable1 Acc++-- |Conversion from HOAS to de Bruijn computation AST+-- -++-- |Convert a closed array expression to de Bruijn form while also incorporating sharing+-- information.+--+convertAcc :: Arrays arrs => Acc arrs -> AST.Acc arrs+convertAcc = convertOpenAcc EmptyLayout++-- |Convert a closed 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 = convertSharingAcc alyt [] . recoverSharing floatOutAccFromExp++-- |Convert a unary function over array computations+--+convertAccFun1 :: forall a b. (Arrays a, Arrays b)+ => (Acc a -> Acc b) + -> AST.Afun (a -> b)+convertAccFun1 f = Alam (Abody openF)+ where+ a = Atag 0+ alyt = EmptyLayout + `PushLayout` + (ZeroIdx :: Idx ((), a) a)+ openF = convertOpenAcc alyt (f (Acc a))++-- |Convert an array expression with given array environment layout and sharing information into+-- de Bruijn form while recovering sharing at the same time (by introducing appropriate let+-- bindings). The latter implements the third phase of sharing recovery.+--+-- The sharing environment 'env' keeps track of all currently bound sharing variables, keeping them+-- in reverse chronological order (outermost variable is at the end of the list)+--+convertSharingAcc :: forall a aenv. Arrays a+ => Layout aenv aenv+ -> [StableSharingAcc]+ -> SharingAcc a+ -> AST.OpenAcc aenv a+convertSharingAcc alyt env (VarSharing sa)+ | Just i <- findIndex (matchStableAcc sa) env + = AST.OpenAcc $ AST.Avar (prjIdx i alyt)+ | otherwise + = INTERNAL_ERROR(error) "convertSharingAcc (prjIdx)" err+ where+ err = "inconsistent valuation; sa = " ++ show (hashStableName sa) ++ "; env = " ++ show env+convertSharingAcc alyt env (LetSharing sa@(StableSharingAcc _ boundAcc) bodyAcc)+ = AST.OpenAcc+ $ let alyt' = incLayout alyt `PushLayout` ZeroIdx+ in+ AST.Let (convertSharingAcc alyt env boundAcc) (convertSharingAcc alyt' (sa:env) bodyAcc)+convertSharingAcc alyt env (AccSharing _ preAcc)+ = AST.OpenAcc+ $ (case preAcc of+ Atag i+ -> AST.Avar (prjIdx i alyt)+ Pipe afun1 afun2 acc+ -> let boundAcc = convertAccFun1 afun1 `AST.Apply` convertSharingAcc alyt env acc+ bodyAcc = convertAccFun1 afun2 `AST.Apply` AST.OpenAcc (AST.Avar AST.ZeroIdx)+ in+ AST.Let (AST.OpenAcc boundAcc) (AST.OpenAcc bodyAcc)+ Acond b acc1 acc2+ -> AST.Acond (convertExp alyt env b) (convertSharingAcc alyt env acc1)+ (convertSharingAcc alyt env acc2)+ FstArray acc+ -> AST.Let2 (convertSharingAcc alyt env acc) + (AST.OpenAcc $ AST.Avar (AST.SuccIdx AST.ZeroIdx))+ SndArray acc+ -> AST.Let2 (convertSharingAcc alyt env acc) + (AST.OpenAcc $ AST.Avar AST.ZeroIdx)+ PairArrays acc1 acc2+ -> AST.PairArrays (convertSharingAcc alyt env acc1)+ (convertSharingAcc alyt env acc2)+ Use array+ -> AST.Use array+ Unit e+ -> AST.Unit (convertExp alyt env e)+ Generate sh f+ -> AST.Generate (convertExp alyt env sh) (convertFun1 alyt env f)+ Reshape e acc+ -> AST.Reshape (convertExp alyt env e) (convertSharingAcc alyt env acc)+ Replicate ix acc+ -> mkReplicate (convertExp alyt env ix) (convertSharingAcc alyt env acc)+ Index acc ix+ -> mkIndex (convertSharingAcc alyt env acc) (convertExp alyt env ix)+ Map f acc + -> AST.Map (convertFun1 alyt env f) (convertSharingAcc alyt env acc)+ ZipWith f acc1 acc2+ -> AST.ZipWith (convertFun2 alyt env f) + (convertSharingAcc alyt env acc1)+ (convertSharingAcc alyt env acc2)+ Fold f e acc+ -> AST.Fold (convertFun2 alyt env f) (convertExp alyt env e) + (convertSharingAcc alyt env acc)+ Fold1 f acc+ -> AST.Fold1 (convertFun2 alyt env f) (convertSharingAcc alyt env acc)+ FoldSeg f e acc1 acc2+ -> AST.FoldSeg (convertFun2 alyt env f) (convertExp alyt env e) + (convertSharingAcc alyt env acc1) (convertSharingAcc alyt env acc2)+ Fold1Seg f acc1 acc2+ -> AST.Fold1Seg (convertFun2 alyt env f)+ (convertSharingAcc alyt env acc1)+ (convertSharingAcc alyt env acc2)+ Scanl f e acc+ -> AST.Scanl (convertFun2 alyt env f) (convertExp alyt env e) + (convertSharingAcc alyt env acc)+ Scanl' f e acc+ -> AST.Scanl' (convertFun2 alyt env f)+ (convertExp alyt env e)+ (convertSharingAcc alyt env acc)+ Scanl1 f acc+ -> AST.Scanl1 (convertFun2 alyt env f) (convertSharingAcc alyt env acc)+ Scanr f e acc+ -> AST.Scanr (convertFun2 alyt env f) (convertExp alyt env e)+ (convertSharingAcc alyt env acc)+ Scanr' f e acc+ -> AST.Scanr' (convertFun2 alyt env f)+ (convertExp alyt env e)+ (convertSharingAcc alyt env acc)+ Scanr1 f acc+ -> AST.Scanr1 (convertFun2 alyt env f) (convertSharingAcc alyt env acc)+ Permute f dftAcc perm acc+ -> AST.Permute (convertFun2 alyt env f) + (convertSharingAcc alyt env dftAcc)+ (convertFun1 alyt env perm) + (convertSharingAcc alyt env acc)+ Backpermute newDim perm acc+ -> AST.Backpermute (convertExp alyt env newDim)+ (convertFun1 alyt env perm) + (convertSharingAcc alyt env acc)+ Stencil stencil boundary acc+ -> AST.Stencil (convertStencilFun acc alyt env stencil) + (convertBoundary boundary) + (convertSharingAcc alyt env acc)+ Stencil2 stencil bndy1 acc1 bndy2 acc2+ -> AST.Stencil2 (convertStencilFun2 acc1 acc2 alyt env stencil) + (convertBoundary bndy1) + (convertSharingAcc alyt env acc1)+ (convertBoundary bndy2) + (convertSharingAcc alyt env acc2)+ :: AST.PreOpenAcc AST.OpenAcc aenv a)++-- |Convert a boundary condition+--+convertBoundary :: Elt e => Boundary e -> Boundary (EltRepr e)+convertBoundary Clamp = Clamp+convertBoundary Mirror = Mirror+convertBoundary Wrap = Wrap+convertBoundary (Constant e) = Constant (fromElt e)+++-- Sharing recovery+-- ----------------++-- Sharing recovery proceeds in two phases:+--+-- /Phase One: build the occurence map/+--+-- This is a top-down traversal of the AST that computes a map from AST nodes to the number of+-- occurences of that AST node in the overall Accelerate program. An occurrences count of two or+-- more indicates sharing.+--+-- IMPORTANT: To avoid unfolding the sharing, we do not descent into subtrees that we have+-- previously encountered. Hence, the complexity is proprtional to the number of nodes in the+-- tree /with/ sharing. Consequently, the occurence count is that in the tree with sharing+-- as well.+--+-- During computation of the occurences, the tree is annotated with stable names on every node+-- using 'AccSharing' constructors and all but the first occurence of shared subtrees are pruned+-- using 'VarSharing' constructors (see 'SharingAcc' below). This phase is impure as it is based+-- on stable names.+--+-- We use a hash table (instead of 'Data.Map') as computing stable names forces us to live in IO+-- anyway. Once, the computation of occurence counts is complete, we freeze the hash table into+-- a 'Data.Map'.+--+-- (Implemented by 'makeOccMap'.)+--+-- /Phase Two: determine scopes and inject sharing information/+--+-- This is a bottom-up traversal that determines the scope for every binding to be introduced+-- to share a subterm. It uses the occurence map to determine, for every shared subtree, the+-- lowest AST node at which the binding for that shared subtree can be placed (using a 'LetSharing'+-- constructor)— it's the meet of all the shared subtree occurences.+--+-- The second phase is also replacing the first occurence of each shared subtree with a+-- 'VarSharing' node and floats the shared subtree up to its binding point.+--+-- (Implemented by 'determineScopes'.)++-- Opaque stable name for an array computation — used to key the occurence map.+--+data StableAccName where+ StableAccName :: Typeable arrs => StableName (Acc arrs) -> StableAccName++instance Show StableAccName where+ show (StableAccName sn) = show $ hashStableName sn++instance Eq StableAccName where+ StableAccName sn1 == StableAccName sn2+ | Just sn1' <- gcast sn1 = sn1' == sn2+ | otherwise = False++makeStableAcc :: Acc arrs -> IO (StableName (Acc arrs))+makeStableAcc acc = acc `seq` makeStableName acc++-- Interleave sharing annotations into an array computation AST. Subtrees can be marked as being+-- represented by variable (binding a shared subtree) using 'VarSharing' and as being prefixed by+-- a let binding (for a shared subtree) using 'LetSharing'.+--+data SharingAcc arrs where+ VarSharing :: Arrays arrs => StableName (Acc arrs) -> SharingAcc arrs+ LetSharing :: StableSharingAcc -> SharingAcc arrs -> SharingAcc arrs+ AccSharing :: Arrays arrs => StableName (Acc arrs) -> PreAcc SharingAcc arrs -> SharingAcc arrs++-- Stable name for an array computation associated with its sharing-annotated version.+--+data StableSharingAcc where+ StableSharingAcc :: Arrays arrs => StableName (Acc arrs) -> SharingAcc arrs -> StableSharingAcc++instance Show StableSharingAcc where+ show (StableSharingAcc sn _) = show $ hashStableName sn++instance Eq StableSharingAcc where+ StableSharingAcc sn1 _ == StableSharingAcc sn2 _+ | Just sn1' <- gcast sn1 = sn1' == sn2+ | otherwise = False++-- Test whether the given stable names matches an array computation with sharing.+--+matchStableAcc :: Typeable arrs => StableName (Acc arrs) -> StableSharingAcc -> Bool+matchStableAcc sn1 (StableSharingAcc sn2 _)+ | Just sn1' <- gcast sn1 = sn1' == sn2+ | otherwise = False++-- Hash table keyed on the stable names of array computations.+-- +type AccHashTable v = Hash.HashTable StableAccName v++-- Mutable version of the occurrence map, which associates each AST node with an occurence count.+--+type OccMapHash = AccHashTable Int++-- Create a new hash table keyed by array computations.+--+newAccHashTable :: IO (AccHashTable v)+newAccHashTable = Hash.new (==) hashStableAcc+ where+ hashStableAcc (StableAccName sn) = fromIntegral (hashStableName sn)++-- Immutable version of the occurence map. We use the 'StableName' hash to index an 'IntMap' and+-- disambiguate 'StableName's with identical hashes explicitly, storing them in a list in the+-- 'IntMap'.+--+type OccMap = IntMap.IntMap [(StableAccName, Int)]++-- Turn a mutable into an immutable occurence map.+--+freezeOccMap :: OccMapHash -> IO OccMap+freezeOccMap oc+ = do+ kvs <- Hash.toList oc+ return . IntMap.fromList . map (\kvs -> (key (head kvs), kvs)). groupBy sameKey $ kvs+ where+ key (StableAccName sn, _) = hashStableName sn+ sameKey kv1 kv2 = key kv1 == key kv2++-- Look up the occurence map keyed by array computations using a stable name. If a the key does+-- not exist in the map, return an occurence count of '1'.+--+lookupWithAccName :: OccMap -> StableAccName -> Int+lookupWithAccName oc sa@(StableAccName sn) + = fromMaybe 1 $ IntMap.lookup (hashStableName sn) oc >>= Prelude.lookup sa+ +-- Look up the occurence map keyed by array computations using a sharing array computation. If an+-- the key does not exist in the map, return an occurence count of '1'.+--+lookupWithSharingAcc :: OccMap -> StableSharingAcc -> Int+lookupWithSharingAcc oc (StableSharingAcc sn _) = lookupWithAccName oc (StableAccName sn)++-- Compute the occurence map, marks all nodes with stable names, and drop repeated occurences+-- of shared subtrees (Phase One).+--+-- Note [Traversing functions and side effects]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- We need to descent into function bodies to build the 'OccMap' with all occurences in the+-- function bodies. Due to the side effects in the construction of the occurence map and, more+-- importantly, the dependence of the second phase on /global/ occurence information, we may not+-- delay the body traversals by putting them under a lambda. Hence, we apply the each function, to+-- traverse its body and use a /dummy abstraction/ of the result.+--+-- For example, given a function 'f', we traverse 'f (Tag 0)', which yields a transformed body 'e'.+-- As the result of the traversal of the overall function, we use 'const e'. Hence, it is crucial+-- that the 'Tag' supplied during the initial traversal is already the one required by the HOAS to+-- de Bruijn conversion in 'convertSharingAcc' — any subsequent application of 'const e' will only+-- yield 'e' with the embedded 'Tag 0' of the original application.+--+makeOccMap :: Typeable arrs => Acc arrs -> IO (SharingAcc arrs, OccMapHash)+makeOccMap rootAcc+ = do+ occMap <- newAccHashTable+ rootAcc' <- traverseAcc True (enterOcc occMap) rootAcc+ return (rootAcc', occMap)+ where+ -- Enter one AST node occurrence into an occurrence map. Returns 'True' if this is a repeated+ -- occurence.+ --+ -- The first argument determines whether the 'OccMap' will be modified - see Note [Traversing+ -- functions and side effects].+ --+ enterOcc :: OccMapHash -> Bool -> StableAccName -> IO Bool+ enterOcc occMap updateMap sa + = do+ entry <- Hash.lookup occMap sa+ case entry of+ Nothing -> when updateMap ( Hash.insert occMap sa 1 ) >> return False+ Just n -> when updateMap (void $ Hash.update occMap sa (n + 1)) >> return True+ where+ void = (>> return ())++ traverseAcc :: forall arrs. Typeable arrs+ => Bool -> (Bool -> StableAccName -> IO Bool) -> Acc arrs -> IO (SharingAcc arrs)+ traverseAcc updateMap enter acc'@(Acc pacc)+ = do+ -- Compute stable name and enter it into the occurence map+ sn <- makeStableAcc acc'+ isRepeatedOccurence <- enter updateMap $ StableAccName sn+ + traceLine (showPreAccOp pacc) $+ if isRepeatedOccurence + then "REPEATED occurence"+ else "first occurence (" ++ show (hashStableName sn) ++ ")"++ -- Reconstruct the computation in shared form+ --+ -- NB: This function can only be used in the case alternatives below; outside of the+ -- case we cannot discharge the 'Arrays arrs' constraint.+ let reconstruct :: Arrays arrs + => IO (PreAcc SharingAcc arrs)+ -> IO (SharingAcc arrs)+ reconstruct newAcc | isRepeatedOccurence = pure $ VarSharing sn+ | otherwise = AccSharing sn <$> newAcc++ case pacc of+ Atag i -> reconstruct $ return (Atag i)+ Pipe afun1 afun2 acc -> reconstruct $ travA (Pipe afun1 afun2) acc+ Acond e acc1 acc2 -> reconstruct $ do+ e' <- traverseExp updateMap enter e+ acc1' <- traverseAcc updateMap enter acc1+ acc2' <- traverseAcc updateMap enter acc2+ return (Acond e' acc1' acc2')+ FstArray acc -> reconstruct $ travA FstArray acc+ SndArray acc -> reconstruct $ travA SndArray acc+ PairArrays acc1 acc2 -> reconstruct $ do+ acc1' <- traverseAcc updateMap enter acc1+ acc2' <- traverseAcc updateMap enter acc2+ return (PairArrays acc1' acc2')+ Use arr -> reconstruct $ return (Use arr)+ Unit e -> reconstruct $ do+ e' <- traverseExp updateMap enter e+ return (Unit e')+ Generate e f -> reconstruct $ do+ e' <- traverseExp updateMap enter e+ f' <- traverseFun1 updateMap enter f+ return (Generate e' f')+ 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' <- traverseFun1 updateMap enter f+ acc' <- traverseAcc updateMap enter acc+ return (Map f' acc')+ 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' <- traverseFun2 updateMap enter f+ e' <- traverseExp updateMap enter e+ acc1' <- traverseAcc updateMap enter acc1+ acc2' <- traverseAcc updateMap enter acc2+ return (FoldSeg f' e' acc1' acc2')+ Fold1Seg f acc1 acc2 -> reconstruct $ travF2A2 Fold1Seg f acc1 acc2+ Scanl f e acc -> reconstruct $ travF2EA Scanl f e acc+ Scanl' f e acc -> reconstruct $ travF2EA Scanl' f e acc+ Scanl1 f acc -> reconstruct $ travF2A Scanl1 f acc+ Scanr f e acc -> reconstruct $ travF2EA Scanr f e acc+ Scanr' f e acc -> reconstruct $ travF2EA Scanr' f e acc+ Scanr1 f acc -> reconstruct $ travF2A Scanr1 f acc+ Permute c acc1 p acc2 -> reconstruct $ do+ c' <- traverseFun2 updateMap enter c+ p' <- traverseFun1 updateMap enter p+ acc1' <- traverseAcc updateMap enter acc1+ acc2' <- traverseAcc updateMap enter acc2+ return (Permute c' acc1' p' acc2')+ Backpermute e p acc -> reconstruct $ do+ e' <- traverseExp updateMap enter e+ p' <- traverseFun1 updateMap enter p+ acc' <- traverseAcc updateMap enter acc+ return (Backpermute e' p' acc')+ Stencil s bnd acc -> reconstruct $ do+ s' <- traverseStencil1 acc updateMap enter s+ acc' <- traverseAcc updateMap enter acc+ return (Stencil s' bnd acc')+ Stencil2 s bnd1 acc1 + bnd2 acc2 -> reconstruct $ do+ s' <- traverseStencil2 acc1 acc2 updateMap enter s+ acc1' <- traverseAcc updateMap enter acc1+ acc2' <- traverseAcc updateMap enter acc2+ return (Stencil2 s' bnd1 acc1' bnd2 acc2')+ where+ travA :: Arrays arrs'+ => (SharingAcc arrs' -> PreAcc SharingAcc arrs) + -> Acc arrs' -> IO (PreAcc SharingAcc arrs)+ travA c acc+ = do+ acc' <- traverseAcc updateMap enter acc+ return $ c acc'++ travEA :: (Typeable b, Arrays arrs')+ => (SharingExp b -> SharingAcc arrs' -> PreAcc SharingAcc arrs) + -> Exp b -> Acc arrs' -> IO (PreAcc SharingAcc arrs)+ travEA c exp acc+ = do+ exp' <- traverseExp updateMap enter exp+ acc' <- traverseAcc updateMap enter acc+ return $ c exp' acc'++ travF2A :: (Elt b, Elt c, Typeable d, Arrays arrs')+ => ((Exp b -> Exp c -> SharingExp d) -> SharingAcc arrs' -> PreAcc SharingAcc arrs) + -> (Exp b -> Exp c -> Exp d) -> Acc arrs' -> IO (PreAcc SharingAcc arrs)+ travF2A c fun acc+ = do+ fun' <- traverseFun2 updateMap enter fun+ acc' <- traverseAcc updateMap enter acc+ return $ c fun' acc'++ travF2EA :: (Elt b, Elt c, Typeable d, Typeable e, Arrays arrs')+ => ((Exp b -> Exp c -> SharingExp d) -> SharingExp e+ -> SharingAcc arrs' -> PreAcc SharingAcc arrs) + -> (Exp b -> Exp c -> Exp d) -> Exp e -> Acc arrs' -> IO (PreAcc SharingAcc arrs)+ travF2EA c fun exp acc+ = do+ fun' <- traverseFun2 updateMap enter fun+ exp' <- traverseExp updateMap enter exp+ acc' <- traverseAcc updateMap enter acc+ return $ c fun' exp' acc'++ travF2A2 :: (Elt b, Elt c, Typeable d, Arrays arrs1, Arrays arrs2)+ => ((Exp b -> Exp c -> SharingExp d) -> SharingAcc arrs1+ -> SharingAcc arrs2 -> PreAcc SharingAcc arrs) + -> (Exp b -> Exp c -> Exp d) -> Acc arrs1 -> Acc arrs2 + -> IO (PreAcc SharingAcc arrs)+ travF2A2 c fun acc1 acc2+ = do+ fun' <- traverseFun2 updateMap enter fun+ acc1' <- traverseAcc updateMap enter acc1+ acc2' <- traverseAcc updateMap enter acc2+ return $ c fun' acc1' acc2'++ traverseFun1 :: (Elt b, Typeable c) + => Bool -> (Bool -> StableAccName -> IO Bool) -> (Exp b -> Exp c) + -> IO (Exp b -> SharingExp c)+ traverseFun1 updateMap enter f+ = do+ -- see Note [Traversing functions and side effects]+ body <- traverseExp updateMap enter $ f (Tag 0)+ return $ const body++ traverseFun2 :: (Elt b, Elt c, Typeable d) + => Bool -> (Bool -> StableAccName -> IO Bool) -> (Exp b -> Exp c -> Exp d) + -> IO (Exp b -> Exp c -> SharingExp d)+ traverseFun2 updateMap enter f+ = do+ -- see Note [Traversing functions and side effects]+ body <- traverseExp updateMap enter $ f (Tag 1) (Tag 0)+ return $ \_ _ -> body++ traverseStencil1 :: forall sh b c stencil. (Stencil sh b stencil, Typeable c) + => Acc (Array sh b){-dummy-}+ -> Bool -> (Bool -> StableAccName -> IO Bool) -> (stencil -> Exp c) + -> IO (stencil -> SharingExp c)+ traverseStencil1 _ updateMap enter stencilFun + = do+ -- see Note [Traversing functions and side effects]+ body <- traverseExp updateMap enter $ + stencilFun (stencilPrj (undefined::sh) (undefined::b) (Tag 0))+ return $ const body+ + 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-}+ -> Bool -> (Bool -> StableAccName -> IO Bool) + -> (stencil1 -> stencil2 -> Exp d) + -> IO (stencil1 -> stencil2 -> SharingExp d)+ traverseStencil2 _ _ updateMap enter stencilFun + = do+ -- see Note [Traversing functions and side effects]+ body <- traverseExp updateMap enter $ + stencilFun (stencilPrj (undefined::sh) (undefined::b) (Tag 1))+ (stencilPrj (undefined::sh) (undefined::c) (Tag 0))+ return $ \_ _ -> body+ + traverseExp :: Typeable a + => Bool -> (Bool -> StableAccName -> IO Bool) -> Exp a -> IO (SharingExp a)+ traverseExp updateMap enter exp -- @(Exp pexp)+ = -- FIXME: recover sharing of scalar expressions as well+ case exp of+ Tag i -> return $ Tag i+ Const c -> return $ Const c+ Tuple tup -> Tuple <$> travTup tup+ Prj i e -> travE1 (Prj i) e+ IndexNil -> return IndexNil+ IndexCons ix i -> travE2 IndexCons ix i+ IndexHead i -> travE1 IndexHead i+ IndexTail ix -> travE1 IndexTail ix+ IndexAny -> return $ IndexAny+ Cond e1 e2 e3 -> travE3 Cond e1 e2 e3+ PrimConst c -> return $ PrimConst c+ PrimApp p e -> travE1 (PrimApp p) e+ IndexScalar a e -> travAE IndexScalar a e+ Shape a -> travA Shape a+ Size a -> travA Size a+ where+ travE1 :: Typeable b => (SharingExp b -> SharingExp c) -> Exp b -> IO (SharingExp c)+ travE1 c e+ = do+ e' <- traverseExp updateMap enter e+ return $ c e'+ + travE2 :: (Typeable b, Typeable c) + => (SharingExp b -> SharingExp c -> SharingExp d) -> Exp b -> Exp c + -> IO (SharingExp d)+ travE2 c e1 e2+ = do+ e1' <- traverseExp updateMap enter e1+ e2' <- traverseExp updateMap enter e2+ return $ c e1' e2'+ + travE3 :: (Typeable b, Typeable c, Typeable d) + => (SharingExp b -> SharingExp c -> SharingExp d -> SharingExp e) + -> Exp b -> Exp c -> Exp d+ -> IO (SharingExp e)+ travE3 c e1 e2 e3+ = do+ e1' <- traverseExp updateMap enter e1+ e2' <- traverseExp updateMap enter e2+ e3' <- traverseExp updateMap enter e3+ return $ c e1' e2' e3'+ + travA :: Typeable b => (SharingAcc b -> SharingExp c) -> Acc b -> IO (SharingExp c)+ travA c acc+ = do+ acc' <- traverseAcc updateMap enter acc+ return $ c acc'++ travAE :: (Typeable b, Typeable c) + => (SharingAcc b -> SharingExp c -> SharingExp d) -> Acc b -> Exp c + -> IO (SharingExp d)+ travAE c acc e+ = do+ acc' <- traverseAcc updateMap enter acc+ e' <- traverseExp updateMap enter e+ return $ c acc' e'++ travTup :: Tuple.Tuple (PreExp Acc) tup -> IO (Tuple.Tuple (PreExp SharingAcc) tup)+ travTup NilTup = return NilTup+ travTup (SnocTup tup e) = pure SnocTup <*> travTup tup <*> traverseExp updateMap enter e++-- Type used to maintain how often each shared subterm occured.+--+-- Invariant: If one shared term 's' is itself a subterm of another shared term 't', then 's' +-- must occur *after* 't' in the 'NodeCounts'. Moreover, no shared term occur twice.+--+-- To ensure the invariant is preserved over merging node counts from sibling subterms, the+-- function '(+++)' must be used.+--+newtype NodeCounts = NodeCounts [(StableSharingAcc, Int)]+ deriving Show++-- Empty node counts+--+noNodeCounts :: NodeCounts+noNodeCounts = NodeCounts []++-- Singleton node counts+--+nodeCount :: (StableSharingAcc, Int) -> NodeCounts+nodeCount nc = NodeCounts [nc]++-- Combine node counts that belong to the same node.+--+-- * We assume that the node counts invariant —subterms follow their parents— holds for both+-- arguments and guarantee that it still holds for the result.+--+-- * This function has quadratic complexity. This could be improved by labelling nodes with their+-- nesting depth, but doesn't seem worthwhile as the arguments are expected to be fairly short.+-- Change if profiling suggests that this function is a bottleneck.+--+(+++) :: NodeCounts -> NodeCounts -> NodeCounts+NodeCounts us +++ NodeCounts vs = NodeCounts $ merge us vs+ where+ merge [] ys = ys+ merge xs [] = xs+ merge xs@(x@(sa1, count1) : xs') ys@(y@(sa2, count2) : ys') + | sa1 == sa2 = (sa1 `pickNoneVar` sa2, count1 + count2) : merge xs' ys'+ | sa1 `notElem` map fst ys' = x : merge xs' ys+ | sa2 `notElem` map fst xs' = y : merge xs ys'+ | otherwise = INTERNAL_ERROR(error) "(+++)" "Precondition violated"++ (StableSharingAcc _ (VarSharing _)) `pickNoneVar` sa2 = sa2+ sa1 `pickNoneVar` _sa2 = sa1++-- Determine the scopes of all variables representing shared subterms (Phase Two) in a bottom-up+-- sweep. The first argument determines whether array computations are floated out of expressions+-- irrespective of whether they are shared or not — 'True' implies floating them out.+--+-- Precondition: there are only 'VarSharing' and 'AccSharing' nodes in the argument.+--+determineScopes :: Typeable a => Bool -> OccMap -> SharingAcc a -> SharingAcc a+determineScopes floatOutAcc occMap rootAcc = fst $ scopesAcc rootAcc+ where+ scopesAcc :: forall arrs. SharingAcc arrs -> (SharingAcc arrs, NodeCounts)+ scopesAcc (LetSharing _ _)+ = INTERNAL_ERROR(error) "determineScopes: scopes" "unexpected 'LetSharing'"+ scopesAcc sharingAcc@(VarSharing sn)+ = (VarSharing sn, nodeCount (StableSharingAcc sn sharingAcc, 1))+ scopesAcc (AccSharing sn pacc)+ = case pacc of+ Atag i -> reconstruct (Atag i) noNodeCounts+ Pipe afun1 afun2 acc -> travA (Pipe afun1 afun2) acc+ -- we are not traversing 'afun1' & 'afun2' — see Note [Pipe and sharing recovery]+ Acond e acc1 acc2 -> let+ (e' , accCount1) = scopesExp e+ (acc1', accCount2) = scopesAcc acc1+ (acc2', accCount3) = scopesAcc acc2+ 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)+ Use arr -> reconstruct (Use arr) noNodeCounts+ Unit e -> let+ (e', accCount) = scopesExp e+ in+ reconstruct (Unit e') accCount+ Generate sh f -> let+ (sh', accCount1) = scopesExp sh+ (f' , accCount2) = scopesFun1 f+ in+ reconstruct (Generate sh' f') (accCount1 +++ accCount2)+ Reshape sh acc -> travEA Reshape sh acc+ Replicate n acc -> travEA Replicate n acc+ Index acc i -> travEA (flip Index) i acc+ Map f acc -> let+ (f' , accCount1) = scopesFun1 f+ (acc', accCount2) = scopesAcc acc+ in+ reconstruct (Map f' acc') (accCount1 +++ accCount2)+ ZipWith f acc1 acc2 -> travF2A2 ZipWith f acc1 acc2+ Fold f z acc -> travF2EA Fold f z acc+ Fold1 f acc -> travF2A Fold1 f acc+ FoldSeg f z acc1 acc2 -> let+ (f' , accCount1) = scopesFun2 f+ (z' , accCount2) = scopesExp z+ (acc1', accCount3) = scopesAcc acc1+ (acc2', accCount4) = scopesAcc acc2+ in+ reconstruct (FoldSeg f' z' acc1' acc2') + (accCount1 +++ accCount2 +++ accCount3 +++ accCount4)+ Fold1Seg f acc1 acc2 -> travF2A2 Fold1Seg f acc1 acc2+ Scanl f z acc -> travF2EA Scanl f z acc+ Scanl' f z acc -> travF2EA Scanl' f z acc+ Scanl1 f acc -> travF2A Scanl1 f acc+ Scanr f z acc -> travF2EA Scanr f z acc+ Scanr' f z acc -> travF2EA Scanr' f z acc+ Scanr1 f acc -> travF2A Scanr1 f acc+ Permute fc acc1 fp acc2 -> let+ (fc' , accCount1) = scopesFun2 fc+ (acc1', accCount2) = scopesAcc acc1+ (fp' , accCount3) = scopesFun1 fp+ (acc2', accCount4) = scopesAcc acc2+ in+ reconstruct (Permute fc' acc1' fp' acc2')+ (accCount1 +++ accCount2 +++ accCount3 +++ accCount4)+ Backpermute sh fp acc -> let+ (sh' , accCount1) = scopesExp sh+ (fp' , accCount2) = scopesFun1 fp+ (acc', accCount3) = scopesAcc acc+ in+ reconstruct (Backpermute sh' fp' acc')+ (accCount1 +++ accCount2 +++ accCount3)+ Stencil st bnd acc -> let+ (st' , accCount1) = scopesStencil1 acc st+ (acc', accCount2) = scopesAcc acc+ in+ reconstruct (Stencil st' bnd acc') (accCount1 +++ accCount2)+ Stencil2 st bnd1 acc1 bnd2 acc2 + -> let+ (st' , accCount1) = scopesStencil2 acc1 acc2 st+ (acc1', accCount2) = scopesAcc acc1+ (acc2', accCount3) = scopesAcc acc2+ in+ reconstruct (Stencil2 st' bnd1 acc1' bnd2 acc2')+ (accCount1 +++ accCount2 +++ accCount3)+ where+ travEA :: Arrays arrs + => (SharingExp e -> SharingAcc arrs' -> PreAcc SharingAcc arrs) + -> SharingExp e+ -> SharingAcc arrs' + -> (SharingAcc arrs, NodeCounts)+ travEA c e acc = reconstruct (c e' acc') (accCount1 +++ accCount2)+ where+ (e' , accCount1) = scopesExp e+ (acc', accCount2) = scopesAcc acc++ travF2A :: (Elt a, Elt b, Arrays arrs)+ => ((Exp a -> Exp b -> SharingExp c) -> SharingAcc arrs' -> PreAcc SharingAcc arrs) + -> (Exp a -> Exp b -> SharingExp c)+ -> SharingAcc arrs'+ -> (SharingAcc arrs, NodeCounts)+ travF2A c f acc = reconstruct (c f' acc') (accCount1 +++ accCount2)+ where+ (f' , accCount1) = scopesFun2 f+ (acc', accCount2) = scopesAcc acc ++ travF2EA :: (Elt a, Elt b, Arrays arrs)+ => ((Exp a -> Exp b -> SharingExp c) -> SharingExp e + -> SharingAcc arrs' -> PreAcc SharingAcc arrs) + -> (Exp a -> Exp b -> SharingExp c)+ -> SharingExp e + -> SharingAcc arrs'+ -> (SharingAcc arrs, NodeCounts)+ travF2EA c f e acc = reconstruct (c f' e' acc') (accCount1 +++ accCount2 +++ accCount3)+ where+ (f' , accCount1) = scopesFun2 f+ (e' , accCount2) = scopesExp e+ (acc', accCount3) = scopesAcc acc++ travF2A2 :: (Elt a, Elt b, Arrays arrs)+ => ((Exp a -> Exp b -> SharingExp c) -> SharingAcc arrs1 + -> SharingAcc arrs2 -> PreAcc SharingAcc arrs) + -> (Exp a -> Exp b -> SharingExp c)+ -> SharingAcc arrs1 + -> SharingAcc arrs2 + -> (SharingAcc arrs, NodeCounts)+ travF2A2 c f acc1 acc2 = reconstruct (c f' acc1' acc2') + (accCount1 +++ accCount2 +++ accCount3)+ where+ (f' , accCount1) = scopesFun2 f+ (acc1', accCount2) = scopesAcc acc1+ (acc2', accCount3) = scopesAcc acc2++ travA :: Arrays arrs + => (SharingAcc arrs' -> PreAcc SharingAcc arrs) + -> SharingAcc arrs' + -> (SharingAcc arrs, NodeCounts)+ travA c acc = reconstruct (c acc') accCount+ where+ (acc', accCount) = scopesAcc acc++ -- Occurence count of the currently processed node+ occCount = lookupWithAccName occMap (StableAccName sn)++ -- Reconstruct the current tree node.+ --+ -- * If the current node is being shared ('occCount > 1'), replace it by a 'VarSharing'+ -- node and float the shared subtree out wrapped in a 'NodeCounts' value.+ -- * If the current node is not shared, reconstruct it in place.+ --+ -- In either case, any completed 'NodeCounts' are injected as bindings using 'LetSharing'+ -- node.+ -- + reconstruct :: Arrays arrs + => PreAcc SharingAcc arrs -> NodeCounts -> (SharingAcc arrs, NodeCounts)+ reconstruct newAcc subCount+ | occCount > 1 = ( VarSharing sn+ , nodeCount (StableSharingAcc sn sharingAcc, 1) +++ newCount)+ | otherwise = (sharingAcc, newCount)+ where+ -- Determine the bindings that need to be attached to the current node...+ (newCount, bindHere) = filterCompleted subCount++ -- ...and wrap them in 'LetSharing' constructors+ lets = foldl (flip (.)) id . map LetSharing $ bindHere+ sharingAcc = lets $ AccSharing sn newAcc++ -- Extract nodes that have a complete node count (i.e., their node count is equal to the+ -- number of occurences of that node in the overall expression) => nodes with a completed+ -- node count should be let bound at the currently processed node.+ --+ filterCompleted :: NodeCounts -> (NodeCounts, [StableSharingAcc])+ filterCompleted (NodeCounts counts) + = let (counts', completed) = fc counts+ in (NodeCounts counts', completed)+ where+ fc [] = ([], [])+ fc (sub@(sa, n):subs)+ -- current node is the binding point for the shared node 'sa'+ | occCount == n = (subs', sa:bindHere)+ -- not a binding point+ | otherwise = (sub:subs', bindHere)+ where+ occCount = lookupWithSharingAcc occMap sa+ (subs', bindHere) = fc subs++ scopesExp :: forall arrs. SharingExp arrs -> (SharingExp arrs, NodeCounts)+ scopesExp pacc+ = case pacc of+ Tag i -> (Tag i, noNodeCounts)+ Const c -> (Const c, noNodeCounts)+ Tuple tup -> let (tup', accCount) = travTup tup in (Tuple tup', accCount)+ Prj i e -> travE1 (Prj i) e+ IndexNil -> (IndexNil, noNodeCounts)+ IndexCons ix i -> travE2 IndexCons ix i+ IndexHead i -> travE1 IndexHead i+ IndexTail ix -> travE1 IndexTail ix+ IndexAny -> (IndexAny, noNodeCounts)+ Cond e1 e2 e3 -> travE3 Cond e1 e2 e3+ PrimConst c -> (PrimConst c, noNodeCounts)+ PrimApp p e -> travE1 (PrimApp p) e+ IndexScalar a e -> travAE IndexScalar a e+ Shape a -> travA Shape a+ Size a -> travA Size a+ where+ travTup :: Tuple.Tuple (PreExp SharingAcc) tup + -> (Tuple.Tuple (PreExp SharingAcc) tup, NodeCounts)+ travTup NilTup = (NilTup, noNodeCounts)+ travTup (SnocTup tup e) = let+ (tup', accCountT) = travTup tup+ (e' , accCountE) = scopesExp e+ in+ (SnocTup tup' e', accCountT +++ accCountE)++ travE1 :: (SharingExp a -> SharingExp b) -> SharingExp a -> (SharingExp b, NodeCounts)+ travE1 c e = (c e', accCount)+ where+ (e', accCount) = scopesExp e++ travE2 :: (SharingExp a -> SharingExp b -> SharingExp c) -> SharingExp a -> SharingExp b + -> (SharingExp c, NodeCounts)+ travE2 c e1 e2 = (c e1' e2', accCount1 +++ accCount2)+ where+ (e1', accCount1) = scopesExp e1+ (e2', accCount2) = scopesExp e2++ travE3 :: (SharingExp a -> SharingExp b -> SharingExp c -> SharingExp d) + -> SharingExp a -> SharingExp b -> SharingExp c + -> (SharingExp d, NodeCounts)+ travE3 c e1 e2 e3 = (c e1' e2' e3', accCount1 +++ accCount2 +++ accCount3)+ where+ (e1', accCount1) = scopesExp e1+ (e2', accCount2) = scopesExp e2+ (e3', accCount3) = scopesExp e3++ travA :: (SharingAcc a -> SharingExp b) -> SharingAcc a -> (SharingExp b, NodeCounts)+ travA c acc = maybeFloatOutAcc c acc' accCount+ where+ (acc', accCount) = scopesAcc acc+ + travAE :: (SharingAcc a -> SharingExp b -> SharingExp c) -> SharingAcc a -> SharingExp b + -> (SharingExp c, NodeCounts)+ travAE c acc e = maybeFloatOutAcc (flip c e') acc' (accCountA +++ accCountE)+ where+ (acc', accCountA) = scopesAcc acc+ (e' , accCountE) = scopesExp e+ + maybeFloatOutAcc :: (SharingAcc a -> SharingExp b) -> SharingAcc a -> NodeCounts+ -> (SharingExp b, NodeCounts)+ maybeFloatOutAcc c acc@(VarSharing _) accCount = (c acc, accCount) -- nothing to float out+ maybeFloatOutAcc c acc accCount+ | floatOutAcc = (c var, nodeCount (stableAcc, 1) +++ accCount)+ | otherwise = (c acc, accCount)+ where+ (var, stableAcc) = abstract acc id++ abstract :: SharingAcc a -> (SharingAcc a -> SharingAcc a) + -> (SharingAcc a, StableSharingAcc)+ abstract (VarSharing _) _ = INTERNAL_ERROR(error) "sharingAccToVar" "VarSharing"+ abstract (LetSharing sa acc) lets = abstract acc (lets . LetSharing sa)+ abstract acc@(AccSharing sn _) lets = (VarSharing sn, StableSharingAcc sn (lets acc))++ -- The lambda bound variable is at this point already irrelevant; for details, see+ -- Note [Traversing functions and side effects]+ --+ scopesFun1 :: Elt e1 => (Exp e1 -> SharingExp e2) -> (Exp e1 -> SharingExp e2, NodeCounts)+ scopesFun1 f = (const body, counts)+ where+ (body, counts) = scopesExp (f undefined)++ -- The lambda bound variable is at this point already irrelevant; for details, see+ -- Note [Traversing functions and side effects]+ --+ scopesFun2 :: (Elt e1, Elt e2) + => (Exp e1 -> Exp e2 -> SharingExp e3) + -> (Exp e1 -> Exp e2 -> SharingExp e3, NodeCounts)+ scopesFun2 f = (\_ _ -> body, counts)+ where+ (body, counts) = scopesExp (f undefined undefined)++ -- The lambda bound variable is at this point already irrelevant; for details, see+ -- Note [Traversing functions and side effects]+ --+ scopesStencil1 :: forall sh e1 e2 stencil. Stencil sh e1 stencil+ => SharingAcc (Array sh e1){-dummy-}+ -> (stencil -> SharingExp e2) + -> (stencil -> SharingExp e2, NodeCounts)+ scopesStencil1 _ stencilFun = (const body, counts)+ where+ (body, counts) = scopesExp (stencilFun undefined)+ + -- The lambda bound variable is at this point already irrelevant; for details, see+ -- Note [Traversing functions and side effects]+ --+ scopesStencil2 :: forall sh e1 e2 e3 stencil1 stencil2. + (Stencil sh e1 stencil1, Stencil sh e2 stencil2)+ => SharingAcc (Array sh e1){-dummy-}+ -> SharingAcc (Array sh e2){-dummy-}+ -> (stencil1 -> stencil2 -> SharingExp e3) + -> (stencil1 -> stencil2 -> SharingExp e3, NodeCounts)+ scopesStencil2 _ _ stencilFun = (\_ _ -> body, counts)+ where+ (body, counts) = scopesExp (stencilFun undefined undefined) + +-- |Recover sharing information and annotate the HOAS AST with variable and let binding+-- annotations. The first argument determines whether array computations are floated out of+-- expressions irrespective of whether they are shared or not — 'True' implies floating them out.+--+-- NB: Strictly speaking, this function is not deterministic, as it uses stable pointers to+-- determine the sharing of subterms. The stable pointer API does not guarantee its+-- completeness; i.e., it may miss some equalities, which implies that we may fail to discover+-- some sharing. However, sharing does not affect the denotational meaning of an array+-- computation; hence, we do not compromise denotational correctness.+--+recoverSharing :: Typeable a => Bool -> Acc a -> SharingAcc a+{-# NOINLINE recoverSharing #-}+recoverSharing floatOutAcc acc + = let (acc', occMap) = -- as we need to use stable pointers; it's safe as explained above+ unsafePerformIO $ do+ (acc', occMap) <- makeOccMap acc+ + occMapList <- Hash.toList occMap+ traceChunk "OccMap" $+ show occMapList+ + frozenOccMap <- freezeOccMap occMap+ return (acc', frozenOccMap)+ in + determineScopes floatOutAcc occMap acc'+++-- Embedded expressions of the surface language+-- --------------------------------------------++-- HOAS expressions mirror the constructors of `AST.OpenExp', but with the+-- `Tag' constructor instead of variables in the form of de Bruijn indices.+-- Moreover, HOAS expression use n-tuples and the type class 'Elt' to+-- constrain element types, whereas `AST.OpenExp' uses nested pairs and the +-- GADT 'TupleType'.+--++-- |Scalar expressions to parametrise collective array operations, themselves parameterised over+-- the type of collective array operations.+--+data PreExp acc t where+ -- Needed for conversion to de Bruijn form+ Tag :: Elt t+ => Int -> PreExp acc t+ -- environment size at defining occurrence++ -- All the same constructors as 'AST.Exp'+ Const :: Elt t + => t -> PreExp acc t++ Tuple :: (Elt t, IsTuple t)+ => Tuple.Tuple (PreExp acc) (TupleRepr t) -> PreExp acc t+ Prj :: (Elt t, IsTuple t)+ => TupleIdx (TupleRepr t) e + -> PreExp acc t -> PreExp acc e+ IndexNil :: PreExp acc Z+ IndexCons :: (Slice sl, Elt a)+ => PreExp acc sl -> PreExp acc a -> PreExp acc (sl:.a)+ IndexHead :: (Slice sl, Elt a)+ => PreExp acc (sl:.a) -> PreExp acc a+ IndexTail :: (Slice sl, Elt a)+ => PreExp acc (sl:.a) -> PreExp acc sl+ IndexAny :: Shape sh+ => PreExp acc (Any sh)+ Cond :: PreExp acc Bool -> PreExp acc t -> PreExp acc t -> PreExp acc t+ PrimConst :: Elt t + => PrimConst t -> PreExp acc t+ PrimApp :: (Elt a, Elt r) + => PrimFun (a -> r) -> PreExp acc a -> PreExp acc r+ IndexScalar :: (Shape sh, Elt t)+ => acc (Array sh t) -> PreExp acc sh -> PreExp acc t+ Shape :: (Shape sh, Elt e)+ => acc (Array sh e) -> PreExp acc sh+ Size :: (Shape sh, Elt e)+ => acc (Array sh e) -> PreExp acc Int++-- |Scalar expressions for plain array computations.+--+type Exp t = PreExp Acc t++-- |Scalar expressions for array computations with sharing annotations.+--+type SharingExp t = PreExp SharingAcc t++-- |Conversion from HOAS to de Bruijn expression AST+-- -++-- |Convert an open expression with given environment layouts.+--+convertOpenExp :: forall t env aenv. + Layout env env -- scalar environment+ -> Layout aenv aenv -- array environment+ -> [StableSharingAcc] -- currently bound sharing variables+ -> SharingExp t -- expression to be converted+ -> AST.OpenExp env aenv t+convertOpenExp lyt alyt env = cvt+ where+ cvt :: SharingExp t' -> AST.OpenExp env aenv t'+ cvt (Tag i) = AST.Var (prjIdx i lyt)+ cvt (Const v) = AST.Const (fromElt v)+ cvt (Tuple tup) = AST.Tuple (convertTuple lyt alyt env tup)+ cvt (Prj idx e) = AST.Prj idx (cvt e)+ cvt IndexNil = AST.IndexNil+ cvt (IndexCons ix i) = AST.IndexCons (cvt ix) (cvt i)+ cvt (IndexHead i) = AST.IndexHead (cvt i)+ cvt (IndexTail ix) = AST.IndexTail (cvt ix)+ cvt (IndexAny) = AST.IndexAny+ cvt (Cond e1 e2 e3) = AST.Cond (cvt e1) (cvt e2) (cvt e3)+ cvt (PrimConst c) = AST.PrimConst c+ cvt (PrimApp p e) = AST.PrimApp p (cvt e)+ cvt (IndexScalar a e) = AST.IndexScalar (convertSharingAcc alyt env a) (cvt e)+ cvt (Shape a) = AST.Shape (convertSharingAcc alyt env a)+ cvt (Size a) = AST.Size (convertSharingAcc alyt env a)++-- |Convert a tuple expression+--+convertTuple :: Layout env env + -> Layout aenv aenv + -> [StableSharingAcc] -- currently bound sharing variables+ -> Tuple.Tuple (PreExp SharingAcc) t + -> Tuple.Tuple (AST.OpenExp env aenv) t+convertTuple _lyt _alyt _env NilTup = NilTup+convertTuple lyt alyt env (es `SnocTup` e) + = convertTuple lyt alyt env es `SnocTup` convertOpenExp lyt alyt env e++-- |Convert an expression closed wrt to scalar variables+--+convertExp :: Layout aenv aenv -- array environment+ -> [StableSharingAcc] -- currently bound sharing variables+ -> SharingExp t -- expression to be converted+ -> AST.Exp aenv t+convertExp alyt env = convertOpenExp EmptyLayout alyt env++-- |Convert a unary functions+--+convertFun1 :: forall a b aenv. Elt a+ => Layout aenv aenv + -> [StableSharingAcc] -- currently bound sharing variables+ -> (Exp a -> SharingExp b) + -> AST.Fun aenv (a -> b)+convertFun1 alyt env f = Lam (Body openF)+ where+ a = Tag 0+ lyt = EmptyLayout + `PushLayout` + (ZeroIdx :: Idx ((), EltRepr a) (EltRepr a))+ openF = convertOpenExp lyt alyt env (f a)++-- |Convert a binary functions+--+convertFun2 :: forall a b c aenv. (Elt a, Elt b) + => Layout aenv aenv + -> [StableSharingAcc] -- currently bound sharing variables+ -> (Exp a -> Exp b -> SharingExp c) + -> AST.Fun aenv (a -> b -> c)+convertFun2 alyt env f = Lam (Lam (Body openF))+ where+ a = Tag 1+ b = Tag 0+ lyt = EmptyLayout + `PushLayout`+ (SuccIdx ZeroIdx :: Idx (((), EltRepr a), EltRepr b) (EltRepr a))+ `PushLayout`+ (ZeroIdx :: Idx (((), EltRepr a), EltRepr b) (EltRepr b))+ openF = convertOpenExp lyt alyt env (f a b)++-- Convert a unary stencil function+--+convertStencilFun :: forall sh a stencil b aenv. (Elt a, Stencil sh a stencil)+ => SharingAcc (Array sh a) -- just passed to fix the type variables+ -> Layout aenv aenv + -> [StableSharingAcc] -- currently bound sharing variables+ -> (stencil -> SharingExp b)+ -> AST.Fun aenv (StencilRepr sh stencil -> b)+convertStencilFun _ alyt env stencilFun = Lam (Body openStencilFun)+ where+ stencil = Tag 0 :: Exp (StencilRepr sh stencil)+ lyt = EmptyLayout + `PushLayout` + (ZeroIdx :: Idx ((), EltRepr (StencilRepr sh stencil)) + (EltRepr (StencilRepr sh stencil)))+ openStencilFun = convertOpenExp lyt alyt env $+ stencilFun (stencilPrj (undefined::sh) (undefined::a) stencil)++-- Convert a binary stencil function+--+convertStencilFun2 :: forall sh a b stencil1 stencil2 c aenv. + (Elt a, Stencil sh a stencil1,+ Elt b, Stencil sh b stencil2)+ => SharingAcc (Array sh a) -- just passed to fix the type variables+ -> SharingAcc (Array sh b) -- just passed to fix the type variables+ -> Layout aenv aenv + -> [StableSharingAcc] -- currently bound sharing variables+ -> (stencil1 -> stencil2 -> SharingExp c)+ -> AST.Fun aenv (StencilRepr sh stencil1 ->+ StencilRepr sh stencil2 -> c)+convertStencilFun2 _ _ alyt env stencilFun = Lam (Lam (Body openStencilFun))+ where+ stencil1 = Tag 1 :: Exp (StencilRepr sh stencil1)+ stencil2 = Tag 0 :: Exp (StencilRepr sh stencil2)+ lyt = EmptyLayout + `PushLayout` + (SuccIdx ZeroIdx :: Idx (((), EltRepr (StencilRepr sh stencil1)),+ EltRepr (StencilRepr sh stencil2)) + (EltRepr (StencilRepr sh stencil1)))+ `PushLayout` + (ZeroIdx :: Idx (((), EltRepr (StencilRepr sh stencil1)),+ EltRepr (StencilRepr sh stencil2)) + (EltRepr (StencilRepr sh stencil2)))+ openStencilFun = convertOpenExp lyt alyt env $+ stencilFun (stencilPrj (undefined::sh) (undefined::a) stencil1)+ (stencilPrj (undefined::sh) (undefined::b) stencil2)+++-- Pretty printing+--++instance Arrays arrs => Show (Acc arrs) where+ show = show . convertAcc+ +instance Show (Exp a) where+ show = show . convertExp EmptyLayout [] . toSharingExp+ where+ toSharingExp :: Exp b -> SharingExp b+ toSharingExp (Tag i) = Tag i+ toSharingExp (Const v) = Const v+ toSharingExp (Tuple tup) = Tuple (toSharingTup tup)+ toSharingExp (Prj idx e) = Prj idx (toSharingExp e)+ toSharingExp IndexNil = IndexNil+ toSharingExp (IndexCons ix i) = IndexCons (toSharingExp ix) (toSharingExp i)+ toSharingExp (IndexHead ix) = IndexHead (toSharingExp ix)+ toSharingExp (IndexTail ix) = IndexTail (toSharingExp ix)+ toSharingExp (IndexAny) = IndexAny+ toSharingExp (Cond e1 e2 e3) = Cond (toSharingExp e1) (toSharingExp e2) (toSharingExp e3)+ toSharingExp (PrimConst c) = PrimConst c+ toSharingExp (PrimApp p e) = PrimApp p (toSharingExp e)+ toSharingExp (IndexScalar a e) = IndexScalar (recoverSharing False a) (toSharingExp e)+ toSharingExp (Shape a) = Shape (recoverSharing False a)+ toSharingExp (Size a) = Size (recoverSharing False a)++ toSharingTup :: Tuple.Tuple (PreExp Acc) tup -> Tuple.Tuple (PreExp SharingAcc) tup+ toSharingTup NilTup = NilTup+ toSharingTup (SnocTup tup e) = SnocTup (toSharingTup tup) (toSharingExp e)++-- for debugging+showPreAccOp :: PreAcc acc arrs -> String+showPreAccOp (Atag _) = "Atag" +showPreAccOp (Pipe _ _ _) = "Pipe"+showPreAccOp (Acond _ _ _) = "Acond"+showPreAccOp (FstArray _) = "FstArray"+showPreAccOp (SndArray _) = "SndArray"+showPreAccOp (PairArrays _ _) = "PairArrays"+showPreAccOp (Use _) = "Use"+showPreAccOp (Unit _) = "Unit"+showPreAccOp (Generate _ _) = "Generate"+showPreAccOp (Reshape _ _) = "Reshape"+showPreAccOp (Replicate _ _) = "Replicate"+showPreAccOp (Index _ _) = "Index"+showPreAccOp (Map _ _) = "Map"+showPreAccOp (ZipWith _ _ _) = "ZipWith"+showPreAccOp (Fold _ _ _) = "Fold"+showPreAccOp (Fold1 _ _) = "Fold1"+showPreAccOp (FoldSeg _ _ _ _) = "FoldSeg"+showPreAccOp (Fold1Seg _ _ _) = "Fold1Seg"+showPreAccOp (Scanl _ _ _) = "Scanl"+showPreAccOp (Scanl' _ _ _) = "Scanl'"+showPreAccOp (Scanl1 _ _) = "Scanl1"+showPreAccOp (Scanr _ _ _) = "Scanr"+showPreAccOp (Scanr' _ _ _) = "Scanr'"+showPreAccOp (Scanr1 _ _) = "Scanr1"+showPreAccOp (Permute _ _ _ _) = "Permute"+showPreAccOp (Backpermute _ _ _) = "Backpermute"+showPreAccOp (Stencil _ _ _) = "Stencil"+showPreAccOp (Stencil2 _ _ _ _ _) = "Stencil2"++_showSharingAccOp :: SharingAcc arrs -> String+_showSharingAccOp (VarSharing sn) = "VAR " ++ show (hashStableName sn)+_showSharingAccOp (LetSharing _ acc) = "LET " ++ _showSharingAccOp acc+_showSharingAccOp (AccSharing _ acc) = showPreAccOp acc+++-- |Smart constructors to construct representation AST forms+-- ---------------------------------------------------------++mkIndex :: forall slix e aenv. (Slice slix, Elt e)+ => AST.OpenAcc aenv (Array (FullShape slix) e)+ -> AST.Exp aenv slix+ -> AST.PreOpenAcc AST.OpenAcc aenv (Array (SliceShape slix) e)+mkIndex arr e+ = AST.Index (sliceIndex slix) arr e+ where+ slix = undefined :: slix++mkReplicate :: forall slix e aenv. (Slice slix, Elt e)+ => AST.Exp aenv slix+ -> AST.OpenAcc aenv (Array (SliceShape slix) e)+ -> AST.PreOpenAcc AST.OpenAcc aenv (Array (FullShape slix) e)+mkReplicate e arr+ = AST.Replicate (sliceIndex slix) e arr+ where+ slix = undefined :: slix+++-- |Smart constructors for stencil reification+-- -------------------------------------------++-- Stencil reification+--+-- In the AST representation, we turn the stencil type from nested tuples of Accelerate expressions+-- into an Accelerate expression whose type is a tuple nested in the same manner. This enables us+-- to represent the stencil function as a unary function (which also only needs one de Bruijn+-- index). The various positions in the stencil are accessed via tuple indices (i.e., projections).++class (Elt (StencilRepr sh stencil), AST.Stencil sh a (StencilRepr sh stencil)) + => Stencil sh a stencil where+ type StencilRepr sh stencil :: *+ stencilPrj :: sh{-dummy-} -> a{-dummy-} -> Exp (StencilRepr sh stencil) -> stencil++-- DIM1+instance Elt e => Stencil DIM1 e (Exp e, Exp e, Exp e) where+ type StencilRepr DIM1 (Exp e, Exp e, Exp e) + = (e, e, e)+ stencilPrj _ _ s = (Prj tix2 s, + Prj tix1 s, + Prj tix0 s)+instance Elt e => Stencil DIM1 e (Exp e, Exp e, Exp e, Exp e, Exp e) where+ type StencilRepr DIM1 (Exp e, Exp e, Exp e, Exp e, Exp e)+ = (e, e, e, e, e)+ stencilPrj _ _ s = (Prj tix4 s, + Prj tix3 s, + Prj tix2 s, + Prj tix1 s, + Prj tix0 s)+instance Elt e => Stencil DIM1 e (Exp e, Exp e, Exp e, Exp e, Exp e, Exp e, Exp e) where+ type StencilRepr DIM1 (Exp e, Exp e, Exp e, Exp e, Exp e, Exp e, Exp e) + = (e, e, e, e, e, e, e)+ stencilPrj _ _ s = (Prj tix6 s, + Prj tix5 s, + Prj tix4 s, + Prj tix3 s, + Prj tix2 s, + Prj tix1 s, + Prj tix0 s)+instance Elt e => Stencil DIM1 e (Exp e, Exp e, Exp e, Exp e, Exp e, Exp e, Exp e, Exp e, Exp e) where+ type StencilRepr DIM1 (Exp e, Exp e, Exp e, Exp e, Exp e, Exp e, Exp e, Exp e, Exp e)+ = (e, e, e, e, e, e, e, e, e)+ stencilPrj _ _ s = (Prj tix8 s, + Prj tix7 s, + Prj tix6 s, + Prj tix5 s, + Prj tix4 s, + Prj tix3 s, + Prj tix2 s, + Prj tix1 s, + Prj tix0 s)++-- DIM(n+1)+instance (Stencil (sh:.Int) a row2, + Stencil (sh:.Int) a row1,+ Stencil (sh:.Int) a row0) => Stencil (sh:.Int:.Int) a (row2, row1, row0) where+ type StencilRepr (sh:.Int:.Int) (row2, row1, row0) + = (StencilRepr (sh:.Int) row2, StencilRepr (sh:.Int) row1, StencilRepr (sh:.Int) row0)+ stencilPrj _ a s = (stencilPrj (undefined::(sh:.Int)) a (Prj tix2 s), + stencilPrj (undefined::(sh:.Int)) a (Prj tix1 s), + stencilPrj (undefined::(sh:.Int)) a (Prj tix0 s))+instance (Stencil (sh:.Int) a row1,+ Stencil (sh:.Int) a row2,+ Stencil (sh:.Int) a row3,+ Stencil (sh:.Int) a row4,+ Stencil (sh:.Int) a row5) => Stencil (sh:.Int:.Int) a (row1, row2, row3, row4, row5) where+ type StencilRepr (sh:.Int:.Int) (row1, row2, row3, row4, row5) + = (StencilRepr (sh:.Int) row1, StencilRepr (sh:.Int) row2, StencilRepr (sh:.Int) row3,+ StencilRepr (sh:.Int) row4, StencilRepr (sh:.Int) row5)+ stencilPrj _ a s = (stencilPrj (undefined::(sh:.Int)) a (Prj tix4 s), + stencilPrj (undefined::(sh:.Int)) a (Prj tix3 s), + stencilPrj (undefined::(sh:.Int)) a (Prj tix2 s), + stencilPrj (undefined::(sh:.Int)) a (Prj tix1 s), + stencilPrj (undefined::(sh:.Int)) a (Prj tix0 s))+instance (Stencil (sh:.Int) a row1,+ Stencil (sh:.Int) a row2,+ Stencil (sh:.Int) a row3,+ Stencil (sh:.Int) a row4,+ Stencil (sh:.Int) a row5,+ Stencil (sh:.Int) a row6,+ Stencil (sh:.Int) a row7) + => Stencil (sh:.Int:.Int) a (row1, row2, row3, row4, row5, row6, row7) where+ type StencilRepr (sh:.Int:.Int) (row1, row2, row3, row4, row5, row6, row7) + = (StencilRepr (sh:.Int) row1, StencilRepr (sh:.Int) row2, StencilRepr (sh:.Int) row3,+ StencilRepr (sh:.Int) row4, StencilRepr (sh:.Int) row5, StencilRepr (sh:.Int) row6,+ StencilRepr (sh:.Int) row7)+ stencilPrj _ a s = (stencilPrj (undefined::(sh:.Int)) a (Prj tix6 s), + stencilPrj (undefined::(sh:.Int)) a (Prj tix5 s), + stencilPrj (undefined::(sh:.Int)) a (Prj tix4 s), + stencilPrj (undefined::(sh:.Int)) a (Prj tix3 s), + stencilPrj (undefined::(sh:.Int)) a (Prj tix2 s), + stencilPrj (undefined::(sh:.Int)) a (Prj tix1 s), + stencilPrj (undefined::(sh:.Int)) a (Prj tix0 s))+instance (Stencil (sh:.Int) a row1,+ Stencil (sh:.Int) a row2,+ Stencil (sh:.Int) a row3,+ Stencil (sh:.Int) a row4,+ Stencil (sh:.Int) a row5,+ Stencil (sh:.Int) a row6,+ Stencil (sh:.Int) a row7,+ Stencil (sh:.Int) a row8,+ Stencil (sh:.Int) a row9) + => Stencil (sh:.Int:.Int) a (row1, row2, row3, row4, row5, row6, row7, row8, row9) where+ type StencilRepr (sh:.Int:.Int) (row1, row2, row3, row4, row5, row6, row7, row8, row9) + = (StencilRepr (sh:.Int) row1, StencilRepr (sh:.Int) row2, StencilRepr (sh:.Int) row3,+ StencilRepr (sh:.Int) row4, StencilRepr (sh:.Int) row5, StencilRepr (sh:.Int) row6,+ StencilRepr (sh:.Int) row7, StencilRepr (sh:.Int) row8, StencilRepr (sh:.Int) row9)+ stencilPrj _ a s = (stencilPrj (undefined::(sh:.Int)) a (Prj tix8 s), + stencilPrj (undefined::(sh:.Int)) a (Prj tix7 s), + stencilPrj (undefined::(sh:.Int)) a (Prj tix6 s), + stencilPrj (undefined::(sh:.Int)) a (Prj tix5 s), + stencilPrj (undefined::(sh:.Int)) a (Prj tix4 s), + stencilPrj (undefined::(sh:.Int)) a (Prj tix3 s), + stencilPrj (undefined::(sh:.Int)) a (Prj tix2 s), + stencilPrj (undefined::(sh:.Int)) a (Prj tix1 s), + stencilPrj (undefined::(sh:.Int)) a (Prj tix0 s))+ +-- Auxiliary tuple index constants+--+tix0 :: Elt s => TupleIdx (t, s) s+tix0 = ZeroTupIdx+tix1 :: Elt s => TupleIdx ((t, s), s1) s+tix1 = SuccTupIdx tix0+tix2 :: Elt s => TupleIdx (((t, s), s1), s2) s+tix2 = SuccTupIdx tix1+tix3 :: Elt s => TupleIdx ((((t, s), s1), s2), s3) s+tix3 = SuccTupIdx tix2+tix4 :: Elt s => TupleIdx (((((t, s), s1), s2), s3), s4) s+tix4 = SuccTupIdx tix3+tix5 :: Elt s => TupleIdx ((((((t, s), s1), s2), s3), s4), s5) s+tix5 = SuccTupIdx tix4+tix6 :: Elt s => TupleIdx (((((((t, s), s1), s2), s3), s4), s5), s6) s+tix6 = SuccTupIdx tix5+tix7 :: Elt s => TupleIdx ((((((((t, s), s1), s2), s3), s4), s5), s6), s7) s+tix7 = SuccTupIdx tix6+tix8 :: Elt s => TupleIdx (((((((((t, s), s1), s2), s3), s4), s5), s6), s7), s8) s+tix8 = SuccTupIdx tix7++-- 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 = Const++-- Smart constructor and destructors for tuples+--++tup2 :: (Elt a, Elt b) => (Exp a, Exp b) -> Exp (a, b)+tup2 (x1, x2) = Tuple (NilTup `SnocTup` x1 `SnocTup` x2)++tup3 :: (Elt a, Elt b, Elt c) => (Exp a, Exp b, Exp c) -> Exp (a, b, c)+tup3 (x1, x2, x3) = Tuple (NilTup `SnocTup` x1 `SnocTup` x2 `SnocTup` x3)++tup4 :: (Elt a, Elt b, Elt c, Elt d) + => (Exp a, Exp b, Exp c, Exp d) -> Exp (a, b, c, d)+tup4 (x1, x2, x3, x4) + = Tuple (NilTup `SnocTup` x1 `SnocTup` x2 `SnocTup` x3 `SnocTup` x4)++tup5 :: (Elt a, Elt b, Elt c, Elt d, Elt e) + => (Exp a, Exp b, Exp c, Exp d, Exp e) -> Exp (a, b, c, d, e)+tup5 (x1, x2, x3, x4, x5)+ = Tuple $+ NilTup `SnocTup` x1 `SnocTup` x2 `SnocTup` x3 `SnocTup` x4 `SnocTup` x5++tup6 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f)+ => (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f) -> Exp (a, b, c, d, e, f)+tup6 (x1, x2, x3, x4, x5, x6)+ = Tuple $+ NilTup `SnocTup` x1 `SnocTup` x2 `SnocTup` x3 `SnocTup` x4 `SnocTup` x5 `SnocTup` x6++tup7 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g)+ => (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g)+ -> Exp (a, b, c, d, e, f, g)+tup7 (x1, x2, x3, x4, x5, x6, x7)+ = Tuple $+ NilTup `SnocTup` x1 `SnocTup` x2 `SnocTup` x3+ `SnocTup` x4 `SnocTup` x5 `SnocTup` x6 `SnocTup` x7++tup8 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h)+ => (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h)+ -> Exp (a, b, c, d, e, f, g, h)+tup8 (x1, x2, x3, x4, x5, x6, x7, x8)+ = Tuple $+ NilTup `SnocTup` x1 `SnocTup` x2 `SnocTup` x3 `SnocTup` x4+ `SnocTup` x5 `SnocTup` x6 `SnocTup` x7 `SnocTup` x8++tup9 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i)+ => (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i)+ -> Exp (a, b, c, d, e, f, g, h, i)+tup9 (x1, x2, x3, x4, x5, x6, x7, x8, x9)+ = Tuple $+ NilTup `SnocTup` x1 `SnocTup` x2 `SnocTup` x3 `SnocTup` x4+ `SnocTup` x5 `SnocTup` x6 `SnocTup` x7 `SnocTup` x8 `SnocTup` x9++untup2 :: (Elt a, Elt b) => Exp (a, b) -> (Exp a, Exp b)+untup2 e = (SuccTupIdx ZeroTupIdx `Prj` e, ZeroTupIdx `Prj` e)++untup3 :: (Elt a, Elt b, Elt c) => Exp (a, b, c) -> (Exp a, Exp b, Exp c)+untup3 e = (SuccTupIdx (SuccTupIdx ZeroTupIdx) `Prj` e, + SuccTupIdx ZeroTupIdx `Prj` e, + ZeroTupIdx `Prj` e)++untup4 :: (Elt a, Elt b, Elt c, Elt d) + => Exp (a, b, c, d) -> (Exp a, Exp b, Exp c, Exp d)+untup4 e = (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)) `Prj` e, + SuccTupIdx (SuccTupIdx ZeroTupIdx) `Prj` e, + SuccTupIdx ZeroTupIdx `Prj` e, + ZeroTupIdx `Prj` e)++untup5 :: (Elt a, Elt b, Elt c, Elt d, Elt e) + => Exp (a, b, c, d, e) -> (Exp a, Exp b, Exp c, Exp d, Exp e)+untup5 e = (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))) + `Prj` e, + SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)) `Prj` e, + SuccTupIdx (SuccTupIdx ZeroTupIdx) `Prj` e, + SuccTupIdx ZeroTupIdx `Prj` e, + ZeroTupIdx `Prj` e)++untup6 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f)+ => Exp (a, b, c, d, e, f) -> (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f)+untup6 e = (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))) `Prj` e,+ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))) `Prj` e,+ SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)) `Prj` e,+ SuccTupIdx (SuccTupIdx ZeroTupIdx) `Prj` e,+ SuccTupIdx ZeroTupIdx `Prj` e,+ ZeroTupIdx `Prj` e)++untup7 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g)+ => Exp (a, b, c, d, e, f, g) -> (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g)+untup7 e = (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))))) `Prj` e,+ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))) `Prj` e,+ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))) `Prj` e,+ SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)) `Prj` e,+ SuccTupIdx (SuccTupIdx ZeroTupIdx) `Prj` e,+ SuccTupIdx ZeroTupIdx `Prj` e,+ ZeroTupIdx `Prj` e)++untup8 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h)+ => Exp (a, b, c, d, e, f, g, h) -> (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h)+untup8 e = (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))))) `Prj` e,+ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))))) `Prj` e,+ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))) `Prj` e,+ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))) `Prj` e,+ SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)) `Prj` e,+ SuccTupIdx (SuccTupIdx ZeroTupIdx) `Prj` e,+ SuccTupIdx ZeroTupIdx `Prj` e,+ ZeroTupIdx `Prj` e)++untup9 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i)+ => Exp (a, b, c, d, e, f, g, h, i) -> (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i)+untup9 e = (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))))))) `Prj` e,+ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))))) `Prj` e,+ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))))) `Prj` e,+ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)))) `Prj` e,+ SuccTupIdx (SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx))) `Prj` e,+ SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)) `Prj` e,+ SuccTupIdx (SuccTupIdx ZeroTupIdx) `Prj` e,+ SuccTupIdx ZeroTupIdx `Prj` e,+ ZeroTupIdx `Prj` e)++-- Smart constructor for constants+-- ++mkMinBound :: (Elt t, IsBounded t) => Exp t+mkMinBound = PrimConst (PrimMinBound boundedType)++mkMaxBound :: (Elt t, IsBounded t) => Exp t+mkMaxBound = PrimConst (PrimMaxBound boundedType)++mkPi :: (Elt r, IsFloating r) => Exp r+mkPi = PrimConst (PrimPi floatingType)+++-- Smart constructors for primitive applications+--++-- Operators from Floating++mkSin :: (Elt t, IsFloating t) => Exp t -> Exp t+mkSin x = PrimSin floatingType `PrimApp` x++mkCos :: (Elt t, IsFloating t) => Exp t -> Exp t+mkCos x = PrimCos floatingType `PrimApp` x++mkTan :: (Elt t, IsFloating t) => Exp t -> Exp t+mkTan x = PrimTan floatingType `PrimApp` x++mkAsin :: (Elt t, IsFloating t) => Exp t -> Exp t+mkAsin x = PrimAsin floatingType `PrimApp` x++mkAcos :: (Elt t, IsFloating t) => Exp t -> Exp t+mkAcos x = PrimAcos floatingType `PrimApp` x++mkAtan :: (Elt t, IsFloating t) => Exp t -> Exp t+mkAtan x = PrimAtan floatingType `PrimApp` x++mkAsinh :: (Elt t, IsFloating t) => Exp t -> Exp t+mkAsinh x = PrimAsinh floatingType `PrimApp` x++mkAcosh :: (Elt t, IsFloating t) => Exp t -> Exp t+mkAcosh x = PrimAcosh floatingType `PrimApp` x++mkAtanh :: (Elt t, IsFloating t) => Exp t -> Exp t+mkAtanh x = PrimAtanh floatingType `PrimApp` x++mkExpFloating :: (Elt t, IsFloating t) => Exp t -> Exp t+mkExpFloating x = PrimExpFloating floatingType `PrimApp` x++mkSqrt :: (Elt t, IsFloating t) => Exp t -> Exp t+mkSqrt x = PrimSqrt floatingType `PrimApp` x++mkLog :: (Elt t, IsFloating t) => Exp t -> Exp t+mkLog x = PrimLog floatingType `PrimApp` x++mkFPow :: (Elt t, IsFloating t) => Exp t -> Exp t -> Exp t+mkFPow x y = PrimFPow floatingType `PrimApp` tup2 (x, y)++mkLogBase :: (Elt t, IsFloating t) => Exp t -> Exp t -> Exp t+mkLogBase x y = PrimLogBase floatingType `PrimApp` tup2 (x, y)++-- Operators from Num++mkAdd :: (Elt t, IsNum t) => Exp t -> Exp t -> Exp t+mkAdd x y = PrimAdd numType `PrimApp` tup2 (x, y)++mkSub :: (Elt t, IsNum t) => Exp t -> Exp t -> Exp t+mkSub x y = PrimSub numType `PrimApp` tup2 (x, y)++mkMul :: (Elt t, IsNum t) => Exp t -> Exp t -> Exp t+mkMul x y = PrimMul numType `PrimApp` tup2 (x, y)++mkNeg :: (Elt t, IsNum t) => Exp t -> Exp t+mkNeg x = PrimNeg numType `PrimApp` x++mkAbs :: (Elt t, IsNum t) => Exp t -> Exp t+mkAbs x = PrimAbs numType `PrimApp` x++mkSig :: (Elt t, IsNum t) => Exp t -> Exp t+mkSig x = PrimSig numType `PrimApp` x++-- Operators from Integral & Bits++mkQuot :: (Elt t, IsIntegral t) => Exp t -> Exp t -> Exp t+mkQuot x y = PrimQuot integralType `PrimApp` tup2 (x, y)++mkRem :: (Elt t, IsIntegral t) => Exp t -> Exp t -> Exp t+mkRem x y = PrimRem integralType `PrimApp` tup2 (x, y)++mkIDiv :: (Elt t, IsIntegral t) => Exp t -> Exp t -> Exp t+mkIDiv x y = PrimIDiv integralType `PrimApp` tup2 (x, y)++mkMod :: (Elt t, IsIntegral t) => Exp t -> Exp t -> Exp t+mkMod x y = PrimMod integralType `PrimApp` tup2 (x, y)++mkBAnd :: (Elt t, IsIntegral t) => Exp t -> Exp t -> Exp t+mkBAnd x y = PrimBAnd integralType `PrimApp` tup2 (x, y)++mkBOr :: (Elt t, IsIntegral t) => Exp t -> Exp t -> Exp t+mkBOr x y = PrimBOr integralType `PrimApp` tup2 (x, y)++mkBXor :: (Elt t, IsIntegral t) => Exp t -> Exp t -> Exp t+mkBXor x y = PrimBXor integralType `PrimApp` tup2 (x, y)++mkBNot :: (Elt t, IsIntegral t) => Exp t -> Exp t+mkBNot x = PrimBNot integralType `PrimApp` x++mkBShiftL :: (Elt t, IsIntegral t) => Exp t -> Exp Int -> Exp t+mkBShiftL x i = PrimBShiftL integralType `PrimApp` tup2 (x, i)++mkBShiftR :: (Elt t, IsIntegral t) => Exp t -> Exp Int -> Exp t+mkBShiftR x i = PrimBShiftR integralType `PrimApp` tup2 (x, i)++mkBRotateL :: (Elt t, IsIntegral t) => Exp t -> Exp Int -> Exp t+mkBRotateL x i = PrimBRotateL integralType `PrimApp` tup2 (x, i)++mkBRotateR :: (Elt t, IsIntegral t) => Exp t -> Exp Int -> Exp t+mkBRotateR x i = PrimBRotateR integralType `PrimApp` tup2 (x, i)++-- Operators from Fractional++mkFDiv :: (Elt t, IsFloating t) => Exp t -> Exp t -> Exp t+mkFDiv x y = PrimFDiv floatingType `PrimApp` tup2 (x, y)++mkRecip :: (Elt t, IsFloating t) => Exp t -> Exp t+mkRecip x = PrimRecip floatingType `PrimApp` x++-- Operators from RealFrac++mkTruncate :: (Elt a, Elt b, IsFloating a, IsIntegral b) => Exp a -> Exp b+mkTruncate x = PrimTruncate floatingType integralType `PrimApp` x++mkRound :: (Elt a, Elt b, IsFloating a, IsIntegral b) => Exp a -> Exp b+mkRound x = PrimRound floatingType integralType `PrimApp` x++mkFloor :: (Elt a, Elt b, IsFloating a, IsIntegral b) => Exp a -> Exp b+mkFloor x = PrimFloor floatingType integralType `PrimApp` x++mkCeiling :: (Elt a, Elt b, IsFloating a, IsIntegral b) => Exp a -> Exp b+mkCeiling x = PrimCeiling floatingType integralType `PrimApp` x++-- Operators from RealFloat++mkAtan2 :: (Elt t, IsFloating t) => Exp t -> Exp t -> Exp t+mkAtan2 x y = PrimAtan2 floatingType `PrimApp` tup2 (x, y)++-- FIXME: add missing operations from Floating, RealFrac & RealFloat++-- Relational and equality operators++mkLt :: (Elt t, IsScalar t) => Exp t -> Exp t -> Exp Bool+mkLt x y = PrimLt scalarType `PrimApp` tup2 (x, y)++mkGt :: (Elt t, IsScalar t) => Exp t -> Exp t -> Exp Bool+mkGt x y = PrimGt scalarType `PrimApp` tup2 (x, y)++mkLtEq :: (Elt t, IsScalar t) => Exp t -> Exp t -> Exp Bool+mkLtEq x y = PrimLtEq scalarType `PrimApp` tup2 (x, y)++mkGtEq :: (Elt t, IsScalar t) => Exp t -> Exp t -> Exp Bool+mkGtEq x y = PrimGtEq scalarType `PrimApp` tup2 (x, y)++mkEq :: (Elt t, IsScalar t) => Exp t -> Exp t -> Exp Bool+mkEq x y = PrimEq scalarType `PrimApp` tup2 (x, y)++mkNEq :: (Elt t, IsScalar t) => Exp t -> Exp t -> Exp Bool+mkNEq x y = PrimNEq scalarType `PrimApp` tup2 (x, y)++mkMax :: (Elt t, IsScalar t) => Exp t -> Exp t -> Exp t+mkMax x y = PrimMax scalarType `PrimApp` tup2 (x, y)++mkMin :: (Elt t, IsScalar t) => Exp t -> Exp t -> Exp t+mkMin x y = PrimMin scalarType `PrimApp` tup2 (x, y)++-- Logical operators++mkLAnd :: Exp Bool -> Exp Bool -> Exp Bool+mkLAnd x y = PrimLAnd `PrimApp` tup2 (x, y)++mkLOr :: Exp Bool -> Exp Bool -> Exp Bool+mkLOr x y = PrimLOr `PrimApp` tup2 (x, y)++mkLNot :: Exp Bool -> Exp Bool+mkLNot x = PrimLNot `PrimApp` x++-- FIXME: Character conversions++-- FIXME: Numeric conversions++mkFromIntegral :: (Elt a, Elt b, IsIntegral a, IsNum b) => Exp a -> Exp b+mkFromIntegral x = PrimFromIntegral integralType numType `PrimApp` x++-- FIXME: Other conversions++mkBoolToInt :: Exp Bool -> Exp Int+mkBoolToInt b = PrimBoolToInt `PrimApp` b+++-- Auxiliary functions+-- --------------------++infixr 0 $$+($$) :: (b -> a) -> (c -> d -> b) -> c -> d -> a+(f $$ g) x y = f (g x y)++infixr 0 $$$+($$$) :: (b -> a) -> (c -> d -> e -> b) -> c -> d -> e -> a+(f $$$ g) x y z = f (g x y z)++infixr 0 $$$$+($$$$) :: (b -> a) -> (c -> d -> e -> f -> b) -> c -> d -> e -> f -> a+(f $$$$ g) x y z u = f (g x y z u)++infixr 0 $$$$$+($$$$$) :: (b -> a) -> (c -> d -> e -> f -> g -> b) -> c -> d -> e -> f -> g-> a+(f $$$$$ g) x y z u v = f (g x y z u v)
− Data/Array/Accelerate/Test.hs
@@ -1,18 +0,0 @@--- |--- Module : Data.Array.Accelerate.Test--- Copyright : [2008..2010] 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.Test- (- module Data.Array.Accelerate.Test.QuickCheck- )- where--import Data.Array.Accelerate.Test.QuickCheck-
− Data/Array/Accelerate/Test/QuickCheck.hs
@@ -1,18 +0,0 @@--- |--- Module : Data.Array.Accelerate.Test.QuickCheck--- Copyright : [2008..2010] 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.Test.QuickCheck- (- module Data.Array.Accelerate.Test.QuickCheck.Arbitrary- )- where--import Data.Array.Accelerate.Test.QuickCheck.Arbitrary-
− Data/Array/Accelerate/Test/QuickCheck/Arbitrary.hs
@@ -1,236 +0,0 @@-{-# LANGUAGE NoMonomorphismRestriction, ScopedTypeVariables #-}-{-# LANGUAGE FlexibleContexts, FlexibleInstances, TypeSynonymInstances #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--- |--- Module : Data.Array.Accelerate.Test.QuickCheck.Arbitrary--- Copyright : [2008..2010] 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.Test.QuickCheck.Arbitrary- (- -- Instances of Arbitrary- arbitraryIntegralExp, arbitraryIntegralVector,- arbitraryFloatingExp, arbitraryFloatingVector- )- where--import Data.Array.Accelerate-import Data.Array.Accelerate.Smart--import Control.Applicative hiding (Const)-import Control.Monad-import Data.List-import Foreign.Storable-import Test.QuickCheck----- Primitive Types--- ----------------instance Arbitrary Int8 where arbitrary = arbitrarySizedIntegral-instance Arbitrary Int16 where arbitrary = arbitrarySizedIntegral-instance Arbitrary Int32 where arbitrary = arbitrarySizedIntegral-instance Arbitrary Int64 where arbitrary = arbitrarySizedIntegral--instance Arbitrary Word where arbitrary = arbitrarySizedIntegral-instance Arbitrary Word8 where arbitrary = arbitrarySizedIntegral-instance Arbitrary Word16 where arbitrary = arbitrarySizedIntegral-instance Arbitrary Word32 where arbitrary = arbitrarySizedIntegral-instance Arbitrary Word64 where arbitrary = arbitrarySizedIntegral----- Arrays--- -------instance (Elem e, Arbitrary e) => Arbitrary (Array DIM0 e) where- arbitrary = fromList () <$> vector 1--instance (Elem e, Arbitrary e) => Arbitrary (Array DIM1 e) where- arbitrary = do- n <- suchThat arbitrary (>= 0)- fromList n <$> vector n--instance (Elem e, Arbitrary e) => Arbitrary (Array DIM2 e) where- arbitrary = do- (n, [a,b]) <- clamp <$> vectorOf 2 (suchThat arbitrary (> 0))- fromList (a,b) <$> vector n--instance (Elem e, Arbitrary e) => Arbitrary (Array DIM3 e) where- arbitrary = do- (n, [a,b,c]) <- clamp <$> vectorOf 3 (suchThat arbitrary (> 0))- fromList (a,b,c) <$> vector n--instance (Elem e, Arbitrary e) => Arbitrary (Array DIM4 e) where- arbitrary = do- (n, [a,b,c,d]) <- clamp <$> vectorOf 4 (suchThat arbitrary (> 0))- fromList (a,b,c,d) <$> vector n--instance (Elem e, Arbitrary e) => Arbitrary (Array DIM5 e) where- arbitrary = do- (n, [a,b,c,d,e]) <- clamp <$> vectorOf 5 (suchThat arbitrary (> 0))- fromList (a,b,c,d,e) <$> vector n---- make sure not to create an index too large that we get integer overflow when--- converting it to linear form----clamp :: [Int] -> (Int, [Int])-clamp = mapAccumL k 1- where k a x = let n = Prelude.max 1 (x `mod` (maxBound `div` a))- in (n*a, n)----- Expressions--- ------------instance Arbitrary (Acc (Vector Int)) where arbitrary = sized arbitraryIntegralVector-instance Arbitrary (Acc (Vector Int8)) where arbitrary = sized arbitraryIntegralVector-instance Arbitrary (Acc (Vector Int16)) where arbitrary = sized arbitraryIntegralVector-instance Arbitrary (Acc (Vector Int32)) where arbitrary = sized arbitraryIntegralVector-instance Arbitrary (Acc (Vector Int64)) where arbitrary = sized arbitraryIntegralVector--instance Arbitrary (Acc (Vector Word)) where arbitrary = sized arbitraryIntegralVector-instance Arbitrary (Acc (Vector Word8)) where arbitrary = sized arbitraryIntegralVector-instance Arbitrary (Acc (Vector Word16)) where arbitrary = sized arbitraryIntegralVector-instance Arbitrary (Acc (Vector Word32)) where arbitrary = sized arbitraryIntegralVector-instance Arbitrary (Acc (Vector Word64)) where arbitrary = sized arbitraryIntegralVector--instance Arbitrary (Acc (Vector Float)) where arbitrary = sized arbitraryFloatingVector-instance Arbitrary (Acc (Vector Double)) where arbitrary = sized arbitraryFloatingVector----- ugly ugly duplication...-----arbitraryIntegralExp :: (IsIntegral e, Elem e, Arbitrary e) => Int -> Gen (Exp e)-arbitraryIntegralExp 0 = liftM Const arbitrary-arbitraryIntegralExp n =- let m = n `div` 4- in oneof [ do vec <- arbitraryIntegralVector m- idx <- abs <$> arbitrary- let idx' = shape vec ==* 0 ? (0, constant idx `mod` shape vec)- return (IndexScalar vec idx')- , liftM (!constant ()) (Fold <$> associative <*> arbitraryIntegralExp m <*> arbitraryIntegralVector m)- ]--arbitraryIntegralVector :: (IsNum e, IsIntegral e, Elem e, Arbitrary e) => Int -> Gen (Acc (Vector e))-arbitraryIntegralVector 0 = Use <$> arbitrary-arbitraryIntegralVector n =- let m = n `div` 4- in oneof [ Map <$> unaryIntegral <*> arbitraryIntegralVector m- , ZipWith <$> binaryIntegral <*> arbitraryIntegralVector m <*> arbitraryIntegralVector m- , liftM FstArray (Scanl <$> associative <*> arbitraryIntegralExp m <*> arbitraryIntegralVector m)- , liftM FstArray (Scanr <$> associative <*> arbitraryIntegralExp m <*> arbitraryIntegralVector m)- ]---arbitraryFloatingExp :: (IsFloating e, Elem e, Arbitrary e) => Int -> Gen (Exp e)-arbitraryFloatingExp 0 = liftM Const arbitrary-arbitraryFloatingExp n =- let m = n `div` 4- in oneof [ do vec <- arbitraryFloatingVector m- idx <- abs <$> arbitrary- let idx' = shape vec ==* 0 ? (0, constant idx `mod` shape vec)- return (IndexScalar vec idx')- , liftM (!constant ()) (Fold <$> associative <*> arbitraryFloatingExp m <*> arbitraryFloatingVector m)- ]--arbitraryFloatingVector :: (IsNum e, IsFloating e, Elem e, Arbitrary e) => Int -> Gen (Acc (Vector e))-arbitraryFloatingVector 0 = Use <$> arbitrary-arbitraryFloatingVector n =- let m = n `div` 4- in oneof [ Map <$> unaryFloating <*> arbitraryFloatingVector m- , ZipWith <$> binaryFloating <*> arbitraryFloatingVector m <*> arbitraryFloatingVector m- , liftM FstArray (Scanl <$> associative <*> arbitraryFloatingExp m <*> arbitraryFloatingVector m)- , liftM FstArray (Scanr <$> associative <*> arbitraryFloatingExp m <*> arbitraryFloatingVector m)- ]----- Functions--- -----------wordSize :: Int-wordSize = 8 * sizeOf (undefined :: Int)---unaryNum :: (Elem t, IsNum t, Arbitrary t) => Gen (Exp t -> Exp t)-unaryNum = oneof- [ return mkNeg- , return mkAbs- , return mkSig- ]--binaryNum :: (Elem t, IsNum t) => Gen (Exp t -> Exp t -> Exp t)-binaryNum = oneof- [ return mkAdd- , return mkSub- , return mkMul- ]--unaryIntegral :: (Elem t, IsIntegral t, Arbitrary t) => Gen (Exp t -> Exp t)-unaryIntegral = sized $ \n -> oneof- [ return mkBNot- , flip shift . constant <$> choose (-wordSize,wordSize)- , flip rotate . constant <$> choose (-wordSize,wordSize)- , flip mkBShiftL . constant <$> choose (0,wordSize)- , flip mkBShiftR . constant <$> choose (0,wordSize)- , flip mkBRotateL . constant <$> choose (0,wordSize)- , flip mkBRotateR . constant <$> choose (0,wordSize)- , flip setBit . constant <$> choose (0,wordSize)- , flip clearBit . constant <$> choose (0,wordSize)- , flip complementBit . constant <$> choose (0,wordSize)- , unaryNum- , binaryNum <*> arbitraryIntegralExp (n `div` 2)- , binaryIntegral <*> arbitraryIntegralExp (n `div` 2)- ]--binaryIntegral :: (Elem t, IsIntegral t) => Gen (Exp t -> Exp t -> Exp t)-binaryIntegral = oneof- [ return mkQuot- , return mkRem- , return mkIDiv- , return mkMod- , return mkBAnd- , return mkBOr- , return mkBXor- , return mkMax- , return mkMin- , binaryNum- ]--unaryFloating :: (Elem t, IsFloating t, Arbitrary t) => Gen (Exp t -> Exp t)-unaryFloating = sized $ \n -> oneof- [ return mkSin- , return mkCos- , return mkTan--- , return mkAsin -- can't be sure inputs will be in the valid range--- , return mkAcos- , return mkAtan- , return mkAsinh--- , return mkAcosh--- , return mkAtanh--- , return mkExpFloating--- , return mkSqrt--- , return mkLog- , unaryNum- , binaryFloating `ap` arbitraryFloatingExp (n `div` 2)- ]--binaryFloating :: (Elem t, IsFloating t) => Gen (Exp t -> Exp t -> Exp t)-binaryFloating = oneof- [ return mkFPow- , return mkLogBase- , return mkMax- , return mkMin- , binaryNum- ]--associative :: (Elem t, IsNum t) => Gen (Exp t -> Exp t -> Exp t)-associative = oneof- [ return mkMax- , return mkMin- , return mkAdd- , return mkMul- ]-
Data/Array/Accelerate/Tuple.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE GADTs, TypeFamilies, FlexibleInstances #-}-+-- | -- Module : Data.Array.Accelerate.Tuple--- Copyright : [2009..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee+-- Copyright : [2009..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee -- License : BSD3 -- -- Maintainer : Manuel M T Chakravarty <chak@cse.unsw.edu.au>@@ -12,6 +12,7 @@ -- 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 ( @@ -30,16 +31,16 @@ -- |We represent tuples as heterogenous lists, typed by a type list. -- data Tuple c t where- NilTup :: Tuple c ()- SnocTup :: Elem t => Tuple c s -> c t -> Tuple c (s, t)+ NilTup :: Tuple c ()+ SnocTup :: Elt t => Tuple c s -> c t -> Tuple c (s, t) -- |Type-safe projection indicies for tuples. -- -- NB: We index tuples by starting to count from the *right*! -- data TupleIdx t e where- ZeroTupIdx :: Elem s => TupleIdx (t, s) s- SuccTupIdx :: TupleIdx t e -> TupleIdx (t, s) e+ ZeroTupIdx :: Elt s => TupleIdx (t, s) s+ SuccTupIdx :: TupleIdx t e -> TupleIdx (t, s) e -- |Conversion between surface n-tuples and our tuple representation. --@@ -48,6 +49,11 @@ fromTuple :: tup -> TupleRepr tup toTuple :: TupleRepr tup -> tup +instance IsTuple () where+ type TupleRepr () = ()+ fromTuple = id+ toTuple = id+ instance IsTuple (a, b) where type TupleRepr (a, b) = (((), a), b) fromTuple (x, y) = (((), x), y)
Data/Array/Accelerate/Type.hs view
@@ -1,7 +1,8 @@-{-# LANGUAGE GADTs, TypeFamilies, FlexibleInstances #-}-+{-# LANGUAGE CPP, TypeOperators, GADTs, TypeFamilies, FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- | -- Module : Data.Array.Accelerate.Type--- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee+-- Copyright : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee -- License : BSD3 -- -- Maintainer : Manuel M T Chakravarty <chak@cse.unsw.edu.au>@@ -20,6 +21,7 @@ -- 'Int' has the same bitwidth as in plain Haskell computations, and 'Float' -- and 'Double' represent IEEE single and double precision floating point -- numbers, respectively.+-- module Data.Array.Accelerate.Type ( module Data.Int,@@ -43,11 +45,18 @@ -- Extend Typeable support for 8- and 9-tuple -- ------------------------------------------ +myMkTyCon :: String -> TyCon+#if __GLASGOW_HASKELL__ == 700+myMkTyCon = mkTyCon+#else+myMkTyCon = mkTyCon3 "accelerate" "Data.Array.Accelerate.Type"+#endif+ class Typeable8 t where typeOf8 :: t a b c d e f g h -> TypeRep instance Typeable8 (,,,,,,,) where- typeOf8 _ = mkTyCon "(,,,,,,,)" `mkTyConApp` []+ typeOf8 _ = myMkTyCon "(,,,,,,,)" `mkTyConApp` [] typeOf7Default :: (Typeable8 t, Typeable a) => t a b c d e f g h -> TypeRep typeOf7Default x = typeOf7 x `mkAppTy` typeOf (argType x)@@ -63,7 +72,7 @@ typeOf9 :: t a b c d e f g h i -> TypeRep instance Typeable9 (,,,,,,,,) where- typeOf9 _ = mkTyCon "(,,,,,,,,)" `mkTyConApp` []+ typeOf9 _ = myMkTyCon "(,,,,,,,,)" `mkTyConApp` [] typeOf8Default :: (Typeable9 t, Typeable a) => t a b c d e f g h i -> TypeRep typeOf8Default x = typeOf8 x `mkAppTy` typeOf (argType x)@@ -76,6 +85,7 @@ typeOf8 = typeOf8Default + -- Scalar types -- ------------ @@ -133,7 +143,7 @@ -- |Non-numeric types supported in array computations. -- data NonNumType a where- TypeBool :: NonNumDict Bool -> NonNumType Bool -- marshaled to CInt+ TypeBool :: NonNumDict Bool -> NonNumType Bool -- marshalled to CInt TypeChar :: NonNumDict Char -> NonNumType Char TypeCChar :: NonNumDict CChar -> NonNumType CChar TypeCSChar :: NonNumDict CSChar -> NonNumType CSChar@@ -590,7 +600,7 @@ | Mirror -- ^mirror coordinates beyond the array extent | Wrap -- ^wrap coordinates around on each dimension | Constant a -- ^use a constant value for outlying coordinates - deriving Show+ deriving (Show, Read) {- -- Vector GPU data types@@ -650,3 +660,4 @@ data CDouble4 = CDouble4 CDouble CDouble CDouble CDouble -- in the future, vector types for CHalf -}+
INSTALL view
@@ -1,5 +1,5 @@ Requirements: -- Glasgow Haskell Compiler (GHC), 6.12.1 or later+- Glasgow Haskell Compiler (GHC), 7.0.3 or later - Haskell libraries as specified in 'accelerate.cabal' - For the CUDA backend, CUDA version 3.0 or later @@ -13,12 +13,7 @@ Then, to use the library, pass the flag "-package accelerate" to GHC. -WARNING: This is an early beta release. Most features are implemented - in both the interpreter and CUDA backend. The code has been- lightly tested. The Accelerate API will surely change a few- more times before settling down. You have been warned.- -Please report bugs at http://trac.haskell.org/accelerate+The source repository is at https://github.com/mchakravarty/accelerate The project web page is at http://www.cse.unsw.edu.au/~chak/project/accelerate/ Direct questions at Manuel M T Chakravarty <chak@cse.unsw.edu.au>
accelerate.cabal view
@@ -1,7 +1,7 @@ Name: accelerate-Version: 0.8.1.0+Version: 0.9.0.0 Cabal-version: >= 1.6-Tested-with: GHC >= 6.12.3+Tested-with: GHC >= 7.0.3 Build-type: Simple Synopsis: An embedded language for accelerated array processing@@ -9,7 +9,7 @@ regular, multi-dimensional array computations with multiple backends to facilitate high-performance implementations. Currently, there are two backends:- (1) an interpreter that serves as a reference + (1) an interpreter that serves as a reference implementation of the intended semantics of the language and (2) a CUDA backend generating code for CUDA-capable NVIDIA GPUs.@@ -18,24 +18,30 @@ installed. The CUDA backend currently doesn't support 'Char' and 'Bool' arrays. .- Known bugs in this version:- <http://trac.haskell.org/accelerate/query?status=new&status=assigned&status=reopened&status=closed&version=0.8.1.0&order=priority>+ Known bugs: <https://github.com/mchakravarty/accelerate/issues> .+ * New in 0.9.0.0: Streaming, precompilation, Repa-style indices, stencils, + more scans, rank-polymorphic fold, generate, block I/O & many bug fixes+ . * New in 0.8.1.0: bug fixes and some performance tweaks .- * New in 0.8.0.0: 'replicate', 'slice' and 'foldSeg' supported in the + * 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>. License: BSD3 License-file: LICENSE-Author: Manuel M T Chakravarty, - Gabriele Keller, - Sean Lee, +Author: Manuel M T Chakravarty,+ Gabriele Keller,+ Sean Lee,+ Ben Lever Trevor L. McDonell+ Sean Seefried Maintainer: Manuel M T Chakravarty <chak@cse.unsw.edu.au> Homepage: http://www.cse.unsw.edu.au/~chak/project/accelerate/-Bug-reports: http://trac.haskell.org/accelerate+Bug-reports: https://github.com/mchakravarty/accelerate/issues Category: Compilers/Interpreters, Concurrency, Data Stability: Experimental@@ -45,36 +51,33 @@ 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/fold_segmented.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/scan_safe.inl+ cubits/thrust/safe_scan_intervals.inl+ cubits/thrust/inclusive_scan.inl+ cubits/thrust/exclusive_scan.inl Extra-source-files: INSTALL include/accelerate.h- examples/simple/src/DotP.hs- examples/simple/src/Filter.hs- examples/simple/src/Main.hs- examples/simple/Makefile- examples/simple/src/Random.hs- examples/simple/src/SAXPY.hs- examples/simple/src/SMVM.hs- examples/simple/src/Stencil.hs- examples/simple/src/Square.hs- examples/simple/src/Sum.hs- examples/rasterize/RasterizeAcc.hs- examples/rasterize/rasterize-test1.txt- examples/rasterize/rasterize-test2.txt- examples/rasterize/rasterize-test3.txt- examples/rasterize/rasterize-test4.txt- examples/rasterize/rasterize.hs+ utils/README+ utils/Paths_accelerate.hs+ utils/dot_ghci Flag llvm Description: Enable the LLVM backend (sequential)@@ -84,6 +87,10 @@ 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@@ -104,80 +111,114 @@ 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- Build-depends: array, - base == 4.*, - ghc-prim, - haskell98,- pretty+ 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(llvm)+ Build-depends: llvm >= 0.6.8 if flag(cuda)- Build-depends: binary,- bytestring,- containers,- cuda >= 0.2.2 && < 0.3,- directory,- fclabels >= 0.9 && < 1.0,- filepath,- language-c >= 0.3 && < 0.4,- monads-fd,- transformers >= 0.2 && < 0.3,- unix+ 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(test-suite)- Build-depends: QuickCheck == 2.*+ if flag(io)+ Build-depends: bytestring == 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.Analysis.Shape+ Data.Array.Accelerate.Analysis.Type+ Data.Array.Accelerate.Array.Sugar+ Data.Array.Accelerate.Array.Representation+ 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)+ if flag(cuda) Exposed-modules: Data.Array.Accelerate.CUDA - If flag(test-suite)- Exposed-modules: Data.Array.Accelerate.Test- Other-modules: Data.Array.Accelerate.Test.QuickCheck- Data.Array.Accelerate.Test.QuickCheck.Arbitrary+ 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 +-- 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.Data Data.Array.Accelerate.Array.Delayed- Data.Array.Accelerate.Array.Representation- Data.Array.Accelerate.Array.Sugar- Data.Array.Accelerate.Analysis.Type- Data.Array.Accelerate.Analysis.Shape- Data.Array.Accelerate.AST+ Data.Array.Accelerate.Analysis.Stencil Data.Array.Accelerate.Debug Data.Array.Accelerate.Language- Data.Array.Accelerate.Pretty- Data.Array.Accelerate.Smart- Data.Array.Accelerate.Tuple- Data.Array.Accelerate.Type+ 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)+ 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.Array.Device 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.Smart Data.Array.Accelerate.CUDA.State if flag(pcache)@@ -192,12 +233,18 @@ if flag(internal-checks) cpp-options: -DACCELERATE_INTERNAL_CHECKS - Ghc-options: -O2 -Wall -fno-warn-orphans -fno-warn-name-shadowing- Extensions: FlexibleContexts, FlexibleInstances, TypeSynonymInstances,- ExistentialQuantification, GADTs, TypeFamilies, MultiParamTypeClasses,- ScopedTypeVariables, DeriveDataTypeable,- BangPatterns, PatternGuards, TypeOperators, RankNTypes+ ghc-options: -O2 -Wall -funbox-strict-fields -fno-warn-name-shadowing -source-repository head- type: darcs- location: http://code.haskell.org/accelerate+ if impl(ghc >= 7.0)+ ghc-options: -fspec-constr-count=25++ Extensions: BangPatterns, CPP, DeriveDataTypeable, EmptyDataDecls,+ FlexibleContexts, FlexibleInstances, GADTs, MagicHash,+ MultiParamTypeClasses, PatternGuards, RankNTypes,+ ScopedTypeVariables, StandaloneDeriving,+ TemplateHaskell, TupleSections, TypeFamilies,+ TypeOperators, TypeSynonymInstances, UnboxedTuples++Source-repository head+ Type: git+ Location: git://github.com/mchakravarty/accelerate.git
cubits/accelerate_cuda_extras.h view
@@ -1,7 +1,7 @@ /* ----------------------------------------------------------------------------- * * Module : Extras- * Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell+ * 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>@@ -14,6 +14,7 @@ #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"
cubits/accelerate_cuda_function.h view
@@ -1,7 +1,7 @@ /* ----------------------------------------------------------------------------- * * Module : Function- * Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell+ * 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>@@ -58,6 +58,7 @@ } +#if 0 /* ----------------------------------------------------------------------------- * Additional helper functions * -------------------------------------------------------------------------- */@@ -123,6 +124,7 @@ { return multiple(x, f) * f; }+#endif #endif // __cplusplus #endif // __ACCELERATE_CUDA_FUNCTION_H__
cubits/accelerate_cuda_shape.h view
@@ -1,7 +1,7 @@ /* ----------------------------------------------------------------------------- * * Module : Shape- * Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell+ * 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>@@ -16,7 +16,7 @@ #include <cuda_runtime.h> typedef int32_t Ix;-typedef Ix DIM0;+typedef void* DIM0; typedef Ix DIM1; typedef struct { Ix a1,a0; } DIM2; typedef struct { Ix a2,a1,a0; } DIM3;@@ -29,275 +29,299 @@ #ifdef __cplusplus -/*- * Number of dimensions of a shape+/* -----------------------------------------------------------------------------+ * Shape construction and destruction */-static __inline__ __device__ int dim(DIM1 sh) { return 1; }-static __inline__ __device__ int dim(DIM2 sh) { return 2; }-static __inline__ __device__ int dim(DIM3 sh) { return 3; }-static __inline__ __device__ int dim(DIM4 sh) { return 4; }-static __inline__ __device__ int dim(DIM5 sh) { return 5; }-static __inline__ __device__ int dim(DIM6 sh) { return 6; }-static __inline__ __device__ int dim(DIM7 sh) { return 7; }-static __inline__ __device__ int dim(DIM8 sh) { return 8; }-static __inline__ __device__ int dim(DIM9 sh) { return 9; } /*- * Yield the total number of elements in a shape- */-static __inline__ __device__ int size(DIM1 sh) { return sh; }-static __inline__ __device__ int size(DIM2 sh) { return sh.a0 * sh.a1; }-static __inline__ __device__ int size(DIM3 sh) { return sh.a0 * sh.a1 * sh.a2; }-static __inline__ __device__ int size(DIM4 sh) { return sh.a0 * sh.a1 * sh.a2 * sh.a3; }-static __inline__ __device__ int size(DIM5 sh) { return sh.a0 * sh.a1 * sh.a2 * sh.a3 * sh.a4; }-static __inline__ __device__ int size(DIM6 sh) { return sh.a0 * sh.a1 * sh.a2 * sh.a3 * sh.a4 * sh.a5; }-static __inline__ __device__ int size(DIM7 sh) { return sh.a0 * sh.a1 * sh.a2 * sh.a3 * sh.a4 * sh.a5 * sh.a6; }-static __inline__ __device__ int size(DIM8 sh) { return sh.a0 * sh.a1 * sh.a2 * sh.a3 * sh.a4 * sh.a5 * sh.a6 * sh.a7; }-static __inline__ __device__ int size(DIM9 sh) { return sh.a0 * sh.a1 * sh.a2 * sh.a3 * sh.a4 * sh.a5 * sh.a6 * sh.a7 * sh.a8; }--/* * Convert the individual dimensions of a linear array into a shape */-static __inline__ __device__ DIM1 shape(Ix a)+static __inline__ __device__ DIM0 shape() {+ return NULL;+}++static __inline__ __device__ DIM1 shape(const Ix a)+{ return a; } -static __inline__ __device__ DIM2 shape(Ix b, Ix a)+static __inline__ __device__ DIM2 shape(const Ix b, const Ix a) { DIM2 sh = { b, a }; return sh; } -static __inline__ __device__ DIM3 shape(Ix c, Ix b, Ix a)+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(Ix d, Ix c, Ix b, Ix a)+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(Ix e, Ix d, Ix c, Ix b, Ix a)+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(Ix f, Ix e, Ix d, Ix c, Ix b, Ix a)+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(Ix g, Ix f, Ix e, Ix d, Ix c, Ix b, Ix a)+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(Ix h, Ix g, Ix f, Ix e, Ix d, Ix c, Ix b, Ix a)+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(Ix i, Ix h, Ix g, Ix f, Ix e, Ix d, Ix c, Ix b, Ix a)+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 index position in a linear, row-major representation of the array.- * First argument is the shape of the array, the second the index+ * Yield the inner-most dimension of a shape only */-static __inline__ __device__ Ix toIndex(DIM1 sh, DIM1 ix)+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; } -static __inline__ __device__ Ix toIndex(DIM2 sh, DIM2 ix)++/*+ * Yield all but the inner-most dimension of a shape+ */+static __inline__ __device__ DIM0 indexTail(const DIM1 ix) {- DIM1 sh_ = sh.a0;- DIM1 ix_ = ix.a0;- return toIndex(sh_, ix_) * sh.a1 + ix.a1;+ return 0; } -static __inline__ __device__ Ix toIndex(DIM3 sh, DIM3 ix)+static __inline__ __device__ DIM1 indexTail(const DIM2 ix) {- DIM2 sh_ = { sh.a1, sh.a0 };- DIM2 ix_ = { ix.a1, ix.a0 };- return toIndex(sh_, ix_) * sh.a2 + ix.a2;+ return ix.a1; } -static __inline__ __device__ Ix toIndex(DIM4 sh, DIM4 ix)+static __inline__ __device__ DIM2 indexTail(const DIM3 ix) {- DIM3 sh_ = { sh.a2, sh.a1, sh.a0 };- DIM3 ix_ = { ix.a2, ix.a1, ix.a0 };- return toIndex(sh_, ix_) * sh.a3 + ix.a3;+ return shape(ix.a2, ix.a1); } -static __inline__ __device__ Ix toIndex(DIM5 sh, DIM5 ix)+static __inline__ __device__ DIM3 indexTail(const DIM4 ix) {- DIM4 sh_ = { sh.a3, sh.a2, sh.a1, sh.a0 };- DIM4 ix_ = { ix.a3, ix.a2, ix.a1, ix.a0 };- return toIndex(sh_, ix_) * sh.a4 + ix.a4;+ return shape(ix.a3, ix.a2, ix.a1); } -static __inline__ __device__ Ix toIndex(DIM6 sh, DIM6 ix)+static __inline__ __device__ DIM4 indexTail(const DIM5 ix) {- DIM5 sh_ = { sh.a4, sh.a3, sh.a2, sh.a1, sh.a0 };- DIM5 ix_ = { ix.a4, ix.a3, ix.a2, ix.a1, ix.a0 };- return toIndex(sh_, ix_) * sh.a5 + ix.a5;+ return shape(ix.a4, ix.a3, ix.a2, ix.a1); } -static __inline__ __device__ Ix toIndex(DIM7 sh, DIM7 ix)+static __inline__ __device__ DIM5 indexTail(const DIM6 ix) {- DIM6 sh_ = { sh.a5, sh.a4, sh.a3, sh.a2, sh.a1, sh.a0 };- DIM6 ix_ = { ix.a5, ix.a4, ix.a3, ix.a2, ix.a1, ix.a0 };- return toIndex(sh_, ix_) * sh.a6 + ix.a6;+ return shape(ix.a5, ix.a4, ix.a3, ix.a2, ix.a1); } -static __inline__ __device__ Ix toIndex(DIM8 sh, DIM8 ix)+static __inline__ __device__ DIM6 indexTail(const DIM7 ix) {- DIM7 sh_ = { sh.a6, sh.a5, sh.a4, sh.a3, sh.a2, sh.a1, sh.a0 };- DIM7 ix_ = { ix.a6, ix.a5, ix.a4, ix.a3, ix.a2, ix.a1, ix.a0 };- return toIndex(sh_, ix_) * sh.a7 + ix.a7;+ return shape(ix.a6, ix.a5, ix.a4, ix.a3, ix.a2, ix.a1); } -static __inline__ __device__ Ix toIndex(DIM9 sh, DIM9 ix)+static __inline__ __device__ DIM7 indexTail(const DIM8 ix) {- DIM8 sh_ = { sh.a7, sh.a6, sh.a5, sh.a4, sh.a3, sh.a2, sh.a1, sh.a0 };- DIM8 ix_ = { ix.a7, ix.a6, ix.a5, ix.a4, ix.a3, ix.a2, ix.a1, ix.a0 };- return toIndex(sh_, ix_) * sh.a8 + ix.a8;+ 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+ */+ /*- * Inverse of 'toIndex'+ * Number of dimensions of a shape */-static __inline__ __device__ DIM1 fromIndex(DIM1 sh, Ix ix)+template <typename Shape>+static __inline__ __device__ int dim(const Shape sh) {- return ix;+ return dim(indexTail(sh)) + 1; } -static __inline__ __device__ DIM2 fromIndex(DIM2 sh, Ix ix)+template <>+static __inline__ __device__ int dim(const DIM0 sh) {- DIM1 sh_ = shape(sh.a0);- DIM1 ix_ = fromIndex(sh_, ix / sh.a1);- return shape(ix % sh.a1, ix_);+ return 0; } -static __inline__ __device__ DIM3 fromIndex(DIM3 sh, Ix ix)++/*+ * Yield the total number of elements in a shape+ */+template <typename Shape>+static __inline__ __device__ int size(const Shape sh) {- DIM2 sh_ = shape(sh.a1, sh.a0);- DIM2 ix_ = fromIndex(sh_, ix / sh.a2);- return shape(ix % sh.a2, ix_.a1, ix_.a0);+ return size(indexTail(sh)) * indexHead(sh); } -static __inline__ __device__ DIM4 fromIndex(DIM4 sh, Ix ix)+template <>+static __inline__ __device__ int size(const DIM0 sh) {- DIM3 sh_ = shape(sh.a2, sh.a1, sh.a0);- DIM3 ix_ = fromIndex(sh_, ix / sh.a3);- return shape(ix % sh.a3, ix_.a2, ix_.a1, ix_.a0);+ return 1; } -static __inline__ __device__ DIM5 fromIndex(DIM5 sh, Ix ix)++/*+ * Add an index to the head of a shape+ */+static __inline__ __device__ DIM1 indexCons(const DIM0 sh, const Ix ix) {- DIM4 sh_ = shape(sh.a3, sh.a2, sh.a1, sh.a0);- DIM4 ix_ = fromIndex(sh_, ix / sh.a4);- return shape(ix % sh.a4, ix_.a3, ix_.a2, ix_.a1, ix_.a0);+ return shape(ix); } -static __inline__ __device__ DIM6 fromIndex(DIM6 sh, Ix ix)+static __inline__ __device__ DIM2 indexCons(const DIM1 sh, const Ix ix) {- DIM5 sh_ = shape(sh.a4, sh.a3, sh.a2, sh.a1, sh.a0);- DIM5 ix_ = fromIndex(sh_, ix / sh.a5);- return shape(ix % sh.a5, ix_.a4, ix_.a3, ix_.a2, ix_.a1, ix_.a0);+ return shape(sh, ix); } -static __inline__ __device__ DIM7 fromIndex(DIM7 sh, Ix ix)+static __inline__ __device__ DIM3 indexCons(const DIM2 sh, const Ix ix) {- DIM6 sh_ = shape(sh.a5, sh.a4, sh.a3, sh.a2, sh.a1, sh.a0);- DIM6 ix_ = fromIndex(sh_, ix / sh.a6);- return shape(ix % sh.a6, ix_.a5, ix_.a4, ix_.a3, ix_.a2, ix_.a1, ix_.a0);+ return shape(sh.a1, sh.a0, ix); } -static __inline__ __device__ DIM8 fromIndex(DIM8 sh, Ix ix)+static __inline__ __device__ DIM4 indexCons(const DIM3 sh, const Ix ix) {- DIM7 sh_ = shape(sh.a6, sh.a5, sh.a4, sh.a3, sh.a2, sh.a1, sh.a0);- DIM7 ix_ = fromIndex(sh_, ix / sh.a7);- return shape(ix % sh.a7, ix_.a6, ix_.a5, ix_.a4, ix_.a3, ix_.a2, ix_.a1, ix_.a0);+ return shape(sh.a2, sh.a1, sh.a0, ix); } -static __inline__ __device__ DIM9 fromIndex(DIM9 sh, Ix ix)+static __inline__ __device__ DIM5 indexCons(const DIM4 sh, const Ix ix) {- DIM8 sh_ = shape(sh.a7, sh.a6, sh.a5, sh.a4, sh.a3, sh.a2, sh.a1, sh.a0);- DIM8 ix_ = fromIndex(sh_, ix / sh.a8);- return shape(ix % sh.a8, ix_.a7, ix_.a6, ix_.a5, ix_.a4, ix_.a3, ix_.a2, ix_.a1, ix_.a0);+ 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);+} -/*- * Test for the magic index `ignore`- */-static __inline__ __device__ int ignore(DIM1 ix)+static __inline__ __device__ DIM7 indexCons(const DIM6 sh, const Ix ix) {- return ix == -1;+ return shape(sh.a5, sh.a4, sh.a3, sh.a2, sh.a1, sh.a0, ix); } -static __inline__ __device__ int ignore(DIM2 ix)+static __inline__ __device__ DIM8 indexCons(const DIM7 sh, const Ix ix) {- return ix.a0 == -1 && ix.a1 == -1;+ return shape(sh.a6, sh.a5, sh.a4, sh.a3, sh.a2, sh.a1, sh.a0, ix); } -static __inline__ __device__ int ignore(DIM3 ix)+static __inline__ __device__ DIM9 indexCons(const DIM8 sh, const Ix ix) {- return ix.a0 == -1 && ix.a1 == -1 && ix.a2 == -1;+ return shape(sh.a7, sh.a6, sh.a5, sh.a4, sh.a3, sh.a2, sh.a1, sh.a0, ix); } -static __inline__ __device__ int ignore(DIM4 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 ix.a0 == -1 && ix.a1 == -1 && ix.a2 == -1 && ix.a3 == -1;+ return toIndex(indexTail(sh), indexTail(ix)) * indexHead(sh) + indexHead(ix); } -static __inline__ __device__ int ignore(DIM5 ix)+template <>+static __inline__ __device__ Ix toIndex(const DIM0 sh, const DIM0 ix) {- return ix.a0 == -1 && ix.a1 == -1 && ix.a2 == -1 && ix.a3 == -1 && ix.a4 == -1;+ return 0; } -static __inline__ __device__ int ignore(DIM6 ix)+template <>+static __inline__ __device__ Ix toIndex(const DIM1 sh, const DIM1 ix) {- return ix.a0 == -1 && ix.a1 == -1 && ix.a2 == -1 && ix.a3 == -1 && ix.a4 == -1 && ix.a5 == -1;+ return ix; } -static __inline__ __device__ int ignore(DIM7 ix)++/*+ * Inverse of 'toIndex'+ */+template <typename Shape>+static __inline__ __device__ Shape fromIndex(const Shape sh, const Ix ix) {- return ix.a0 == -1 && ix.a1 == -1 && ix.a2 == -1 && ix.a3 == -1 && ix.a4 == -1 && ix.a5 == -1 && ix.a6 == -1;+ const Ix d = indexHead(sh);+ return indexCons(fromIndex(indexTail(sh), ix / d), ix % d); } -static __inline__ __device__ int ignore(DIM8 ix)+template <>+static __inline__ __device__ DIM0 fromIndex(const DIM0 sh, const Ix ix) {- return ix.a0 == -1 && ix.a1 == -1 && ix.a2 == -1 && ix.a3 == -1 && ix.a4 == -1 && ix.a5 == -1 && ix.a6 == -1 && ix.a7 == -1;+ return 0; } -static __inline__ __device__ int ignore(DIM9 ix)+template <>+static __inline__ __device__ DIM1 fromIndex(const DIM1 sh, const Ix ix) {- return ix.a0 == -1 && ix.a1 == -1 && ix.a2 == -1 && ix.a3 == -1 && ix.a4 == -1 && ix.a5 == -1 && ix.a6 == -1 && ix.a7 == -1 && ix.a8 == -1;+ 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 -int dim(Ix sh);-int size(Ix sh);-int shape(Ix sh);-int toIndex(Ix sh, Ix ix);-int fromIndex(Ix sh, Ix ix);+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 view
@@ -0,0 +1,91 @@+/* -----------------------------------------------------------------------------+ *+ * 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 view
@@ -1,7 +1,7 @@ /* ----------------------------------------------------------------------------- * * Module : Texture- * Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell+ * 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>
cubits/accelerate_cuda_util.h view
@@ -1,7 +1,7 @@ /* ----------------------------------------------------------------------------- * * Module : Util- * Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell+ * 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>
cubits/backpermute.inl view
@@ -1,7 +1,7 @@ /* ----------------------------------------------------------------------------- * * Kernel : Backpermute- * Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell+ * 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>
cubits/fold.inl view
@@ -1,94 +1,97 @@ /* ----------------------------------------------------------------------------- * * Kernel : Fold- * Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell+ * 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 an array to a single value with a binary associative function+ * Reduce the innermost dimension of a multidimensional array to a single value+ * with a binary associative function * * ---------------------------------------------------------------------------*/ -#ifndef LENGTH_IS_POW_2-#define LENGTH_IS_POW_2 0-#endif+#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+ const DimOut shOut,+ const DimIn0 shIn0 ) { extern volatile __shared__ void* s_ptr[]; ArrOut s_data = partition(s_ptr, blockDim.x); - /*- * Calculate first level of reduction reading into shared memory- */- Ix i;- TyOut sum = identity();- const Ix tid = threadIdx.x;- const Ix gridSize = blockDim.x * 2 * gridDim.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);+ /*- * 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.+ * Each warp reduces elements along a projection through an innermost+ * dimension to a single value */- for (i = blockIdx.x * blockDim.x * 2 + tid; i < shape; i += gridSize)+ for (Ix seg = vector_id; seg < num_segments; seg += num_vectors) {- sum = apply(sum, get0(d_in0, i));+ const Ix start = seg * num_elements;+ const Ix end = start + num_elements;+ TyOut sum; - /*- * Ensure we don't read out of bounds. This is optimised away if the- * input length is a power of two- */- if (LENGTH_IS_POW_2 || i + blockDim.x < shape)- sum = apply(sum, get0(d_in0, i+blockDim.x));- }+ 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); - /*- * 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();+ if (i + warpSize < end)+ {+ TyOut tmp = get0(d_in0, i + warpSize); - if (blockDim.x >= 512) { if (tid < 256) { sum = apply(sum, get0(s_data, tid+256)); set(s_data, tid, sum); } __syncthreads(); }- if (blockDim.x >= 256) { if (tid < 128) { sum = apply(sum, get0(s_data, tid+128)); set(s_data, tid, sum); } __syncthreads(); }- if (blockDim.x >= 128) { if (tid < 64) { sum = apply(sum, get0(s_data, tid+ 64)); set(s_data, tid, sum); } __syncthreads(); }+ if (i >= start) sum = apply(sum, tmp);+ else sum = tmp;+ } - if (tid < 32)- {+ /*+ * 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);+ }+ /*- * Use an extra warps worth of elements of shared memory, to let threads- * index beyond the input data without using any branch instructions.+ * Each thread puts its local sum into shared memory, then cooperatively+ * reduce the shared array to a single value. */- sum = apply(sum, get0(s_data, tid+32)); set(s_data, tid, sum);- sum = apply(sum, get0(s_data, tid+16)); set(s_data, tid, sum);- sum = apply(sum, get0(s_data, tid+ 8)); set(s_data, tid, sum);- sum = apply(sum, get0(s_data, tid+ 4)); set(s_data, tid, sum);- sum = apply(sum, get0(s_data, tid+ 2)); set(s_data, tid, sum);- sum = apply(sum, get0(s_data, tid+ 1));- }+ set(s_data, threadIdx.x, sum);+ sum = reduce_warp_n(s_data, sum, min(num_elements, warpSize)); - /*- * Write the results of this block back to global memory- */- if (tid == 0)- set(d_out, blockIdx.x, sum);+ /*+ * 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 view
@@ -0,0 +1,80 @@+/* -----------------------------------------------------------------------------+ *+ * 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 view
@@ -0,0 +1,132 @@+/* -----------------------------------------------------------------------------+ *+ * 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/fold_segmented.inl
@@ -1,120 +0,0 @@-/* ------------------------------------------------------------------------------ *- * Kernel : FoldSeg- * Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell- * License : BSD3- *- * Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>- * Stability : experimental- *- * Reduction an array to a single value for each segment, using a binary- * associative function- *- * ---------------------------------------------------------------------------*/---/*- * Cooperatively reduce an array to a single value. The computation requires an- * extra half-warp worth of elements of shared memory per block, to let threads- * index beyond the input data without using any branch instructions.- */-static __inline__ __device__-TyOut reduce_warp(ArrOut s_data, TyOut sum)-{- set(s_data, threadIdx.x, sum);- sum = apply(sum, get0(s_data, threadIdx.x + 16)); set(s_data, threadIdx.x, sum);- sum = apply(sum, get0(s_data, threadIdx.x + 8)); set(s_data, threadIdx.x, sum);- sum = apply(sum, get0(s_data, threadIdx.x + 4)); set(s_data, threadIdx.x, sum);- sum = apply(sum, get0(s_data, threadIdx.x + 2)); set(s_data, threadIdx.x, sum);- sum = apply(sum, get0(s_data, threadIdx.x + 1));-- return sum;-}---/*- * 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-fold_segmented-(- ArrOut d_out,- const ArrIn0 d_in0,- const Int* d_offset,- const Ix num_segments,- const Ix length // of input array d_in0-)-{- 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;-- /*- * 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 < num_segments; seg += num_vectors)- {- /*- * 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 we are the last segment, the final index is- * taken from the overall array length.- */- if (seg < num_segments - 1)- {- if (thread_lane < 2)- s_ptrs[vector_lane][thread_lane] = d_offset[seg + thread_lane];- }- else- {- if (thread_lane == 0)- s_ptrs[vector_lane][0] = d_offset[seg];-- s_ptrs[vector_lane][1] = length;- }-- const Ix start = s_ptrs[vector_lane][0];- const Ix end = s_ptrs[vector_lane][1];-- /*- * Have each thread read in all values for this segment, accumulating a- * local sum. This is then reduced cooperatively in shared memory.- */- TyOut sum = identity();- for (Ix i = start + thread_lane; i < end; i += warpSize)- sum = apply(sum, get0(d_in0, i));-- sum = reduce_warp(s_data, sum);-- /*- * Finally, the first thread writes the result for this segment- */- if (thread_lane == 0)- set(d_out, seg, sum);- }-}-
+ cubits/generate.inl view
@@ -0,0 +1,32 @@+/* -----------------------------------------------------------------------------+ *+ * 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 view
@@ -1,7 +1,7 @@ /* ----------------------------------------------------------------------------- * * Kernel : Map- * Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell+ * 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>
cubits/permute.inl view
@@ -1,7 +1,7 @@ /* ----------------------------------------------------------------------------- * * Kernel : Permute- * Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell+ * 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>
+ cubits/reduce.inl view
@@ -0,0 +1,72 @@+/* -----------------------------------------------------------------------------+ *+ * 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 view
@@ -1,7 +1,7 @@ /* ----------------------------------------------------------------------------- * * Kernel : Replicate- * Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell+ * 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>
+ cubits/scan.inl view
@@ -0,0 +1,23 @@+/* -----------------------------------------------------------------------------+ *+ * 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 view
@@ -0,0 +1,17 @@+/* -----------------------------------------------------------------------------+ *+ * 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 view
@@ -1,7 +1,7 @@ /* ----------------------------------------------------------------------------- * * Kernel : Slice- * Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell+ * 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>
+ cubits/stencil.inl view
@@ -0,0 +1,33 @@+/* -----------------------------------------------------------------------------+ *+ * 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 view
@@ -0,0 +1,36 @@+/* -----------------------------------------------------------------------------+ *+ * 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 view
@@ -0,0 +1,124 @@+/*+ * 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 view
@@ -0,0 +1,74 @@+/*+ * 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 view
@@ -0,0 +1,128 @@+/*+ * 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/thrust/scan_safe.inl
@@ -1,264 +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 <bool inclusive, typename T>-__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(); }-- if (inclusive) return val;- else return threadIdx.x > 0 ? array[threadIdx.x - 1] : identity();-}--#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---template <bool inclusive>-__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<inclusive>(sdata, val);-- // write data- set(d_out, output, val);-- // update output iterator- if (reverse) output -= blockDim.x;- else output += blockDim.x;- }- __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);- }- }-}---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<true>(sdata, d_out, d_in0, d_block_results, N, interval_size);-}--#if 0-extern "C"-__global__ void-exclusive_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<false>(sdata, d_out, d_in0, d_block_results, N, interval_size);-}-#endif-#if 0-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);-- if (blockIdx.x == 0)- return;-- // value to add to this segment- TyOut sum = get0(d_in0, blockIdx.x - 1);-- // 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();- }-}-#endif---extern "C"-__global__ void-exclusive_update-(- ArrOut d_out,- ArrIn0 d_in0,- 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);- }- }-- // 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)- set(d_out, output, val);-- if (threadIdx.x == 0)- val = sdata[blockDim.x - 1];-- __syncthreads();-- if (reverse) output -= blockDim.x;- else output += blockDim.x;- }-}-
cubits/zipWith.inl view
@@ -1,7 +1,7 @@ /* ----------------------------------------------------------------------------- * * Kernel : ZipWith- * Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell+ * 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>
− examples/rasterize/RasterizeAcc.hs
@@ -1,244 +0,0 @@-{-- Copyright (C) 2010 by IPwn Studios- Released under GNU General Public License v3--}--{-# LANGUAGE ScopedTypeVariables #-}-module RasterizeAcc where--import Control.Arrow-import Control.Parallel-import Control.Parallel.Strategies-import Data.Array.Accelerate-import Data.Array.Accelerate.Interpreter-import Data.Bits ((.&.))-import Prelude hiding (replicate, zip, unzip, map, filter, max, min, not,- zipWith, round, uncurry, scanl, fst, snd, tail, even)-import qualified Prelude-import Debug.Trace---type Area = ((Int, Int), (Int, Int))-type Value = ((Int, Int), Float)-type Insertion = ((Int, Int), Float)-type Facet = (Int, Int, Int)--aseq :: (NFData a, Elem a, Ix dim) => String -> Acc (Array dim a) -> Acc (Array dim a)-aseq descr = id -- use . trace descr . hseq . run--aseq1 :: (NFData a, Elem a, Ix dim, Show a) => String -> Acc (Array dim a) -> Acc (Array dim a)-aseq1 descr aarr =- let arr = run aarr- in use $ {-trace (descr ++ " " ++ show (arrayShape arr) ++ " " ++ show arr)-} arr--hseq :: (NFData a, Elem a, Ix dim) => Array dim a -> Array dim a-hseq arr =- let l = toList arr `using` seqList rwhnf- in l `seq` fromList (arrayShape arr) l--rasterize :: Exp Area- -> Acc (Vector Value)- -> Acc (Vector Facet) - -> Acc (Array DIM2 Float)-rasterize area values facets =- let -- Triangle vertices sorted by X co-ordinate- tris :: Acc (Vector (Value, Value, Value))- tris = flip map facets $ \tri ->- let (iA, iB, iC) = untuple tri- in sort3Tuple lessThanX $ tuple (values ! iA, values ! iB, values ! iC)-- noOfTris = shape tris :: Exp Int-- -- Vector of (triangle index, (start column, end column))- columnRanges :: Acc (Vector (Int, Int))- columnRanges = aseq1 "columnRanges" $ map rangeOfColumns tris-- -- Vector of (triangle index, integer x co-ordinate of column)- columnIndices :: Acc (Vector (Int, Int))- columnIndices = aseq1 "columnIndices" $ flatten columnRanges-- columns :: Acc (Vector ((Int, Float, Float), (Int, Float, Float)))- columns = aseq1 "columns" $ flip map columnIndices $ \pair ->- let (triIx, xInt) = untuple pair- in rowRange (tris ! triIx) xInt-- pointRanges :: Acc (Vector (Int, Int))- pointRanges = aseq1 "pointRanges" $ flip map columns $ \col ->- let ((yStart, _, _), (yEnd, _, _)) = (untuple *** untuple) $ untuple col- :: ((Exp Int, Exp Float, Exp Float), (Exp Int, Exp Float, Exp Float))- in tuple (yStart, yEnd)-- -- Vector of (column index, integer y co-ordinate of column)- pointIndices :: Acc (Vector (Int, Int))- pointIndices = aseq1 "pointIndices" $ flatten pointRanges-- insertions :: Acc (Vector Insertion)- insertions = aseq1 "insertions" $ flip map pointIndices $ \pi ->- let (colIx, yInt) = untuple pi- (triIx, xInt) = untuple $ columnIndices ! colIx- :: (Exp Int, Exp Int)- ((_, yBot, vBot), (_, yTop, vTop)) =- (untuple *** untuple) $ untuple $ columns ! colIx- :: ((Exp Int, Exp Float, Exp Float), (Exp Int, Exp Float, Exp Float))- -- Displace odd columns because the terrain mesh is hexagonal- hexify yInt = even xInt ? (intToFloat yInt, intToFloat yInt + 0.5)- v = interpolate (yBot, vBot) (yTop, vTop) (hexify yInt)- in tuple (tuple (xInt, yInt), v)- in toArray area insertions- where- ((x0,y0),(x1,y1)) = (untuple *** untuple) $ untuple area :: ((Exp Int, Exp Int), (Exp Int, Exp Int))-- -- Give the start and end of the Y value of the specified row in both- -- floating point and integer co-ordinates. Output is a pair of- -- (integer y, float y, value)- rowRange :: Exp (Value, Value, Value) -> Exp Int -> Exp ((Int, Float, Float), (Int, Float, Float))- rowRange tri xInt =- let (a, b, c) = untuple tri- ((axInt, ayInt), vA) = (untuple *** id) (untuple a) :: ((Exp Int, Exp Int), Exp Float)- ((bxInt, byInt), vB) = (untuple *** id) (untuple b) :: ((Exp Int, Exp Int), Exp Float)- ((cxInt, cyInt), vC) = (untuple *** id) (untuple c) :: ((Exp Int, Exp Int), Exp Float)- ax = intToFloat axInt- ay = intToFloat ayInt- bx = intToFloat bxInt- by = intToFloat byInt- cx = intToFloat cxInt- cy = intToFloat cyInt- x = intToFloat xInt- yAC = interpolate (ax, ay) (cx, cy) x :: Exp Float- vAC = interpolate (ax, vA) (cx, vC) x :: Exp Float- (yOther, vOther) = untuple (- x <* bx ? (tuple (interpolate (ax,ay) (bx,by) x, interpolate (ax,vA) (bx,vB) x),- tuple (interpolate (bx,by) (cx,cy) x, interpolate (bx,vB) (cx,vC) x))- ) :: (Exp Float, Exp Float)- -- Order AC and Other so that y is increasing- (yBot, vBot, yTop, vTop) = untuple (- yAC <=* yOther ? (tuple (yAC, vAC, yOther, vOther),- tuple (yOther, vOther, yAC, vAC))- ) :: (Exp Float, Exp Float, Exp Float, Exp Float)- yStart = max y0 (roundFloatToInt yBot)- yEnd = min (y1+1) (roundFloatToInt yTop)- in tuple (tuple (yStart, yBot, vBot), tuple (yEnd, yTop, vTop))-- rangeOfColumns :: Exp (Value, Value, Value) -> Exp (Int, Int)- rangeOfColumns tri =- let (a, _, c) = untuple tri :: (Exp Value, Exp Value, Exp Value)- (xyA, _) = untuple a :: (Exp (Int, Int), Exp Float)- (xA, _) = untuple xyA :: (Exp Int, Exp Int)- (xyC, _) = untuple c :: (Exp (Int, Int), Exp Float)- (xC, _) = untuple xyC :: (Exp Int, Exp Int)- in tuple (x0 `max` xA, (x1 + 1) `min` xC)---- | Flatten a list of ranges with an exclusive upper value into a list of--- indices into the concatenated ranges in the form (input ix, value in range). e.g.------ > [(5,8),(10,15),(3,4)]------ > [(0,5),(0,6),(0,7),(1,10),(1,11),(1,12),(1,13),(1,14),(2,3)]-flatten :: Acc (Vector (Int, Int))- -> Acc (Vector (Int, Int))-flatten ranges0 =- let -- ensure the ranges are not decreasing- ranges = flip map ranges0 $ \ab ->- let (a, b) = untuple ab- in tuple (a, a `max` b)- noOfRanges = shape ranges :: Exp Int-- rangeWidths :: Acc (Vector Int)- rangeWidths = aseq1 "f.rangeWidths" $ map (uncurry $ flip (-)) ranges-- -- The start position of each column in a yet-to-be-created array of columns- (columnOffsets, noOfCols) = second (! constant ()) $ scanl (+) 0 $ rangeWidths- :: (Acc (Vector Int), Exp Int)-- -- Input indices for each of the output elements, e.g. for the example- -- above, [0,0,0,1,1,1,1,1,2]- rangeIndices :: Acc (Vector Int)- rangeIndices = aseq1 "f.rangeIndices" $- let ones = replicate noOfRanges (unit 1) :: Acc (Vector Int)- zeroes = replicate (noOfCols + 1) (unit 0) :: Acc (Vector Int)- steps = permute (+) zeroes (columnOffsets !) ones- in tail $ Prelude.fst $ scanl (+) (-1) steps-- columnIndices :: Acc (Vector Int)- columnIndices = aseq1 "f.columnIndices" $- -- [10 - 8 + 1, 3 - 15 + 1] - -- [3, -11]- -- 5 - let ones = use $ run $ replicate (noOfCols + 1) (unit 1) :: Acc (Vector Int)- -- ([5,10,3], [8,15,4]) - (rangeStarts, rangeEnds) = unzip ranges- -- [3, -11]- deltas = use $ run $ map (1+) $ zipWith (-) (tail rangeStarts) rangeEnds- deltas_m1 = map (\x -> x - 1) deltas- -- [1, 1, 1, 3, 1, 1, 1, 1,-11, 1]- changes = use $ run $ permute (+) ones (\ix -> columnOffsets ! (ix + 1)) deltas_m1- -- [5, 6, 7,10,11,12,13, 14, 3]- in tail $ Prelude.fst $ scanl (+) ((rangeStarts ! 0) - 1) changes-- in zip rangeIndices columnIndices--tail :: Elem a => Acc (Vector a) -> Acc (Vector a)-tail xs = backpermute (shape xs - 1) (1+) xs--even :: Exp Int -> Exp Bool-even x = (x .&. 1) ==* 0--interpolate :: (Exp Float, Exp Float) -> (Exp Float, Exp Float) -> Exp Float -> Exp Float-interpolate (t0, x0) (t1, x1) t = (t - t0) * (x1 - x0) / (t1 - t0) + x0---- | Give an array of values [0..length xs-1], e.g. [8,2,3,4] -> [0,1,2,3]-indicesOf :: Elem a => Acc (Vector a) -> Acc (Vector Int)-indicesOf = Prelude.fst . scanl (+) 0 . map (const 1)--lessThanX :: Exp Value -> Exp Value -> Exp Bool-lessThanX a b =- let (xyA, _) = untuple a :: (Exp (Int, Int), Exp Float)- (xA, _) = untuple xyA :: (Exp Int, Exp Int)- (xyB, _) = untuple b :: (Exp (Int, Int), Exp Float)- (xB, _) = untuple xyB :: (Exp Int, Exp Int)- in xA <* xB--sort3Tuple :: forall a . (Elem a) =>- (Exp a -> Exp a -> Exp Bool) -- ^ Less-than function- -> Exp (a, a, a) -- ^ Tuple- -> Exp (a, a, a)-sort3Tuple lessThan = shuttle1 . untuple- where- -- Shuttle sort- shuttle1 :: (Exp a, Exp a, Exp a) -> Exp (a, a, a)- shuttle1 (a, b, c) = a `lessThan` b ? (shuttle2 (a, b, c), shuttle2 (b, a, c))-- shuttle2 :: (Exp a, Exp a, Exp a) -> Exp (a, a, a)- shuttle2 (a, b, c) = b `lessThan` c ? (tuple (a, b, c), shuttle3 (a, c, b))-- shuttle3 :: (Exp a, Exp a, Exp a) -> Exp (a, a, a)- shuttle3 (a, b, c) = a `lessThan` b ? (tuple (a, b, c), tuple (b, a, c))--prop_sort3Tuple :: (Int, Int, Int) -> Bool-prop_sort3Tuple triple =- let (a, b, c) = head $ toList $ run (map (sort3Tuple (<*)) $ unit $ constant triple)- in a <= b && b <= c--toArray :: Exp Area- -> Acc (Vector Insertion)- -> Acc (Array DIM2 Float)-toArray area insertions =- let (bl, tr) = untuple area- (x0, y0) = untuple bl- (x1, y1) = untuple tr- w = x1 - x0 + 1- h = y1 - y0 + 1 - z = zeroArray (tuple (h, w))- (ixs, values) = unzip insertions- perm :: Exp Int -> Exp (Int, Int)- perm ix =- let (x, y) = untuple (ixs ! ix)- in- x >=* x0 &&* x <=* x1 &&*- y >=* y0 &&* y <=* y1- ? (tuple (y - y0, x - x0), ignore)- in permute const z perm values--zeroArray :: Exp (Int, Int) -> Acc (Array DIM2 Float)-zeroArray dim = replicate dim (unit 0)-
− examples/rasterize/rasterize-test1.txt
@@ -1,4 +0,0 @@-[((-267,-201),33.957397),((-244,-202),-69.39026),((-226,-217),36.21704),((-287,-181),-15.463562),((-309,-170),-11.445068),((-280,-273),39.814148),((-324,-236),79.39956),((-349,-182),59.562397),((-316,-199),29.185278),((-305,-213),43.06239),((-258,-179),-97.86456),((-362,-201),56.988422),((-335,-252),121.0145),((-318,-277),66.3733),((-235,-275),136.13342),((-295,-196),11.120207)]-[(5,0,9),(6,8,11),(6,9,8),(5,9,6),(6,13,5),(6,12,13),(11,8,7),(8,4,7),(4,8,15),(8,9,15),(9,0,15),(15,0,3),(4,15,3),(0,10,3),(0,1,10),(2,0,1),(5,2,0),(14,2,5)]-((-321,-257),(-255,-191))-[72.88643,73.098595,73.31075,73.52292,73.735085,73.94725,74.15941,74.371574,74.58374,74.7959,75.008064,75.22023,75.432396,75.644554,75.85672,76.068886,76.281044,76.49321,76.68934,76.195625,75.70191,75.208206,74.71449,74.22078,73.72707,72.55211,71.27393,69.99576,68.71758,67.43941,66.161224,64.88305,63.604874,62.3267,61.048523,59.795395,58.557297,57.319202,56.081104,54.843006,53.604908,52.366814,51.128716,49.890617,48.65252,47.41442,46.176323,44.93823,43.70013,42.462032,41.223938,39.98584,38.74774,37.509644,36.271545,35.03345,33.795353,32.55726,32.613297,33.17915,33.745003,32.81883,31.77035,30.721872,29.673395,28.624916,27.576439,72.05909,72.271255,72.48342,72.69558,72.907745,73.11991,73.33208,73.544235,73.7564,73.96857,74.180725,74.39289,74.60506,74.81722,75.02938,75.24155,75.45371,75.66587,75.62136,75.12765,74.633934,74.14023,73.646515,73.1528,72.659096,72.16538,71.547806,70.26963,68.991455,67.71327,66.4351,65.15692,63.878746,62.600567,61.32239,60.044212,58.766037,57.48786,56.209686,54.91147,53.67337,52.435272,51.197174,49.959076,48.72098,47.482883,46.244785,45.006687,43.76859,42.530495,41.292397,40.0543,38.8162,37.578102,36.340004,35.101906,33.863808,32.62571,31.701357,32.26721,32.9309,31.882423,30.833946,29.78547,28.736992,27.688515,26.640038,71.44391,71.656075,71.86824,72.0804,72.292564,72.50473,72.716896,72.929054,73.14122,73.353386,73.565544,73.77771,73.989876,74.20204,74.4142,74.626366,74.83853,74.553375,74.05966,73.565956,73.07224,72.57853,72.08482,71.59111,71.097404,70.60369,70.10998,69.26532,67.987144,66.70897,65.43079,64.15262,62.87444,61.59626,60.318085,59.03991,57.76173,56.483555,55.205376,53.9272,52.649025,51.370846,50.09267,48.81449,47.551346,46.313248,45.075153,43.837055,42.59896,41.360863,40.122765,38.884666,37.646572,36.408478,35.17038,33.93228,32.694183,31.456089,31.355259,31.921112,30.946014,29.897537,28.84906,27.800583,26.752106,25.703629,24.655151,70.61658,70.828735,71.0409,71.25307,71.465225,71.67739,71.88956,72.10172,72.31388,72.52605,72.73821,72.95037,73.16254,73.3747,73.58687,73.79903,73.9791,73.4854,72.991684,72.49798,72.004265,71.51056,71.016846,70.52314,70.02943,69.53572,69.04201,68.5483,68.261024,66.98285,65.704666,64.42649,63.148315,61.87014,60.59196,59.31378,58.035606,56.75743,55.47925,54.201077,52.922897,51.644722,50.366547,49.088367,47.81019,46.532013,45.253838,43.975662,42.69748,41.429325,40.191227,38.95313,37.71503,36.476933,35.23884,34.00074,32.76264,31.524544,30.443316,31.058088,30.009611,28.961134,27.912657,26.864182,25.815704,24.767227,23.71875,70.0014,70.21356,70.42573,70.63789,70.85006,71.06222,71.27438,71.48655,71.69871,71.91087,72.12304,72.335205,72.54736,72.75953,72.971695,72.91113,72.41742,71.923706,71.43,70.93629,70.44258,69.94887,69.45516,68.96145,68.467735,67.97403,67.480316,66.98661,66.4929,65.97854,64.70036,63.422188,62.14401,60.865833,59.587658,58.30948,57.031303,55.753124,54.47495,53.19677,51.918594,50.64042,49.36224,48.084064,46.805885,45.52771,44.249535,42.971355,41.69318,40.415,39.136826,37.85865,36.58047,35.307304,34.06921,32.831112,31.593016,30.35492,30.097223,29.073206,28.024729,26.976252,25.927776,24.8793,23.830822,22.782345,21.733868,69.17406,69.386215,69.59838,69.81055,70.02271,70.23487,70.44704,70.6592,70.87137,71.08353,71.29569,71.50786,71.72002,71.93218,72.33685,71.84315,71.349434,70.85573,70.362015,69.86831,69.374596,68.88089,68.38718,67.89346,67.39976,66.906044,66.41234,65.918625,65.42492,64.931206,64.4375,63.696056,62.41788,61.139706,59.861526,58.58335,57.305172,56.026997,54.748817,53.470642,52.192467,50.914288,49.636112,48.357933,47.079758,45.801582,44.523407,43.245228,41.96705,40.688873,39.410698,38.13252,36.85434,35.576164,34.29799,33.019814,31.741634,30.463455,29.185278,28.1368,27.088324,26.039845,24.991367,23.94289,22.894413,21.845936,20.797459,68.558876,68.77104,68.98321,69.19537,69.40753,69.6197,69.83186,70.04402,70.25619,70.46835,70.68052,70.89268,71.10484,71.26888,70.77518,70.28146,69.78776,69.294044,68.80034,68.306625,67.81291,67.31921,66.82549,66.33179,65.83807,65.34437,64.850655,64.35695,63.863235,63.369526,62.875816,62.382107,61.413593,60.135418,58.85724,57.579063,56.300884,55.02271,53.74453,52.466354,51.188175,49.909996,48.63182,47.353645,46.075466,44.797287,43.51911,42.240932,40.962753,39.684578,38.406403,37.128227,35.850044,34.57187,33.293694,32.015514,30.737335,29.288607,27.883595,26.647572,25.411549,24.175524,23.006483,21.958006,20.909529,19.861052,18.812574,67.731544,67.9437,68.15587,68.368034,68.5802,68.79236,69.004524,69.21669,69.428856,69.641014,69.85318,70.065346,70.27751,70.200905,69.7072,69.213486,68.71977,68.22607,67.73235,67.23865,66.744934,66.25122,65.757515,65.2638,64.770096,64.27638,63.782673,63.288963,62.79525,62.30154,61.80783,61.31412,60.82041,60.409267,59.131092,57.852917,56.574738,55.296562,54.018387,52.740208,51.462032,50.183853,48.905678,47.6275,46.349323,45.071144,43.79297,42.514793,41.236614,39.95844,38.68026,37.402084,36.12391,34.845734,33.567554,32.389698,30.890816,29.391935,27.817951,26.581928,25.345905,24.109882,22.873857,21.637835,20.401812,19.165787,17.876179,67.11636,67.32853,67.540695,67.75285,67.96502,68.177185,68.38934,68.60151,68.813675,69.02583,69.238,69.450165,69.13292,68.63921,68.1455,67.651794,67.15808,66.664375,66.17066,65.676956,65.18324,64.68954,64.19582,63.702114,63.208405,62.714695,62.220985,61.727276,61.233566,60.739857,60.246147,59.752438,59.258728,58.76502,58.126804,56.84863,55.57045,54.292274,53.014095,51.73592,50.45774,49.179565,47.901386,46.62321,45.34503,44.066856,42.788677,41.510498,40.232323,38.954147,37.67597,36.39779,35.119614,33.84144,32.493034,30.994148,29.495264,27.996378,26.516268,25.280245,24.044222,22.808199,21.572174,20.336151,19.100128,17.864105,16.628082,66.289024,66.50119,66.71335,66.925514,67.13768,67.349846,67.562004,67.77417,67.986336,68.1985,68.41066,68.558655,68.06494,67.571236,67.07752,66.58382,66.0901,65.5964,65.102684,64.60898,64.115265,63.621555,63.127846,62.634136,62.140427,61.646717,61.153008,60.659298,60.16559,59.671875,59.17817,58.684456,58.190746,57.697037,57.203327,56.709618,55.844322,54.566143,53.287968,52.00979,50.73161,49.453434,48.175255,46.897076,45.618896,44.34072,43.062542,41.784363,40.506187,39.228012,37.94983,36.671654,35.393475,34.095234,32.596348,31.097466,29.598581,28.099697,26.600815,25.214584,23.978561,22.742538,21.506516,20.27049,19.034468,17.798443,16.56242,65.67385,65.88602,66.098175,66.31034,66.52251,66.73467,66.94683,67.159,67.37116,67.58333,67.49068,66.99696,66.50326,66.009544,65.51584,65.022125,64.52842,64.034706,63.540997,63.047287,62.553577,62.059868,61.56616,61.07245,60.57874,60.08503,59.591316,59.097607,58.603897,58.110188,57.616478,57.12277,56.62906,56.13535,55.64164,55.147926,54.65422,53.56184,52.28366,51.005486,49.72731,48.44913,47.170956,45.892776,44.6146,43.336422,42.058247,40.780067,39.501892,38.223713,36.945538,35.66736,34.19857,32.699684,31.200798,29.701912,28.203024,26.704138,25.205252,23.912903,22.676878,21.440855,20.20483,18.968807,17.732784,16.496761,15.260737,64.846504,65.05867,65.270836,65.482994,65.69516,65.907326,66.11949,66.33165,66.543816,66.91641,66.4227,65.928986,65.43528,64.94157,64.44786,63.954147,63.460438,62.96673,62.47302,61.97931,61.4856,60.99189,60.49818,60.00447,59.510757,59.017048,58.52334,58.02963,57.53592,57.04221,56.5485,56.054787,55.56108,55.067368,54.57366,54.07995,53.58624,53.09253,52.557533,51.279358,50.00118,48.723,47.444824,46.166645,44.888466,43.61029,42.33211,41.053932,39.775753,38.497574,37.299656,35.80077,34.301888,32.803005,31.304123,29.80524,28.306358,26.807476,25.308592,23.84726,22.611237,21.375212,20.139189,18.903166,17.667143,16.431118,15.195095,64.23133,64.4435,64.65566,64.86782,65.07999,65.29215,65.50432,65.71648,65.848434,65.35472,64.861015,64.3673,63.873592,63.379883,62.88617,62.39246,61.89875,61.40504,60.91133,60.41762,59.923912,59.430202,58.936493,58.44278,57.94907,57.45536,56.96165,56.46794,55.97423,55.480522,54.98681,54.4931,53.99939,53.50568,53.01197,52.518257,52.02455,51.530838,51.03713,50.27505,48.996876,47.718697,46.44052,45.162342,43.884167,42.605988,41.327812,40.049633,38.771458,37.402992,35.904106,34.40522,32.906338,31.407454,29.908567,28.409683,26.910799,25.411915,23.91303,22.545576,21.309553,20.073528,18.837505,17.601482,16.365458,15.129436,13.893411,63.403996,63.616158,63.828323,64.04049,64.25265,64.46481,64.67698,64.889145,64.78046,64.28674,63.793034,63.299324,62.805614,62.311905,61.818195,61.324482,60.830772,60.337063,59.843353,59.349644,58.855934,58.36222,57.86851,57.3748,56.881092,56.387383,55.893673,55.399963,54.90625,54.41254,53.91883,53.42512,52.93141,52.437702,51.943993,51.45028,50.95657,50.46286,49.96915,49.47544,49.270744,47.99257,46.71439,45.43621,44.15803,42.879852,41.601677,40.323498,39.005188,37.506306,36.00742,34.508537,33.009655,31.510769,30.011887,28.513,27.014118,25.515234,24.01635,22.479916,21.243893,20.00787,18.771845,17.535822,16.299799,15.063775,13.827751,62.788815,63.00098,63.213142,63.42531,63.63747,63.849632,64.0618,63.71247,63.21876,62.725048,62.23134,61.73763,61.24392,60.75021,60.2565,59.76279,59.26908,58.77537,58.281662,57.787952,57.294243,56.80053,56.306824,55.81311,55.3194,54.82569,54.33198,53.838272,53.344563,52.850853,52.357143,51.863434,51.36972,50.876015,50.3823,49.88859,49.394882,48.901173,48.407463,47.913754,47.420044,46.926334,45.71009,44.43191,43.153732,41.875557,40.597378,39.108524,37.609642,36.11076,34.611877,33.11299,31.614109,30.115225,28.61634,27.117458,25.618576,24.119692,22.620808,21.17825,19.942226,18.706203,17.47018,16.234156,14.998133,13.76211,12.526086,61.96148,62.17364,62.385807,62.59797,62.810135,63.022297,63.138203,62.644493,62.150784,61.657074,61.16336,60.66965,60.17594,59.68223,59.188522,58.694813,58.201103,57.707394,57.213684,56.71997,56.226265,55.73255,55.238842,54.745132,54.251423,53.757713,53.264004,52.770294,52.276585,51.782875,51.28916,50.795452,50.301743,49.808033,49.314323,48.820614,48.326904,47.833195,47.339485,46.84577,46.352066,45.858353,45.364647,44.705784,43.4276,42.20961,40.710728,39.211845,37.71296,36.214077,34.715195,33.216312,31.717428,30.218544,28.719662,27.22078,25.721895,24.223011,22.724129,21.11259,19.876566,18.640543,17.40452,16.168495,14.932472,13.696449,12.460425,61.346302,61.558464,61.77063,61.98279,62.194958,62.07022,61.57651,61.0828,60.589092,60.095383,59.601673,59.10796,58.61425,58.12054,57.62683,57.13312,56.639412,56.145702,55.651993,55.158283,54.664574,54.17086,53.677155,53.18344,52.68973,52.196022,51.702312,51.208603,50.714893,50.221184,49.727474,49.233765,48.74005,48.246346,47.752632,47.258923,46.765213,46.271503,45.777794,45.284084,44.790375,44.296665,43.802956,43.309242,42.312946,40.814064,39.315178,37.816296,36.31741,34.818527,33.31964,31.820757,30.321873,28.822989,27.324104,25.82522,24.326334,22.827452,21.328566,19.829681,18.574883,17.33886,16.102837,14.866813,13.63079,12.394766,11.158743,60.51896,60.73112,60.943283,61.15545,61.495956,61.002247,60.508537,60.014828,59.52112,59.02741,58.5337,58.039986,57.546276,57.052567,56.558857,56.065147,55.571438,55.07773,54.58402,54.09031,53.596596,53.10289,52.609177,52.115467,51.621758,51.128048,50.63434,50.14063,49.64692,49.15321,48.6595,48.165787,47.672077,47.178368,46.684658,46.19095,45.69724,45.20353,44.70982,44.21611,43.722397,43.22869,42.916306,42.875923,43.49686,41.362335,39.418503,37.919617,36.420734,34.92185,33.422962,31.92408,30.425194,28.926311,27.427425,25.928541,24.429657,22.930773,21.431889,19.933002,18.509224,17.2732,16.037176,14.801153,13.56513,12.329105,11.093082,59.903786,60.115948,60.328114,60.42798,59.93427,59.44056,58.94685,58.45314,57.959427,57.465717,56.972008,56.4783,55.98459,55.49088,54.99717,54.503456,54.009747,53.516037,53.022327,52.528618,52.03491,51.5412,51.047485,50.553776,50.060066,49.566357,49.072647,48.578934,48.085228,47.591515,47.097805,46.604095,46.110386,45.616676,45.122963,44.629257,44.135544,43.641834,43.148125,42.790413,42.75003,42.709644,42.669262,42.628876,42.588493,40.72952,38.595005,36.524055,35.025173,33.52629,32.02741,30.528524,29.029642,27.530758,26.031876,24.532993,23.034111,21.535229,20.036345,18.537462,17.20756,15.971535,14.735512,13.499489,12.263464,11.027441,9.791417,59.076443,59.28861,59.50077,59.359997,58.866287,58.372578,57.87887,57.38516,56.89145,56.39774,55.90403,55.410316,54.91661,54.422897,53.929188,53.43548,52.94177,52.44806,51.95435,51.46064,50.96693,50.47322,49.979507,49.485798,48.99209,48.49838,48.00467,47.51096,47.01725,46.52354,46.02983,45.536118,45.042408,44.5487,44.05499,43.56128,43.06757,42.664524,42.624138,42.583755,42.54337,42.502987,42.4626,42.42222,42.381832,42.23124,40.09673,37.96222,35.82771,33.629635,32.13075,30.631865,29.132978,27.634094,26.135208,24.636322,23.137438,21.638554,20.139668,18.640781,17.141897,15.905873,14.66985,13.433826,12.1978035,10.96178,9.725756,58.461266,58.67343,58.29202,57.798306,57.304596,56.810886,56.317177,55.823467,55.329758,54.83605,54.34234,53.848625,53.35492,52.861206,52.367496,51.873787,51.380077,50.886368,50.39266,49.89895,49.405235,48.91153,48.417816,47.924107,47.430397,46.936687,46.442978,45.94927,45.45556,44.961845,44.46814,43.974426,43.480717,42.987007,42.53863,42.49825,42.457863,42.41748,42.377094,42.33671,42.296326,42.255943,42.215557,42.175175,42.13479,41.59842,39.46391,37.3294,35.194893,33.060383,30.925877,29.236301,27.737415,26.23853,24.739645,23.240759,21.741875,20.242989,18.744102,17.245216,15.840212,14.604189,13.368165,12.132142,10.896118,9.660095,8.424072,57.63393,57.71775,57.22404,56.73033,56.23662,55.74291,55.2492,54.75549,54.26178,53.76807,53.27436,52.78065,52.28694,51.793232,51.299522,50.80581,50.312103,49.81839,49.32468,48.83097,48.33726,47.84355,47.349842,46.856133,46.362423,45.868713,45.375,44.881294,44.38758,43.89387,43.40016,42.906452,42.412743,42.372356,42.331974,42.291588,42.251205,42.21082,42.170437,42.13005,42.08967,42.049282,42.0089,41.968513,41.92813,41.887745,40.965626,38.831116,36.6966,34.56209,32.427578,30.293068,28.158554,26.341858,24.842974,23.344091,21.84521,20.346325,18.847443,17.34856,15.774572,14.538548,13.302525,12.066502,10.830479,9.594455,8.358431,56.64977,56.15606,55.66235,55.16864,54.67493,54.18122,53.68751,53.1938,52.70009,52.20638,51.71267,51.21896,50.72525,50.23154,49.73783,49.24412,48.750412,48.256702,47.762993,47.269283,46.775574,46.28186,45.788155,45.29444,44.800735,44.307022,43.813313,43.319603,42.825893,42.332184,42.246464,42.20608,42.165695,42.125313,42.084927,42.044544,42.004158,41.963776,41.92339,41.883007,41.84262,41.80224,41.761852,41.72147,41.681084,41.6407,40.3328,38.19829,36.06378,33.92927,31.794762,29.660252,27.525742,25.39123,23.44741,21.948528,20.449644,18.950762,17.45188,15.952996,14.472889,13.236865,12.000841,10.764818,9.528795,8.29277,7.0567474,55.581787,55.088078,54.594368,54.10066,53.60695,53.11324,52.61953,52.12582,51.63211,51.138397,50.64469,50.150978,49.65727,49.16356,48.66985,48.17614,47.68243,47.18872,46.69501,46.2013,45.707592,45.213882,44.72017,44.22646,43.73275,43.239044,42.74533,42.160957,42.120575,42.08019,42.039806,41.99942,41.959038,41.91865,41.87827,41.837883,41.7975,41.757114,41.716732,41.676346,41.635963,41.595577,41.555195,41.51481,41.474426,41.43404,41.834522,39.700012,37.5655,35.430984,33.296474,31.16196,29.027447,26.892935,24.758423,22.62391,20.552965,19.054081,17.555199,16.056316,14.557432,13.171205,11.935182,10.699158,9.463135,8.227112,6.9910884,54.0201,53.52639,53.03268,52.53897,52.04526,51.55155,51.057842,50.564133,50.070423,49.576714,49.083004,48.589294,48.095585,47.601875,47.108166,46.614456,46.120743,45.627037,45.133324,44.639618,44.145905,43.6522,43.158485,42.66478,42.171066,41.994682,41.9543,41.913914,41.87353,41.833145,41.792763,41.752377,41.711994,41.671608,41.631226,41.59084,41.550457,41.51007,41.46969,41.429302,41.38892,41.348534,41.30815,41.267765,41.227383,41.186996,41.146614,39.067223,36.93271,34.7982,32.66369,30.529177,28.394665,26.260155,24.125643,21.99113,19.856619,17.722107,16.15965,14.660761,13.161869,11.869519,10.633496,9.397472,8.161449,6.8576865,5.5354505,52.952133,52.458424,51.96471,51.471,50.97729,50.48358,49.98987,49.49616,49.00245,48.50874,48.01503,47.521317,47.027607,46.533897,46.040184,45.546474,45.052765,44.559055,44.065346,43.571632,43.077923,42.584213,41.909176,41.86879,41.828407,41.78802,41.74764,41.707253,41.66687,41.626484,41.5861,41.545715,41.505333,41.464947,41.424564,41.38418,41.343796,41.30341,41.263027,41.22264,41.18226,41.141872,41.10149,41.061104,41.02072,40.980335,40.939953,40.56891,38.4344,36.29989,34.16538,32.03087,29.896358,27.761848,25.627337,23.492826,21.358316,19.223804,17.089294,14.764094,13.265211,11.803879,10.567856,9.319516,7.9972796,6.6750426,5.3528056,51.39044,50.896732,50.403023,49.90931,49.4156,48.92189,48.42818,47.93447,47.440758,46.94705,46.45334,45.95963,45.46592,44.972206,44.4785,43.984787,43.491077,42.997368,42.50366,42.00995,41.7429,41.702515,41.662132,41.621746,41.581364,41.540977,41.500595,41.46021,41.419827,41.37944,41.339058,41.29867,41.25829,41.217903,41.17752,41.137135,41.096752,41.056366,41.015984,40.975597,40.935215,40.89483,40.854446,40.81406,40.773678,40.73329,40.69291,39.93612,37.801605,35.667095,33.53258,31.398071,29.26356,27.129047,24.994534,22.860023,20.725512,18.591,16.456486,14.321976,12.187464,10.459088,9.136852,7.8146152,6.492378,5.1701417,3.8479047,50.322464,49.828754,49.335045,48.841335,48.347626,47.853912,47.360203,46.866493,46.372784,45.879074,45.385365,44.891655,44.39794,43.904232,43.410522,42.916813,42.423103,41.929394,41.61701,41.576626,41.53624,41.495857,41.45547,41.41509,41.374702,41.33432,41.293934,41.25355,41.213165,41.172783,41.132397,41.092014,41.05163,41.011246,40.97086,40.930477,40.89009,40.84971,40.809322,40.76894,40.728554,40.68817,40.647785,40.607403,40.567017,40.526634,40.486248,41.437805,39.303295,37.168785,35.034275,32.899765,30.765251,28.630741,26.496231,24.36172,22.22721,20.092697,17.958187,15.823677,13.689163,11.575939,9.560631,7.631956,6.309719,4.9874825,3.665246,48.760773,48.267063,47.773354,47.27964,46.78593,46.29222,45.79851,45.304802,44.811092,44.317383,43.82367,43.32996,42.83625,42.34254,41.84883,41.49112,41.450733,41.41035,41.369965,41.329582,41.289196,41.248814,41.208427,41.168045,41.12766,41.087276,41.04689,41.006508,40.96612,40.92574,40.885353,40.84497,40.804585,40.764202,40.723816,40.683434,40.643047,40.602665,40.56228,40.521896,40.48151,40.441128,40.40074,40.36036,40.319973,40.27959,40.239204,40.198822,38.670506,36.53599,34.40148,32.266968,30.132454,27.997942,25.86343,23.728918,21.594406,19.459894,17.32538,15.190868,13.056356,11.024018,9.008709,6.9934,4.9780912,3.482587,2.1603503,47.69279,47.19908,46.70537,46.211662,45.717953,45.224243,44.730534,44.236824,43.74311,43.2494,42.75569,42.261982,41.768272,41.365227,41.32484,41.28446,41.244072,41.20369,41.163303,41.12292,41.082535,41.042152,41.001766,40.961384,40.920998,40.880615,40.84023,40.799847,40.75946,40.719078,40.67869,40.63831,40.597923,40.55754,40.517155,40.476772,40.436386,40.396004,40.355618,40.315235,40.27485,40.234467,40.19408,40.153698,40.11331,40.07293,40.032543,39.99216,40.172226,38.037712,35.9032,33.768684,31.63417,29.499657,27.365143,25.230629,23.096115,20.961601,18.827087,16.692574,14.502715,12.487406,10.472097,8.456789,6.4414797,4.4261703,2.410862,46.131104,45.637394,45.143684,44.64997,44.15626,43.66255,43.168842,42.675133,42.18142,41.68771,41.239334,41.19895,41.158566,41.118183,41.077797,41.037415,40.99703,40.956646,40.91626,40.875877,40.83549,40.79511,40.754723,40.71434,40.673954,40.63357,40.593185,40.552803,40.512417,40.472034,40.43165,40.391266,40.35088,40.310497,40.27011,40.22973,40.189342,40.14896,40.108574,40.06819,40.027805,39.987423,39.947037,39.906654,39.86627,39.825886,39.7855,39.745117,39.539402,37.404892,35.270382,33.13587,31.001362,28.866852,26.732342,24.597832,22.463322,20.328812,18.194302,16.059793,13.950823,11.935511,9.920198,7.904886,5.889573,3.87426,1.8589478,45.063126,44.569416,44.075706,43.581993,43.088284,42.594574,42.100864,41.607155,41.113445,41.07306,41.032677,40.99229,40.95191,40.911522,40.87114,40.830753,40.79037,40.749985,40.709602,40.669216,40.628834,40.588448,40.548065,40.50768,40.467297,40.42691,40.386528,40.34614,40.30576,40.265373,40.22499,40.184605,40.144222,40.103836,40.063454,40.023067,39.982685,39.9423,39.901917,39.86153,39.821148,39.78076,39.74038,39.699993,39.65961,39.619225,39.578842,39.538456,39.498074,38.906612,36.7721,34.63759,32.503075,30.368565,28.234055,26.09954,23.96503,21.830519,19.696007,17.561495,15.414211,13.3989,11.383588,9.368277,7.3529644,5.337652,3.322341,43.501434,43.007725,42.514015,42.020306,41.526596,41.032887,40.947166,40.906784,40.866398,40.826015,40.78563,40.745247,40.70486,40.66448,40.624092,40.58371,40.543324,40.50294,40.462555,40.422173,40.381786,40.341404,40.301018,40.260635,40.22025,40.179867,40.13948,40.0991,40.058712,40.01833,39.977943,39.93756,39.897175,39.856792,39.816406,39.776024,39.735638,39.695255,39.65487,39.614487,39.5741,39.53372,39.493332,39.45295,39.412563,39.37218,39.331795,39.291412,39.251026,38.27379,36.13928,34.00477,31.870258,29.735748,27.601238,25.466726,23.332218,21.197706,19.063196,16.928686,14.862289,12.846978,10.831667,8.816355,6.8010445,4.7857323,2.770422,42.433453,41.939743,41.446033,40.86166,40.821278,40.78089,40.74051,40.700123,40.65974,40.619354,40.57897,40.538586,40.498203,40.457817,40.417435,40.37705,40.336666,40.29628,40.255898,40.21551,40.17513,40.134743,40.09436,40.053974,40.01359,39.973206,39.932823,39.892437,39.852055,39.81167,39.771286,39.7309,39.690517,39.65013,39.60975,39.569363,39.52898,39.488594,39.44821,39.407825,39.367443,39.327057,39.286674,39.24629,39.205906,39.16552,39.125137,39.08475,39.04437,39.77551,37.641,35.506485,33.37197,31.237461,29.10295,26.968437,24.833923,22.699413,20.5649,18.430387,16.325676,14.310366,12.2950535,10.279743,8.264433,6.2491217,4.2338104,40.87176,40.695385,40.655003,40.614616,40.574234,40.533848,40.493465,40.45308,40.412697,40.37231,40.33193,40.291542,40.25116,40.210773,40.170387,40.130005,40.08962,40.049236,40.00885,39.968468,39.92808,39.8877,39.847313,39.80693,39.766544,39.726162,39.685776,39.645393,39.605007,39.564625,39.52424,39.483856,39.44347,39.403084,39.3627,39.322315,39.281933,39.241547,39.201164,39.160778,39.120396,39.08001,39.039627,38.99924,38.95886,38.918472,38.87809,38.837704,38.79732,38.756935,37.00817,34.87366,32.73915,30.604641,28.47013,26.33562,24.20111,22.066599,19.93209,17.797579,15.773754,13.758444,11.743133,9.727822,7.712511,5.697201,3.6818895,40.529114,40.488728,40.44834,40.40796,40.367573,40.32719,40.286804,40.24642,40.206036,40.165653,40.125267,40.084885,40.0445,40.004116,39.96373,39.923347,39.88296,39.84258,39.802193,39.76181,39.721424,39.68104,39.640656,39.600273,39.559887,39.519505,39.47912,39.438736,39.39835,39.357967,39.31758,39.2772,39.236813,39.19643,39.156044,39.11566,39.075275,39.034893,38.994507,38.954124,38.91374,38.873356,38.83297,38.792587,38.7522,38.71182,38.671432,38.63105,38.590664,38.550278,38.509895,36.37538,34.24087,32.106358,29.971844,27.837332,25.70282,23.568306,21.433794,19.25245,17.23714,15.221831,13.20652,11.19121,9.1759,7.16059,5.145279,40.282066,40.24168,40.201298,40.16091,40.12053,40.080143,40.03976,39.999374,39.958992,39.918606,39.878223,39.837837,39.79745,39.75707,39.716682,39.6763,39.635914,39.59553,39.555145,39.514763,39.474377,39.433994,39.39361,39.353226,39.31284,39.272457,39.23207,39.19169,39.151302,39.11092,39.070534,39.03015,38.989765,38.949383,38.908997,38.868614,38.828228,38.787846,38.74746,38.707077,38.66669,38.62631,38.585922,38.54554,38.505154,38.464767,38.424385,38.384003,38.343616,38.30323,37.8771,35.742584,33.60807,31.473557,29.339043,27.204529,25.070015,22.935501,20.800985,18.700531,16.68522,14.66991,12.6546,10.63929,8.623979,6.6086693,4.593359,40.075405,40.035023,39.994637,39.954254,39.913868,39.873486,39.8331,39.792717,39.75233,39.71195,39.671562,39.63118,39.590794,39.55041,39.510025,39.46964,39.429256,39.38887,39.348488,39.3081,39.26772,39.227333,39.18695,39.146564,39.106182,39.065796,39.025414,38.985027,38.944645,38.90426,38.863876,38.82349,38.783108,38.74272,38.70234,38.661953,38.62157,38.581184,38.5408,38.500416,38.46003,38.419647,38.37926,38.33888,38.298492,38.25811,38.217724,38.17734,38.136955,38.096573,38.056187,37.244278,35.109768,32.97526,30.840752,28.706242,26.571733,24.437225,22.302717,20.16395,18.148638,16.133326,14.118013,12.102701,10.087389,8.072077,6.0567646,39.82836,39.78798,39.747593,39.70721,39.666824,39.626442,39.586056,39.545673,39.505287,39.464905,39.42452,39.384136,39.34375,39.303368,39.26298,39.2226,39.182213,39.14183,39.101444,39.061058,39.020676,38.98029,38.939907,38.89952,38.85914,38.818752,38.77837,38.737984,38.6976,38.657215,38.616833,38.576447,38.536064,38.495678,38.455296,38.41491,38.374527,38.33414,38.293755,38.253372,38.212986,38.172604,38.132217,38.091835,38.05145,38.011066,37.97068,37.930298,37.88991,37.84953,37.809143,36.61149,34.476974,32.342464,30.207954,28.07344,25.93893,23.80442,21.669909,19.612024,17.596714,15.581402,13.56609,11.550778,9.535466,7.520155,5.5048428,39.621704,39.581318,39.540936,39.50055,39.460167,39.41978,39.3794,39.339012,39.29863,39.258244,39.217857,39.177475,39.13709,39.096706,39.05632,39.015938,38.97555,38.93517,38.894783,38.8544,38.814014,38.773632,38.733246,38.692863,38.652477,38.612095,38.57171,38.531326,38.49094,38.450554,38.41017,38.369785,38.329403,38.289017,38.248634,38.20825,38.167866,38.12748,38.087097,38.04671,38.00633,37.965942,37.92556,37.885174,37.84479,37.804405,37.764023,37.723637,37.68325,37.642868,37.60248,38.113174,35.978664,33.844154,31.709646,29.575138,27.440628,25.30612,23.17161,21.075415,19.060102,17.044792,15.02948,13.014169,10.9988575,8.983546,6.968234,39.374657,39.334274,39.293888,39.253506,39.21312,39.172737,39.13235,39.091965,39.051582,39.011196,38.970814,38.930428,38.890045,38.84966,38.809277,38.76889,38.728508,38.68812,38.64774,38.607353,38.56697,38.526585,38.486202,38.445816,38.405434,38.365047,38.324665,38.28428,38.243896,38.20351,38.163128,38.12274,38.08236,38.041973,38.00159,37.961205,37.920822,37.880436,37.84005,37.799667,37.75928,37.7189,37.678513,37.63813,37.597744,37.55736,37.516975,37.476593,37.436207,37.395824,37.35544,37.315056,35.34587,33.21136,31.076849,28.942337,26.807827,24.673315,22.538803,20.523493,18.50818,16.49287,14.477559,12.462248,10.446938,8.431625,6.416315,39.168,39.127613,39.08723,39.046844,39.006462,38.966076,38.925694,38.885307,38.84492,38.80454,38.764153,38.72377,38.683384,38.643,38.602615,38.562233,38.521847,38.481464,38.44108,38.400696,38.36031,38.319927,38.27954,38.23916,38.198772,38.15839,38.118004,38.07762,38.037235,37.996853,37.956467,37.916084,37.875698,37.83531,37.79493,37.754543,37.71416,37.673775,37.633392,37.593006,37.552624,37.512238,37.471855,37.43147,37.391087,37.3507,37.310318,37.26993,37.22955,37.189163,37.14878,37.108395,36.84756,34.71305,32.57854,30.444033,28.309523,26.175014,24.00219,21.98688,19.97157,17.956259,15.9409485,13.925637,11.910327,9.895017,7.8797054,38.92095,38.88057,38.840183,38.7998,38.759415,38.719032,38.678646,38.638264,38.597878,38.557495,38.51711,38.476727,38.43634,38.395958,38.35557,38.31519,38.274803,38.23442,38.194035,38.153652,38.113266,38.072884,38.032497,37.99211,37.95173,37.911343,37.87096,37.830574,37.79019,37.749805,37.709423,37.669037,37.628654,37.58827,37.547886,37.5075,37.467117,37.42673,37.38635,37.345963,37.30558,37.265194,37.22481,37.184425,37.144043,37.103657,37.063274,37.02289,36.982506,36.94212,36.901733,36.86135,36.21477,34.080257,31.945744,29.811232,27.67672,25.542206,23.450266,21.434956,19.419647,17.404335,15.389027,13.373715,11.358406,9.343096,7.3277855,38.714294,38.67391,38.633526,38.59314,38.552757,38.51237,38.47199,38.431602,38.39122,38.350834,38.31045,38.270065,38.229683,38.189297,38.148914,38.10853,38.068146,38.02776,37.987377,37.94699,37.90661,37.866222,37.825836,37.785454,37.745068,37.704685,37.6643,37.623917,37.58353,37.543148,37.50276,37.46238,37.421993,37.38161,37.341225,37.300842,37.260456,37.220074,37.179688,37.139305,37.09892,37.058537,37.01815,36.977768,36.93738,36.896996,36.856613,36.81623,36.775845,36.73546,36.695076,36.65469,36.614307,35.581978,33.44746,31.312946,29.17843,27.043915,24.913656,22.898346,20.883038,18.867727,16.852417,14.837109,12.821798,10.806489,8.79118,38.47243,38.426865,38.386482,38.346096,38.30571,38.265327,38.22494,38.18456,38.144173,38.10379,38.063404,38.02302,37.982635,37.942253,37.901867,37.861485,37.8211,37.780716,37.74033,37.699947,37.65956,37.61918,37.578793,37.53841,37.498024,37.45764,37.417255,37.376873,37.336487,37.296104,37.25572,37.215336,37.17495,37.134563,37.09418,37.053795,37.013412,36.973026,36.932644,36.892258,36.851875,36.81149,36.771107,36.73072,36.69034,36.649952,36.60957,36.569183,36.5288,36.488415,36.448032,36.407646,36.367264,34.949158,32.81465,30.680145,28.545639,26.41113,24.361763,22.346449,20.331137,18.315825,16.300512,14.285199,12.269887,10.254574,6.7620554,38.536903,38.45162,38.366333,38.281048,38.195763,38.110474,38.018284,37.977898,37.937515,37.89713,37.856747,37.81636,37.775978,37.73559,37.69521,37.654823,37.61444,37.574055,37.53367,37.493286,37.4529,37.412518,37.37213,37.33175,37.291363,37.25098,37.210594,37.17021,37.129826,37.089443,37.049057,37.008675,36.96829,36.927906,36.88752,36.847137,36.80675,36.76637,36.725983,36.6856,36.645214,36.60483,36.564445,36.524063,36.483677,36.443295,36.40291,36.362526,36.32214,36.281757,36.24137,36.20099,36.160603,36.45088,34.316364,32.181854,30.047344,27.912834,25.82515,23.809837,21.794525,19.779215,17.763903,15.7485895,13.733278,11.717966,6.748244,38.51609,38.430805,38.34552,38.260235,38.17495,38.089664,38.00438,37.919094,37.83381,37.748524,37.66324,37.57795,37.52893,37.48855,37.448162,37.40778,37.367393,37.32701,37.286625,37.246243,37.205856,37.165474,37.125088,37.084705,37.04432,37.003937,36.96355,36.92317,36.882782,36.8424,36.802013,36.76163,36.721245,36.680862,36.640476,36.600094,36.559708,36.519325,36.47894,36.438557,36.39817,36.357788,36.3174,36.277016,36.236633,36.196247,36.155865,36.11548,36.075096,36.03471,35.994328,35.95394,35.91356,35.818054,33.683548,31.54904,29.414532,27.28854,25.273228,23.257915,21.242605,19.227293,17.21198,15.19667,11.704154,6.7344337,1.7647133,38.580566,38.49528,38.409996,38.32471,38.239426,38.15414,38.068855,37.98357,37.89828,37.812996,37.72771,37.642426,37.55714,37.471855,37.38657,37.301285,37.216,37.12035,37.079967,37.03958,36.9992,36.958813,36.91843,36.878044,36.83766,36.797276,36.756893,36.716507,36.676125,36.63574,36.595352,36.55497,36.514584,36.4742,36.433815,36.393433,36.353046,36.312664,36.272278,36.231895,36.19151,36.151127,36.11074,36.07036,36.029972,35.98959,35.949203,35.90882,35.868435,35.828053,35.787666,35.747284,35.706898,35.666515,35.185265,33.05075,30.91624,28.751928,26.736616,24.721306,22.705994,20.690683,18.675373,16.66006,11.690336,6.7206116,1.7508879,38.559753,38.47447,38.389183,38.303898,38.218613,38.133327,38.048042,37.962757,37.877472,37.792187,37.7069,37.621616,37.53633,37.451042,37.365757,37.28047,37.195187,37.1099,37.024616,36.93933,36.854046,36.76876,36.683475,36.631004,36.59062,36.550236,36.50985,36.469463,36.42908,36.388695,36.348312,36.307926,36.267544,36.227158,36.186775,36.14639,36.106007,36.06562,36.025238,35.98485,35.94447,35.904083,35.863697,35.823315,35.78293,35.742546,35.70216,35.661777,35.62139,35.58101,35.540623,35.50024,35.459854,35.41947,34.55244,32.417934,30.283426,28.200005,26.184694,24.169386,22.154076,20.138767,16.64625,11.676527,6.7068043,1.7370796,-3.2326431,38.62423,38.538944,38.45366,38.368374,38.28309,38.1978,38.112514,38.02723,37.941944,37.85666,37.771374,37.68609,37.600803,37.51552,37.430233,37.344948,37.259663,37.174377,37.089092,37.003807,36.91852,36.833237,36.747948,36.662663,36.577377,36.492092,36.406807,36.32152,36.22242,36.182037,36.14165,36.10127,36.060883,36.0205,35.980114,35.93973,35.899345,35.858963,35.818577,35.778194,35.73781,35.697422,35.65704,35.616653,35.57627,35.535885,35.495502,35.455116,35.414734,35.374348,35.333965,35.29358,35.253197,35.21281,36.05416,33.919647,31.785133,29.663393,27.648085,25.632774,23.617466,21.602158,16.632435,11.662714,6.692992,1.7232704,-3.2464504,38.60342,38.51813,38.432846,38.34756,38.262276,38.17699,38.091705,38.00642,37.921135,37.83585,37.750565,37.66528,37.579994,37.49471,37.409424,37.324135,37.23885,37.153564,37.06828,36.982994,36.89771,36.812424,36.72714,36.641853,36.55657,36.471283,36.385998,36.300713,36.215424,36.13014,36.044853,35.959568,35.874283,35.788998,35.73307,35.692688,35.6523,35.611916,35.571533,35.531147,35.490765,35.45038,35.409996,35.36961,35.329227,35.28884,35.24846,35.208073,35.16769,35.127304,35.08692,35.046535,35.00615,34.965767,34.92538,33.28685,31.152327,29.111473,27.096165,25.080858,21.588345,16.618624,11.648903,6.679182,1.7094612,-3.2602596,-8.22998,38.667892,38.582607,38.497322,38.412037,38.326748,38.241463,38.156178,38.070892,37.985607,37.900322,37.815037,37.72975,37.644466,37.55918,37.473896,37.38861,37.303326,37.218037,37.13275,37.047466,36.96218,36.876896,36.79161,36.706326,36.62104,36.535755,36.45047,36.365185,36.2799,36.194614,36.10933,36.02404,35.938755,35.85347,35.768185,35.6829,35.597614,35.51233,35.427044,35.32449,35.284103,35.24372,35.203335,35.162952,35.122566,35.082184,35.041798,35.00141,34.96103,34.920643,34.88026,34.839874,34.79949,34.759106,34.718723,34.788548,32.65405,30.574886,28.55957,26.544254,21.574532,16.604807,11.635084,6.6653595,1.6956348,-3.274086,-8.243813,38.647083,38.561794,38.47651,38.391224,38.30594,38.220654,38.13537,38.050083,37.964798,37.879513,37.794228,37.708942,37.623657,37.53837,37.453083,37.367798,37.282513,37.197227,37.111942,37.026657,36.941372,36.856087,36.7708,36.685516,36.600227,36.514942,36.429657,36.34437,36.259087,36.1738,36.088516,36.00323,35.917946,35.83266,35.747375,35.66209,35.576805,35.491516,35.40623,35.320946,35.23566,35.150375,35.06509,34.979805,34.89452,34.835136,34.794754,34.754368,34.713985,34.6736,34.633217,34.59283,34.55245,34.512062,34.47168,34.155758,32.038277,30.02296,26.53044,21.560719,16.590994,11.621273,6.6515484,1.6818275,-3.2878952,-8.257618,-13.227341,38.71155,38.626266,38.54098,38.455696,38.37041,38.285126,38.19984,38.114555,38.02927,37.943985,37.8587,37.773415,37.68813,37.602844,37.517555,37.43227,37.346985,37.2617,37.176414,37.09113,37.005844,36.92056,36.835274,36.74999,36.664703,36.57942,36.494133,36.408844,36.32356,36.238274,36.15299,36.067703,35.982418,35.897133,35.811848,35.726563,35.641277,35.555992,35.470707,35.38542,35.300137,35.21485,35.129562,35.044277,34.958992,34.873707,34.78842,34.703136,34.61785,34.532566,34.426556,34.386173,34.345787,34.305405,34.26502,34.224632,33.501667,31.486351,26.51663,21.54691,16.577187,11.607466,6.637745,1.6680222,-3.3017006,-8.27142,-13.241142,38.690742,38.605457,38.52017,38.434883,38.349598,38.264313,38.179028,38.093742,38.008457,37.923172,37.837887,37.7526,37.667316,37.58203,37.496746,37.41146,37.32617,37.240887,37.1556,37.070316,36.98503,36.899746,36.81446,36.729176,36.64389,36.558605,36.47332,36.388035,36.30275,36.21746,36.132175,36.04689,35.961605,35.87632,35.791035,35.70575,35.620464,35.53518,35.449894,35.36461,35.279324,35.19404,35.10875,35.023464,34.93818,34.852894,34.76761,34.682323,34.59704,34.511753,34.426468,34.341183,34.255898,34.170612,34.085327,34.00004,31.472536,26.502811,21.533087,16.563364,11.593637,6.6239166,1.6541901,-3.3155327,-8.285259,-13.254982,-18.224705,38.75522,38.66993,38.584644,38.49936,38.414074,38.32879,38.243504,38.15822,38.072933,37.987648,37.902363,37.817078,37.731792,37.646507,37.56122,37.475933,37.390648,37.305363,37.220078,37.134792,37.049507,36.964222,36.878937,36.79365,36.708366,36.62308,36.537796,36.452507,36.36722,36.281937,36.19665,36.111366,36.02608,35.940796,35.85551,35.770226,35.68494,35.599655,35.51437,35.429085,35.343796,35.25851,35.173225,35.08794,35.002655,34.91737,34.832085,34.7468,34.661514,34.57623,34.490944,34.40566,34.320374,34.235085,34.1498,34.064514,29.286606,25.205473,21.51927,16.549547,11.579824,6.6101007,1.640379,-3.3293457,-8.29907,-13.268791,-18.238514,38.734406,38.64912,38.563835,38.478546,38.39326,38.307976,38.22269,38.137405,38.05212,37.966835,37.88155,37.796265,37.71098,37.625694,37.54041,37.45512,37.369835,37.28455,37.199265,37.11398,37.028694,36.94341,36.858124,36.77284,36.687553,36.60227,36.516983,36.431694,36.34641,36.261124,36.17584,36.090553,36.00527,35.919983,35.834698,35.749413,35.664127,35.578842,35.493553,35.408268,35.322983,35.237698,35.152412,35.067127,34.981842,34.896557,34.81127,34.725986,34.6407,34.555416,34.47013,34.384842,34.299557,34.21427,34.128986,30.388481,22.575193,18.494074,14.412954,10.331835,6.2507153,1.626559,-3.3431616,-8.312883,-13.282604,-18.252327,-23.222048,39.95767,38.713593,38.628304,38.54302,38.457733,38.372448,38.287163,38.201878,38.116592,38.031307,37.946022,37.860737,37.77545,37.690166,37.60488,37.519596,37.43431,37.349022,37.263737,37.17845,37.093166,37.00788,36.922596,36.83731,36.752026,36.66674,36.581455,36.49617,36.410885,36.3256,36.240314,36.15503,36.06974,35.984455,35.89917,35.813885,35.7286,35.643314,35.55803,35.472744,35.38746,35.302174,35.21689,35.131603,35.046318,34.961033,34.875748,34.79046,34.705177,34.61989,34.534603,34.449318,34.364033,34.278748,34.193462,31.883286,19.944958,15.863836,11.782712,7.7015896,3.6204662,-0.46065903,-4.5417805,-8.32671,-13.296429,-18.266148,-23.235867,40.98701,38.946255,38.607494,38.52221,38.436924,38.35164,38.266354,38.18107,38.09578,38.010494,37.92521,37.839924,37.75464,37.669353,37.58407,37.498783,37.413498,37.328213,37.242928,37.157642,37.072357,36.98707,36.901783,36.816498,36.731213,36.645927,36.560642,36.475357,36.39007,36.304787,36.2195,36.134216,36.048927,35.963642,35.878357,35.79307,35.707787,35.6225,35.537216,35.45193,35.366646,35.28136,35.196075,35.11079,35.025505,34.940216,34.85493,34.769646,34.68436,34.599075,34.51379,34.428505,34.34322,34.257935,33.37805,20.26108,13.233546,9.152427,5.071307,0.99018764,-3.0909328,-7.1720505,-11.253168,-15.33429,-19.415407,-23.49653,-28.21942,44.057144,42.016388,39.975628,38.586685,38.5014,38.416115,38.33083,38.24554,38.160255,38.07497,37.989685,37.9044,37.819115,37.73383,37.648544,37.56326,37.477974,37.39269,37.307404,37.222115,37.13683,37.051544,36.96626,36.880974,36.79569,36.710403,36.62512,36.539833,36.454548,36.369263,36.283978,36.198692,36.113403,36.02812,35.942833,35.857548,35.772263,35.686977,35.601692,35.516407,35.43112,35.345837,35.26055,35.175262,35.089977,35.004692,34.919407,34.83412,34.748837,34.66355,34.578266,34.49298,34.407696,34.32241,34.872837,21.75592,10.6033125,6.5221963,2.44108,-1.6400366,-5.7211514,-9.802267,-13.883385,-17.964502,-22.045618,-26.126734,-30.20785,45.086483,43.045723,41.004967,38.96421,38.480587,38.3953,38.310017,38.22473,38.139446,38.05416,37.968876,37.88359,37.798306,37.71302,37.62773,37.542446,37.45716,37.371876,37.28659,37.201305,37.11602,37.030735,36.94545,36.860165,36.77488,36.689594,36.60431,36.51902,36.433735,36.34845,36.263165,36.17788,36.092594,36.00731,35.922024,35.83674,35.751453,35.66617,35.580883,35.495598,35.41031,35.325024,35.23974,35.154453,35.069168,34.983883,34.898598,34.813313,34.728027,34.642742,34.557457,34.47217,34.386887,34.301598,23.250732,10.133852,3.8919613,-0.18915796,-4.270276,-8.351396,-12.432516,-16.513634,-20.594753,-24.675873,-28.756992,-32.838108,-36.919228,48.156586,46.11583,44.07507,42.034313,39.993553,38.459778,38.374493,38.289204,38.20392,38.118633,38.033348,37.948063,37.862778,37.777493,37.692207,37.606922,37.521637,37.43635,37.351063,37.265778,37.180492,37.095207,37.009922,36.924637,36.83935,36.754066,36.66878,36.583496,36.49821,36.412926,36.327637,36.24235,36.157066,36.07178,35.986496,35.90121,35.815926,35.73064,35.645355,35.56007,35.474785,35.389496,35.30421,35.218925,35.13364,35.048355,34.96307,34.877785,34.7925,34.707214,34.62193,34.536644,34.451355,37.8624,24.745468,11.628534,1.2616678,-2.819449,-6.900566,-10.981683,-15.062801,-19.143917,-23.225035,-27.306152,-31.387266,-35.468384,-39.5495,49.185932,47.145172,45.104416,43.063656,41.022892,38.982132,38.353676,38.26839,38.183105,38.09782,38.012535,37.92725,37.841965,37.75668,37.671394,37.58611,37.50082,37.415535,37.33025,37.244965,37.15968,37.074394,36.98911,36.903824,36.81854,36.733253,36.64797,36.562683,36.477398,36.392113,36.306828,36.221542,36.136253,36.05097,35.965683,35.880398,35.795113,35.709827,35.624542,35.539257,35.45397,35.368687,35.2834,35.198116,35.11283,35.027546,34.94226,34.85697,34.771687,34.6864,34.601116,34.51583,34.430546,26.240269,13.123367,6.462097e-3,-5.449684,-9.530803,-13.611922,-17.69304,-21.774162,-25.85528,-29.936398,-34.017517,-38.098637,-42.17976,-46.260876,52.256042,50.21529,48.17453,46.133778,44.09302,42.052265,40.01151,38.332867,38.24758,38.162296,38.07701,37.991726,37.906437,37.82115,37.735867,37.65058,37.565296,37.48001,37.394726,37.30944,37.224155,37.13887,37.053585,36.9683,36.88301,36.797726,36.71244,36.627155,36.54187,36.456585,36.3713,36.286015,36.20073,36.115444,36.03016,35.94487,35.859585,35.7743,35.689014,35.60373,35.518444,35.43316,35.347874,35.26259,35.177303,35.09202,35.00673,34.921444,34.83616,34.750874,34.66559,34.580303,40.851967,27.735023,14.618082,1.5011406,-8.079979,-12.161097,-16.242214,-20.323332,-24.40445,-28.485567,-32.56669,-36.647804,-40.72892,-44.81004,-48.891155,53.285397,51.24464,49.20388,47.163124,45.122364,43.081608,41.04085,39.000095,38.22677,38.141483,38.0562,37.970913,37.885628,37.800343,37.715057,37.629772,37.544487,37.4592,37.373913,37.288628,37.203342,37.118057,37.032772,36.947487,36.8622,36.776917,36.69163,36.606346,36.52106,36.435776,36.35049,36.2652,36.179916,36.09463,36.009346,35.92406,35.838776,35.75349,35.668205,35.58292,35.497635,35.41235,35.327065,35.241776,35.15649,35.071205,34.98592,34.900635,34.81535,34.730064,34.64478,34.559494,29.229818,16.112902,2.995985,-10.120934,-14.79133,-18.872448,-22.953566,-27.034681,-31.115799,-35.196915,-39.278034,-43.35915,-47.44027,-51.521385,-55.602505,56.355488,54.31473,52.273975,50.23322,48.192463,46.151703,44.110947,42.07019,40.029434,38.20596,38.120674,38.03539,37.950104,37.86482,37.77953,37.694244,37.60896,37.523674,37.43839,37.353104,37.26782,37.182533,37.097248,37.011963,36.926678,36.841393,36.756107,36.67082,36.585533,36.500248,36.414963,36.329678,36.244392,36.159107,36.073822,35.988537,35.90325,35.817966,35.73268,35.647392,35.56211,35.47682,35.391537,35.30625,35.220966,35.13568,35.050396,34.96511,34.879826,34.79454,34.709255,34.62397,30.724606,17.60771,4.4908123,-8.62608,-17.421564,-21.502686,-25.583805,-29.664927,-33.746048,-37.82717,-41.90829,-45.989414,-50.070534,-54.151653,-58.232777,57.384857,55.3441,53.303345,51.262585,49.22183,47.181072,45.140316,43.09956,41.058804,39.018047,38.09986,38.014572,37.929287,37.844,37.758717,37.67343,37.588146,37.50286,37.417576,37.33229,37.247005,37.16172,37.076435,36.99115,36.90586,36.820576,36.73529,36.650005,36.56472,36.479435,36.39415,36.308865,36.22358,36.138294,36.05301,35.967724,35.88244,35.79715,35.711864,35.62658,35.541294,35.45601,35.370724,35.28544,35.200153,35.11487,35.029583,34.944298,34.859013,34.773727,34.68844,32.219376,19.102448,5.985523,-7.131405,-20.051859,-24.132977,-28.214096,-32.29521,-36.376328,-40.45745,-44.538567,-48.619682,-52.700806,-56.78192,-60.86304,-64.94415]
− examples/rasterize/rasterize-test2.txt
@@ -1,4 +0,0 @@-[((-309,-170),-11.445068),((-397,-258),39.884766),((-280,-273),39.814148),((-324,-236),79.39956),((-349,-182),59.562397),((-375,-221),54.81807),((-410,-194),75.88132),((-383,-188),48.284355),((-404,-225),37.207848),((-316,-199),29.185278),((-305,-213),43.06239),((-362,-201),56.988422),((-374,-256),158.54184),((-350,-246),84.5153),((-335,-252),121.0145),((-342,-262),371.26556),((-361,-258),461.29483),((-371,-267),346.42474),((-363,-251),221.5157),((-367,-241),134.81987),((-353,-260),441.5962),((-332,-271),140.75253),((-318,-277),66.3733)]-[(6,8,7),(8,5,7),(8,19,5),(12,17,16),(19,12,18),(12,16,18),(18,16,20),(11,13,3),(3,9,11),(3,10,9),(2,10,3),(3,22,2),(14,15,21),(22,14,21),(3,14,22),(13,14,3),(15,14,13),(20,15,13),(18,20,13),(19,18,13),(5,19,13),(11,5,13),(7,5,11),(7,11,4),(11,9,4),(9,0,4),(17,12,1),(19,1,12),(8,1,19)]-((-385,-257),(-319,-191))-[99.89475,95.73703,91.57931,87.421585,83.26386,79.10614,78.22758,78.754395,79.28121,79.80802,80.33484,80.86166,81.38847,81.91528,82.4421,82.96892,83.49573,84.022545,84.54936,85.07618,85.60299,86.12981,86.656624,87.18344,84.782684,81.22195,77.66122,74.10048,70.53975,66.97902,63.41828,59.85755,56.296814,52.736084,49.17535,48.702374,48.653236,48.6041,48.554962,48.50583,48.45669,48.407555,48.358418,48.30928,48.260147,48.21101,48.161873,48.112736,48.0636,48.01446,47.96533,47.91619,47.867054,47.817917,47.76878,47.719646,47.67051,47.621372,47.572235,47.523098,47.47396,47.424828,47.37569,47.326553,47.277416,47.253407,48.259827,107.4941,103.33639,99.17867,95.020966,90.86325,86.705536,80.83015,81.356964,81.88378,82.41059,82.93741,83.464226,83.991035,84.51785,85.04467,85.57149,86.0983,86.625114,87.15193,87.67874,88.20556,88.732376,89.259186,91.22216,87.66142,84.10069,80.539955,76.97922,73.41849,69.85775,66.29702,62.736282,59.17555,55.61481,52.054077,49.34097,49.291832,49.242695,49.193558,49.144424,49.095287,49.04615,48.997013,48.947876,48.898743,48.849606,48.80047,48.75133,48.702194,48.65306,48.603924,48.554787,48.50565,48.456512,48.407375,48.358242,48.309105,48.259968,48.21083,48.161694,48.11256,48.063423,48.014286,47.96515,47.91601,47.866875,47.81774,110.935745,106.77804,102.62032,98.462616,94.30491,90.1472,85.98949,84.48634,85.01315,85.53997,86.06679,86.593605,87.12042,87.64723,88.17405,88.70087,89.227684,89.7545,90.28131,90.80813,91.334946,91.86176,92.38858,90.54018,86.97944,83.4187,79.85796,76.297226,72.736496,69.17575,65.61502,62.054283,58.49354,54.932804,51.372066,49.930424,49.881287,49.83215,49.783016,49.73388,49.684742,49.635605,49.586468,49.537334,49.488197,49.43906,49.389923,49.340786,49.291653,49.242516,49.19338,49.14424,49.095104,49.045967,48.996834,48.947697,48.89856,48.849422,48.800285,48.751152,48.702015,48.652878,48.60374,48.554604,48.50547,48.456333,48.407196,118.535225,114.3775,110.21978,106.06206,101.90434,97.74662,93.5889,87.08891,87.61572,88.14254,88.66936,89.196175,89.72299,90.24981,90.77662,91.30344,91.83025,92.35707,92.88389,93.410706,93.937515,94.46433,96.97967,93.41893,89.8582,86.29746,82.736725,79.175995,75.61526,72.05453,68.49379,64.93306,61.372322,57.811584,54.250854,50.56902,50.519882,50.47075,50.42161,50.372475,50.323338,50.2742,50.225067,50.17593,50.126793,50.077656,50.02852,49.97938,49.93025,49.88111,49.831974,49.782837,49.7337,49.684566,49.63543,49.586292,49.537155,49.488018,49.438885,49.389748,49.34061,49.291473,49.242336,49.193203,49.144066,49.08673,48.972,121.97686,117.819145,113.66143,109.503716,105.346,101.188286,97.03057,92.872856,90.74511,91.27193,91.798744,92.325554,92.85237,93.37919,93.906,94.432816,94.95963,95.48645,96.01326,96.54008,97.066895,97.59371,96.29767,92.73693,89.1762,85.61546,82.054726,78.49399,74.93326,71.37252,67.81178,64.25105,60.690315,57.12958,53.568848,51.158478,51.109344,51.060207,51.01107,50.961933,50.912796,50.863663,50.814526,50.76539,50.71625,50.667114,50.61798,50.568844,50.519707,50.47057,50.421432,50.372295,50.323162,50.274025,50.224888,50.17575,50.126614,50.07748,50.028343,49.979206,49.93007,49.831738,49.71701,49.60228,49.487553,49.37282,49.25809,129.57634,125.41862,121.260895,117.103165,112.94544,108.78772,104.62999,100.47226,96.31454,93.87449,94.401306,94.928116,95.45493,95.98175,96.50857,97.03538,97.562195,98.08901,98.61583,99.14265,99.66946,100.19627,99.176476,95.61574,92.055,88.49426,84.933525,81.37279,77.81205,74.25131,70.690575,67.12984,63.569103,60.008366,56.447628,51.797073,51.747936,51.6988,51.649662,51.600525,51.551388,51.502254,51.453117,51.40398,51.354843,51.305706,51.256573,51.207436,51.1583,51.10916,51.060024,51.01089,50.961754,50.912617,50.86348,50.814342,50.765205,50.691475,50.576744,50.462017,50.347286,50.23256,50.11783,50.003098,49.88837,49.77364,49.658913,133.7453,128.86026,124.70254,120.544815,116.3871,112.22938,108.071655,103.91394,99.75621,97.00387,97.530685,98.0575,98.58432,99.11113,99.63795,100.164764,100.69158,101.21839,101.74521,102.272026,102.79884,102.05522,98.494484,94.93375,91.373,87.81226,84.251526,80.69079,77.13005,73.56931,70.008575,66.44784,62.8871,59.32636,55.765625,52.38653,52.337395,52.288258,52.23912,52.189983,52.14085,52.091713,52.042576,51.99344,51.9443,51.89517,51.84603,51.796894,51.747757,51.69862,51.649487,51.60035,51.551212,51.43648,51.321754,51.207024,51.092297,50.977566,50.86284,50.748108,50.633377,50.51865,50.40392,50.289192,50.17446,50.05973,49.945004,147.89052,136.45961,132.3019,128.14418,123.986465,119.82875,115.671036,111.51332,107.355606,103.19789,100.133255,100.66007,101.18689,101.7137,102.24052,102.767334,103.29414,103.82096,104.34778,104.87459,105.401405,104.93397,101.37323,97.81249,94.251755,90.691025,87.13029,83.56955,80.00882,76.44808,72.887344,69.326614,65.76588,62.20514,58.644405,55.083668,52.97599,52.926853,52.877716,52.828583,52.779446,52.73031,52.68117,52.632034,52.5829,52.533764,52.484627,52.43549,52.41095,52.296223,52.18149,52.066765,51.952034,51.837303,51.722576,51.607845,51.49312,51.378387,51.263657,51.14893,51.0342,50.919468,50.80474,50.69001,50.575283,50.460552,50.34684,146.72606,139.90137,135.74365,131.58592,127.4282,123.27048,119.112755,114.95503,110.7973,106.63959,103.26264,103.78945,104.31627,104.84309,105.369896,105.89671,106.42353,106.95034,107.47716,108.003975,107.812706,104.251976,100.69124,97.1305,93.56976,90.009026,86.44829,82.88756,79.32681,75.76608,72.205345,68.64461,65.08387,61.523132,57.9624,54.401657,53.565445,53.516308,53.467175,53.418037,53.3689,53.319763,53.270626,53.221493,53.155956,53.04123,52.9265,52.81177,52.69704,52.582314,52.467583,52.352856,52.238125,52.123398,52.008667,51.89394,51.77921,51.664482,51.54975,51.43502,51.320293,51.205563,51.090836,50.976105,50.861378,50.748936,50.64489,160.87128,147.50072,143.343,139.18529,135.02757,130.86986,126.712135,122.55441,118.3967,114.23898,110.08126,106.39202,106.91884,107.445656,107.97247,108.49928,109.0261,109.55292,110.079735,110.606544,110.69146,107.13073,103.56999,100.00926,96.448524,92.88779,89.32706,85.76632,82.20559,78.64485,75.08412,71.523384,67.96265,64.40192,60.84118,57.28045,54.204044,54.154907,54.10577,54.056633,54.015694,53.900967,53.786236,53.67151,53.556778,53.44205,53.32732,53.212593,53.097862,52.983135,52.868404,52.753677,52.638947,52.524216,52.40949,52.294758,52.18003,52.0653,51.950573,51.835842,51.721115,51.606384,51.491657,51.376926,51.2622,51.151028,51.04698,159.70679,150.94249,146.78476,142.62703,138.4693,134.31158,130.15385,125.996124,121.838394,117.68067,113.52295,109.5214,110.04822,110.575035,111.101845,111.62866,112.15547,112.68229,113.20911,113.5702,110.00947,106.44873,102.88799,99.327255,95.766525,92.20579,88.64505,85.08432,81.52358,77.962845,74.402115,70.841385,67.28064,63.719906,60.159172,56.59844,54.760704,54.645977,54.531246,54.41652,54.30179,54.187057,54.07233,53.9576,53.842873,53.72814,53.613415,53.498684,53.383953,53.269226,53.154495,53.03977,52.925037,52.81031,52.69558,52.580853,52.46612,52.35139,52.236664,52.121933,52.007206,51.892475,51.77775,51.663017,51.55312,51.44907,51.345024,173.852,158.54184,154.38412,150.22641,146.0687,141.91098,137.75327,133.59555,129.43784,125.280106,121.12239,116.964676,112.65078,113.1776,113.704414,114.231224,114.75804,115.28486,115.811676,116.44895,112.888214,109.327484,105.76675,102.20601,98.64528,95.08454,91.52381,87.96307,84.402336,80.841606,77.28087,73.72014,70.1594,67.755745,61.88085,56.00596,55.60377,55.201584,54.932068,54.81734,54.70261,54.587883,54.473152,54.35842,54.243694,54.128963,54.014236,53.899506,53.78478,53.670048,53.55532,53.44059,53.325863,53.211132,53.0964,52.981674,52.866943,52.752216,52.637486,52.52276,52.408028,52.2933,52.17857,52.059265,51.955215,51.851166,51.74712,185.70709,164.02136,158.6232,153.66808,149.51036,145.35265,141.19493,137.03722,132.8795,128.72179,124.56407,120.40636,116.24864,116.30698,116.83379,117.36061,117.88743,118.414246,118.941055,115.76696,112.20623,108.64549,105.08476,101.524025,97.963295,94.40256,90.84183,87.28109,83.72035,80.15962,76.59889,71.88107,66.00618,60.131294,56.992752,56.590565,56.188377,55.78619,55.384,55.10343,54.9887,54.873974,54.759243,54.644512,54.529785,54.415054,54.300327,54.185596,54.07087,53.95614,53.84141,53.72668,53.611954,53.497223,53.382492,53.267765,53.153034,53.038307,52.923576,52.80885,52.69412,52.57939,52.46466,52.357307,52.253258,52.149208,52.045162,212.87228,196.23668,169.50089,164.10275,158.70462,152.95207,148.79436,144.63664,140.47893,136.3212,132.16348,128.00577,123.848045,118.909546,119.43636,119.96318,120.49,121.016815,122.20645,118.64571,115.084984,111.52425,107.96352,104.40278,100.84204,97.28131,93.72058,90.15984,86.599106,81.881294,76.00641,70.131516,64.25663,58.381737,57.97955,57.577362,57.175175,56.772984,56.370796,55.96861,55.56642,55.274796,55.160065,55.045334,54.930607,54.815876,54.70115,54.58642,54.47169,54.35696,54.24223,54.127502,54.01277,53.898045,53.783314,53.668587,53.553856,53.439125,53.324398,53.209667,53.09494,52.98021,52.863445,52.7594,52.65535,52.5513,52.447254,228.83853,200.64885,174.9804,169.58226,164.18411,158.78598,153.38785,148.07831,143.9206,139.76288,135.60516,131.44745,127.28972,123.132,122.56575,123.09256,123.61938,124.146194,121.52451,117.963776,114.40303,110.84229,107.281555,103.72082,100.16008,96.599335,91.88152,86.00664,80.131744,74.25685,68.381966,62.50707,59.36853,58.966343,58.564156,58.16197,57.759777,57.35759,56.955402,56.553215,56.151024,55.748837,55.446156,55.331425,55.216698,55.101967,54.98724,54.87251,54.757782,54.64305,54.52832,54.413593,54.298862,54.184135,54.069405,53.954678,53.839947,53.725216,53.61049,53.495758,53.38103,53.2663,53.16149,53.05744,52.953392,52.849346,52.745296,262.8001,233.93083,205.06157,180.45992,175.06177,169.66364,164.26549,158.86736,153.46921,148.07108,143.20454,139.04683,134.88911,130.7314,125.16832,125.69513,126.22195,127.964,124.40326,120.84252,117.281784,113.72105,110.16031,107.756645,101.88175,96.00686,90.13197,84.25708,78.38219,72.50729,66.63241,60.757515,60.355328,59.95314,59.55095,59.14876,58.746574,58.344387,57.9422,57.54001,57.13782,56.735634,56.333447,55.93126,55.61752,55.50279,55.38806,55.27333,55.158604,55.043873,54.929146,54.814415,54.699688,54.584957,54.47023,54.3555,54.24077,54.12604,54.01131,53.896584,53.781853,53.667633,53.563583,53.459538,53.355488,53.25144,53.147392,267.21292,238.34358,209.47424,185.93944,180.54129,175.14314,169.74501,164.34686,158.94872,153.55057,148.15244,142.75429,138.33078,134.17307,130.01537,128.82451,129.35133,127.28201,123.72127,120.16053,116.59979,111.88197,106.00708,100.132195,94.2573,88.382416,82.50752,76.63263,70.75774,64.88285,61.74431,61.34212,60.939934,60.537746,60.13556,59.73337,59.331184,58.928993,58.526806,58.12462,57.72243,57.320244,56.918056,56.51587,56.113678,55.788883,55.674152,55.559425,55.444695,55.329967,55.215237,55.100506,54.98578,54.871048,54.75632,54.64159,54.526863,54.412132,54.2974,54.182674,54.069725,53.965675,53.86163,53.75758,53.65353,53.549484,53.445435,300.49503,271.62576,242.75652,213.88724,191.41904,186.02089,180.62274,175.22461,169.82646,164.42831,159.03017,153.63202,148.23387,142.83572,137.61478,131.42708,133.72148,130.16075,126.60001,121.882195,116.00731,110.132416,104.25752,98.38264,92.507744,86.63286,80.757965,74.88307,69.00818,63.133293,62.731106,62.32892,61.926727,61.52454,61.122353,60.720165,60.317978,59.915787,59.5136,59.111412,58.709225,58.307037,57.904846,57.50266,57.10047,56.698284,56.296093,55.960243,55.845516,55.730785,55.61606,55.501328,55.386597,55.27187,55.15714,55.04241,54.92768,54.812954,54.698223,54.583492,54.471817,54.367767,54.26372,54.15967,54.055622,53.951576,53.847527,304.9071,276.03796,247.16887,218.29976,196.89856,191.50041,186.10226,180.70412,175.30597,169.90782,164.50967,159.11153,153.71338,148.31523,142.91708,137.51895,131.88243,126.00754,120.132645,114.25775,108.382866,102.507965,96.63309,90.758194,84.8833,79.00841,73.133514,67.25863,64.12009,63.7179,63.315712,62.913525,62.511337,62.10915,61.70696,61.30477,60.902584,60.500397,60.09821,59.696022,59.29383,58.891644,58.489456,58.08727,57.68508,57.28289,56.880703,56.478516,56.131607,56.01688,55.90215,55.787422,55.67269,55.557964,55.443233,55.328506,55.213776,55.09905,54.984318,54.873913,54.769863,54.665817,54.561768,54.457718,54.35367,54.249622,54.145573,338.18912,309.31995,280.45078,251.5816,222.71242,202.37807,196.97992,191.58177,186.18362,180.78549,175.38734,169.9892,164.59105,162.07732,150.91035,139.7434,130.13289,124.258,118.38311,112.50822,106.63332,100.75843,94.88354,89.008644,83.13375,77.25885,71.383965,65.50907,65.10688,64.7047,64.302505,63.90032,63.49813,63.095943,62.693756,62.29157,61.88938,61.48719,61.085003,60.682816,60.28063,59.87844,59.476254,59.074066,58.671875,58.269688,57.8675,57.465313,57.063126,56.66094,56.30297,56.188244,56.073513,55.958786,55.844055,55.729324,55.614597,55.499866,55.380054,55.276005,55.171955,55.06791,54.96386,54.85981,54.755764,54.651714,54.54767,342.602,313.73276,284.86353,255.99431,227.12508,207.8576,202.45946,197.06131,191.66315,186.26501,180.86685,172.58429,161.41728,150.25029,139.0833,128.38329,122.50839,116.6335,110.75861,104.88373,99.00884,93.13396,87.25906,81.38418,75.50929,69.6344,66.495865,66.09368,65.69149,65.2893,64.887115,64.484924,64.08274,63.68055,63.278362,62.876175,62.473984,62.071796,61.66961,61.26742,60.865234,60.463043,60.060856,59.65867,59.25648,58.854294,58.452103,58.049915,57.647728,57.24554,56.843353,56.474335,56.359604,56.244877,56.130146,56.015415,55.90069,55.785957,55.678097,55.574047,55.47,55.36595,55.2619,55.157856,55.053806,54.94976,54.84571,375.88403,347.01477,318.1455,289.27625,260.40698,231.5377,213.33711,207.93896,202.5408,194.25824,183.09126,171.92427,160.7573,149.5903,138.42331,126.63374,120.75885,114.883965,109.00907,103.134186,97.25929,91.38441,85.50952,79.63463,73.759735,67.88485,67.48266,67.080475,66.67828,66.2761,65.87391,65.471725,65.069534,64.66734,64.26516,63.86297,63.46078,63.058594,62.656406,62.25422,61.852028,61.44984,61.047653,60.645466,60.24328,59.84109,59.438904,59.036713,58.634525,58.232338,57.83015,57.427963,57.025772,56.6457,56.530968,56.416237,56.30151,56.184235,56.08019,55.97614,55.872093,55.768044,55.663994,55.559948,55.4559,55.351852,55.247803,380.2961,351.42694,322.55777,293.6886,264.81946,235.95029,215.9322,204.76523,193.59825,182.43127,171.26428,160.09732,148.93033,137.76335,126.596375,119.00932,113.13443,107.25954,101.38464,95.50975,89.63486,83.75997,77.88508,72.010185,68.87164,68.46946,68.06727,67.66508,67.26289,66.8607,66.45852,66.05633,65.65414,65.25195,64.84976,64.44758,64.04539,63.6432,63.241013,62.83882,62.436634,62.034447,61.63226,61.230072,60.82788,60.425694,60.023506,59.62132,59.21913,58.81694,58.414753,58.012566,57.61038,57.20819,56.81706,56.70233,56.5876,56.482285,56.378235,56.274185,56.17014,56.06609,55.962044,55.857994,55.753944,55.6499,55.54585,413.5782,384.709,355.83984,322.58194,284.9353,246.05748,215.27217,204.1052,192.93823,181.77126,170.60428,159.43732,148.27036,137.1034,125.93641,117.25979,111.384895,105.51,99.6351,93.76021,87.885315,82.01042,76.13553,70.26063,69.85844,69.45625,69.05406,68.65188,68.24969,67.847496,67.44531,67.04312,66.64094,66.23875,65.83656,65.43437,65.03218,64.63,64.227806,63.82562,63.42343,63.021244,62.619057,62.216866,61.81468,61.41249,61.010303,60.608116,60.205925,59.803738,59.40155,58.999363,58.597176,58.194984,57.7928,57.39061,56.988422,56.884373,56.780327,56.676277,56.57223,56.46818,56.364132,56.260086,56.156036,56.05199,55.94794,404.8247,367.17792,329.5312,291.8844,257.93103,232.59538,207.25974,192.27818,181.1112,169.94421,158.77724,147.61026,136.44327,125.27629,115.51018,109.63529,103.7604,97.88551,92.01063,86.135735,80.26085,74.385956,71.24742,70.84524,70.44305,70.040855,69.63867,69.23648,68.8343,68.432106,68.02992,67.62773,67.22554,66.82336,66.421165,66.01898,65.61679,65.2146,64.812416,64.410225,64.00804,63.60585,63.203663,62.801476,62.399284,61.9971,61.59491,61.192722,60.790535,60.388348,59.98616,59.58397,59.131733,58.52934,57.926945,57.056885,56.642334,57.18242,57.07837,56.974323,56.870274,56.766224,56.662178,56.55813,56.454082,56.350033,56.245983,411.7741,374.12738,336.48068,295.14066,269.80493,244.46924,219.13354,191.61813,180.45117,169.2842,158.11723,146.95026,135.7833,124.616325,113.76065,107.88576,102.010864,96.13597,90.26108,84.38619,78.5113,72.636406,72.234215,71.83203,71.42984,71.02766,70.625465,70.223274,69.82109,69.4189,69.016716,68.614525,68.21233,67.81015,67.40796,67.005775,66.603584,66.20139,65.79921,65.39702,64.994835,64.59264,64.19045,63.78827,63.386078,62.98389,62.581703,62.179516,61.77733,61.275036,60.672646,60.07025,59.467857,58.865467,58.36345,57.12535,55.730385,56.296238,56.86209,57.376415,57.272366,57.16832,57.06427,56.960224,56.856174,56.752125,56.64808,381.0766,343.4298,307.0142,281.67862,256.34305,231.00748,205.6719,180.33632,168.62431,157.45732,146.29034,135.12335,123.956375,112.78939,106.136215,100.26132,94.38643,88.511536,82.636635,76.76174,73.6232,73.221016,72.818825,72.41663,72.01445,71.61226,71.210075,70.807884,70.40569,70.00351,69.60132,69.199135,68.79694,68.39476,67.99257,67.59038,67.188194,66.786,66.38381,65.98163,65.57944,65.17725,64.77506,64.37288,63.970688,63.418346,62.815952,62.21356,61.611164,61.008774,60.40638,59.803986,59.20159,58.43191,57.193813,55.95571,55.384296,55.95015,56.516003,57.081856,57.57041,57.466362,57.362316,57.258266,57.154217,57.05017,56.94612,388.02606,344.22375,318.88812,293.55252,268.21692,242.88129,217.54567,192.21005,167.96428,156.79727,145.63028,134.46327,123.29627,110.26149,104.386604,98.51172,92.63684,86.761955,80.88707,75.012184,74.60999,74.20781,73.80562,73.403435,73.00124,72.59905,72.19687,71.79468,71.392494,70.9903,70.58812,70.18593,69.78374,69.38155,68.97936,68.57718,68.17499,67.7728,67.37061,66.96842,66.56624,66.16405,65.56165,64.95926,64.356865,63.754475,63.15208,62.549686,61.947296,61.344902,60.742508,60.140114,59.738476,58.500378,57.26228,56.024185,54.472347,55.0382,55.604053,56.169907,56.73576,57.301613,57.76441,57.66036,57.556313,57.452263,57.348213,357.3289,330.76205,305.42642,280.09076,254.75513,229.41948,204.08383,178.74818,156.13725,144.97028,133.80328,122.63629,111.469315,102.63708,96.762184,90.8873,85.012405,79.13751,75.99898,75.596794,75.1946,74.79241,74.39023,73.98804,73.58585,73.18366,72.78148,72.37929,71.9771,71.57491,71.17272,70.77054,70.36835,69.966156,69.56397,69.16178,68.7596,68.30736,67.70496,67.10257,66.500175,65.89778,65.29539,64.69299,64.0906,63.488205,62.88581,62.283417,61.681023,61.07863,60.476234,59.806923,58.568825,57.33073,56.092636,54.85454,54.12626,54.692112,55.257965,55.82382,56.38967,56.955524,57.521378,57.958405,57.854355,57.75031,57.64626,367.97165,342.636,317.30032,291.96466,266.62897,241.2933,215.95764,190.62196,165.2863,144.31024,133.14328,121.9763,110.80934,100.88754,95.01265,89.13776,83.26286,77.38796,76.98577,76.58359,76.1814,75.77921,75.37702,74.97484,74.57265,74.170456,73.76827,73.36608,72.9639,72.56171,72.159515,71.75733,71.35514,71.053055,70.45067,69.848274,69.24588,68.643486,68.04109,67.4387,66.8363,66.23391,65.631516,65.02912,64.42673,63.824333,63.22194,62.619545,62.01715,61.414757,61.113483,59.875385,58.63729,57.399193,56.161095,54.923,53.214317,53.78017,54.346024,54.911877,55.47773,56.043583,56.609436,57.17529,57.741142,58.1524,58.04835,354.50925,329.17365,303.838,278.5024,253.16681,227.83119,202.49559,177.15997,151.82436,132.48323,121.31623,110.14924,99.137924,93.26305,87.38817,81.51329,78.374756,77.97257,77.57038,77.1682,76.76601,76.363815,75.96163,75.55944,75.15726,74.755066,74.35288,73.95069,73.5485,73.14632,72.59397,71.99158,71.38918,70.78679,70.1844,69.58201,68.979614,68.37722,67.774826,67.17243,66.57004,65.96764,65.36525,64.762856,64.16046,63.558067,62.955673,62.35328,61.750885,61.14849,59.94385,58.705757,57.46766,56.229565,54.99147,53.753372,52.868214,53.43407,53.999924,54.565777,55.13163,55.697483,56.263336,56.82919,57.395042,57.9609,58.346397,366.38315,341.04755,315.7119,290.37628,265.04065,239.70502,214.36938,189.03375,163.69814,131.8232,120.65623,109.48925,97.3884,91.51351,85.638626,79.76374,79.36155,78.959366,78.557175,78.15499,77.7528,77.35062,76.948425,76.54624,76.14405,75.74187,75.339676,74.73728,74.13489,73.53249,72.9301,72.327705,71.72531,71.12292,70.52052,69.91814,69.31574,68.71335,68.110954,67.50856,66.906166,66.30377,65.70138,65.09898,64.49659,63.894196,63.2918,62.689407,62.087017,61.250416,60.012318,58.77422,57.53612,56.298023,55.059925,53.82183,51.956272,52.52213,53.087982,53.653835,54.21969,54.78554,55.351395,55.917248,56.4831,57.048958,57.614807,352.92154,327.58594,302.2503,276.91467,251.57907,226.24347,200.90785,175.57224,150.2366,124.901,108.82935,97.66234,89.76398,83.88908,80.750534,80.34835,79.94616,79.54397,79.141785,78.73959,78.3374,77.93522,77.48298,76.880585,76.27819,75.6758,75.0734,74.47101,73.868614,73.26622,72.66383,72.06144,71.459045,70.85665,70.25426,69.65186,69.04947,68.447075,67.84468,67.24229,66.63989,66.037506,65.435104,64.83272,64.23032,63.62793,63.025536,62.42314,61.31888,60.08078,58.842686,57.604588,56.366493,55.128395,53.8903,52.652206,51.610176,52.176033,52.741886,53.30774,53.873592,54.43945,55.005302,55.571156,56.13701,56.702866,57.26872,361.28693,338.05637,314.12415,288.7885,263.45288,238.11725,212.78162,187.44597,162.11034,136.77472,108.16933,97.002365,88.01444,82.13952,81.73733,81.335144,80.93295,80.53076,80.12858,79.62629,79.023895,78.4215,77.81911,77.21671,76.61432,76.011925,75.40953,74.80714,74.20474,73.60235,72.999954,72.39757,71.79517,71.19278,70.590385,69.98799,69.3856,68.7832,68.18081,67.578415,66.97602,66.373634,65.77124,65.168846,64.56645,63.964058,63.361664,62.62544,61.38734,60.149242,58.911148,57.67305,56.43495,55.196854,53.95876,52.72066,50.698235,51.264088,51.82994,52.395798,52.96165,53.527504,54.093357,54.65921,55.225063,55.790916,56.35677,339.05396,315.82336,292.59277,269.36218,246.13156,222.90097,199.31952,173.98395,148.64836,123.312775,97.97719,86.26483,83.12631,82.72413,82.32194,81.76959,81.1672,80.564804,79.96242,79.36002,78.75763,78.155235,77.55284,76.95045,76.34805,75.74566,75.143265,74.54087,73.93848,73.33609,72.733696,72.1313,71.52891,70.92651,70.32412,69.721725,69.11933,68.51694,67.91454,67.31215,66.70976,66.10737,65.504974,64.90258,64.300186,63.697792,62.693905,61.455807,60.21771,58.97961,57.741512,56.503414,55.265316,54.027218,52.78912,51.55102,50.352146,50.918,51.483856,52.04971,52.615562,53.181416,53.74727,54.31312,54.878975,55.444828,56.01068,340.05225,316.82162,293.591,270.36035,247.12973,223.8991,200.66846,177.43782,154.20718,130.97656,107.74591,84.5153,83.9129,83.31051,82.708115,82.10572,81.50333,80.90093,80.298546,79.69615,79.09376,78.49136,77.88897,77.286575,76.68418,76.08179,75.47939,74.877,74.274605,73.67221,73.069824,72.46743,71.865036,71.26264,70.66025,70.05785,69.45546,68.853065,68.25067,67.64828,67.04588,66.44349,65.841095,65.23871,64.63631,64.000465,62.762367,61.52427,60.28617,59.048077,57.80998,56.57188,55.333786,54.095688,52.85759,51.61949,50.381397,50.00605,50.571903,51.137756,51.70361,52.269463,52.83532,53.401173,53.967026,54.53288,55.098732,317.81943,294.5888,271.35815,248.12752,224.8969,201.66626,178.43564,155.20502,131.97437,109.91834,89.03685,84.24902,83.64664,83.04424,82.44185,81.839455,81.23706,80.63467,80.03227,79.42988,78.827484,78.22509,77.622696,77.02031,76.417915,75.81552,75.21313,74.61073,74.00834,73.405945,72.80355,72.20116,71.59877,70.996376,70.39398,69.79159,69.18919,68.5868,67.984406,67.38201,66.77962,66.17723,65.57484,64.97244,64.068924,62.83083,61.59273,60.354633,59.11654,57.87844,56.640343,55.402245,54.164146,52.92605,51.68795,50.449852,49.211754,49.65996,50.225815,50.791668,51.35752,51.923378,52.48923,53.055084,53.620937,54.18679,54.752644,318.8172,295.58655,272.35596,249.12534,225.89471,202.6641,179.43347,156.20287,135.32129,114.4397,90.05225,86.70023,83.982765,83.38037,82.77798,82.17558,81.57319,80.970795,80.3684,79.76601,79.16361,78.56122,77.958824,77.35643,76.75404,76.15165,75.549255,74.94686,74.34447,73.74207,73.13968,72.537285,71.93489,71.3325,70.7301,70.12771,69.525314,68.92292,68.320526,67.71814,67.11574,66.51335,65.91096,65.37547,64.137375,62.899277,61.66118,60.423084,59.184986,57.94689,56.708794,55.470695,54.232597,52.994503,51.756405,50.51831,49.280212,48.74802,49.313873,49.879726,50.44558,51.011433,51.577286,52.143143,52.708992,53.27485,53.840702,296.58438,273.35376,250.12318,226.89258,203.66197,181.60588,160.72433,139.84277,118.96122,98.07967,89.468735,86.11671,83.71649,83.1141,82.5117,81.90931,81.30692,80.70453,80.102135,79.49974,78.89735,78.29495,77.69256,77.090164,76.48777,75.885376,75.28299,74.68059,74.0782,73.47581,72.87341,72.27102,71.668625,71.06623,70.46384,69.86144,69.25905,68.656654,68.05426,67.45187,66.84948,66.247086,65.44394,64.20584,62.967743,61.72965,60.49155,59.253456,58.015358,56.777264,55.539165,54.30107,53.062973,51.824875,50.58678,49.348686,48.110588,48.401924,48.967777,49.53363,50.099483,50.665337,51.231194,51.797047,52.3629,52.928753,53.494606,297.58218,274.35162,251.12103,227.89044,207.00885,186.12727,165.24568,144.3641,123.482506,95.5892,92.2372,88.8852,85.5332,83.45024,82.84785,82.24545,81.64306,81.040665,80.43827,79.83588,79.23348,78.63109,78.028694,77.4263,76.823906,76.22151,75.61912,75.01672,74.41433,73.811935,73.20954,72.60715,72.00476,71.40236,70.79997,70.19757,69.595184,68.99279,68.390396,67.788,67.18561,66.750496,65.512405,64.27431,63.03621,61.79811,60.560013,59.32192,58.08382,56.845722,55.607628,54.36953,53.13143,51.893333,50.65524,49.417145,48.179047,47.489983,48.055836,48.62169,49.187542,49.753395,50.31925,50.8851,51.45096,52.01681,52.582664,275.3495,253.29344,232.41188,211.5303,190.64874,169.76718,148.88562,128.00404,107.12248,95.0057,91.65369,88.30168,84.94967,83.18397,82.58157,81.97918,81.376785,80.77439,80.172,79.56961,78.96722,78.36482,77.76243,77.160034,76.55764,75.955246,75.35285,74.75046,74.14806,73.54567,72.943275,72.34088,71.73849,71.13609,70.53371,69.93131,69.32892,68.726524,68.12413,67.521736,66.81896,65.58087,64.34277,63.104675,61.866577,60.628483,59.390385,58.15229,56.914192,55.676098,54.438,53.199905,51.961807,50.72371,49.485615,48.24752,47.009422,47.143887,47.70974,48.275593,48.841446,49.4073,49.973152,50.53901,51.104862,51.670715,52.23657,278.69644,257.8149,236.93335,216.0518,195.17026,174.2887,153.40715,132.5256,111.64404,97.7742,94.42218,91.07017,87.71815,83.520096,82.9177,82.31531,81.71291,81.11052,80.508125,79.90573,79.30334,78.70094,78.09855,77.496155,76.89377,76.291374,75.68898,75.086586,74.48419,73.8818,73.2794,72.67701,72.074615,71.47222,70.86983,70.26744,69.66504,69.06265,68.46026,68.12553,66.88743,65.64933,64.41124,63.173138,61.935043,60.696945,59.458847,58.22075,56.982655,55.744556,54.506462,53.268364,52.030266,50.792168,49.55407,48.315975,47.077877,46.231945,46.7978,47.36365,47.929504,48.495358,49.06121,49.627064,50.192917,50.758774,51.324627,262.3363,241.45473,220.57315,199.69157,178.81001,157.92844,137.04688,116.16531,100.54265,97.19064,93.83863,90.48662,87.13461,83.7826,82.651436,82.04904,81.44665,80.84425,80.24186,79.639465,79.03708,78.434685,77.83229,77.2299,76.6275,76.02511,75.422714,74.82032,74.217926,73.61553,73.01314,72.41074,71.80835,71.20596,70.60357,70.001175,69.39878,68.79639,68.19399,66.955894,65.7178,64.4797,63.241604,62.003506,60.765408,59.52731,58.28921,57.051113,55.81302,54.57492,53.336823,52.098724,50.860626,49.622528,48.38443,47.14633,45.908234,45.885857,46.45171,47.017563,47.583416,48.14927,48.715122,49.280975,49.84683,50.41268,50.978535,266.85776,245.97621,225.09465,204.21309,183.33153,162.44997,141.5684,120.68686,103.31114,99.95913,96.60712,93.255104,89.90308,86.55107,82.98756,82.38516,81.782776,81.18038,80.57799,79.97559,79.3732,78.770805,78.16841,77.56602,76.96362,76.36124,75.75884,75.15645,74.554054,73.95166,73.349266,72.74687,72.144485,71.54209,70.9397,70.3373,69.73491,69.132515,68.26246,67.02436,65.78626,64.548164,63.31007,62.07197,60.833874,59.59578,58.35768,57.119583,55.881485,54.64339,53.405293,52.167194,50.9291,49.691,48.452904,47.214806,45.97671,44.973907,45.53976,46.105614,46.671467,47.23732,47.803173,48.369026,48.934883,49.500736,50.06659,250.4974,229.61584,208.7343,187.85275,166.97119,146.08963,125.208084,106.079605,102.72759,99.37558,96.02357,92.671555,89.31954,85.96753,82.72129,82.1189,81.5165,80.91411,80.311714,79.70933,79.10693,78.50454,77.902145,77.29975,76.69736,76.09496,75.49258,74.89018,74.28779,73.685394,73.083,72.480606,71.87822,71.275826,70.67343,70.07104,69.46864,68.330925,67.09283,65.85473,64.61663,63.378532,62.140434,60.902336,59.664238,58.426144,57.188046,55.949947,54.71185,53.47375,52.235657,50.99756,49.75946,48.521362,47.283264,46.045166,44.807068,44.62782,45.193672,45.759525,46.32538,46.89123,47.457085,48.022938,48.58879,49.154644,49.720497,255.01912,234.13754,213.25597,192.37439,171.49283,150.61125,129.72968,108.8481,105.49609,102.14408,98.792076,95.44006,92.08806,88.73605,85.38404,82.45503,81.85264,81.250244,80.64785,80.045456,79.44307,78.840675,78.23828,77.63589,77.03349,76.4311,75.828705,75.22631,74.62392,74.02152,73.41913,72.816734,72.21434,71.611946,71.00955,70.40716,69.63748,68.39938,67.161285,65.92319,64.68509,63.446995,62.208897,60.9708,59.732704,58.494606,57.256508,56.01841,54.780315,53.542217,52.304123,51.066025,49.827927,48.58983,47.35173,46.113636,44.87554,43.715862,44.28172,44.847572,45.413425,45.97928,46.545135,47.11099,47.67684,48.242695,48.80855,238.65878,217.77727,196.89575,176.01422,155.13269,134.25117,113.36966,108.26459,104.912575,101.56056,98.20856,94.856544,91.50453,88.15252,84.80051,82.18877,81.58637,80.98398,80.381584,79.77919,79.176796,78.5744,77.97201,77.36961,76.76722,76.16483,75.56244,74.960045,74.35765,73.75526,73.15286,72.55047,71.948074,71.34568,70.743286,69.70594,68.46785,67.22975,65.99165,64.753555,63.515457,62.27736,61.03926,59.801163,58.563065,57.32497,56.086872,54.848774,53.61068,52.37258,51.134483,49.896385,48.658287,47.42019,46.18209,44.943996,43.705894,43.369778,43.93563,44.501484,45.067337,45.63319,46.199043,46.764896,47.33075,47.896606,48.46246,232.16034,222.29897,201.41736,180.53574,159.65414,138.77252,114.385056,111.03304,107.68104,104.329025,100.97702,97.62501,94.272995,90.92099,87.568985,84.21697,81.9225,81.32011,80.71771,80.11532,79.512924,78.91053,78.30814,77.70575,77.103355,76.50096,75.89857,75.29617,74.69378,74.091385,73.48899,72.8866,72.2842,71.68181,71.012505,69.77441,68.53631,67.29821,66.06011,64.822014,63.58392,62.34582,61.107723,59.869625,58.631527,57.39343,56.155334,54.917236,53.67914,52.44104,51.20294,49.964844,48.726746,47.488647,46.25055,45.01245,43.774353,42.457836,43.02369,43.589542,44.155396,44.72125,45.2871,45.852955,46.418808,46.98466,47.550514,201.47409,196.0206,185.05702,164.1755,143.29398,122.41246,113.801544,110.44953,107.09752,103.74551,100.39349,97.04148,93.68947,90.33746,86.98544,83.63344,81.656235,81.05384,80.45145,79.84905,79.24666,78.644264,78.04187,77.439476,76.83708,76.23469,75.63229,75.0299,74.427505,73.82511,73.22272,72.62032,72.01793,71.080956,69.84286,68.60476,67.36666,66.12856,64.89047,63.652374,62.414276,61.176178,59.938084,58.699986,57.46189,56.223793,54.985695,53.7476,52.509506,51.271408,50.03331,48.79521,47.557117,46.31902,45.080925,43.842827,42.60473,42.111736,42.677593,43.243446,43.8093,44.375153,44.94101,45.506863,46.072716,46.638573,47.204426,176.24142,170.78793,165.33444,159.88094,147.81535,119.922005,116.56999,113.21799,109.865974,106.51396,103.16196,99.809944,96.45793,93.10593,89.753914,86.4019,81.992355,81.38996,80.78757,80.18517,79.58278,78.980385,78.37799,77.775604,77.17321,76.570816,75.96842,75.36603,74.76363,74.16124,73.558846,72.95645,72.38751,71.14942,69.91132,68.673225,67.43513,66.19703,64.95893,63.720837,62.48274,61.244644,60.006546,58.768448,57.53035,56.29225,55.054157,53.81606,52.577965,51.339867,50.10177,48.86367,47.625576,46.387478,45.14938,43.911285,42.673187,41.199795,41.765648,42.331505,42.897358,43.46321,44.029064,44.594917,45.16077,45.726624,46.29248,145.55524,140.10175,134.64825,129.19475,123.74125,119.3385,115.98649,112.634476,109.28246,105.93045,102.57844,99.226425,95.874405,92.5224,89.17038,85.818375,82.466354,81.123695,80.5213,79.918915,79.31652,78.71413,78.11173,77.50934,76.906944,76.30455,75.702156,75.09976,74.49737,73.89497,73.29258,72.45598,71.21788,69.97979,68.74169,67.50359,66.265495,65.027405,63.789303,62.55121,61.31311,60.075012,58.836918,57.59882,56.360725,55.122627,53.88453,52.646435,51.408337,50.170242,48.932144,47.694046,46.455948,45.217854,43.979755,42.74166,41.503563,40.8537,41.41955,41.98541,42.55126,43.117115,43.68297,44.248825,44.81468,45.38053,45.946384,124.908516,122.89453,120.88055,118.86656,117.70878,117.51426,118.75496,115.40295,112.050934,108.69892,105.34691,101.994896,98.64288,95.29087,91.93886,88.586845,85.23483,81.45982,80.85743,80.255035,79.65264,79.05025,78.44785,77.84546,77.24307,76.64068,76.038284,75.43589,74.833496,74.2311,73.76254,72.524445,71.28635,70.04825,68.81016,67.57206,66.33396,65.09586,63.857765,62.619667,61.381573,60.143475,58.905376,57.667282,56.429184,55.191086,53.952988,52.714893,51.476795,50.2387,49.000603,47.762505,46.524406,45.28631,44.04821,42.81012,41.57202,39.941757,40.50761,41.073463,41.63932,42.205173,42.771027,43.33688,43.902733,44.46859,45.034443,117.725586,115.71159,114.50031,114.30579,114.111275,113.91676,113.722244,113.527725,111.46741,108.1154,104.7634,101.411385,98.05938,94.70737,91.35536,88.00336,84.651344,81.29933,80.59117,79.98878,79.38638,78.78399,78.181595,77.5792,76.97681,76.37441,75.77202,75.16963,74.56723,73.83101,72.59291,71.35481,70.116714,68.87862,67.64052,66.40242,65.16432,63.926228,62.68813,61.45003,60.211937,58.97384,57.73574,56.497643,55.259544,54.021446,52.783348,51.54525,50.307156,49.069054,47.83096,46.592865,45.354763,44.11667,42.87857,41.640472,40.402374,39.595665,40.161522,40.727375,41.29323,41.85908,42.424934,42.99079,43.556644,44.122498,44.688354,112.556625,111.29185,111.09733,110.90281,110.70829,110.51377,110.31926,110.12474,109.93022,110.883865,107.53186,104.179855,100.82784,97.47584,94.12383,90.77182,87.419815,84.0678,80.9273,80.324905,79.72251,79.12012,78.51772,77.91533,77.312935,76.71054,76.10815,75.50575,75.13757,73.899475,72.66138,71.42328,70.18518,68.94708,67.708984,66.47089,65.232796,63.994698,62.7566,61.5185,60.280403,59.04231,57.80421,56.566116,55.32802,54.08992,52.85182,51.613724,50.375626,49.137527,47.89943,46.661335,45.42324,44.185143,42.947044,41.708946,40.470848,38.683716,39.24957,39.815422,40.381275,40.94713,41.512985,42.07884,42.64469,43.210545,44.167763,107.888855,107.694336,107.499825,107.305305,107.11079,106.916275,106.721756,106.52724,106.33272,106.13821,105.94369,103.59632,100.24431,96.8923,93.54029,90.188286,86.83627,83.48427,80.661026,80.05863,79.45624,78.85385,78.25146,77.64906,77.04667,76.444275,75.84189,75.20604,73.96794,72.72984,71.491745,70.25365,69.01555,67.77745,66.53935,65.301254,64.063156,62.82506,61.586964,60.348866,59.11077,57.872673,56.634575,55.396477,54.15838,52.92028,51.682182,50.444084,49.205986,47.96789,46.72979,45.491695,44.253597,43.0155,41.777405,40.539307,39.301205,38.337627,38.90348,39.469334,40.035187,40.60104,41.166893,41.732746,42.2986,42.86445,42.182877,104.48587,104.29135,104.09684,103.90232,103.7078,103.51328,103.31877,103.12425,102.92973,102.735214,102.5407,102.34618,103.01278,99.660774,96.30876,92.95676,89.60475,86.25274,82.900734,80.39476,79.79237,79.18998,78.587585,77.98519,77.3828,76.78041,76.17802,75.2745,74.03641,72.79831,71.56021,70.32211,69.084015,67.84592,66.60782,65.36972,64.13163,62.893528,61.655434,60.417336,59.179237,57.94114,56.70304,55.464947,54.22685,52.98875,51.750656,50.512558,49.27446,48.03636,46.798264,45.560165,44.32207,43.083973,41.84588,40.60778,39.369682,37.42568,37.99153,38.557384,39.123238,39.68909,40.254944,40.8208,41.386654,42.294952,41.246475,100.888374,100.693855,100.49934,100.304825,100.110306,99.91579,99.721275,99.52676,99.33224,99.137726,98.94321,98.74869,98.55417,98.35966,95.72527,92.37325,89.02123,85.66922,82.3172,80.128494,79.5261,78.923706,78.32131,77.71892,77.11653,76.51414,75.34295,74.10485,72.86675,71.628654,70.390564,69.152466,67.91437,66.67627,65.43817,64.20007,62.96198,61.72388,60.485786,59.24769,58.00959,56.771492,55.533398,54.2953,53.057205,51.819107,50.58101,49.34291,48.104816,46.86672,45.628624,44.390522,43.152428,41.91433,40.676235,39.438137,38.20004,37.07959,37.645443,38.211296,38.77715,39.343002,39.908855,40.47471,41.040565,40.31007,39.261593,97.48538,97.29087,97.09635,96.90183,96.70732,96.5128,96.31828,96.123764,95.92925,95.73473,95.540215,95.3457,95.151184,94.956665,94.762146,95.14174,91.78972,88.4377,85.08568,80.464615,79.86222,79.25983,78.65743,78.055046,77.45265,76.649506,75.41141,74.17331,72.93521,71.69711,70.459015,69.220924,67.98283,66.74473,65.50663,64.26853,63.030437,61.79234,60.55424,59.316147,58.07805,56.83995,55.601852,54.363758,53.12566,51.88756,50.649467,49.41137,48.17327,46.935173,45.69708,44.45898,43.220882,41.982788,40.74469,39.50659,38.268494,36.16765,36.7335,37.299355,37.865208,38.43106,38.99691,39.562763,40.422142,39.373665,38.325188,93.887886,93.69337,93.498856,93.30434,93.10982,92.915306,92.72079,92.52627,92.33175,92.13724,91.94272,91.7482,91.55369,91.35917,91.16465,90.97014,90.77562,87.85419,84.50218,81.15017,79.59597,78.99357,78.391174,77.78878,76.71797,75.47987,74.241776,73.00368,71.76558,70.52749,69.28939,68.05129,66.813194,65.575096,64.337,63.098904,61.86081,60.62271,59.384613,58.146515,56.90842,55.670326,54.432228,53.19413,51.95603,50.717937,49.47984,48.241745,47.003647,45.76555,44.52745,43.289356,42.051258,40.813164,39.575066,38.33697,37.09887,35.860775,36.387405,36.95326,37.51911,38.084965,38.650818,39.21667,38.437256,37.38878,36.3403,90.4849,90.29038,90.09587,89.90135,89.70683,89.512314,89.3178,89.12328,88.928764,88.73425,88.539734,88.345215,88.150696,87.956184,87.761665,87.56715,87.37263,87.178116,87.27065,83.91864,79.93209,79.3297,78.7273,78.02453,76.78643,75.54834,74.31024,73.07214,71.834045,70.59595,69.35785,68.11975,66.88166,65.64356,64.405464,63.167366,61.929268,60.69117,59.453075,58.214977,56.976883,55.738785,54.500687,53.26259,52.024494,50.786396,49.548298,48.310204,47.072105,45.834007,44.59591,43.35781,42.119717,40.88162,39.643524,38.405426,37.167328,35.92923,35.475464,36.041317,36.60717,37.17302,37.738873,38.54933,37.50085,36.452374,35.403896,86.887405,86.69289,86.49837,86.303856,86.10934,85.91482,85.7203,85.52579,85.33127,85.13675,84.94223,84.74772,84.5532,84.35868,84.16417,83.96965,83.77513,83.58061,83.3861,83.19158,79.9831,79.06343,78.092995,76.8549,75.6168,74.37871,73.14061,71.90251,70.66441,69.426315,68.18822,66.95012,65.71202,64.47392,63.23583,61.99773,60.759636,59.521538,58.28344,57.04534,55.807243,54.569145,53.331047,52.092953,50.854855,49.616756,48.378662,47.140564,45.902466,44.664368,43.42627,42.188175,40.950077,39.71198,38.473885,37.235783,35.997684,34.75959,35.129375,35.695225,36.261078,36.82693,37.392784,36.56445,35.515972,34.467495,33.419014,83.48441,83.2899,83.09538,82.90086,82.706345,82.51183,82.317314,82.122795,81.92828,81.733765,81.539246,81.34473,81.150215,80.955696,80.76118,80.56666,80.37215,80.17763,79.98311,79.78859,79.59408,79.39956,78.16146,76.92336,75.685265,74.447174,73.209076,71.97098,70.73288,69.49478,68.25668,67.018585,65.780495,64.5424,63.3043,62.0662,60.828102,59.590004,58.351906,57.11381,55.875717,54.63762,53.39952,52.161423,50.923325,49.685226,48.447136,47.209034,45.97094,44.73284,43.494743,42.25665,41.018547,39.780453,38.54236,37.304256,36.066162,34.828064,34.217422,34.783276,35.34913,35.91498,36.676517,35.62804,34.579563,33.531086,32.48261,79.88692,79.6924,79.49788,79.30337,79.10885,78.91433,78.71981,78.5253,78.33078,78.13626,77.94174,77.74723,77.55271,77.35819,77.29923,77.5114,77.723564,77.93573,78.147896,78.36006,78.33158,77.83787,77.11707,75.8389,74.56072,73.28255,72.03944,70.80134,69.56324,68.32514,67.08705,65.84895,64.610855,63.372757,62.13466,60.89656,59.658463,58.42037,57.18227,55.94417,54.706078,53.46798,52.22988,50.991783,49.753685,48.51559,47.277493,46.039394,44.8013,43.5632,42.325104,41.087006,39.848907,38.610813,37.37271,36.134617,34.89652,33.658424,33.871334,34.437187,35.003036,35.56889,34.691635,33.643158,32.59468,31.546204,30.497726,76.48393,76.28941,76.094894,75.900375,75.705864,75.511345,75.316826,74.986755,75.19891,75.41108,75.623245,75.8354,76.04757,76.259735,76.47189,76.68406,76.896225,77.10839,77.32055,77.75731,77.263596,76.76989,76.27618,76.11277,74.834595,73.55642,72.278244,71.00007,69.72189,68.44371,67.15552,65.91742,64.67932,63.441227,62.20313,60.96503,59.726936,58.48884,57.25074,56.01264,54.774548,53.53645,52.29835,51.060257,49.82216,48.58406,47.345963,46.10787,44.86977,43.63167,42.393578,41.15548,39.91738,38.679283,37.441185,36.203094,34.964996,33.7269,32.959385,33.525238,34.09109,34.803707,33.75523,32.706753,31.658278,30.6098,29.561323,72.88643,73.098595,73.31075,73.52292,73.735085,73.94725,74.15941,74.371574,74.58374,74.7959,75.008064,75.22023,75.432396,75.644554,75.85672,76.068886,76.281044,76.49321,76.68934,76.195625,75.70191,75.208206,74.71449,74.22078,73.72707,72.55211,71.27393,69.99576,68.71758,67.43941,66.161224,64.88305,63.604874,62.3267,61.048523,59.795395,58.557297,57.319202,56.081104,54.843006,53.604908,52.366814,51.128716,49.890617,48.65252,47.41442,46.176323,44.93823,43.70013,42.462032,41.223938,39.98584,38.74774,37.509644,36.271545,35.03345,33.795353,32.55726,32.613297,33.17915,33.745003,32.81883,31.77035,30.721872,29.673395,28.624916,27.576439,72.05909,72.271255,72.48342,72.69558,72.907745,73.11991,73.33208,73.544235,73.7564,73.96857,74.180725,74.39289,74.60506,74.81722,75.02938,75.24155,75.45371,75.66587,75.62136,75.12765,74.633934,74.14023,73.646515,73.1528,72.659096,72.16538,71.547806,70.26963,68.991455,67.71327,66.4351,65.15692,63.878746,62.600567,61.32239,60.044212,58.766037,57.48786,56.209686,54.91147,53.67337,52.435272,51.197174,49.959076,48.72098,47.482883,46.244785,45.006687,43.76859,42.530495,41.292397,40.0543,38.8162,37.578102,36.340004,35.101906,33.863808,32.62571,31.701357,32.26721,32.9309,31.882423,30.833946,29.78547,28.736992,27.688515,26.640038,71.44391,71.656075,71.86824,72.0804,72.292564,72.50473,72.716896,72.929054,73.14122,73.353386,73.565544,73.77771,73.989876,74.20204,74.4142,74.626366,74.83853,74.553375,74.05966,73.565956,73.07224,72.57853,72.08482,71.59111,71.097404,70.60369,70.10998,69.26532,67.987144,66.70897,65.43079,64.15262,62.87444,61.59626,60.318085,59.03991,57.76173,56.483555,55.205376,53.9272,52.649025,51.370846,50.09267,48.81449,47.551346,46.313248,45.075153,43.837055,42.59896,41.360863,40.122765,38.884666,37.646572,36.408478,35.17038,33.93228,32.694183,31.456089,31.355259,31.921112,30.946014,29.897537,28.84906,27.800583,26.752106,25.703629,24.655151]
− examples/rasterize/rasterize-test3.txt
@@ -1,4 +0,0 @@-[((-501,-48),-80.0),((-421,-167),-80.0),((-431,-189),-80.0),((-430,-199),-80.0),((-418,-227),-38.57129),((-397,-258),39.884766),((-410,-267),-80.0),((-432,-259),-1.5870361),((-447,-262),-41.32361),((-451,-276),-42.149414),((-375,-221),54.81807),((-410,-194),75.88132),((-383,-188),48.284355),((-404,-225),37.207848),((-401,-170),-33.527046),((-374,-256),158.54184),((-371,-267),346.42474),((-367,-241),134.81987)]-[(14,11,12),(11,13,12),(13,10,12),(13,17,10),(7,4,8),(6,4,7),(6,5,4),(16,15,5),(17,5,15),(13,5,17),(4,5,13),(13,11,4),(11,3,4),(8,4,3),(3,2,8),(3,11,2),(11,1,2),(14,1,11),(8,2,0),(9,8,0)]-((-449,-257),(-383,-191))-[-42.59036,-42.65867,-42.726974,-42.96707,-43.334618,-43.702164,-44.06971,-44.437256,-44.804802,-45.172348,-45.539894,-45.907444,-46.27499,-46.642536,-47.010082,-47.37763,-47.745174,-48.11272,-48.480267,-48.847813,-49.215363,-49.58291,-49.950455,-50.318,-50.685547,-51.053093,-51.42064,-51.788185,-52.15573,-52.523277,-52.890823,-53.25837,-53.62592,-53.993465,-54.36101,-54.728558,-55.096104,-55.46365,-55.831196,-56.198742,-56.566288,-56.933834,-57.301384,-57.66893,-58.036476,-58.404022,-58.77157,-59.139114,-59.50666,-59.874207,-60.241753,-60.6093,-60.976845,-61.34439,-61.711937,-62.079483,-62.44703,-62.81458,-63.18213,-63.549675,-63.91722,-64.28477,-64.65231,-65.01986,-65.387405,-65.75495,-66.1225,-42.421005,-42.78855,-43.156097,-43.523643,-43.89119,-44.258736,-44.62628,-44.993828,-45.361374,-45.72892,-46.096466,-46.464016,-46.831562,-47.19911,-47.566654,-47.9342,-48.301746,-48.669292,-49.03684,-49.404385,-49.77193,-50.13948,-50.507027,-50.874573,-51.24212,-51.609665,-51.97721,-52.344757,-52.712303,-53.07985,-53.447395,-53.81494,-54.182487,-54.550034,-54.917583,-55.285126,-55.652676,-56.02022,-56.387768,-56.755314,-57.12286,-57.490406,-57.857956,-58.225502,-58.59305,-58.960594,-59.32814,-59.695686,-60.063232,-60.43078,-60.798325,-61.16587,-61.533417,-61.900963,-62.26851,-62.636055,-63.0036,-63.37115,-63.738693,-64.10624,-64.473785,-64.84134,-65.208885,-65.57643,-65.94397,-66.31152,-66.67907,-43.345116,-43.71266,-44.080208,-44.447754,-44.8153,-45.182846,-45.550392,-45.91794,-46.285484,-46.65303,-47.02058,-47.388126,-47.755672,-48.12322,-48.490765,-48.85831,-49.225857,-49.593403,-49.960953,-50.3285,-50.696045,-51.06359,-51.431137,-51.798683,-52.16623,-52.533775,-52.90132,-53.268867,-53.636414,-54.00396,-54.37151,-54.73905,-55.1066,-55.474148,-55.841694,-56.20924,-56.576786,-56.944332,-57.311882,-57.67943,-58.046974,-58.41452,-58.782066,-59.149612,-59.51716,-59.884705,-60.25225,-60.619797,-60.987343,-61.35489,-61.72244,-62.08998,-62.45753,-62.825077,-63.192623,-63.56017,-63.92772,-64.29526,-64.66281,-65.03036,-65.3979,-65.76545,-66.132996,-66.50054,-66.86809,-67.235634,-67.60318,-43.901684,-44.26923,-44.636776,-45.004322,-45.371872,-45.739418,-46.106964,-46.47451,-46.842056,-47.209602,-47.57715,-47.944695,-48.31224,-48.679787,-49.047337,-49.414883,-49.78243,-50.149975,-50.51752,-50.885067,-51.252613,-51.62016,-51.987705,-52.355255,-52.7228,-53.090347,-53.457893,-53.82544,-54.192986,-54.56053,-54.928078,-55.295624,-55.66317,-56.030716,-56.398262,-56.765812,-57.133354,-57.500904,-57.86845,-58.235996,-58.603542,-58.97109,-59.33864,-59.70618,-60.07373,-60.441277,-60.808823,-61.17637,-61.543915,-61.91146,-62.279007,-62.646553,-63.0141,-63.381645,-63.74919,-64.11674,-64.48428,-64.85184,-65.219376,-65.58693,-65.95447,-66.32202,-66.68957,-67.05711,-67.42465,-67.792206,-68.15975,-44.060696,-45.00908,-45.88842,-46.054413,-46.295986,-46.663532,-47.031082,-47.39863,-47.766174,-48.13372,-48.501266,-48.868813,-49.23636,-49.603905,-49.97145,-50.338997,-50.706547,-51.074093,-51.44164,-51.809185,-52.17673,-52.544277,-52.911823,-53.279373,-53.646915,-54.014465,-54.38201,-54.749557,-55.117104,-55.48465,-55.852196,-56.21974,-56.587288,-56.954834,-57.32238,-57.68993,-58.057476,-58.425022,-58.79257,-59.160114,-59.52766,-59.895206,-60.262753,-60.630302,-60.99785,-61.365395,-61.73294,-62.100487,-62.468033,-62.83558,-63.203125,-63.57067,-63.938217,-64.30577,-64.67331,-65.04086,-65.4084,-65.775955,-66.14349,-66.51105,-66.87859,-67.24614,-67.613686,-67.98123,-68.34878,-68.716324,-69.08387,-42.346992,-43.295372,-44.243755,-45.192135,-46.14052,-47.088898,-48.129326,-48.29532,-48.46131,-48.69029,-49.05784,-49.425385,-49.79293,-50.160477,-50.528023,-50.89557,-51.263115,-51.63066,-51.998207,-52.365753,-52.7333,-53.10085,-53.468395,-53.83594,-54.203487,-54.571033,-54.93858,-55.306126,-55.67367,-56.04122,-56.408768,-56.776314,-57.14386,-57.511406,-57.878952,-58.2465,-58.614044,-58.98159,-59.349136,-59.716686,-60.084232,-60.45178,-60.819324,-61.18687,-61.554417,-61.921963,-62.28951,-62.657055,-63.024605,-63.39215,-63.759697,-64.12724,-64.49479,-64.862335,-65.22988,-65.59743,-65.96497,-66.33252,-66.700066,-67.06761,-67.435165,-67.802704,-68.17026,-68.537796,-68.90535,-69.27289,-69.64044,-41.58169,-42.53007,-43.47845,-44.426826,-45.375206,-46.323586,-47.271965,-48.220345,-49.168724,-50.117104,-50.536224,-50.702217,-50.86821,-51.084595,-51.45214,-51.819687,-52.187233,-52.55478,-52.922325,-53.28987,-53.657417,-54.024963,-54.392513,-54.76006,-55.127605,-55.49515,-55.862698,-56.230244,-56.59779,-56.96534,-57.332886,-57.70043,-58.067978,-58.435524,-58.80307,-59.170616,-59.538162,-59.90571,-60.273254,-60.640804,-61.00835,-61.375896,-61.743443,-62.11099,-62.478535,-62.846085,-63.21363,-63.581177,-63.948723,-64.31627,-64.683815,-65.05136,-65.41891,-65.78645,-66.154,-66.521545,-66.88909,-67.25664,-67.62419,-67.99173,-68.35928,-68.72683,-69.094376,-69.46192,-69.82947,-70.197014,-70.56456,-38.22489,-40.81637,-41.764748,-42.713127,-43.661507,-44.609886,-45.558266,-46.506645,-47.455025,-48.403404,-49.351788,-50.300167,-51.248547,-52.196926,-52.77713,-52.943123,-53.109116,-53.275112,-53.478897,-53.846443,-54.21399,-54.581535,-54.94908,-55.316628,-55.684174,-56.05172,-56.41927,-56.786816,-57.15436,-57.521908,-57.889454,-58.257,-58.624546,-58.992092,-59.359642,-59.72719,-60.094734,-60.46228,-60.829826,-61.197372,-61.56492,-61.932465,-62.30001,-62.667557,-63.035103,-63.402653,-63.7702,-64.13774,-64.505295,-64.87284,-65.24039,-65.60793,-65.97548,-66.343025,-66.71057,-67.07812,-67.44566,-67.81321,-68.180756,-68.5483,-68.91585,-69.283394,-69.65094,-70.01849,-70.38603,-70.753586,-71.121124,-36.336792,-38.8735,-40.99943,-41.947815,-42.896194,-43.844574,-44.792957,-45.741337,-46.689716,-47.6381,-48.58648,-49.53486,-50.48324,-51.43162,-52.38,-53.32838,-54.276764,-55.01804,-55.184032,-55.350025,-55.516018,-55.68201,-55.8732,-56.240746,-56.60829,-56.975838,-57.343384,-57.71093,-58.078476,-58.446026,-58.813572,-59.181118,-59.548664,-59.91621,-60.283756,-60.651302,-61.01885,-61.3864,-61.753944,-62.12149,-62.489037,-62.856583,-63.22413,-63.591675,-63.95922,-64.32677,-64.69431,-65.06186,-65.429405,-65.79695,-66.164505,-66.53204,-66.8996,-67.26714,-67.63469,-68.002235,-68.36978,-68.73733,-69.10487,-69.47242,-69.839966,-70.20751,-70.57506,-70.942604,-71.31015,-71.6777,-72.04524,-31.912018,-34.44872,-36.98542,-40.234123,-41.182503,-42.130882,-43.079266,-44.027645,-44.976025,-45.924404,-46.872787,-47.821167,-48.769547,-49.717926,-50.666306,-51.61469,-52.56307,-53.511448,-54.45983,-55.40821,-56.35659,-57.25895,-57.424942,-57.590935,-57.756927,-57.92292,-58.088913,-58.2675,-58.635048,-59.002594,-59.37014,-59.737686,-60.105232,-60.47278,-60.84033,-61.207874,-61.57542,-61.942966,-62.310513,-62.67806,-63.045605,-63.41315,-63.7807,-64.14825,-64.51579,-64.88334,-65.250885,-65.61843,-65.98598,-66.35352,-66.72107,-67.088615,-67.45616,-67.82371,-68.19125,-68.5588,-68.926346,-69.2939,-69.661446,-70.02899,-70.39654,-70.764084,-71.13163,-71.499176,-71.86672,-72.23427,-72.601814,-30.02391,-32.560616,-35.09732,-37.634026,-40.170734,-41.36557,-42.31395,-43.26233,-44.21071,-45.15909,-46.107468,-47.05585,-48.00423,-48.95261,-49.90099,-50.84937,-51.79775,-52.746128,-53.694508,-54.64289,-55.59127,-56.53965,-57.48803,-58.43641,-59.38479,-59.665844,-59.831837,-59.99783,-60.163822,-60.32982,-60.49581,-60.661804,-61.02935,-61.396896,-61.764442,-62.13199,-62.499535,-62.867085,-63.23463,-63.602177,-63.969723,-64.337265,-64.70482,-65.072365,-65.43991,-65.80746,-66.175,-66.54255,-66.910095,-67.27764,-67.64519,-68.01273,-68.38028,-68.747826,-69.11537,-69.48292,-69.850464,-70.21801,-70.585556,-70.9531,-71.32065,-71.6882,-72.05575,-72.423294,-72.79084,-73.15839,-73.52593,-25.599129,-28.135826,-30.672523,-33.20922,-35.74592,-38.282616,-40.600246,-41.548626,-42.49701,-43.44539,-44.39377,-45.34215,-46.29053,-47.238914,-48.187294,-49.135674,-50.084057,-51.032436,-51.98082,-52.9292,-53.87758,-54.825962,-55.774345,-56.722725,-57.671104,-58.619484,-59.567867,-60.516247,-61.74076,-61.906754,-62.072746,-62.23874,-62.40473,-62.570724,-62.736717,-62.90271,-63.056107,-63.423653,-63.7912,-64.158745,-64.52629,-64.89384,-65.26138,-65.62893,-65.996475,-66.36402,-66.731575,-67.09912,-67.46667,-67.83421,-68.20176,-68.569305,-68.93685,-69.3044,-69.67194,-70.03949,-70.407036,-70.77458,-71.14213,-71.509674,-71.87722,-72.24477,-72.61231,-72.97986,-73.347404,-73.71495,-74.0825,-23.711018,-26.247719,-28.78442,-31.321123,-33.857826,-36.394524,-38.93123,-40.783314,-41.731697,-42.680077,-43.628456,-44.576836,-45.52522,-46.4736,-47.421978,-48.37036,-49.31874,-50.26712,-51.2155,-52.16388,-53.112263,-54.060642,-55.00902,-55.957405,-56.905785,-57.854164,-58.802544,-59.750923,-60.699306,-61.64769,-62.59607,-63.54445,-64.14766,-64.31365,-64.479645,-64.64564,-64.81163,-64.97762,-65.143616,-65.30961,-65.4756,-65.817955,-66.1855,-66.55305,-66.92059,-67.28814,-67.655685,-68.02324,-68.390785,-68.75833,-69.12588,-69.49342,-69.86097,-70.228516,-70.59606,-70.96361,-71.331154,-71.6987,-72.066246,-72.43379,-72.80134,-73.168884,-73.53643,-73.90398,-74.27153,-74.63908,-75.00662,-19.286198,-21.822903,-24.35961,-26.896313,-29.43302,-31.969725,-34.50643,-37.043137,-40.018,-40.96638,-41.91476,-42.863144,-43.811523,-44.759903,-45.708282,-46.656666,-47.605045,-48.553425,-49.50181,-50.450188,-51.398567,-52.346947,-53.295326,-54.24371,-55.19209,-56.14047,-57.088852,-58.03723,-58.98561,-59.93399,-60.882374,-61.830753,-62.779137,-63.727516,-64.675896,-65.624275,-66.388565,-66.55456,-66.72055,-66.88654,-67.052536,-67.21853,-67.38452,-67.550514,-67.716515,-67.84471,-68.21226,-68.5798,-68.94735,-69.314896,-69.68244,-70.04999,-70.41754,-70.78509,-71.15263,-71.52018,-71.887726,-72.25527,-72.62282,-72.990364,-73.35791,-73.72546,-74.093,-74.46055,-74.828094,-75.19564,-75.56319,-17.398142,-19.934845,-22.471546,-25.008247,-27.544949,-30.081652,-32.618355,-35.155056,-37.691757,-40.201073,-41.149452,-42.09783,-43.04621,-43.994595,-44.942974,-45.891354,-46.839737,-47.788116,-48.736496,-49.684875,-50.633255,-51.58164,-52.530018,-53.4784,-54.42678,-55.37516,-56.32354,-57.27192,-58.220303,-59.168686,-60.117065,-61.065445,-62.013824,-62.962204,-63.910587,-64.85896,-65.80734,-66.75573,-67.70411,-68.62947,-68.79546,-68.96146,-69.12745,-69.29344,-69.459435,-69.62543,-69.79143,-69.95742,-70.12341,-70.289406,-70.60656,-70.974106,-71.34165,-71.7092,-72.076744,-72.4443,-72.811844,-73.17939,-73.546936,-73.91448,-74.28203,-74.649574,-75.01712,-75.38467,-75.75221,-76.11976,-76.487305,-12.973322,-15.510026,-18.04673,-20.583435,-23.12014,-25.656845,-28.193548,-30.730253,-33.266956,-35.803665,-38.34037,-40.384136,-41.33252,-42.2809,-43.22928,-44.177658,-45.12604,-46.07442,-47.0228,-47.971184,-48.919563,-49.867943,-50.816322,-51.7647,-52.713085,-53.661465,-54.609844,-55.558228,-56.506607,-57.454987,-58.403366,-59.35175,-60.30013,-61.24851,-62.19689,-63.14527,-64.09365,-65.04203,-65.99041,-66.9388,-67.88718,-68.835556,-69.783936,-70.870384,-71.03638,-71.20237,-71.36836,-71.534355,-71.70035,-71.86634,-72.03233,-72.198326,-72.36432,-72.53031,-72.633316,-73.00086,-73.36841,-73.735954,-74.1035,-74.471054,-74.8386,-75.20615,-75.57369,-75.94124,-76.308784,-76.67633,-77.04388,-11.085267,-13.621969,-16.15867,-18.695372,-21.232073,-23.768774,-26.305477,-28.84218,-31.378881,-33.91558,-36.452286,-38.988987,-40.567207,-41.515587,-42.46397,-43.41235,-44.36073,-45.30911,-46.257492,-47.20587,-48.15425,-49.10263,-50.05101,-50.999393,-51.947773,-52.896152,-53.844532,-54.792915,-55.741295,-56.689674,-57.638054,-58.586433,-59.534813,-60.483196,-61.43158,-62.379955,-63.32834,-64.27672,-65.2251,-66.17348,-67.12186,-68.07024,-69.018616,-69.966995,-70.91538,-71.86376,-72.81214,-73.27728,-73.443275,-73.60927,-73.77526,-73.94125,-74.10725,-74.27324,-74.43923,-74.605225,-74.77122,-74.93721,-75.1032,-75.395164,-75.76271,-76.130264,-76.49781,-76.86536,-77.2329,-77.60045,-77.967995,-6.6604395,-9.197142,-11.733843,-14.270544,-16.807247,-19.343948,-21.88065,-24.41735,-26.954052,-29.490753,-32.02746,-34.564156,-37.10086,-39.80188,-40.75026,-41.698643,-42.647022,-43.5954,-44.543785,-45.492165,-46.440544,-47.388927,-48.337307,-49.28569,-50.23407,-51.18245,-52.130833,-53.079212,-54.02759,-54.975975,-55.924355,-56.872734,-57.821117,-58.7695,-59.71788,-60.66626,-61.61464,-62.563023,-63.511406,-64.459785,-65.408165,-66.356544,-67.30493,-68.25331,-69.20169,-70.15007,-71.09845,-72.04683,-72.99521,-73.94359,-74.891975,-75.51819,-75.68418,-75.850174,-76.01617,-76.18216,-76.34815,-76.514145,-76.68014,-76.84613,-77.01212,-77.178116,-77.34411,-77.42192,-77.78947,-78.15702,-78.52457,-4.7723694,-7.3090696,-9.845771,-12.382471,-14.919172,-17.455872,-19.992573,-22.529274,-25.065975,-27.602676,-30.139378,-32.67608,-35.212776,-37.749477,-39.98495,-40.93333,-41.88171,-42.830093,-43.778473,-44.726852,-45.675232,-46.623615,-47.571995,-48.520374,-49.468758,-50.417137,-51.365517,-52.313896,-53.26228,-54.21066,-55.15904,-56.10742,-57.0558,-58.00418,-58.95256,-59.900944,-60.849323,-61.797703,-62.746086,-63.694466,-64.642845,-65.591225,-66.539604,-67.48799,-68.43637,-69.38475,-70.33313,-71.28151,-72.22989,-73.17827,-74.12665,-75.07503,-76.023415,-76.971794,-77.75909,-77.92509,-78.09108,-78.25707,-78.423065,-78.58906,-78.75505,-78.92104,-79.087036,-79.25303,-79.41902,-79.585014,-79.75101,-7.765863,-7.4176664,-7.06947,-7.9576645,-10.494367,-13.031069,-15.56777,-18.104471,-20.641174,-23.177876,-25.714577,-28.25128,-30.78798,-33.324684,-35.861385,-38.398087,-40.168015,-41.116398,-42.064777,-43.013157,-43.96154,-44.90992,-45.8583,-46.80668,-47.755062,-48.70344,-49.65182,-50.600204,-51.548584,-52.496964,-53.445343,-54.393723,-55.342106,-56.290485,-57.23887,-58.18725,-59.135628,-60.084007,-61.032387,-61.980766,-62.92915,-63.877533,-64.82591,-65.77429,-66.72267,-67.67105,-68.61943,-69.56781,-70.51619,-71.46457,-72.41296,-73.361336,-74.309715,-75.258095,-76.20648,-77.15486,-78.10324,-79.05162,-80.0,-79.2396,-78.4792,-77.71881,-76.95841,-76.19801,-75.43762,-74.67722,-73.916824,-11.029373,-10.681177,-10.332982,-9.984787,-9.636591,-11.142961,-13.679665,-16.21637,-18.753075,-21.289776,-23.82648,-26.363186,-28.899889,-31.436594,-33.973297,-36.510002,-39.046707,-40.351086,-41.299465,-42.24785,-43.196228,-44.144608,-45.092987,-46.041367,-46.98975,-47.93813,-48.88651,-49.834892,-50.78327,-51.73165,-52.68003,-53.62841,-54.57679,-55.525173,-56.473553,-57.421932,-58.370316,-59.318695,-60.267075,-61.215454,-62.163834,-63.112213,-64.06059,-65.00897,-65.95735,-66.90574,-67.85411,-68.8025,-69.75088,-70.69926,-71.64764,-72.59602,-73.544395,-74.49278,-75.44116,-76.38954,-75.14707,-73.46642,-72.01583,-71.25544,-70.49504,-69.73464,-68.97424,-68.21385,-67.45345,-66.693054,-65.932655,-14.641076,-14.292881,-13.944685,-13.596489,-13.248294,-12.900098,-12.551903,-11.791591,-14.328294,-16.864996,-19.4017,-21.9384,-24.475105,-27.011806,-29.548512,-32.085213,-34.621914,-37.158615,-39.585773,-40.534153,-41.482533,-42.430916,-43.379295,-44.327675,-45.276054,-46.224438,-47.172817,-48.121197,-49.06958,-50.01796,-50.96634,-51.91472,-52.863102,-53.81148,-54.759865,-55.708244,-56.656624,-57.605003,-58.553383,-59.501762,-60.450146,-61.398525,-62.34691,-63.295288,-64.24367,-65.19205,-66.14043,-67.088806,-68.037186,-68.98557,-69.93395,-70.88233,-71.83071,-73.65542,-71.97478,-70.29413,-68.61348,-66.93284,-65.25219,-64.03167,-63.27127,-62.510876,-61.75048,-60.99008,-60.229687,-59.46929,-58.708897,-17.904593,-17.556396,-17.2082,-16.860004,-16.511808,-16.163612,-15.815416,-15.46722,-15.119024,-14.976886,-17.513586,-20.050287,-22.586988,-25.12369,-27.66039,-30.197092,-32.733795,-35.270493,-37.807198,-39.76883,-40.71721,-41.66559,-42.61397,-43.56235,-44.51073,-45.459114,-46.407494,-47.355873,-48.304253,-49.252636,-50.20102,-51.1494,-52.09778,-53.046158,-53.994537,-54.94292,-55.891304,-56.839684,-57.788063,-58.736443,-59.684822,-60.633205,-61.58159,-62.52997,-63.478348,-64.42673,-65.37511,-66.32349,-67.271866,-68.22025,-69.16863,-68.8025,-67.12185,-65.4412,-63.760555,-62.079906,-60.39926,-58.718613,-57.037964,-56.047504,-55.28711,-54.52671,-53.766315,-53.00592,-52.24552,-51.485126,-50.72473,-21.516296,-21.1681,-20.819904,-20.471708,-20.123512,-19.775316,-19.42712,-19.078924,-18.730728,-18.382532,-18.034336,-17.68614,-18.16222,-20.698917,-23.235619,-25.772316,-28.309015,-30.845715,-33.382416,-35.919113,-39.003517,-39.951897,-40.90028,-41.84866,-42.79704,-43.745422,-44.6938,-45.64218,-46.59056,-47.53894,-48.487324,-49.435703,-50.384083,-51.332466,-52.280846,-53.229225,-54.177605,-55.125984,-56.074368,-57.022747,-57.971127,-58.91951,-59.86789,-60.81627,-61.76465,-62.713028,-63.66141,-64.60979,-65.55817,-65.63022,-63.949574,-62.268925,-60.588276,-58.907627,-57.226982,-55.546333,-53.865685,-52.185036,-50.504387,-48.82374,-48.06334,-47.302944,-46.542545,-45.78215,-45.02175,-44.261356,-43.500957,-24.779812,-24.431616,-24.08342,-23.735224,-23.387028,-23.03883,-22.690634,-22.342438,-21.994242,-21.646046,-21.29785,-20.949654,-20.601458,-20.253262,-21.347513,-23.884214,-26.420918,-28.957619,-31.49432,-34.03102,-36.567722,-39.104424,-40.134964,-41.083347,-42.031727,-42.980106,-43.92849,-44.87687,-45.82525,-46.773632,-47.72201,-48.670395,-49.618774,-50.567154,-51.515533,-52.463917,-53.412296,-54.36068,-55.30906,-56.25744,-57.20582,-58.1542,-59.102585,-60.050964,-60.999344,-61.947723,-62.45792,-60.777275,-59.096626,-57.415977,-55.735332,-54.054688,-52.37404,-50.69339,-49.012745,-47.332096,-45.65145,-43.970802,-42.290157,-40.839573,-40.079174,-39.31878,-38.55838,-37.797985,-37.03759,-36.27719,-35.516796,-28.391518,-28.043322,-27.695126,-27.34693,-26.998734,-26.650537,-26.302341,-25.954145,-25.60595,-25.257753,-24.909557,-24.561361,-24.213165,-23.864971,-23.516773,-23.16858,-21.996107,-24.532812,-27.069517,-29.606222,-32.14293,-34.679634,-37.216335,-39.369656,-40.318035,-41.266415,-42.214794,-43.163177,-44.111557,-45.059937,-46.00832,-46.9567,-47.90508,-48.85346,-49.80184,-50.75022,-51.6986,-52.64698,-53.59536,-54.543743,-55.492123,-56.440506,-57.388885,-58.337265,-59.285645,-57.604996,-55.924347,-54.243702,-52.563053,-50.882404,-49.20176,-47.52111,-45.84046,-44.159813,-42.479164,-40.79852,-39.11787,-37.43722,-35.756577,-33.615803,-32.855404,-32.09501,-31.334612,-30.574215,-29.813818,-29.053421,-27.024725,-31.655024,-31.306828,-30.958632,-30.610435,-30.26224,-29.914043,-29.565847,-29.217651,-28.869457,-28.52126,-28.173065,-27.82487,-27.476673,-27.128477,-26.780281,-26.432085,-26.083889,-25.735693,-25.387497,-27.718142,-30.254845,-32.791546,-35.32825,-37.864952,-39.55272,-40.501102,-41.449482,-42.39786,-43.34624,-44.29462,-45.243004,-46.191383,-47.139763,-48.088142,-49.036522,-49.9849,-50.93328,-51.881664,-52.830044,-53.778423,-54.726803,-55.675182,-54.43272,-52.75207,-51.071423,-49.390778,-47.71013,-46.02948,-44.34883,-42.668182,-40.987534,-39.306885,-37.626236,-35.94559,-34.264942,-32.584297,-30.903646,-29.222998,-27.54235,-25.861704,-24.871243,-24.110847,-23.350452,-22.590055,-21.82966,-21.069263,-21.84894,-35.26674,-34.91854,-34.570347,-34.22215,-33.873955,-33.525757,-33.17756,-32.829365,-32.48117,-32.132973,-31.784777,-31.43658,-31.088385,-30.740189,-30.391993,-30.043797,-29.6956,-29.347404,-28.999207,-28.651012,-28.302814,-28.366735,-30.903444,-33.44015,-35.97686,-38.78741,-39.73579,-40.684174,-41.632553,-42.580933,-43.529312,-44.47769,-45.426075,-46.374454,-47.322834,-48.271217,-49.219597,-50.167976,-51.116356,-52.941067,-51.260418,-49.579773,-47.899124,-46.218475,-44.53783,-42.85718,-41.176537,-39.495888,-37.81524,-36.13459,-34.45395,-32.7733,-31.092651,-29.412004,-27.731356,-26.05071,-24.370062,-22.689415,-21.008766,-19.328117,-17.647472,-16.887075,-16.126678,-15.366282,-14.605886,-13.8454895,-13.628641,-38.530243,-38.18205,-37.83385,-37.485657,-37.13746,-36.789265,-36.441067,-36.092873,-35.744675,-35.39648,-35.048283,-34.70009,-34.35189,-34.003696,-33.6555,-33.307304,-32.959106,-32.61091,-32.262714,-31.914518,-31.566322,-31.218126,-30.86993,-31.552069,-34.08877,-36.625477,-38.970478,-39.918858,-40.867237,-41.815617,-42.763996,-43.712376,-44.66076,-45.60914,-46.557518,-47.505898,-48.454277,-48.088142,-46.407494,-44.72685,-43.0462,-41.36555,-39.684906,-38.004257,-36.32361,-34.64296,-32.962315,-31.281666,-29.601019,-27.92037,-26.239723,-24.559076,-22.87843,-21.19778,-19.517132,-17.836487,-16.155838,-14.475189,-12.79454,-11.113895,-9.663309,-8.902912,-8.142514,-7.3821173,-6.62172,-5.8613224,-8.452904,-42.14195,-41.79375,-41.445557,-41.09736,-40.749165,-40.40097,-40.052773,-39.70458,-39.35638,-39.008186,-38.65999,-38.311794,-37.9636,-37.615402,-37.26721,-36.91901,-36.570816,-36.22262,-35.874424,-35.52623,-35.178032,-34.829838,-34.481644,-34.133446,-33.785248,-32.200665,-34.737362,-37.274063,-39.153534,-40.101913,-41.050293,-41.998672,-42.947056,-43.895435,-44.843815,-44.915867,-43.235218,-41.55457,-39.873924,-38.193275,-36.512627,-34.831978,-33.15133,-31.470684,-29.790035,-28.109386,-26.428738,-24.748089,-23.067444,-21.386795,-19.706146,-18.025497,-16.34485,-14.664202,-12.983555,-11.302906,-9.622257,-7.9416084,-6.2609596,-4.580311,-2.8996658,-1.6791434,-0.9187472,-0.15835106,0.60204506,2.8119414,-0.232615,-45.405464,-45.05727,-44.709072,-44.360878,-44.01268,-43.664482,-43.316288,-42.968094,-42.619896,-42.271698,-41.923504,-41.575306,-41.22711,-40.878914,-40.53072,-40.18252,-39.834328,-39.48613,-39.13793,-38.789738,-38.441544,-38.093346,-37.745148,-37.396954,-37.04876,-36.70056,-36.352364,-36.00417,-37.92268,-39.3366,-40.284985,-41.233368,-41.743565,-40.06292,-38.38227,-36.701622,-35.020973,-33.34033,-31.65968,-29.979033,-28.298386,-26.617737,-24.93709,-23.256441,-21.575796,-19.895147,-18.2145,-16.533852,-14.853207,-13.172558,-11.491911,-9.811264,-8.130615,-6.4499664,-4.7693214,-3.0886726,-1.4080276,0.27262115,1.95327,3.6339188,5.3145638,6.305023,7.0654197,7.825816,8.586212,7.9876804,4.943125,-49.017166,-48.668972,-48.320774,-47.97258,-47.624382,-47.276188,-46.927994,-46.579796,-46.231598,-45.883404,-45.53521,-45.18701,-44.838818,-44.49062,-44.142426,-43.794228,-43.446033,-43.097836,-42.74964,-42.401443,-42.05325,-41.70505,-41.356857,-41.00866,-40.660465,-40.312267,-39.964073,-39.615875,-39.26768,-38.919487,-38.57129,-36.89064,-35.20999,-33.529346,-31.848698,-30.168049,-28.487402,-26.806755,-25.126106,-23.445457,-21.76481,-20.084164,-18.403515,-16.722866,-15.042221,-13.361572,-11.680923,-10.000277,-8.319628,-6.638981,-4.958332,-3.277687,-1.5970383,8.3610535e-2,1.7642593,3.4449081,5.125557,6.806202,8.486847,10.167496,11.848145,13.528793,14.289192,15.04959,15.809989,16.207983,13.163428,-52.280674,-51.93248,-51.584282,-51.236088,-50.887894,-50.539696,-50.1915,-49.843304,-49.49511,-49.14691,-48.798717,-48.45052,-48.102325,-47.754128,-47.405933,-47.05774,-46.70954,-46.361347,-46.01315,-45.664955,-45.316757,-44.968563,-44.62037,-44.27217,-43.923977,-42.484966,-39.955147,-37.425323,-34.895504,-33.824272,-32.360836,-30.127422,-27.894009,-25.660597,-23.63447,-21.953823,-20.273174,-18.592525,-16.911879,-15.231231,-13.550583,-11.869936,-10.189287,-8.508639,-6.8279915,-5.1473427,-3.4666958,-1.786047,-0.105400085,1.5752468,3.2558956,4.9365444,6.617193,8.29784,9.978485,11.659134,13.339783,15.020428,16.70108,18.381725,20.062378,21.512959,22.273352,23.033747,23.79414,21.38376,18.339203,-55.892387,-55.544193,-55.195995,-54.8478,-54.499603,-54.15141,-53.80321,-53.455017,-53.10682,-52.758625,-52.410427,-52.062233,-51.714035,-51.36584,-51.017643,-50.66945,-50.32125,-49.973053,-49.62486,-49.276665,-48.928467,-46.39865,-43.868835,-41.33902,-38.809204,-36.27939,-33.749577,-31.148603,-30.11294,-29.077274,-28.383831,-26.150414,-23.916996,-21.683578,-19.450161,-17.216743,-14.983327,-12.749909,-10.3783,-8.697652,-7.017004,-5.3363566,-3.6557088,-1.9750614,-0.29441357,1.3862343,3.0668812,4.74753,6.428177,8.108826,9.789473,11.470121,13.150768,14.831415,16.512064,18.192709,19.873358,21.554007,23.234653,24.915302,26.595947,28.736723,29.497118,30.257515,32.648613,29.604057,26.559502,-59.155895,-58.8077,-58.459503,-58.11131,-57.76311,-57.414917,-57.06672,-56.718525,-56.37033,-56.022133,-55.67394,-55.32574,-54.977547,-54.62935,-54.281155,-52.842148,-50.312332,-47.782513,-45.252697,-42.722878,-40.19306,-37.663246,-35.13343,-32.60361,-30.073793,-27.543978,-26.40159,-25.365925,-24.33026,-23.294594,-22.173378,-19.939962,-17.706547,-15.473129,-13.239714,-11.006298,-8.772881,-6.539465,-4.3060493,-2.0726318,0.16078377,2.3941994,4.5585194,6.239167,7.919815,9.600462,11.28111,12.961758,14.6424055,16.323053,18.0037,19.68435,21.364996,23.045645,24.726292,26.406939,28.087587,29.768236,31.448883,33.12953,34.81018,36.490826,37.481285,38.24168,37.824352,34.779793,31.735233,-62.767605,-62.41941,-62.071213,-61.72302,-61.37482,-61.026627,-60.67843,-60.330235,-59.982037,-59.633842,-59.285645,-56.75583,-54.226013,-51.696198,-49.16638,-46.636566,-44.106754,-41.57694,-39.047123,-36.517307,-33.98749,-31.457676,-28.927862,-26.398045,-23.72592,-22.690252,-21.654585,-20.618917,-19.58325,-18.547583,-17.511915,-15.962924,-13.729509,-11.496094,-9.262678,-7.0292635,-4.795848,-2.5624332,-0.32901764,1.904398,4.1378136,6.3712273,8.604645,10.838058,13.071474,15.304888,17.538305,19.495338,21.175985,22.856634,24.537281,26.21793,27.898577,29.579226,31.259872,32.94052,34.62117,36.301815,37.982464,39.663113,41.343758,43.024406,44.705055,45.46545,46.044647,43.000088,39.95553,-66.03111,-65.68292,-65.334724,-64.98653,-64.63833,-63.199326,-60.66951,-58.139694,-55.609875,-53.08006,-50.550243,-48.020424,-45.49061,-42.960793,-40.430977,-37.90116,-35.371346,-32.84153,-30.31171,-27.781895,-25.252079,-22.72226,-20.192448,-18.978903,-17.943235,-16.90757,-15.871902,-14.836235,-13.800568,-12.7649,-11.729233,-9.75247,-7.5190554,-5.2856402,-3.052225,-0.81881046,1.4146051,3.6480207,5.8814354,8.114851,10.348265,12.58168,14.815096,17.04851,19.281925,21.51534,23.748755,25.982168,28.215586,30.449,32.68242,34.43216,36.11281,37.793453,39.474102,41.154747,42.835396,44.516045,46.19669,47.877335,49.557983,51.238632,52.689217,53.449623,51.220394,48.175835,45.13128,-69.64282,-67.11301,-64.58319,-62.05337,-59.523552,-56.993736,-54.46392,-51.934105,-49.404285,-46.87447,-44.34465,-41.814835,-39.28502,-36.7552,-34.225384,-31.695568,-29.165749,-26.635933,-24.106117,-21.576298,-19.046482,-16.30322,-15.267556,-14.231891,-13.196225,-12.160561,-11.124895,-10.08923,-9.053564,-8.0178995,-6.982234,-5.775467,-3.5420508,-1.3086348,0.9247813,3.1581974,5.391614,7.6250296,9.858445,12.091862,14.325277,16.558693,18.792109,21.025528,23.258944,25.49236,27.725773,29.95919,32.192608,34.426025,36.65944,38.892857,41.126274,43.359688,45.593105,47.688328,49.368973,51.04962,52.73027,54.410915,56.091564,57.772213,59.452858,62.485287,59.440723,56.39616,53.3516,-60.907425,-58.37761,-55.847794,-53.317978,-50.788162,-48.258343,-45.72853,-43.19871,-40.6689,-38.13908,-35.609264,-33.07945,-30.549637,-28.019817,-25.490002,-22.960186,-20.43037,-17.900555,-15.370739,-12.8409195,-11.556221,-10.520555,-9.484888,-8.449221,-7.4135547,-6.3778877,-5.3422213,-4.306555,-3.2708874,-2.235221,-1.1995544,0.43498707,2.6684027,4.9018183,7.1352334,9.368649,11.602065,13.835481,16.068895,18.30231,20.535727,22.769142,25.002558,27.235975,29.469389,31.702805,33.93622,36.169636,38.403053,40.636467,42.869884,45.1033,47.33671,49.570126,51.803543,54.03696,56.270374,58.50379,60.737206,62.62514,64.30579,65.98644,67.66708,67.661026,64.61646,61.476612,56.33574,-54.701836,-52.172016,-49.6422,-47.112385,-44.58257,-42.052753,-39.522934,-36.993114,-34.463303,-31.933483,-29.403667,-26.873852,-24.344032,-21.814217,-19.2844,-16.754585,-14.22477,-11.694946,-8.880537,-7.84487,-6.8092036,-5.773537,-4.7378707,-3.7022042,-2.6665378,-1.6308713,-0.59520435,0.44046116,1.4761286,2.511795,3.5474606,4.412026,6.645441,8.878857,11.112271,13.345687,15.5791025,17.812517,20.045933,22.279348,24.512762,26.746178,28.979593,31.213009,33.446423,35.67984,37.913254,40.146667,42.380085,44.6135,46.846916,49.08033,51.313744,53.54716,55.78058,58.01399,60.247406,62.480824,64.71423,66.94765,69.18106,71.414474,73.6479,75.88132,70.74044,65.59957,60.458694,-45.966446,-43.43663,-40.90681,-38.37699,-35.84717,-33.317356,-30.787533,-28.257717,-25.727898,-23.198082,-20.668262,-18.138447,-15.608627,-13.078812,-10.548988,-8.019169,-5.4893494,-4.133522,-3.097857,-2.0621917,-1.0265267,9.138107e-3,1.0448031,2.0804682,3.1161337,4.151799,5.1874638,6.2231293,7.258794,8.294459,9.330124,10.622442,12.855859,15.089275,17.322693,19.55611,21.789526,24.022942,26.25636,28.489777,30.723192,32.95661,35.190025,37.423443,39.65686,41.890274,44.12369,46.35711,48.590527,50.82394,53.057358,55.290775,57.524193,59.757607,61.991024,64.22444,66.457855,68.69127,70.10669,71.1131,72.119514,73.12593,74.13235,73.59396,69.038994,64.48402,59.440792,-39.76085,-37.23103,-34.701214,-32.1714,-29.641584,-27.111767,-24.581951,-22.052135,-19.522316,-16.992504,-14.462685,-11.932873,-9.403053,-6.8732376,-4.3434258,-1.457852,-0.42218572,0.61348057,1.6491468,2.684813,3.720479,4.7561455,5.7918115,6.8274775,7.863144,8.89881,9.934477,10.970143,12.005809,13.041475,14.077142,14.599484,16.8329,19.066315,21.29973,23.533146,25.766562,27.999977,30.23339,32.46681,34.700222,36.93364,39.167053,41.400467,43.633884,45.867302,48.10071,50.33413,52.567543,54.80096,57.034378,59.26779,61.50121,63.32563,64.33205,65.33846,66.34488,67.351295,68.35771,69.364136,70.37055,71.37697,72.383385,75.86153,71.30655,66.75157,62.196598,-31.025461,-28.495644,-25.965826,-23.436008,-20.90619,-18.37637,-15.846554,-13.316734,-10.786919,-8.257099,-5.7272797,-3.197464,-0.6676445,1.8621712,3.2891617,4.3248277,5.3604937,6.39616,7.431826,8.467492,9.503159,10.538825,11.574491,12.610156,13.6458235,14.681489,15.7171545,16.752821,17.788486,18.824152,19.85982,20.895487,23.04335,25.276766,27.510181,29.743597,31.977013,34.210426,36.443844,38.677258,40.910675,43.14409,45.377502,47.61092,49.844337,52.07775,54.311165,56.544582,57.551,58.557415,59.56383,60.570248,61.576664,62.58308,63.589497,64.59592,65.60233,66.60875,67.615166,68.62158,69.628,70.634415,71.64083,72.64725,69.019196,64.464226,59.90925,-24.81986,-22.290045,-19.76023,-17.230413,-14.700598,-12.170784,-9.640968,-7.1111565,-4.581337,-2.051525,0.47829056,3.0081062,5.9648304,7.0004973,8.036164,9.071831,10.107498,11.143165,12.178831,13.2144985,14.250166,15.285831,16.321499,17.357166,18.392834,19.4285,20.464167,21.499834,22.5355,23.571167,24.606834,25.642502,27.02039,29.253805,31.48722,33.720634,35.954052,38.18747,40.420883,42.654297,44.887714,47.12113,49.76354,50.769955,51.77637,52.78279,53.789207,54.795624,55.80204,56.808456,57.814873,58.82129,59.827705,60.83412,61.840538,62.846954,63.85337,64.85979,65.8662,66.87262,67.879036,68.88545,69.89188,70.898285,71.28675,66.73179,62.17682,-16.084475,-13.554655,-11.024839,-8.49502,-5.9652023,-3.4353848,-0.90556717,1.6242485,4.154072,6.6838875,9.213703,10.711848,11.747514,12.78318,13.818846,14.854511,15.890178,16.925844,17.96151,18.997175,20.03284,21.068508,22.104172,23.13984,24.175505,25.21117,26.246838,27.282503,28.318169,29.353834,30.3895,31.425167,33.23081,35.464226,37.69764,39.931057,42.16447,43.988895,44.99531,46.001728,47.008144,48.01456,49.020977,50.027393,51.033813,52.04023,53.046646,54.053062,55.05948,56.065895,57.07231,58.078728,59.085144,60.09156,61.09798,62.104397,63.110813,64.11723,65.12365,66.130066,67.13648,68.1429,69.149315,70.15573,68.999405,64.44443,59.889454,-9.8788595,-7.349041,-4.819227,-2.2894115,0.24040604,2.7702217,5.3000374,7.829853,10.359669,13.387529,14.423196,15.458861,16.494528,17.530193,18.565859,19.601524,20.637192,21.672857,22.708523,23.74419,24.779856,25.815521,26.851189,27.886852,28.92252,29.958185,30.99385,32.02952,33.065186,34.10085,35.136517,36.17218,37.207848,38.214264,39.22068,40.227097,41.233517,42.239933,43.24635,44.252766,45.259182,46.265602,47.27202,48.278435,49.28485,50.291267,51.297684,52.3041,53.310516,54.316936,55.323353,56.32977,57.336185,58.342606,59.349022,60.35544,61.361855,62.36827,63.374687,64.3811,65.38753,66.393936,67.40036,68.40677,71.26696,66.71199,62.157017,-1.1434851,1.3863316,3.9161491,6.4459667,8.975782,11.505598,14.035416,16.565235,18.134531,19.170197,20.205862,21.24153,22.277195,23.31286,24.348526,25.384193,26.419859,27.455524,28.491192,29.526857,30.562523,31.598188,32.633854,33.66952,34.705185,35.740852,36.77652,37.703148,38.229965,38.756783,39.2836,39.810417,37.797306,37.74817,38.478138,39.484554,40.49097,41.497387,42.503803,43.51022,44.516636,45.523052,46.52947,47.535885,48.5423,49.548717,50.555138,51.561554,52.56797,53.574387,54.580803,55.58722,56.593636,57.60005,58.60647,59.612885,60.6193,61.625717,62.632133,63.63855,64.644966,65.65138,66.6578,67.664215,68.67063,64.42464,59.869667,5.062129,7.5919437,10.1217575,12.651573,15.181389,17.711203,20.810215,21.845882,22.881548,23.917215,24.95288,25.988548,27.024214,28.05988,29.095547,30.131212,31.166878,32.202545,33.238213,34.273876,35.309544,36.34521,37.380875,38.198463,38.725277,39.25209,39.778908,40.30572,40.83254,41.359352,41.88617,42.96534,38.435898,38.386765,38.337627,38.28849,38.742004,39.74842,40.754837,41.761253,42.76767,43.77409,44.780506,45.786922,46.79334,47.799755,48.80617,49.812588,50.819008,51.825424,52.83184,53.838257,54.844673,55.85109,56.857506,57.863922,58.87034,59.87676,60.88317,61.88959,62.89601,63.902424,64.908844,65.91526,66.92168,66.69219,62.13722,13.797519,16.32734,18.857159,21.386978,23.916798,25.557228,26.592894,27.62856,28.664225,29.69989,30.735556,31.771221,32.806885,33.842552,34.87822,35.913883,36.949547,37.985214,38.693764,39.22058,39.747395,40.27421,40.801025,41.327843,41.85466,42.381474,42.90829,43.435104,43.96192,44.48874,45.015553,42.28335,39.02536,38.976223,38.927086,38.87795,38.828815,39.00586,40.01228,41.018696,42.025112,43.03153,44.037945,45.044365,46.05078,47.057198,48.063614,49.07003,50.076447,51.082863,52.089283,53.0957,54.102116,55.108532,56.114952,57.12137,58.127785,59.1342,60.140617,61.147034,62.15345,63.159866,64.16628,65.1727,66.17912,64.40484,59.84987,20.003113,22.532925,25.062737,28.232899,29.268566,30.304232,31.3399,32.375565,33.411232,34.4469,35.482567,36.518234,37.5539,38.66226,39.18907,39.71589,40.242702,40.76952,41.296333,41.82315,42.349964,42.87678,43.403595,43.930412,44.457226,44.984043,45.510857,46.037674,46.564487,47.091305,48.72283,45.16211,41.60139,39.61482,39.56568,39.516544,39.467407,39.41827,39.369133,39.26973,40.276146,41.282562,42.28898,43.295395,44.30181,45.308228,46.314644,47.32106,48.32748,49.333897,50.340313,51.34673,52.353146,53.359562,54.36598,55.372395,56.378815,57.38523,58.391647,59.398064,60.40448,61.410896,62.417313,63.42373,64.430145,66.67246,62.117493,28.738506,31.268326,32.97991,34.015575,35.051243,36.086906,37.122574,38.158237,39.15756,39.684376,40.21119,40.738007,41.26482,41.791634,42.31845,42.845264,43.37208,43.898895,44.425713,44.952526,45.479343,46.006157,46.532974,47.059788,47.586605,48.11342,48.640236,49.16705,49.693867,50.22068,48.040894,44.480145,40.91939,40.204273,40.155136,40.106003,40.056866,40.00773,39.95859,39.90946,39.86032,40.540016,41.546436,42.552853,43.55927,44.565685,45.5721,46.578518,47.584934,48.591354,49.59777,50.604187,51.610603,52.61702,53.623436,54.629852,55.63627,56.642685,57.6491,58.65552,59.661938,60.668354,61.67477,62.68119,63.687607,64.38505,59.830074,35.655582,36.691254,37.72692,38.762592,39.65287,40.179688,40.7065,41.23332,41.76013,42.286945,42.813763,43.340576,43.867393,44.394207,44.92102,45.447838,45.97465,46.501465,47.028282,47.555096,48.081913,48.608727,49.135544,49.662357,50.18917,50.71599,51.2428,51.769615,52.296432,54.480385,50.919647,47.35891,43.798176,40.84287,40.79373,40.7446,40.69546,40.646324,40.597187,40.54805,40.498913,40.449776,40.40064,40.803886,41.810303,42.81672,43.823135,44.82955,45.835968,46.842384,47.8488,48.855217,49.861633,50.86805,51.87447,52.880886,53.887302,54.89372,55.900135,56.90655,57.912968,58.919384,59.925804,60.93222,61.938637,62.945053,62.0977,40.674988,41.201805,41.72862,42.255436,42.78225,43.309067,43.83588,44.362694,44.88951,45.416325,45.943142,46.469955,46.996773,47.523586,48.050404,48.577217,49.104034,49.630848,50.15766,50.68448,51.211296,51.73811,52.264923,52.79174,53.318554,53.84537,54.372185,54.899002,55.425816,53.798393,50.23765,46.67691,43.116173,41.432327,41.383194,41.334057,41.28492,41.235783,41.186646,41.13751,41.08837,41.039238,40.9901,40.940964,41.067757,42.074173,43.080593,44.08701,45.093426,46.099842,47.10626,48.112675,49.11909,50.12551,51.131927,52.138344,53.14476,54.151176,55.157593,56.16401,57.170425,58.17684,59.183258,60.189674,61.196095,62.202507,59.810284,43.27755,43.804367,44.33118,44.857998,45.38481,45.91163,46.438442,46.96526,47.492073,48.01889,48.545704,49.07252,49.599335,50.126152,50.652966,51.179783,51.706596,52.233414,52.760227,53.287045,53.813858,54.340675,54.86749,55.394306,55.92112,56.447937,56.97475,57.501568,58.02838,56.677143,53.116413,49.55568,45.99495,42.070927,42.02179,41.972652,41.923515,41.87438,41.82524,41.776108,41.72697,41.677834,41.628696,41.57956,41.530426,41.48129,41.331615,42.33803,43.344448,44.350864,45.35728,46.3637,47.370117,48.376534,49.38295,50.389366,51.395782,52.402203,53.40862,54.415035,55.42145,56.427868,57.434288,58.440704,59.44712,60.453537,62.077904,46.406937,46.933754,47.460567,47.987385,48.5142,49.041016,49.56783,50.094646,50.62146,51.148273,51.67509,52.201904,52.72872,53.255535,53.782352,54.309166,54.835983,55.362797,55.88961,56.416428,56.94324,57.47006,57.996872,58.52369,59.050503,59.577316,60.104134,60.630947,59.555885,55.99515,52.434414,48.87368,45.312943,42.66038,42.611244,42.562107,42.51297,42.463833,42.4147,42.365562,42.316425,42.26729,42.21815,42.169018,42.11988,42.070744,42.021606,41.97247,42.6019,43.60832,44.614735,45.62115,46.62757,47.633987,48.640404,49.64682,50.65324,51.659657,52.666073,53.672493,54.67891,55.685326,56.691742,57.698162,58.704575,59.710995,59.790485,52.288696,49.536316,50.06313,50.589947,51.11676,51.643578,52.170395,52.69721,53.224026,53.75084,54.277657,54.80447,55.331287,55.8581,56.38492,56.911736,57.43855,57.965366,58.49218,59.018997,59.545815,60.072628,60.59944,61.12626,61.653076,62.17989,62.706707,63.23352,62.43464,58.873898,55.313156,51.75242,48.191677,43.298977,43.24984,43.200703,43.151566,43.102432,43.053295,43.004158,42.95502,42.905884,42.856747,42.807613,42.758476,42.70934,42.660202,42.611065,42.56193,42.512794,42.865772,43.87219,44.878605,45.88502,46.891438,47.897854,48.90427,49.91069,50.917107,51.923523,52.92994,53.936356,54.942772,55.94919,56.955605,57.96202,58.968437,55.730373,52.665703,53.19252,53.719334,54.24615,54.772964,55.29978,55.826595,56.353413,56.880226,57.407043,57.933857,58.460674,58.987488,59.514305,60.04112,60.567932,61.09475,61.621567,62.14838,62.675194,63.20201,63.72883,64.25564,64.782455,65.30927,65.83609,65.313385,61.75265,58.191917,54.631184,51.07045,47.50972,43.948982,43.8393,43.79016,43.741028,43.69189,43.642754,43.593616,43.54448,43.495342,43.446205,43.397068,43.347935,43.298798,43.24966,43.200523,43.151386,43.10225,43.053112,43.12964,44.13606,45.142475,46.14889,47.15531,48.161728,49.168144,50.17456,51.18098,52.187397,53.193813,54.200233,55.20665,56.213066,57.219482,58.2259,63.329765,59.172035,55.79509,56.321903,56.84872,57.375534,57.902348,58.429165,58.95598,59.482796,60.00961,60.536427,61.06324,61.590057,62.11687,62.643684,63.1705,63.697315,64.22413,64.750946,65.27776,65.80458,66.33139,66.85821,67.385025,67.911835,68.43865,68.19213,64.63139,61.070656,57.50992,53.949184,50.388447,46.82771,44.47789,44.428753,44.37962,44.330482,44.281345,44.23221,44.18307,44.133938,44.0848,44.035664,43.986526,43.93739,43.888256,43.83912,43.78998,43.740845,43.691708,43.642574,43.593437,43.393513,44.39993,45.406345,46.41276,47.419178,48.425594,49.43201,50.438427,51.444847,52.451263,53.45768,54.464096,55.470512,56.47693,66.771416,62.6137,58.924473,59.451286,59.978104,60.504917,61.031734,61.558548,62.085365,62.612183,63.138996,63.66581,64.19263,64.719444,65.246254,65.77307,66.29989,66.826706,67.353516,67.88033,68.40715,68.93397,69.460785,69.987595,70.51441,71.04123,71.070885,67.51015,63.949417,60.388687,56.827953,53.26722,49.70649,46.145756,45.067352,45.018215,44.969078,44.91994,44.870804,44.821667,44.77253,44.723396,44.67426,44.625122,44.575985,44.526848,44.47771,44.428577,44.37944,44.330303,44.281166,44.23203,44.18289,44.133755,44.08462,44.663795,45.67021,46.67663,47.683044,48.68946,49.695877,50.702293,51.70871,52.715126,53.721542,54.727955,55.73437,74.37088,70.21314,66.055405,62.053852,62.58067,63.107483,63.6343,64.16112,64.68793,65.214745,65.74156,66.26837,66.79519,67.32201,67.848816,68.37563,68.90245,69.42927,69.95608,70.482895,71.00971,71.53653,72.06334,72.59016,73.116974,73.64378,73.949684,70.38894,66.8282,63.267456,59.70672,56.145977,52.585236,49.024494,45.705948,45.65681,45.607674,45.558537,45.5094,45.460262,45.41113,45.36199,45.312855,45.263718,45.21458,45.165443,45.11631,45.067173,45.018036,44.9689,44.91976,44.870625,44.82149,44.772354,44.723217,44.67408,44.624943,44.927654,45.93407,46.94049,47.946907,48.953323,49.959743,50.96616,51.972576,52.978996,53.985413,77.81253,73.65482,69.497116,65.33941,65.710045,66.236855,66.76367,67.29049,67.81731,68.34412,68.87093,69.39775,69.92457,70.45138,70.978195,71.50501,72.03183,72.55864,73.08546,73.612274,74.13909,74.66591,75.19272,75.719536,76.24635,76.77316,73.26769,69.706955,66.14622,62.58548,59.024742,55.464005,51.903267,48.342533,46.295403,46.246265,46.19713,46.147995,46.098858,46.04972,46.000584,45.951447,45.902313,45.853176,45.80404,45.7549,45.705765,45.65663,45.607494,45.558357,45.50922,45.460087,45.41095,45.361813,45.312675,45.26354,45.214405,45.165268,45.191525,46.19794,47.204357,48.210773,49.21719,50.223606,51.230026,52.236443,53.24286,85.412,81.25427,77.09655,72.93882,68.31261,68.839424,69.36624,69.89306,70.419876,70.946686,71.4735,72.00032,72.52714,73.053955,73.580765,74.10758,74.6344,75.16122,75.688034,76.21484,76.74166,77.26848,77.795296,78.32211,78.84892,79.707184,76.14644,72.5857,69.02496,65.464226,61.903484,58.342743,54.782005,51.221268,46.934,46.88486,46.835724,46.786587,46.737453,46.688316,46.63918,46.590042,46.540905,46.49177,46.442635,46.393497,46.34436,46.295223,46.246086,46.196953,46.147816,46.09868,46.04954,46.000404,45.951267,45.902134,45.852997,45.80386,45.754723,45.705585,45.455395,46.46181,47.468227,48.474644,49.481064,50.48748,51.493896,88.853645,84.69592,80.53821,76.38049,72.22278,71.96881,72.49563,73.02244,73.549255,74.07607,74.60289,75.1297,75.65652,76.183334,76.710144,77.23696,77.76378,78.290596,78.817406,79.34422,79.87104,80.39785,80.92467,81.451485,81.9783,79.025185,75.46445,71.90372,68.34298,64.78225,61.22151,57.660778,54.100044,50.539307,47.523457,47.47432,47.425186,47.37605,47.326912,47.277775,47.228638,47.179504,47.130367,47.08123,47.032093,46.982956,46.93382,46.884686,46.83555,46.78641,46.737274,46.688137,46.639,46.589867,46.54073,46.491592,46.442455,46.39332,46.344185,46.295048,46.24591,46.196774,46.72568,47.732098,48.738514,49.74493,50.751343,96.452995,92.29529,88.13758,83.97987,79.82216,74.57138,75.0982,75.62501,76.151825,76.67864,77.20546,77.73227,78.25909,78.785904,79.31272,79.83953,80.36635,80.893166,81.41998,81.94679,82.47361,83.00043,83.527245,84.054054,85.46467,81.90393,78.3432,74.78246,71.221725,67.66099,64.10025,60.539513,56.978775,53.418037,48.16205,48.11291,48.063778,48.01464,47.965504,47.916367,47.86723,47.818096,47.76896,47.719822,47.670685,47.621548,47.57241,47.523277,47.47414,47.425003,47.375866,47.32673,47.277596,47.22846,47.17932,47.130184,47.081047,47.03191,46.982777,46.93364,46.884502,46.835365,46.78623,46.73709,46.98955,47.995968,49.002384,99.89475,95.73703,91.57931,87.421585,83.26386,79.10614,78.22758,78.754395,79.28121,79.80802,80.33484,80.86166,81.38847,81.91528,82.4421,82.96892,83.49573,84.022545,84.54936,85.07618,85.60299,86.12981,86.656624,87.18344,84.782684,81.22195,77.66122,74.10048,70.53975,66.97902,63.41828,59.85755,56.296814,52.736084,49.17535,48.702374,48.653236,48.6041,48.554962,48.50583,48.45669,48.407555,48.358418,48.30928,48.260147,48.21101,48.161873,48.112736,48.0636,48.01446,47.96533,47.91619,47.867054,47.817917,47.76878,47.719646,47.67051,47.621372,47.572235,47.523098,47.47396,47.424828,47.37569,47.326553,47.277416,47.253407,48.259827,107.4941,103.33639,99.17867,95.020966,90.86325,86.705536,80.83015,81.356964,81.88378,82.41059,82.93741,83.464226,83.991035,84.51785,85.04467,85.57149,86.0983,86.625114,87.15193,87.67874,88.20556,88.732376,89.259186,91.22216,87.66142,84.10069,80.539955,76.97922,73.41849,69.85775,66.29702,62.736282,59.17555,55.61481,52.054077,49.34097,49.291832,49.242695,49.193558,49.144424,49.095287,49.04615,48.997013,48.947876,48.898743,48.849606,48.80047,48.75133,48.702194,48.65306,48.603924,48.554787,48.50565,48.456512,48.407375,48.358242,48.309105,48.259968,48.21083,48.161694,48.11256,48.063423,48.014286,47.96515,47.91601,47.866875,47.81774,110.935745,106.77804,102.62032,98.462616,94.30491,90.1472,85.98949,84.48634,85.01315,85.53997,86.06679,86.593605,87.12042,87.64723,88.17405,88.70087,89.227684,89.7545,90.28131,90.80813,91.334946,91.86176,92.38858,90.54018,86.97944,83.4187,79.85796,76.297226,72.736496,69.17575,65.61502,62.054283,58.49354,54.932804,51.372066,49.930424,49.881287,49.83215,49.783016,49.73388,49.684742,49.635605,49.586468,49.537334,49.488197,49.43906,49.389923,49.340786,49.291653,49.242516,49.19338,49.14424,49.095104,49.045967,48.996834,48.947697,48.89856,48.849422,48.800285,48.751152,48.702015,48.652878,48.60374,48.554604,48.50547,48.456333,48.407196]
− examples/rasterize/rasterize-test4.txt
@@ -1,4 +0,0 @@-[((-267,-201),33.957397),((-226,-217),36.21704),((-244,-303),166.1195),((-343,-316),15.7873535),((-280,-273),39.814148),((-306,-342),27.929932),((-324,-236),79.39956),((-305,-213),43.06239),((-335,-252),121.0145),((-330,-297),15.217541),((-294,-311),19.864101),((-332,-271),140.75253),((-336,-285),167.71878),((-319,-285),68.29455),((-318,-277),66.3733),((-235,-275),136.13342),((-246,-339),96.01575)]-[(11,12,14),(4,0,7),(4,7,6),(6,14,4),(14,13,4),(14,12,13),(13,12,9),(14,8,11),(6,8,14),(4,1,0),(15,1,4),(2,15,4),(10,2,4),(13,10,4),(9,10,13),(3,10,9),(3,5,10),(5,10,16),(10,2,16)]-((-321,-321),(-255,-255))-[19.671001,19.366583,19.062164,18.757746,18.453327,18.14891,17.844492,17.593893,17.500454,17.407015,17.313576,17.220135,17.126696,17.033257,16.939817,16.846378,16.75294,16.659498,16.56606,16.47262,16.37918,19.552664,22.726147,25.899628,29.07311,32.246593,35.420074,38.59356,41.76704,44.940525,48.114006,51.287487,54.46097,57.634453,65.31526,75.09943,80.23697,80.727875,81.21878,81.70969,82.20059,82.6915,83.1824,82.961136,82.59746,81.88012,79.86614,77.852165,75.99871,75.80419,75.60967,75.41515,75.220634,75.02612,74.831604,74.637085,74.442566,74.248055,74.053535,73.85902,73.6645,73.46998,73.27547,73.08095,72.88643,73.098595,73.31075,19.93747,19.63305,19.328632,19.024214,18.719795,18.415377,18.110958,17.733347,17.639906,17.546467,17.453028,17.359589,17.26615,17.17271,17.07927,16.98583,16.892391,16.798952,16.705513,16.612074,16.155632,19.329115,22.502598,25.676079,28.849564,32.023045,35.19653,38.37001,41.543495,44.716976,47.890457,51.063942,54.237427,57.410908,60.58439,64.358864,74.143036,74.63394,75.12485,75.615746,76.10665,76.59756,77.08846,77.674324,77.31064,76.7112,74.69719,72.79024,72.59572,72.4012,72.20668,72.01217,71.81765,71.62313,71.42861,71.2341,71.03958,70.84506,70.78611,70.998276,71.210434,71.4226,71.634766,71.846924,72.05909,72.271255,72.48342,19.899525,19.595106,19.290688,18.986269,18.68185,18.377432,18.073013,17.77936,17.68592,17.592482,17.499043,17.405603,17.312164,17.218725,17.125284,17.031845,16.938406,16.844967,16.751528,16.658089,19.105566,22.279049,25.452532,28.626015,31.799498,34.97298,38.14646,41.319946,44.49343,47.666912,50.840393,54.013878,57.187363,60.36084,63.534325,66.70781,68.54,69.03091,69.52181,70.01272,70.503624,70.99452,71.48543,71.97633,71.54222,69.581764,69.387245,69.19273,68.998215,68.803696,68.609184,68.68578,68.89795,69.11011,69.32227,69.53444,69.7466,69.95876,70.17093,70.383095,70.59525,70.80742,71.019585,71.23175,71.44391,71.656075,71.86824,20.165998,19.86158,19.557161,19.252743,18.948324,18.643906,18.339487,18.035069,17.825375,17.731936,17.638496,17.545057,17.451616,17.358177,17.264738,17.171299,17.07786,16.98442,16.89098,15.708533,18.882019,22.055504,25.228989,28.402473,31.575958,34.749443,37.922928,41.096413,44.269897,47.443382,50.616867,53.79036,56.963837,60.13732,63.310806,66.39316,67.611916,67.457085,67.30226,67.14743,66.99261,66.837776,66.68295,66.52812,66.3733,66.585464,66.79762,67.00979,67.221954,67.43412,67.64628,67.858444,68.07061,68.282776,68.494934,68.7071,68.919266,69.131424,69.34359,69.555756,69.76792,69.98008,70.192245,70.40441,70.61658,70.828735,71.0409,20.128054,19.823635,19.519217,19.214798,18.91038,18.60596,18.301544,17.997124,17.87139,17.77795,17.684511,17.591072,17.497631,17.404192,17.310753,17.217314,17.123875,17.030436,16.936996,18.658468,21.83195,25.005432,28.178913,31.352394,34.525875,37.699356,40.872837,44.046318,47.219803,50.393284,53.56676,56.740246,59.913727,63.087208,64.93953,65.835106,66.730675,66.69705,66.54223,66.3874,66.23257,66.07774,65.92291,65.76809,65.758125,65.97029,66.18246,66.39462,66.60678,66.81895,67.03111,67.24327,67.45544,67.6676,67.87976,68.09193,68.30409,68.51626,68.72842,68.94058,69.15275,69.364914,69.57707,69.78924,70.0014,70.21356,70.42573,20.394522,20.090103,19.785685,19.481266,19.176847,18.872429,18.56801,18.263592,18.010841,17.917402,17.823963,17.730524,17.637083,17.543644,17.450205,17.356764,17.263325,17.169886,17.076447,18.435013,21.60849,24.781967,27.955444,31.128923,34.3024,37.47588,40.649353,43.822834,46.996307,50.16979,53.343266,56.516743,59.69022,62.59036,63.48593,64.3815,65.27708,66.091835,65.937004,65.78218,65.62735,65.47253,65.317696,65.16287,64.93078,65.142944,65.35511,65.56727,65.779434,65.9916,66.203766,66.415924,66.62809,66.840256,67.052414,67.26458,67.476746,67.68891,67.90107,68.113235,68.3254,68.53757,68.749725,68.96189,69.17406,69.386215,69.59838,20.356575,20.052156,19.747738,19.44332,19.1389,18.834482,18.530064,18.225647,18.056856,17.963417,17.869978,17.776537,17.683098,17.589659,17.49622,17.402779,17.30934,17.2159,18.211468,21.384947,24.558426,27.731907,30.905386,34.078865,37.252346,40.425827,43.599304,46.772785,49.946266,53.119743,56.29322,59.466705,61.136753,62.032322,62.92789,63.823456,64.719025,65.331795,65.17697,65.02214,64.86731,64.71249,64.557655,64.402824,64.3156,64.52776,64.73993,64.952095,65.16425,65.37642,65.588585,65.80075,66.01291,66.225075,66.43724,66.64941,66.861565,67.07373,67.2859,67.49806,67.71022,67.922386,68.13455,68.34672,68.558876,68.77104,68.98321,20.623047,20.31863,20.014212,19.709793,19.405375,19.100956,18.796537,18.492119,18.19631,18.10287,18.009432,17.91599,17.822552,17.729113,17.635672,17.542233,17.448793,17.355352,17.987919,21.161402,24.334885,27.508368,30.68185,33.85533,37.028816,40.2023,43.375782,46.549267,49.722748,52.896233,56.06971,58.787582,59.68315,60.57872,61.47429,62.369854,63.265423,64.16099,64.571754,64.41692,64.2621,64.10727,63.952442,63.797615,63.488266,63.70043,63.912594,64.124756,64.33692,64.54909,64.761246,64.97341,65.18558,65.39774,65.6099,65.82207,66.03423,66.2464,66.45856,66.67072,66.88289,67.09505,67.30721,67.51938,67.731544,67.9437,68.15587,20.585096,20.280678,19.97626,19.67184,19.367422,19.063004,18.758585,18.454166,18.242321,18.148882,18.055443,17.962004,17.868565,17.775126,17.681686,17.588247,17.494808,17.76437,20.937847,24.111326,27.284805,30.458282,33.63176,36.805237,39.978718,43.152195,46.325672,49.49915,52.67263,55.846107,57.333954,58.229523,59.12509,60.02066,60.91623,61.8118,62.707367,63.602936,63.811714,63.656887,63.50206,63.347233,63.1924,63.037575,62.882748,63.085255,63.29742,63.509583,63.72175,63.93391,64.14607,64.35824,64.570404,64.78256,64.99473,65.206894,65.41905,65.63122,65.84338,66.05555,66.26771,66.47987,66.69204,66.9042,67.11636,67.32853,67.540695,20.85157,20.547152,20.242733,19.938314,19.633896,19.329477,19.025059,18.72064,18.381775,18.288336,18.194897,18.101458,18.008018,17.91458,17.821138,17.7277,17.63426,17.540821,20.714302,23.887783,27.061264,30.234745,33.408226,36.581707,39.755188,42.928673,46.10215,49.275635,52.449116,54.984783,55.880352,56.77592,57.67149,58.567062,59.46263,60.3582,61.25377,62.149338,63.2065,63.051674,62.896847,62.74202,62.587193,62.432365,62.277534,62.25791,62.470074,62.68224,62.8944,63.106567,63.31873,63.530895,63.743057,63.955223,64.16739,64.37955,64.59171,64.80388,65.016045,65.2282,65.44037,65.652534,65.8647,66.07686,66.289024,66.50119,66.71335,20.813625,20.509207,20.204788,19.90037,19.595951,19.291534,18.987114,18.682697,18.42779,18.33435,18.240911,18.147472,18.054031,17.960592,17.867153,17.773714,17.680273,20.490755,23.664242,26.837727,30.011211,33.184692,36.358177,39.531662,42.705147,45.87863,49.052116,52.2256,53.531178,54.426746,55.32231,56.21788,57.11345,58.009014,58.904583,59.800148,60.695717,61.591286,62.44646,62.291634,62.136806,61.98198,61.82715,61.67232,61.517494,61.64274,61.8549,62.067066,62.27923,62.491394,62.703556,62.91572,63.127884,63.34005,63.55221,63.764378,63.97654,64.188705,64.40087,64.61303,64.825195,65.03736,65.24953,65.461685,65.67385,65.88602,66.098175,21.080093,20.775675,20.471256,20.166838,19.86242,19.558,19.253582,18.949163,18.567244,18.473804,18.380363,18.286924,18.193485,18.100046,18.006607,17.913168,17.093725,20.267204,23.440681,26.614162,29.78764,32.96112,36.134598,39.308075,42.48156,45.655037,48.828514,51.18198,52.077553,52.97312,53.86869,54.764263,55.659832,56.5554,57.450974,58.346542,59.24211,60.137684,61.033253,61.68642,61.53159,61.376762,61.221935,61.06711,60.91228,60.8154,61.02756,61.239727,61.45189,61.664055,61.876217,62.08838,62.300545,62.512707,62.724873,62.937035,63.149197,63.361362,63.573524,63.78569,63.997852,64.210014,64.42218,64.634346,64.846504,65.05867,65.270836,21.042147,20.737728,20.43331,20.128891,19.824474,19.520054,19.215637,18.911217,18.613256,18.519817,18.426378,18.33294,18.2395,18.14606,18.05262,17.95918,20.043657,23.21714,26.390623,29.564106,32.737587,35.91107,39.084557,42.258038,45.43152,48.605003,49.72838,50.623947,51.519512,52.41508,53.31065,54.20622,55.101788,55.997356,56.892925,57.78849,58.68406,59.579628,60.475197,60.92638,60.771553,60.616722,60.461895,60.307064,60.152237,60.200226,60.412388,60.62455,60.836716,61.048878,61.261044,61.473206,61.68537,61.897533,62.109695,62.32186,62.534023,62.74619,62.95835,63.170517,63.38268,63.59484,63.807007,64.01917,64.23133,64.4435,64.65566,21.308619,21.004202,20.699783,20.395365,20.090946,19.786528,19.48211,19.177692,18.873272,18.659271,18.565832,18.472393,18.378954,18.285515,18.192076,16.646624,19.820112,22.993599,26.167086,29.340572,32.51406,35.687546,38.86103,42.034523,45.208008,47.379204,48.274773,49.17034,50.06591,50.96148,51.857048,52.752617,53.648186,54.543755,55.439323,56.334892,57.23046,58.12603,59.0216,60.321163,60.166336,60.01151,59.85668,59.701855,59.547028,59.37288,59.585045,59.797207,60.009373,60.221535,60.4337,60.645863,60.85803,61.07019,61.282356,61.49452,61.706684,61.918846,62.131012,62.343174,62.55534,62.7675,62.979668,63.19183,63.403996,63.616158,63.828323,21.270668,20.96625,20.66183,20.357412,20.052994,19.748575,19.444157,19.139738,18.83532,18.705284,18.611843,18.518404,18.424965,18.331526,18.238087,19.596655,22.770136,25.943617,29.117096,32.290577,35.464058,38.63754,41.81102,44.9845,45.925602,46.821167,47.716736,48.612305,49.50787,50.40344,51.299004,52.194572,53.09014,53.98571,54.881275,55.776844,56.67241,57.567978,58.463547,59.35911,59.4063,59.25147,59.09664,58.941814,58.786983,58.757706,58.969868,59.182034,59.394196,59.60636,59.818523,60.030685,60.24285,60.455013,60.66718,60.87934,61.091507,61.30367,61.51583,61.727997,61.94016,62.152325,62.364487,62.576653,62.788815,63.00098,63.213142,21.537144,21.232725,20.928307,20.623888,20.31947,20.01505,19.710632,19.406214,19.101795,18.84474,18.751299,18.65786,18.56442,18.47098,18.37754,19.373104,22.546577,25.72005,28.893524,32.066998,35.24047,38.41394,42.680836,43.576405,44.471973,45.367542,46.26311,47.15868,48.05425,48.949818,49.845387,50.740955,51.636528,52.532097,53.427666,54.323235,55.218803,56.114372,57.00994,57.90551,58.80108,58.64625,58.491425,58.336597,58.18177,57.930367,58.142532,58.354694,58.566856,58.779022,58.991184,59.20335,59.415512,59.627678,59.83984,60.052006,60.264168,60.476334,60.688496,60.900658,61.112823,61.324986,61.53715,61.749313,61.96148,62.17364,62.385807,21.499199,21.19478,20.890362,20.585943,20.281525,19.977106,19.672688,19.368269,19.06385,18.890753,18.797314,18.703873,18.610434,18.516994,19.149557,22.323034,25.496513,28.66999,31.843468,35.016945,38.190422,41.227234,42.122803,43.01837,43.91394,44.80951,45.70508,46.60065,47.49622,48.39179,49.287357,50.182926,51.0785,51.974068,52.869637,53.765205,54.660774,55.556343,56.451912,57.347485,58.04104,57.88621,57.731384,57.576557,57.421726,57.315193,57.527355,57.73952,57.951683,58.16385,58.37601,58.588173,58.80034,59.0125,59.224667,59.43683,59.648994,59.861156,60.07332,60.285484,60.497646,60.709812,60.921974,61.13414,61.346302,61.558464,61.77063,21.765663,21.461245,21.156826,20.852407,20.547989,20.243572,19.939152,19.634735,19.330315,19.030205,18.936766,18.843327,18.749887,18.656448,18.92601,22.099493,25.272976,28.446457,31.61994,34.793423,38.878056,39.773624,40.669193,41.564762,42.46033,43.3559,44.25147,45.147038,46.042606,46.938175,47.833744,48.72931,49.624878,50.520447,51.416016,52.311584,53.207153,54.102722,54.99829,55.89386,56.78943,57.281002,57.12617,56.971344,56.816517,56.487846,56.700012,56.912174,57.12434,57.336502,57.548668,57.76083,57.972992,58.185158,58.39732,58.609486,58.821648,59.033813,59.245975,59.458138,59.670303,59.882465,60.09463,60.306793,60.51896,60.73112,60.943283,21.727718,21.423302,21.118881,20.814465,20.510044,20.205627,19.901207,19.59679,19.29237,19.07622,18.982779,18.88934,18.7959,18.702461,21.875952,25.04944,28.22293,31.39642,34.56991,37.424458,38.320026,39.215595,40.111164,41.006733,41.9023,42.79787,43.69344,44.58901,45.484573,46.380142,47.27571,48.17128,49.06685,49.962418,50.857986,51.753555,52.649124,53.544693,54.44026,55.33583,56.2314,56.520958,56.36613,56.211304,56.056473,55.901646,56.08484,56.297,56.509163,56.72133,56.93349,57.145657,57.35782,57.569984,57.782146,57.994312,58.206474,58.41864,58.630802,58.842964,59.05513,59.267292,59.479458,59.69162,59.903786,60.115948,60.328114,21.994194,21.689775,21.385357,21.080938,20.77652,20.472101,20.167683,19.863264,19.558846,19.215673,19.122232,19.028793,18.935354,18.478912,21.652391,24.82587,27.999352,31.172829,35.07526,35.970825,36.866394,37.761963,38.65753,39.5531,40.44867,41.34424,42.239807,43.135376,44.030945,44.926514,45.822083,46.71765,47.61322,48.50879,49.404358,50.299927,51.195496,52.091064,52.986633,53.882202,54.77777,55.91574,55.760914,55.606087,55.45126,55.296432,55.2575,55.46966,55.681828,55.89399,56.10615,56.318317,56.53048,56.742645,56.954807,57.166973,57.379135,57.5913,57.803463,58.015625,58.22779,58.439953,58.65212,58.86428,59.076443,59.28861,59.50077,21.95624,21.651821,21.347404,21.042984,20.738567,20.434149,20.12973,19.825312,19.520893,19.261686,19.168247,19.074808,18.981369,21.42885,24.602337,27.775822,30.94931,33.62165,34.51722,35.41279,36.30836,37.20393,38.0995,38.995068,39.890636,40.786205,41.681774,42.577343,43.47291,44.368484,45.264053,46.159622,47.05519,47.95076,48.84633,49.741898,50.637466,51.533035,52.428604,53.324173,54.21974,55.115314,55.000874,54.846046,54.69122,54.53639,54.642323,54.85449,55.06665,55.278816,55.49098,55.70314,55.915306,56.12747,56.339634,56.551796,56.763958,56.976124,57.188286,57.40045,57.612614,57.824776,58.03694,58.249104,58.461266,58.67343,58.29202,22.222715,21.918297,21.613878,21.30946,21.005041,20.700623,20.396204,20.091785,19.787367,19.40114,19.307701,19.21426,18.031809,21.205307,24.378803,27.552301,31.27248,32.16805,33.063618,33.959183,34.85475,35.75032,36.64589,37.54146,38.437027,39.332596,40.22816,41.12373,42.0193,42.914867,43.810432,44.706,45.60157,46.49714,47.392708,48.288277,49.183846,50.079414,50.97498,51.870552,52.766117,53.661686,54.39566,54.240833,54.086006,53.93118,53.81498,54.027145,54.239307,54.451473,54.663635,54.8758,55.087963,55.30013,55.51229,55.724457,55.93662,56.148785,56.360947,56.573112,56.785275,56.99744,57.209602,57.42177,57.63393,57.71775,57.22404,22.18477,21.880352,21.575933,21.271515,20.967096,20.662678,20.35826,20.05384,19.749422,19.447155,19.353716,19.260277,20.981749,24.155231,27.328712,29.81885,30.71442,31.60999,32.505558,33.401127,34.296696,35.192265,36.087837,36.983406,37.878975,38.774544,39.670113,40.56568,41.46125,42.356823,43.25239,44.14796,45.04353,45.939102,46.83467,47.73024,48.62581,49.521378,50.416946,51.312515,52.208084,53.103653,53.635616,53.48079,53.325962,53.171135,53.199806,53.41197,53.624134,53.836296,54.048462,54.260624,54.47279,54.68495,54.897118,55.10928,55.32144,55.533607,55.74577,55.957935,56.170097,56.382263,56.594425,56.80659,56.64977,56.15606,55.66235,22.451235,22.146816,21.842398,21.53798,21.23356,20.929142,20.624723,20.320305,20.015886,19.711468,19.493166,19.399727,20.758286,23.931747,27.469679,28.365246,29.260815,30.156384,31.051952,31.947521,32.84309,33.73866,34.634228,35.529797,36.425365,37.32093,38.2165,39.11207,40.007637,40.903206,41.798775,42.694344,43.589912,44.48548,45.38105,46.27662,47.172188,48.067757,48.963326,49.858894,50.754463,51.65003,53.030407,52.87558,52.72075,52.56592,52.372467,52.58463,52.796795,53.008957,53.221123,53.433285,53.64545,53.857613,54.069775,54.28194,54.494102,54.70627,54.91843,55.130596,55.34276,55.554924,55.767086,56.075497,55.581787,55.088078,54.594368,23.12876,22.4155,21.804455,21.500036,21.195618,20.8912,20.58678,20.282362,19.977943,19.673525,19.53918,20.534744,23.708218,26.016075,26.911644,27.807213,28.702782,29.59835,30.49392,31.389488,32.285057,33.180626,34.076195,34.971764,35.867332,36.7629,37.65847,38.55404,39.449608,40.345177,41.240746,42.136314,43.031883,43.927452,44.82302,45.71859,46.61416,47.509727,48.405296,49.300865,50.196434,51.092003,51.98757,52.11554,51.960712,51.805885,51.757286,51.96945,52.181614,52.39378,52.60594,52.818108,53.03027,53.242435,53.4546,53.666763,53.87893,54.09109,54.303257,54.51542,54.727585,54.93975,55.00752,54.51381,54.0201,53.52639,53.03268,24.655819,23.942562,23.229305,22.51605,21.802794,21.157673,20.853254,20.548836,20.244417,19.94,19.678635,20.311203,23.666903,24.562471,25.45804,26.353607,27.249176,28.144743,29.040312,29.935879,30.831448,31.727016,32.622585,33.51815,34.41372,35.309288,36.204857,37.100426,37.99599,38.89156,39.78713,40.682693,41.578262,42.47383,43.3694,44.26497,45.160538,46.056107,46.951675,47.84724,48.742805,49.638374,50.533943,51.510326,51.355495,51.20067,50.929947,51.142113,51.354275,51.56644,51.778603,51.990765,52.20293,52.415092,52.62726,52.83942,53.051582,53.26375,53.47591,53.688076,53.900238,54.433266,53.939552,53.445843,52.952133,52.458424,51.96471,25.4696,24.756346,24.043089,23.329834,22.616577,21.90332,21.190065,20.510881,20.206463,19.902046,20.087645,22.213274,23.108843,24.004412,24.89998,25.79555,26.69112,27.586689,28.482258,29.377827,30.273396,31.168964,32.064533,32.960106,33.855675,34.751244,35.646812,36.54238,37.43795,38.33352,39.229088,40.124657,41.020226,41.915794,42.811363,43.706932,44.602505,45.49807,46.393642,47.289207,48.18478,49.08035,49.975918,50.750286,50.595455,50.440628,50.314774,50.526936,50.7391,50.951263,51.163425,51.37559,51.587753,51.79992,52.01208,52.224243,52.43641,52.64857,52.860733,53.0729,53.28506,52.87157,52.37786,51.88415,51.39044,50.896732,50.403023,26.996666,26.28341,25.570154,24.856897,24.14364,23.430384,22.717129,22.00387,21.290613,20.577358,19.864101,20.75967,21.65524,22.550806,23.446375,24.341944,25.23751,26.13308,27.028648,27.924217,28.819786,29.715355,30.610922,31.50649,32.402058,33.297626,34.193195,35.088764,35.98433,36.8799,37.775467,38.671036,39.566605,40.462173,41.357742,42.25331,43.14888,44.04445,44.940018,45.835587,46.731155,47.626724,48.52229,49.41786,49.990242,49.835415,49.680584,49.6996,49.911762,50.123924,50.33609,50.548252,50.760418,50.97258,51.184742,51.396908,51.60907,51.821236,52.033398,52.24556,52.297306,51.803596,51.309883,50.816174,50.322464,49.828754,49.335045,27.810455,27.0972,26.383944,25.670687,24.95743,24.244175,23.530918,22.817661,22.104404,21.60068,22.589533,22.002245,21.414957,21.992758,22.888327,23.783895,24.679464,25.575035,26.470604,27.366173,28.261742,29.15731,30.05288,30.948448,31.844017,32.739586,33.635155,34.530724,35.426292,36.32186,37.21743,38.113,39.008568,39.904137,40.79971,41.695274,42.590843,43.486412,44.381985,45.277554,46.173122,47.068687,47.96426,48.85983,49.2302,49.075375,48.920547,49.08442,49.29658,49.508747,49.72091,49.933075,50.145237,50.357403,50.569565,50.78173,50.993893,51.20606,51.41822,51.229324,50.735615,50.241905,49.74819,49.254482,48.760773,48.267063,47.773354,29.337524,28.624268,27.911013,27.197756,26.484499,25.771244,25.057987,24.34473,23.631474,23.337206,25.902254,25.314962,24.72767,24.140379,23.553087,22.330303,23.225872,24.12144,25.01701,25.912579,26.808147,27.703716,28.599285,29.494854,30.390423,31.285992,32.18156,33.07713,33.9727,34.868267,35.763836,36.659405,37.554974,38.450542,39.34611,40.24168,41.13725,42.032818,42.928387,43.823956,44.719524,45.615093,46.510662,47.40623,48.624985,48.470158,48.31533,48.25708,48.469242,48.681408,48.89357,49.105736,49.317898,49.530064,49.742226,49.954388,50.166553,50.378716,50.655052,50.161343,49.667633,49.173923,48.680214,48.1865,47.69279,47.19908,46.70537,30.151318,29.43806,28.724802,28.011547,27.29829,26.585033,25.871778,25.158522,25.073784,26.874603,28.627686,28.040396,27.453104,26.865814,26.278524,25.691233,25.103943,24.516651,24.45896,25.354528,26.250097,27.145666,28.041235,28.936804,29.832373,30.727942,31.62351,32.51908,33.414646,34.310215,35.205784,36.101353,36.99692,37.89249,38.78806,39.683628,40.579197,41.474766,42.370335,43.265903,44.161472,45.05704,45.95261,46.84818,47.743748,47.71012,47.55529,47.641907,47.85407,48.066235,48.278397,48.490562,48.702724,48.914886,49.127052,49.339214,49.55138,49.587074,49.093365,48.599655,48.105946,47.612232,47.118523,46.624813,46.131104,45.637394,45.143684,31.678364,30.965107,30.25185,29.538595,28.825338,28.112082,27.398825,26.68557,26.81036,28.611174,30.411987,31.353117,30.765827,30.178537,29.591248,29.003958,28.416668,27.829378,27.242088,26.654797,26.067507,25.692049,26.587618,27.483187,28.378756,29.274326,30.169895,31.065464,31.961035,32.8566,33.752174,34.647743,35.543312,36.43888,37.33445,38.23002,39.125587,40.021156,40.91673,41.812298,42.707867,43.60344,44.49901,45.394577,46.290146,47.1049,46.950073,46.814568,47.02673,47.238895,47.451057,47.663223,47.875385,48.087547,48.299713,48.511875,49.012802,48.519093,48.025383,47.531673,47.037964,46.544254,46.050545,45.556835,45.063126,44.569416,44.075706,32.492176,31.77892,31.065662,30.352406,29.63915,28.925894,28.212639,28.546894,30.347733,32.14857,33.94941,34.07853,33.49124,32.903954,32.316666,31.729378,31.14209,30.554802,29.967514,29.380226,28.792938,28.20565,27.618362,27.031075,27.820705,28.716274,29.611843,30.507412,31.402983,32.298553,33.194122,34.08969,34.98526,35.88083,36.776398,37.671967,38.567535,39.463104,40.358673,41.254246,42.149815,43.045383,43.940956,44.836525,45.732094,46.344868,46.190037,46.199387,46.41155,46.623714,46.83588,47.048042,47.26021,47.47237,47.684536,47.896698,47.451115,46.957405,46.46369,45.969982,45.476273,44.982563,44.488853,43.995144,43.501434,43.007725,42.514015,34.019222,33.305965,32.59271,31.879452,31.166197,30.45294,29.739685,30.283472,32.084305,33.885136,35.685966,37.391254,36.803963,36.216675,35.629383,35.042095,34.454807,33.867516,33.280228,32.69294,32.105648,31.51836,30.93107,30.34378,29.756493,29.169203,28.158253,29.053822,29.94939,30.84496,31.740528,32.636097,33.531666,34.427235,35.322803,36.218372,37.11394,38.00951,38.90508,39.800648,40.696217,41.591785,42.487354,43.382923,44.278492,45.174057,45.58482,45.372047,45.584213,45.796375,46.00854,46.220703,46.432865,46.64503,46.857193,46.876842,46.383133,45.889423,45.395714,44.902004,44.408295,43.91458,43.42087,42.927162,42.433453,41.939743,41.446033,34.83302,34.119762,33.406506,32.69325,31.979992,31.266735,32.02005,33.820877,35.621704,37.42253,39.223354,40.116688,39.529396,38.94211,38.35482,37.76753,37.18024,36.59295,36.00566,35.418373,34.831085,34.243793,33.656506,33.069214,32.481926,31.894638,31.307348,30.720058,30.13277,30.28691,31.182478,32.078045,32.973614,33.869183,34.76475,35.66032,36.55589,37.451454,38.347023,39.24259,40.13816,41.03373,41.9293,42.824867,43.720436,44.616005,44.82478,44.756874,44.969036,45.181202,45.393364,45.60553,45.817696,46.029858,45.808865,45.315155,44.821445,44.327732,43.834023,43.340313,42.846603,42.352894,41.859184,41.36547,40.87176,40.695385,40.655003,36.36008,35.646828,34.93357,34.220314,33.507057,31.955746,33.756577,35.557407,37.358242,39.159073,40.959904,43.429405,42.842117,42.254826,41.667538,41.08025,40.49296,39.90567,39.318382,38.731094,38.143803,37.556515,36.969227,36.381935,35.794647,35.20736,34.62007,34.03278,33.44549,32.858204,32.270912,31.683624,31.519997,32.415565,33.31114,34.206707,35.102276,35.997845,36.893417,37.788986,38.684555,39.580124,40.475693,41.371265,42.266834,43.162403,44.219566,43.929535,44.1417,44.353863,44.566025,44.77819,44.990353,45.234592,44.740883,44.247173,43.753464,43.259754,42.766045,42.272335,41.778625,41.284916,40.609882,40.569496,40.529114,40.488728,40.44834,37.17387,36.460617,35.74736,35.034103,34.320847,35.493153,37.29398,39.094807,40.895634,42.69646,44.497288,46.154835,45.567547,44.980255,44.392967,43.805676,43.218388,42.6311,42.043808,41.45652,40.86923,40.28194,39.69465,39.10736,38.520073,37.93278,37.345493,36.7582,36.170914,35.583622,34.996334,34.409042,33.821754,33.234467,32.753113,33.64868,34.544247,35.439816,36.33538,37.23095,38.126514,39.022083,39.91765,40.813217,41.708782,42.60435,43.459526,43.314354,43.52652,43.73868,43.950848,44.163013,44.16661,43.6729,43.179195,42.685486,42.191776,41.698067,41.204357,40.710648,40.443604,40.403217,40.362835,40.32245,40.282066,40.24168,40.201298,38.700924,37.987667,37.27441,36.561153,35.42891,37.229733,39.030556,40.83138,42.632202,44.43303,46.233852,48.034676,48.88027,48.29298,47.70569,47.1184,46.531113,45.94382,45.356533,44.76924,44.181953,43.59466,43.007374,42.420086,41.832794,41.245506,40.65822,40.070927,39.483635,38.896347,38.30906,37.72177,37.13448,36.547188,35.9599,35.372612,34.78532,33.986202,34.88177,35.77734,36.67291,37.568478,38.464043,39.35961,40.25518,41.15075,42.046318,42.699486,42.69918,42.911343,43.123505,43.592354,43.098644,42.604935,42.111225,41.617516,41.123806,40.630096,40.31771,40.27733,40.236942,40.19656,40.156174,40.11579,40.075405,40.035023,39.994637,39.514732,38.80148,38.088223,37.374966,38.966263,40.76709,42.567917,44.368744,46.169575,47.9704,49.771233,51.57206,51.6057,51.018414,50.43112,49.843834,49.256546,48.669254,48.081966,47.494675,46.907387,46.3201,45.732807,45.14552,44.558228,43.97094,43.38365,42.79636,42.209072,41.62178,41.034492,40.447205,39.859913,39.272625,38.685333,38.098045,37.510757,36.923466,36.336178,35.748886,36.114857,37.010426,37.90599,38.80156,39.69713,40.592697,41.488262,41.939445,42.084003,42.296165,42.50833,42.03067,41.53696,41.04325,40.54954,40.191822,40.15144,40.111053,40.07067,40.030285,39.989902,39.949516,39.90913,39.868748,39.82836,39.78798,39.747593,41.041782,40.328526,39.61527,38.90201,40.70284,42.503662,44.30449,46.105312,47.906136,49.706963,51.50779,53.308613,54.918423,54.33113,53.743843,53.156555,52.569263,51.981976,51.394688,50.807396,50.220108,49.63282,49.04553,48.45824,47.87095,47.28366,46.696373,46.10908,45.521793,44.934505,44.347214,43.759926,43.172638,42.585346,41.99806,41.410767,40.82348,40.23619,39.6489,39.06161,38.47432,37.88703,37.299744,37.347946,38.24352,39.13909,40.03466,41.334232,41.256668,41.468826,41.456394,40.962685,40.46897,40.065933,40.025547,39.985165,39.94478,39.904392,39.86401,39.823624,39.78324,39.742855,39.702473,39.662086,39.621704,39.581318,39.540936,41.855568,41.142315,40.63859,42.43942,44.24025,46.041077,47.841904,49.642735,51.443565,53.244392,55.04522,56.84605,57.643837,57.05655,56.469257,55.88197,55.29468,54.70739,54.120102,53.532814,52.945522,52.358234,51.770947,51.183655,50.596367,50.00908,49.421787,48.8345,48.247208,47.65992,47.07263,46.485344,45.898052,45.310764,44.723473,44.136185,43.548897,42.961605,42.374317,41.787025,41.199738,40.61245,40.02516,39.437874,38.85058,38.58106,39.476616,40.372177,40.641483,40.388412,39.940037,39.899654,39.85927,39.818886,39.7785,39.738117,39.69773,39.65735,39.616962,39.57658,39.536194,39.49581,39.455425,39.415043,39.374657,39.334274,39.293888,43.38264,42.669384,42.37512,44.17595,45.97678,47.77761,49.578445,51.379276,53.180107,54.98094,56.78177,58.582603,60.956562,60.36927,59.781982,59.19469,58.607403,58.020115,57.432823,56.845535,56.258247,55.670956,55.083668,54.49638,53.90909,53.3218,52.734512,52.147224,51.559933,50.97264,50.385353,49.798065,49.210777,48.623486,48.036198,47.448906,46.861618,46.27433,45.687042,45.09975,44.512463,43.92517,43.337883,42.750595,42.163307,41.576015,40.988728,40.401436,39.814148,39.77376,39.73338,39.692993,39.65261,39.612225,39.571842,39.531456,39.491074,39.450687,39.410305,39.36992,39.329536,39.28915,39.248768,39.20838,39.168,39.127613,39.08723,44.196434,44.1117,45.91253,47.713356,49.514183,51.315014,53.115845,54.91667,56.717503,58.51833,60.31916,62.119987,63.68199,63.0947,62.507412,61.92012,61.332832,60.745544,60.158253,59.570965,58.983677,58.396385,57.809097,57.22181,56.634518,56.04723,55.459938,54.87265,54.285362,53.69807,53.110783,52.52349,51.936203,51.348915,50.761623,50.174335,49.587044,48.999756,48.412468,47.825176,47.23789,46.650597,46.06331,45.47602,44.888733,44.30144,43.71415,42.744576,40.84352,39.708054,39.622765,39.53748,39.452194,39.36691,39.3248,39.284412,39.24403,39.203644,39.163258,39.122875,39.08249,39.042107,39.00172,38.961338,38.92095,38.88057,38.840183,45.72348,45.848274,47.6491,49.44993,51.250755,53.051582,54.85241,56.653236,58.454063,60.25489,62.055717,63.856544,65.65737,66.407425,65.82014,65.23285,64.64555,64.058266,63.470978,62.88369,62.2964,61.70911,61.121822,60.53453,59.947243,59.359955,58.772663,58.185375,57.598087,57.010796,56.423508,55.83622,55.24893,54.66164,54.07435,53.48706,52.899773,52.312485,51.725197,51.137905,50.550617,49.963326,49.376038,48.78875,48.20146,47.61417,47.409187,45.675014,43.913586,41.87283,39.68724,39.601955,39.51667,39.431385,39.3461,39.26081,39.175526,39.09024,39.004955,38.916214,38.87583,38.835445,38.795063,38.754677,38.714294,38.67391,38.633526,47.5848,49.38563,51.18646,52.98729,54.78812,56.58895,58.38978,60.19061,61.99144,63.792267,65.593094,67.39393,69.194756,69.13286,68.54557,67.958275,67.37099,66.7837,66.19641,65.60912,65.021835,64.43454,63.84725,63.259964,62.672672,62.085384,61.498093,60.910805,60.323517,59.73623,59.148937,58.56165,57.974358,57.38707,56.799778,56.21249,55.6252,55.03791,54.450623,53.863335,53.276043,52.688755,52.101463,51.514175,50.926884,50.339596,48.605442,46.871292,44.942955,42.9022,40.861443,39.581142,39.495857,39.410572,39.325283,39.239998,39.154713,39.069427,38.984142,38.898857,38.813572,38.728287,38.643,38.557716,38.47243,38.426865,38.386482,49.32138,51.122208,52.923035,54.72386,56.52469,58.325516,60.126343,61.92717,63.728,65.528824,67.32965,69.13048,70.931305,72.44557,71.858284,71.270996,70.6837,70.09641,69.509125,68.92184,68.33455,67.74725,67.159966,66.57268,65.98539,65.3981,64.81081,64.22352,63.63623,63.04894,62.46165,61.87436,61.28707,60.699783,60.11249,59.525204,58.937912,58.350624,57.763336,57.176044,56.588753,56.001465,55.414177,54.82689,54.239597,53.27001,51.535873,49.80173,48.01309,45.972332,43.931572,41.890816,39.56033,39.475044,39.38976,39.304474,39.21919,39.133904,39.04862,38.963333,38.878048,38.79276,38.707474,38.62219,38.536903,38.45162,38.366333,52.858788,54.65961,56.460438,58.26126,60.062088,61.86291,63.663734,65.46456,67.26539,69.06621,70.867035,72.66786,74.46869,75.171,74.58371,73.99642,73.409134,72.821846,72.23455,71.64726,71.059975,70.47269,69.8854,69.29811,68.71082,68.12353,67.53624,66.94895,66.361664,65.774376,65.18709,64.5998,64.01251,63.425217,62.83793,62.25064,61.663353,61.076065,60.488773,59.901485,59.314194,58.726906,58.139618,57.55233,56.20047,54.46631,52.732147,50.99799,49.042397,47.00164,44.960884,42.920128,40.87937,39.454235,39.368946,39.28366,39.198376,39.11309,39.027805,38.94252,38.857235,38.77195,38.686665,38.60138,38.51609,38.430805,38.34552,54.595314,56.39614,58.196968,59.997795,61.798622,63.59945,65.400276,67.2011,69.00193,70.802765,72.60359,74.40441,76.20524,78.48372,77.89643,77.30914,76.721855,76.13457,75.54727,74.959984,74.372696,73.78541,73.19812,72.61083,72.02354,71.43625,70.84896,70.26167,69.674385,69.0871,68.4998,67.91251,67.325226,66.73794,66.15065,65.563354,64.97607,64.38878,63.80149,63.2142,62.62691,62.03962,61.45233,60.865044,59.130894,57.39674,55.66259,53.928436,52.112526,50.07177,48.031013,45.990257,43.9495,41.908745,39.433422,39.348137,39.26285,39.177567,39.09228,39.006996,38.92171,38.836426,38.75114,38.66585,38.580566,38.49528,38.409996,58.132725,59.933556,61.734383,63.535213,65.336044,67.13687,68.9377,70.73853,72.53936,74.340195,76.14102,77.94185,79.742676,81.20914,80.62185,80.03456,79.44727,78.85998,78.27269,77.6854,77.098114,76.510826,75.92354,75.33624,74.748955,74.16167,73.57438,72.98709,72.399796,71.81251,71.22522,70.63793,70.050644,69.463356,68.87607,68.28877,67.701485,67.1142,66.52691,65.93962,65.352325,64.76504,63.795456,62.06131,60.327164,58.59302,56.858875,55.124733,53.141888,51.101124,49.06036,47.019592,44.97883,42.938065,40.8973,39.32732,39.242035,39.15675,39.071465,38.98618,38.900894,38.81561,38.730324,38.64504,38.559753,38.47447,38.389183,59.8693,61.670128,63.47096,65.27179,67.07262,68.87344,70.67427,72.4751,74.275925,76.07675,77.87758,79.678406,81.47924,83.28007,83.93457,83.34728,82.759995,82.17271,81.58542,80.99812,80.410835,79.82355,79.23626,78.64897,78.06168,77.474396,76.88711,76.29982,75.712524,75.12524,74.53795,73.95066,73.36337,72.776085,72.1888,71.6015,71.01421,70.426926,69.83964,69.25235,68.66506,68.460075,66.725914,64.99176,63.257607,61.52345,59.78929,58.055138,56.211964,54.171207,52.13045,50.08969,48.048935,46.00818,43.967422,41.926666,39.30651,39.221226,39.13594,39.050655,38.96537,38.880085,38.7948,38.709515,38.62423,38.538944,38.45366,63.406662,65.2075,67.00832,68.80915,70.609985,72.41081,74.21164,76.01247,77.8133,79.614136,81.41496,83.21579,85.01662,86.81745,86.66,86.072716,85.48543,84.89814,84.31085,83.72356,83.13627,82.54898,81.96169,81.374405,80.78712,80.19982,79.61253,79.025246,78.43796,77.85067,77.26338,76.67609,76.0888,75.50151,74.91422,74.326935,73.73965,73.15236,72.56506,71.977776,71.39049,69.656334,67.92219,66.188034,64.45388,62.71973,60.98558,59.251427,57.241333,55.200577,53.15982,51.119064,49.07831,47.03755,44.996796,42.95604,40.915283,39.200417,39.11513,39.029846,38.94456,38.859276,38.77399,38.688705,38.60342,38.51813,38.432846,65.143234,66.94406,68.744896,70.54572,72.34655,74.14738,75.948204,77.74904,79.549866,81.35069,83.15152,84.95235,86.753174,88.55401,89.972725,89.38544,88.79815,88.21086,87.62357,87.03628,86.44899,85.8617,85.274414,84.687126,84.09983,83.51254,82.925255,82.33797,81.75067,81.16338,80.576096,79.98881,79.40152,78.81423,78.22694,77.63965,77.05236,76.46507,75.877785,75.29049,74.3209,72.58675,70.85259,69.11844,67.384285,65.65013,63.915977,62.181824,60.311398,58.27064,56.229885,54.18913,52.148373,50.107616,48.06686,46.026104,43.985348,41.94459,39.179604,39.09432,39.009033,38.923748,38.838463,38.753178,38.667892,38.582607,38.497322,68.68063,70.48146,72.28229,74.08312,75.88394,77.68478,79.4856,81.28643,83.08726,84.888084,86.68891,88.48974,90.290565,92.09139,92.69816,92.11087,91.52358,90.936295,90.34901,89.76172,89.17443,88.587135,87.99985,87.41256,86.82527,86.23798,85.650696,85.0634,84.47611,83.888824,83.30154,82.71425,82.12696,81.53967,80.95238,80.36509,79.7778,79.19051,78.603226,77.251366,75.51721,73.78306,72.048904,70.31474,68.58059,66.846436,65.112274,63.37812,61.34077,59.300014,57.25926,55.218502,53.177746,51.13699,49.096233,47.055473,45.01472,42.973965,40.933205,39.07351,38.988224,38.90294,38.817654,38.73237,38.647083,38.561794,38.47651,70.417175,72.218,74.01883,75.81966,77.62048,79.42132,81.222145,83.02297,84.82381,86.62463,88.42546,90.22629,92.027115,93.82794,96.01089,95.42359,94.8363,94.249016,93.66173,93.07444,92.487144,91.89986,91.31257,90.72528,90.13799,89.550705,88.96341,88.37612,87.78883,87.201546,86.61426,86.02696,85.439674,84.85239,84.2651,83.67781,83.090515,82.50323,81.91594,80.181786,78.44764,76.713486,74.97933,73.24518,71.51103,69.77688,68.042725,66.45166,64.410904,62.370148,60.329388,58.28863,56.247875,54.20712,52.166363,50.125603,48.084846,46.04409,44.003334,41.962578,39.052696,38.96741,38.882126,38.79684,38.71155,38.626266,38.54098,73.95457,75.755394,77.55622,79.35705,81.157875,82.9587,84.75953,86.560356,88.36118,90.16201,91.96284,93.763664,95.56449,97.36532,98.736305,98.14902,97.56172,96.974434,96.387146,95.79986,95.21257,94.62528,94.03799,93.4507,92.86341,92.27612,91.688835,91.10155,90.51425,89.92696,89.339676,88.75239,88.1651,87.57781,86.990524,86.40323,85.81594,84.84635,83.1122,81.378044,79.64389,77.909744,76.17558,74.44144,72.707275,70.97313,69.23897,67.480965,65.44021,63.399456,61.3587,59.31794,57.277184,55.236427,53.19567,51.154915,49.11416,47.073402,45.032646,42.99189,40.95113,38.946598,38.861313,38.776028,38.690742,38.605457,38.52017,75.69115,77.491974,79.2928,81.09363,82.894455,84.69528,86.49611,88.296936,90.09776,91.89859,93.69942,95.50024,97.30107,99.1019,102.04904,101.461754,100.87446,100.28717,99.69988,99.112595,98.52531,97.93801,97.35072,96.763435,96.17615,95.58885,95.001564,94.414276,93.82699,93.2397,92.652405,92.06512,91.47783,90.89053,90.303246,89.71596,89.51097,87.77682,86.042656,84.3085,82.57435,80.840195,79.10604,77.37189,75.63773,73.90358,72.16942,70.551094,68.51034,66.46958,64.428825,62.38807,60.347313,58.306557,56.2658,54.225044,52.184288,50.143528,48.102776,46.062016,44.02126,41.980503,39.939747,38.840504,38.75522,38.66993,38.584644,79.22851,81.029335,82.83016,84.63099,86.431816,88.23264,90.03347,91.8343,93.635124,95.43595,97.23678,99.037605,100.83843,102.63927,104.440094,104.18717,103.59988,103.01259,102.4253,101.83801,101.250725,100.66343,100.07614,99.48885,98.901566,98.31427,97.72698,97.139694,96.55241,95.96511,95.37782,94.790535,94.20325,93.61595,93.02866,92.441376,90.70722,88.973076,87.23892,85.50477,83.77062,82.03647,80.30232,78.56817,76.834015,75.09987,73.365715,71.58047,69.5397,67.49895,65.45818,63.417423,61.376663,59.335903,57.295143,55.254383,53.213623,51.17286,49.132103,47.091343,45.050583,43.00982,40.969063,38.9283,38.734406,38.64912,38.563835,80.965096,82.76592,84.56676,86.367584,88.16841,89.96924,91.770065,93.5709,95.37173,97.172554,98.97338,100.774216,102.57504,104.37587,106.1767,107.49988,106.91258,106.325294,105.73801,105.15072,104.56343,103.97614,103.38885,102.80156,102.21427,101.62698,101.039696,100.45241,99.86511,99.277824,98.69054,98.10325,97.51596,96.928665,96.34138,95.37179,93.63764,91.90349,90.169334,88.43518,86.701035,84.96688,83.23273,81.49857,79.76442,78.03027,76.29612,74.650536,72.60978,70.56902,68.52827,66.48751,64.446754,62.405994,60.36524,58.324482,56.283722,54.24297,52.20221,50.161453,48.120697,46.07994,44.039185,41.99843,39.95767,38.713593,38.628304,84.502495,86.30332,88.10415,89.904976,91.70581,93.50664,95.307465,97.10829,98.90912,100.709946,102.51077,104.3116,106.11243,107.91325,109.71408,110.22531,109.63802,109.050735,108.46344,107.87615,107.288864,106.70158,106.11429,105.527,104.93971,104.352425,103.76514,103.17784,102.59055,102.003265,101.41598,100.82869,100.2414,99.65411,98.30226,96.56811,94.833954,93.0998,91.36565,89.63149,87.89734,86.163185,84.42903,82.69488,80.960724,79.22657,77.49242,75.67991,73.639145,71.59839,69.55763,67.51688,65.47611,63.435356,61.3946,59.35384,57.31308,55.272324,53.231564,51.190804,49.150047,47.10929,45.06853,43.02777,40.98701,38.946255,38.607494,86.23904,88.03986,89.84069,91.641525,93.44235,95.24318,97.04401,98.84483,100.64567,102.446495,104.24733,106.04816,107.84898,109.64981,111.45064,113.53803,112.950745,112.36346,111.77616,111.18887,110.601585,110.0143,109.42701,108.83972,108.252426,107.66514,107.07785,106.49056,105.903275,105.31599,104.7287,104.1414,103.554115,102.96683,101.23267,99.49853,97.76437,96.03022,94.296074,92.56192,90.82777,89.09362,87.35947,85.62531,83.89116,82.15701,80.42286,78.75004,76.709274,74.66852,72.62776,70.587,68.54624,66.505486,64.46473,62.42397,60.38321,58.342453,56.301693,54.260933,52.220177,50.17942,48.138664,46.097904,44.057144,42.016388,39.975628,89.77643,91.577255,93.37808,95.17892,96.979744,98.78057,100.5814,102.382225,104.18306,105.98389,107.78471,109.58554,111.38637,113.187195,114.98802,116.263466,115.67618,115.08888,114.501595,113.91431,113.32702,112.73973,112.152435,111.56515,110.97786,110.39057,109.80328,109.21599,108.6287,108.04141,107.454124,106.86683,105.89724,104.16309,102.42894,100.694786,98.96063,97.22648,95.492325,93.75817,92.02402,90.28987,88.55572,86.82156,85.08741,83.35326,81.6191,79.77934,77.73859,75.69783,73.657074,71.61632,69.57556,67.534805,65.49405,63.45329,61.412533,59.371777,57.33102,55.290264,53.249508,51.20875,49.167995,47.12724,45.086483,43.045723,41.004967,91.513,93.31383,95.114655,96.91548,98.71631,100.517136,102.31796,104.11879,105.91962,107.72044,109.52127,111.3221,113.122925,114.92375,116.72458,119.57619,118.9889,118.40161,117.81432,117.227036,116.63974,116.05245,115.465164,114.87788,114.29059,113.7033,113.11601,112.52872,111.94143,111.35414,110.76685,110.56187,108.82771,107.09356,105.359406,103.625244,101.8911,100.15694,98.42278,96.68863,94.954475,93.22032,91.48617,89.752014,88.01786,86.28371,84.54955,82.84947,80.80871,78.76795,76.727196,74.68644,72.645676,70.60492,68.56416,66.52341,64.48265,62.44189,60.40113,58.360374,56.31962,54.278862,52.238102,50.197342,48.156586,46.11583,44.07507,95.05036,96.85119,98.652016,100.45284,102.25368,104.054504,105.85533,107.65616,109.456985,111.25781,113.05864,114.85947,116.66029,118.46112,120.26195,122.06278,121.71432,121.12703,120.53974,119.95245,119.365166,118.77788,118.19059,117.6033,117.01601,116.42872,115.84143,115.25414,114.666855,114.07957,113.49228,111.758125,110.02398,108.289825,106.55567,104.821526,103.08737,101.35322,99.619064,97.88492,96.150764,94.41661,92.682465,90.94831,89.21416,87.48001,85.74586,83.878845,81.83809,79.797325,77.75657,75.715805,73.67505,71.63429,69.59353,67.55277,65.51201,63.471252,61.43049,59.389732,57.348972,55.308212,53.267452,51.226692,49.185932,47.145172,45.104416,96.78693,98.58775,100.38858,102.18941,103.990234,105.79106,107.591896,109.392715,111.19354,112.99437,114.795204,116.59602,118.39685,120.19768,121.99851,123.79934,125.02704,124.43975,123.85246,123.265175,122.67788,122.09059,121.5033,120.916016,120.32872,119.74143,119.154144,118.56686,117.97957,117.39227,116.42268,114.68854,112.954384,111.22023,109.48608,107.75192,106.01777,104.283615,102.54947,100.815315,99.08116,97.34701,95.612854,93.8787,92.14455,90.4104,88.67624,86.948906,84.90815,82.86739,80.82664,78.78588,76.745125,74.70436,72.663605,70.62285,68.58209,66.541336,64.50058,62.459827,60.41907,58.378315,56.33756,54.296803,52.256042,50.21529,48.17453,100.32433,102.12516,103.92598,105.72681,107.52763,109.32846,111.12929,112.930115,114.73094,116.53177,118.332596,120.13342,121.93425,123.73507,125.5359,127.33672,127.75247,127.165184,126.577896,125.99061,125.40332,124.81603,124.228745,123.64145,123.05416,122.46687,121.879585,121.2923,120.70501,119.35316,117.619,115.88485,114.150696,112.41654,110.68239,108.948235,107.21408,105.47993,103.74577,102.01162,100.277466,98.54332,96.80916,95.07501,93.34085,91.606705,89.87254,87.97828,85.93752,83.89677,81.85601,79.81525,77.77449,75.733734,73.69298,71.65222,69.61146,67.5707,65.529945,63.48919,61.44843,59.40767,57.366913,55.326157,53.285397,51.24464,49.20388,102.06089,103.861725,105.66255,107.46338,109.264206,111.06504,112.86587,114.666695,116.46753,118.26836,120.06918,121.87001,123.670845,125.47167,127.27251,129.07333,131.06519,130.47789,129.89061,129.30331,128.71603,128.12874,127.54145,126.95416,126.366875,125.77959,125.1923,124.60501,124.01772,122.28357,120.549416,118.81526,117.08111,115.346954,113.6128,111.87865,110.14449,108.41034,106.676186,104.94203,103.20788,101.473724,99.73956,98.00542,96.271255,94.53711,92.802956,91.048355,89.0076,86.96684,84.92609,82.88533,80.84457,78.80381,76.763054,74.7223,72.68154,70.640785,68.60003,66.55927,64.51852,62.47776,60.437,58.396244,56.355488,54.31473,52.273975,105.59829,107.399124,109.19995,111.00078,112.801605,114.60243,116.40326,118.20409,120.00492,121.80574,123.606575,125.4074,127.20824,129.00906,130.80989,132.61072,133.79062,133.20332,132.61604,132.02875,131.44145,130.85417,130.26688,129.6796,129.0923,128.50502,127.917725,126.948135,125.21399,123.479836,121.74568,120.01153,118.277374,116.54323,114.809074,113.07492,111.34077,109.60661,107.87247,106.13831,104.40416,102.670006,100.93585,99.201706,97.467545,95.7334,93.99925,92.07772,90.036964,87.99621,85.95545,83.914696,81.87394,79.83318,77.79243,75.75167,73.710915,71.67015,69.629395,67.58864,65.54788,63.507126,61.46637,59.425613,57.384857,55.3441,53.303345]
− examples/rasterize/rasterize.hs
@@ -1,111 +0,0 @@-{-- Copyright (C) 2010 by IPwn Studios- Released under GNU General Public License v3--}-import qualified RasterizeAcc--import Control.Applicative-import Control.Arrow-import Data.Array (Array)-import Data.Array.IArray as A-import qualified Data.Array.Accelerate as Acc-import qualified Data.Array.Accelerate.Interpreter as Acc-import Data.List-import Data.Ord-import Debug.Trace-import System.IO--main :: IO ()-main = do- test rasterizeH "rasterize-test1.txt"- test rasterizeH "rasterize-test2.txt"- test rasterizeH "rasterize-test3.txt"- test rasterizeH "rasterize-test4.txt"- test rasterizeAI "rasterize-test1.txt"- test rasterizeAI "rasterize-test2.txt"- test rasterizeAI "rasterize-test3.txt"- test rasterizeAI "rasterize-test4.txt"- where- rasterizeH = (rasterize, "Haskell")- rasterizeAI = (rasterizeAI_, "Accelerate interpreted")- rasterizeAI_ :: Area -> [Value] -> [Facet] -> [Float]- rasterizeAI_ area@((x0,y0),(x1,y1)) values facets =- let acc = RasterizeAcc.rasterize - (Acc.tuple (Acc.tuple (Acc.constant x0, Acc.constant y0),- Acc.tuple (Acc.constant x1, Acc.constant y1)))- (Acc.use $ Acc.fromList (length values) values)- (Acc.use $ Acc.fromList (length facets) facets)- out = Acc.toList $ Acc.run acc- in out - where- v2acc ((x, y), v) = Acc.tuple (Acc.tuple (Acc.constant x, Acc.constant y), Acc.constant v)- f2acc (a, b, c) = Acc.tuple (Acc.constant a, Acc.constant b, Acc.constant c)--test :: (Area -> [Insertion] -> [Facet] -> [Float], String) -> FilePath -> IO ()-test (rast, descr) fn = do- (values, facets, area, sb) <- withFile fn ReadMode $ \h -> do- values <- read <$> hGetLine h - facets <- read <$> hGetLine h- area <- read <$> hGetLine h- sb <- read <$> hGetLine h- return (values, facets, area, sb)- let is = rast area values facets- if sb `similarTo` is- then putStrLn $ fn ++ " (" ++ descr ++ ") - pass"- else putStrLn $ fn ++ " (" ++ descr ++ ") - fail - "++- show (length sb)++" vs. "++show (length is)++" got "++show (zip is sb) --similarTo :: [Float] -> [Float] -> Bool-similarTo xs ys = and (zipWith near xs ys) && length xs == length ys- where- near x y = abs (x - y) < 0.001--type Area = ((Int, Int), (Int, Int))-type Value = ((Int, Int), Float)-type Insertion = ((Int, Int), Float)-type Facet = (Int, Int, Int)---- | Rasterize the specified facets, clipping to area.--- Any gaps are filled with 0 values.-rasterize :: Area -> [Value] -> [Facet] -> [Float]-rasterize area@((x0,y0),(x1,y1)) values facets = toArray $ concatMap tri facets- where- tri :: (Int,Int,Int) -> [((Int, Int), Float)]- tri (iA,iB,iC) =- -- Sort by increasing X- let [(aInt@(axInt, _), vA),- (bInt, vB),- (cInt@(cxInt, _), vC)] = sortBy (comparing xCoord) $- map (values !!) [iA,iB,iC]- -- Scan across- a@(ax, _) = fromIntegral *** fromIntegral $ aInt :: (Float, Float)- b@(bx, _) = fromIntegral *** fromIntegral $ bInt :: (Float, Float)- c@(cx, _) = fromIntegral *** fromIntegral $ cInt :: (Float, Float)- in flip concatMap [(max x0 axInt)..(min x1 (cxInt-1))] $ \xInt ->- let x = fromIntegral xInt :: Float- (yAC, vAC) = (interpolate a c x, interpolate (ax,vA) (cx,vC) x)- (yOther, vOther) = if x < bx- then (interpolate a b x, interpolate (ax,vA) (bx,vB) x)- else (interpolate b c x, interpolate (bx,vB) (cx,vC) x)- -- Order AC and Other so that y is increasing- (yBot, vBot, yTop, vTop) = if yAC <= yOther- then (yAC, vAC, yOther, vOther)- else (yOther, vOther, yAC, vAC)- yStart = max y0 (round yBot)- yEnd = min y1 (round yTop - 1)- -- Displace odd columns because the terrain mesh is hexagonal- hexify y | even xInt = fromIntegral y- hexify y = fromIntegral y + 0.5- in flip map [yStart .. yEnd] $ \yInt ->- ((xInt, yInt), interpolate (yBot, vBot) (yTop, vTop) (hexify yInt))- where- xCoord ((x, _), _) = x-- interpolate :: (Float, Float) -> (Float, Float) -> Float -> Float- interpolate (t0, x0) (t1, x1) t = (t - t0) * (x1 - x0) / (t1 - t0) + x0-- toArray :: [Insertion] -> [Float]- toArray output =- let output' = A.accumArray (flip const) 0 area output :: Array (Int, Int) Float- in A.elems output'-
− examples/simple/Makefile
@@ -1,17 +0,0 @@--GHC = ghc-HCFLAGS = -O2 -Wall -package accelerate-SRCDIR = src-BUILDDIR = dist-HSMAIN = src/Main.hs-TARGET = test---all:- @mkdir -p $(BUILDDIR)- $(GHC) --make $(HCFLAGS) -odir $(BUILDDIR) -hidir $(BUILDDIR) -i$(SRCDIR) $(HSMAIN) -o $(TARGET)--clean:- $(RM) -r $(BUILDDIR)- $(RM) $(TARGET)-
− examples/simple/src/DotP.hs
@@ -1,22 +0,0 @@-{-# LANGUAGE ParallelListComp #-}--module DotP (dotp, dotp_ref) where--import Prelude hiding (zipWith)--import Data.Array.Unboxed-import Data.Array.Accelerate--dotp :: Vector Float -> Vector Float -> Acc (Scalar Float)-dotp xs ys - = let- xs' = use xs- ys' = use ys- in- fold (+) 0 (zipWith (*) xs' ys')--dotp_ref :: UArray Int Float - -> UArray Int Float - -> UArray () Float-dotp_ref xs ys - = listArray ((), ()) $ [sum [x * y | x <- elems xs | y <- elems ys]]
− examples/simple/src/Filter.hs
@@ -1,40 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}--module Filter (filter, filter_ref) where--import Prelude hiding (length, scanl, map, filter)-import qualified Prelude--import Data.Array.Unboxed (UArray)-import Data.Array.IArray (IArray)-import qualified Data.Array.IArray as IArray--import Data.Array.Accelerate---filter :: Elem a - => (Exp a -> Exp Bool) - -> Vector a- -> Acc (Vector a)-filter p vec- = let arr = use vec- flags = map (boolToInt . p) arr- (targetIdx, length) = scanl (+) 0 flags- arr' = backpermute (length!(constant ())) id arr- in- permute const arr' (\ix -> flags!ix ==* 0 ? (ignore, targetIdx!ix)) arr- -- FIXME: This is abusing 'permute' in that the first two arguments are- -- only justified because we know the permutation function will- -- write to each location in the target exactly once.- -- Instead, we should have a primitive that directly encodes the- -- compaction pattern of the permutation function.-- -filter_ref :: IArray UArray e - => (e -> Bool)- -> UArray Int e - -> UArray Int e-filter_ref p xs- = let xs' = Prelude.filter p (IArray.elems xs)- in- IArray.listArray (0, Prelude.length xs' - 1) xs'
− examples/simple/src/Main.hs
@@ -1,127 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}--module Main where--import Prelude hiding (filter)--import DotP-import Filter-import Random-import SAXPY-import SMVM--import Data.Array.Accelerate (Acc)-import qualified Data.Array.Accelerate as Acc-import qualified Data.Array.Accelerate.CUDA as CUDA-import qualified Data.Array.Accelerate.Interpreter as Interp--import Data.Array.Unboxed (IArray, UArray, Ix, elems, indices, (!))-import System.Random.MWC (create, uniform, GenIO)-import Control.Exception (evaluate)-import Control.DeepSeq-import Criterion.Main---instance (Ix dim, IArray UArray e) => NFData (UArray dim e) where- rnf a = a ! head (indices a) `seq` ()----- Generate a benchmark test iff the reference and accelerate tests succeed.----benchmark- :: (IArray UArray e, Ix dim, Acc.Ix dim, Acc.Elem e)- => String- -> (e -> e -> Bool)- -> (() -> UArray dim e)- -> (() -> Acc (Acc.Array dim e))- -> IO Benchmark--benchmark name sim ref acc = do- putStr "Interpreter : " ; v1 <- validate sim (ref ()) (Acc.toIArray $ Interp.run (acc ()))- putStr "CUDA : " ; v2 <- validate sim (ref ()) (Acc.toIArray $ CUDA.run (acc ()))- if not (v1 && v2)- then return $ bgroup "" []- else return $ bgroup name- [ bench "ref" $ nf ref ()- , bench "cuda" $ whnf (CUDA.run . acc) ()- ]----- Tests----test_dotp :: GenIO -> Int -> IO Benchmark-test_dotp gen n = do- putStrLn $ "== Dot Product (n = " ++ shows n ") =="- xs <- randomVector gen id n- ys <- randomVector gen id n- xs' <- convertVector xs- ys' <- convertVector ys- benchmark "dotp" similar (run_ref xs ys) (run_acc xs' ys')- where- {-# NOINLINE run_ref #-}- run_ref x y () = dotp_ref x y- run_acc x y () = dotp x y---test_saxpy :: GenIO -> Int -> IO Benchmark-test_saxpy gen n = do- putStrLn $ "== SAXPY (n = " ++ shows n ") =="- xs <- randomVector gen id n- ys <- randomVector gen id n- xs' <- convertVector xs- ys' <- convertVector ys- alpha <- uniform gen- benchmark "saxpy" similar (run_ref alpha xs ys) (run_acc alpha xs' ys')- where- {-# NOINLINE run_ref #-}- run_ref alpha x y () = saxpy_ref alpha x y- run_acc alpha x y () = saxpy alpha x y---test_filter :: GenIO -> Int -> IO Benchmark-test_filter gen n = do- putStrLn $ "== Filter (n = " ++ shows n ") =="- xs <- randomVector gen id n :: IO (UArray Int Float)- xs' <- convertVector xs- benchmark "filter" similar (run_ref xs) (run_acc xs')- where- {-# NOINLINE run_ref #-}- run_ref x () = filter_ref (< 0.5) x- run_acc x () = filter (Acc.<* 0.5) x---test_smvm :: GenIO -> (Int,Int) -> (Int,Int) -> IO Benchmark-test_smvm gen (n,m) (rows,cols) = do- putStr $ "== SMVM (" ++ shows rows " x " ++ shows cols ", "- vec <- randomVector gen id cols- segd <- randomVector gen (\x -> (abs x `rem` (m-n)) + n) rows- let nnz = sum (elems segd)- putStrLn $ shows nnz " non-zeros) =="- inds <- randomVector gen (\x -> abs x `rem` cols) nnz- vals <- randomVector gen id nnz- segd' <- convertVector segd- vec' <- convertVector vec- mat' <- let v = Acc.fromList nnz (zip (elems inds) (elems vals))- in evaluate (v `Acc.indexArray` 0) >> return v- benchmark "smvm" similar (run_ref segd inds vals vec) (run_acc segd' mat' vec')- where- {-# NOINLINE run_ref #-}- run_ref d i x v () = smvm_ref (d, (i,x)) v- run_acc d x v () = smvm (d,x) v----- Main----main :: IO ()-main = do- putStrLn "Data.Array.Accelerate: simple examples"- putStrLn "--------------------------------------"-- gen <- create- defaultMain =<< sequence- [ test_dotp gen 100000- , test_saxpy gen 100000- , test_filter gen 10000- , test_smvm gen (0,42) (2400,400)- ]-
− examples/simple/src/Random.hs
@@ -1,60 +0,0 @@-{-# LANGUAGE BangPatterns, FlexibleContexts, ScopedTypeVariables #-}-{-# LANGUAGE ParallelListComp #-}--module Random where--import System.Random.MWC-import Data.Array.IArray-import Data.Array.Unboxed (UArray)-import Data.Array.IO (MArray, IOUArray)-import Control.Exception (evaluate)-import qualified Data.Array.MArray as M-import qualified Data.Array.Accelerate as Acc----- Convert an unboxed array to an Accelerate array----convertVector :: (IArray UArray e, Acc.Elem e) => UArray Int e -> IO (Acc.Vector e)-convertVector v =- let arr = Acc.fromIArray v- in evaluate (arr `Acc.indexArray` 0) >> return arr----- Generate a random, uniformly distributed vector of specified size. The second--- argument can be used to modify the generated value (e.g. map into a certain--- range)----randomVector- :: (Variate a, MArray IOUArray e IO, IArray UArray e)- => GenIO -> (a -> e) -> Int -> IO (UArray Int e)--randomVector gen f n = do- mu <- M.newArray_ (0,n-1) :: MArray IOUArray e IO => IO (IOUArray Int e)- let go !i | i < n = uniform gen >>= (\e -> M.writeArray mu i (f e)) >> go (i+1)- | otherwise = M.unsafeFreeze mu- go 0----- Compare two vectors element-wise for equality, for a given measure of--- similarity. The index and values are printed for pairs that fail.----validate- :: (IArray UArray e, Ix ix, Show e, Show ix)- => (e -> e -> Bool) -> UArray ix e -> UArray ix e -> IO Bool--validate f ref arr =- let sim = filter (not . null) [ if f x y then [] else ">>> " ++ shows i ": " ++ show (x,y)- | (i,x) <- assocs ref- | y <- elems arr ]- in if null sim- then putStrLn "Valid" >> return True- else mapM_ putStrLn ("INVALID!" : sim) >> return False----- Floating point equality with relative tolerance----similar :: (Fractional a, Ord a) => a -> a -> Bool-similar x y =- let epsilon = 0.0001- in abs ((x-y) / (x+y+epsilon)) < epsilon-
− examples/simple/src/SAXPY.hs
@@ -1,21 +0,0 @@-{-# LANGUAGE ParallelListComp #-}--module SAXPY (saxpy, saxpy_ref) where--import Prelude hiding (replicate, zip, map, filter, max, min, not, zipWith)--import Data.Array.Unboxed-import Data.Array.Accelerate--saxpy :: Float -> Vector Float -> Vector Float -> Acc (Vector Float)-saxpy alpha xs ys- = let- xs' = use xs- ys' = use ys- in - zipWith (\x y -> constant alpha * x + y) xs' ys'--saxpy_ref :: Float -> UArray Int Float -> UArray Int Float -> UArray Int Float-saxpy_ref alpha xs ys- = listArray (bounds xs) [alpha * x + y | x <- elems xs | y <- elems ys]-
− examples/simple/src/SMVM.hs
@@ -1,39 +0,0 @@-{-# LANGUAGE ParallelListComp #-}--module SMVM (smvm, smvm_ref) where--import Data.Array.Unboxed--import Data.Array.Accelerate (Vector, Segments, Acc)-import qualified Data.Array.Accelerate as Acc---type SparseVector a = Vector (Int, a)-type SparseMatrix a = (Segments, SparseVector a)--smvm :: SparseMatrix Float -> Vector Float -> Acc (Vector Float)-smvm (segd', smat') vec'- = let- segd = Acc.use segd'- (inds, vals) = Acc.unzip (Acc.use smat')- vec = Acc.use vec'- ---- vecVals = Acc.backpermute (Acc.shape inds) (\i -> inds Acc.! i) vec- products = Acc.zipWith (*) vecVals vals- in- Acc.foldSeg (+) 0 products segd---type USparseMatrix a = (UArray Int Int, (UArray Int Int, UArray Int a))--smvm_ref :: USparseMatrix Float - -> UArray Int Float - -> UArray Int Float-smvm_ref (segd, (inds, values)) vec- = listArray (0, rangeSize (bounds segd) - 1)- $ [sum [ values!i * vec!(inds!i) | i <- range seg] | seg <- segd' ]- where- segbegin = scanl (+) 0 $ elems segd- segend = scanl1 (+) $ elems segd- segd' = zipWith (\x y -> (x,y-1)) segbegin segend-
− examples/simple/src/Square.hs
@@ -1,23 +0,0 @@-{-# LANGUAGE ParallelListComp #-}--module Square (square, square_ref) where--import Prelude hiding (replicate, zip, map, filter, max, min, not, zipWith)-import qualified Prelude--import Data.Array.Unboxed-import Data.Array.IArray--import Data.Array.Accelerate--square :: Vector Float -> Acc (Vector Float)-square xs- = let- xs' = use xs- in - map (\x -> x * x) xs'--square_ref :: UArray Int Float -> UArray Int Float-square_ref xs- = listArray (bounds xs) [x * x| x <- elems xs]-
− examples/simple/src/Stencil.hs
@@ -1,77 +0,0 @@-{-# LANGUAGE ParallelListComp #-}--module Stencil (stencil_test, stencil_test_ref) where--import Prelude hiding (replicate, zip, map, filter, max, min, not, zipWith)-import qualified Prelude--import Data.Array.Unboxed hiding (Array)-import Data.Array.IArray as IArray hiding (Array)--import Data.Array.Accelerate--stencil_test :: Array DIM2 Float -> Acc (Array DIM2 Float)-stencil_test = stencil stencil2D5 Clamp . use--stencil_test_ref :: UArray (Int, Int) Float - -> UArray (Int, Int) Float-stencil_test_ref arr- = array (bounds arr) [(xy, stencilFun xy) | xy <- indices arr]- where- stencilFun (x, y) = (arr IArray.! (clamp (x-1,y)) + - arr IArray.! (clamp (x+1,y)) + - arr IArray.! (clamp (x,y-1)) + - arr IArray.! (clamp (x,y+1)) - - 4*arr IArray.! (clamp (x,y))) / 4- clamp (x, y) = (minx `Prelude.max` x `Prelude.min` maxx, - miny `Prelude.max` y `Prelude.min` maxy) - where- ((minx, miny), (maxx, maxy)) = bounds arr---- some example stencils--stencil1D :: (Elem a, IsFloating a) - => Stencil3 a -> Exp a-stencil1D (x, y, z) = (x + z - 2 * y) / 2--stencil2D5 :: (Elem a, IsFloating a) - => Stencil3x3 a -> Exp a-stencil2D5 ( (_, t, _)- , (l, m, r)- , (_, b, _)- ) - = (t + l + r + b - 4 * m) / 4--stencil2D :: (Elem a, IsFloating a) - => Stencil3x3 a -> Exp a-stencil2D ( (t1, t2, t3)- , (l , m, r )- , (b1, b2, b3)- ) - = (t1/2 + t2 + t3/2 + l + r + b1/2 + b2 + b3/2 - 4 * m) / 4--stencil3D :: (Elem a, IsNum a)- => Stencil3x3x3 a -> Exp a-stencil3D (front, back, _) = -- 'b4' is the focal point- let ((f1, f2, _),- (f3, f4, _),- _ ) = front- ((b1, b2, _),- (b3, b4, _),- _ ) = back- in- f1 + f2 + f3 + f4 + b1 + b2 + b3 + b4---- usaging them to ensure the types of the example fit the 'stencil' function--use1D :: Acc (Array DIM1 Float) -> Acc (Array DIM1 Float)-use1D arr = stencil stencil1D Clamp arr--use2D5 :: Acc (Array DIM2 Float) -> Acc (Array DIM2 Float)-use2D5 arr = stencil stencil2D5 Clamp arr--use2D :: Acc (Array DIM2 Float) -> Acc (Array DIM2 Float)-use2D arr = stencil stencil2D Clamp arr--use3D :: Acc (Array DIM3 Float) -> Acc (Array DIM3 Float)-use3D arr = stencil stencil3D Clamp arr
− examples/simple/src/Sum.hs
@@ -1,23 +0,0 @@-{-# LANGUAGE ParallelListComp #-}--module Sum (sum, sum_ref) where--import Prelude hiding (replicate, zip, map, filter, max, min, not, zipWith, sum)-import qualified Prelude--import Data.Array.Unboxed-import Data.Array.IArray--import Data.Array.Accelerate--sum :: Vector Float -> Acc (Scalar Float)-sum xs- = let- xs' = use xs- in - fold (\x y -> x + y) (constant 0.0) xs'--sum_ref :: UArray Int Float -> UArray () Float-sum_ref xs- = listArray ((), ()) $ [Prelude.sum $ elems xs]-
+ utils/Paths_accelerate.hs view
@@ -0,0 +1,11 @@+-- 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 view
@@ -0,0 +1,2 @@+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 view
@@ -0,0 +1,5 @@+:set -DACCELERATE_CUDA_BACKEND+:set -DACCELERATE_BOUNDS_CHECKS+:set -DACCELERATE_INTERNAL_CHECKS+:set -iutils+:set -Iinclude