diff --git a/Data/Array/Accelerate.hs b/Data/Array/Accelerate.hs --- a/Data/Array/Accelerate.hs +++ b/Data/Array/Accelerate.hs @@ -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 @@ -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 diff --git a/Data/Array/Accelerate/AST.hs b/Data/Array/Accelerate/AST.hs --- a/Data/Array/Accelerate/AST.hs +++ b/Data/Array/Accelerate/AST.hs @@ -1,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 @@ -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) + diff --git a/Data/Array/Accelerate/Analysis/Shape.hs b/Data/Array/Accelerate/Analysis/Shape.hs --- a/Data/Array/Accelerate/Analysis/Shape.hs +++ b/Data/Array/Accelerate/Analysis/Shape.hs @@ -1,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 @@ -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 -- diff --git a/Data/Array/Accelerate/Analysis/Stencil.hs b/Data/Array/Accelerate/Analysis/Stencil.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/Analysis/Stencil.hs @@ -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 +-- 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 ] + diff --git a/Data/Array/Accelerate/Analysis/Type.hs b/Data/Array/Accelerate/Analysis/Type.hs --- a/Data/Array/Accelerate/Analysis/Type.hs +++ b/Data/Array/Accelerate/Analysis/Type.hs @@ -1,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 +-- 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 diff --git a/Data/Array/Accelerate/Array/Data.hs b/Data/Array/Accelerate/Array/Data.hs --- a/Data/Array/Accelerate/Array/Data.hs +++ b/Data/Array/Accelerate/Array/Data.hs @@ -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 @@ -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) #) + diff --git a/Data/Array/Accelerate/Array/Delayed.hs b/Data/Array/Accelerate/Array/Delayed.hs --- a/Data/Array/Accelerate/Array/Delayed.hs +++ b/Data/Array/Accelerate/Array/Delayed.hs @@ -1,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 +-- 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) - diff --git a/Data/Array/Accelerate/Array/Representation.hs b/Data/Array/Accelerate/Array/Representation.hs --- a/Data/Array/Accelerate/Array/Representation.hs +++ b/Data/Array/Accelerate/Array/Representation.hs @@ -1,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 +-- 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 ++ ")" + diff --git a/Data/Array/Accelerate/Array/Sugar.hs b/Data/Array/Accelerate/Array/Sugar.hs --- a/Data/Array/Accelerate/Array/Sugar.hs +++ b/Data/Array/Accelerate/Array/Sugar.hs @@ -1,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 +-- 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) + diff --git a/Data/Array/Accelerate/CUDA.hs b/Data/Array/Accelerate/CUDA.hs --- a/Data/Array/Accelerate/CUDA.hs +++ b/Data/Array/Accelerate/CUDA.hs @@ -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 -- 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 diff --git a/Data/Array/Accelerate/CUDA/Analysis/Device.hs b/Data/Array/Accelerate/CUDA/Analysis/Device.hs --- a/Data/Array/Accelerate/CUDA/Analysis/Device.hs +++ b/Data/Array/Accelerate/CUDA/Analysis/Device.hs @@ -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 diff --git a/Data/Array/Accelerate/CUDA/Analysis/Hash.hs b/Data/Array/Accelerate/CUDA/Analysis/Hash.hs --- a/Data/Array/Accelerate/CUDA/Analysis/Hash.hs +++ b/Data/Array/Accelerate/CUDA/Analysis/Hash.hs @@ -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 @@ -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) +-} diff --git a/Data/Array/Accelerate/CUDA/Analysis/Launch.hs b/Data/Array/Accelerate/CUDA/Analysis/Launch.hs --- a/Data/Array/Accelerate/CUDA/Analysis/Launch.hs +++ b/Data/Array/Accelerate/CUDA/Analysis/Launch.hs @@ -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 @@ -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) diff --git a/Data/Array/Accelerate/CUDA/Array/Data.hs b/Data/Array/Accelerate/CUDA/Array/Data.hs --- a/Data/Array/Accelerate/CUDA/Array/Data.hs +++ b/Data/Array/Accelerate/CUDA/Array/Data.hs @@ -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 @@ -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 diff --git a/Data/Array/Accelerate/CUDA/Array/Device.hs b/Data/Array/Accelerate/CUDA/Array/Device.hs deleted file mode 100644 --- a/Data/Array/Accelerate/CUDA/Array/Device.hs +++ /dev/null @@ -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 --- 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 - diff --git a/Data/Array/Accelerate/CUDA/CodeGen.hs b/Data/Array/Accelerate/CUDA/CodeGen.hs --- a/Data/Array/Accelerate/CUDA/CodeGen.hs +++ b/Data/Array/Accelerate/CUDA/CodeGen.hs @@ -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 @@ -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 diff --git a/Data/Array/Accelerate/CUDA/CodeGen/Data.hs b/Data/Array/Accelerate/CUDA/CodeGen/Data.hs --- a/Data/Array/Accelerate/CUDA/CodeGen/Data.hs +++ b/Data/Array/Accelerate/CUDA/CodeGen/Data.hs @@ -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 @@ -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 diff --git a/Data/Array/Accelerate/CUDA/CodeGen/Skeleton.hs b/Data/Array/Accelerate/CUDA/CodeGen/Skeleton.hs --- a/Data/Array/Accelerate/CUDA/CodeGen/Skeleton.hs +++ b/Data/Array/Accelerate/CUDA/CodeGen/Skeleton.hs @@ -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 @@ -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)) diff --git a/Data/Array/Accelerate/CUDA/CodeGen/Stencil.hs b/Data/Array/Accelerate/CUDA/CodeGen/Stencil.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/CUDA/CodeGen/Stencil.hs @@ -0,0 +1,124 @@ +-- | +-- Module : Data.Array.Accelerate.CUDA.CodeGen.Tuple +-- Copyright : [2010..2011] Ben Lever +-- License : BSD3 +-- +-- Maintainer : Manuel M T Chakravarty +-- 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] + diff --git a/Data/Array/Accelerate/CUDA/CodeGen/Tuple.hs b/Data/Array/Accelerate/CUDA/CodeGen/Tuple.hs --- a/Data/Array/Accelerate/CUDA/CodeGen/Tuple.hs +++ b/Data/Array/Accelerate/CUDA/CodeGen/Tuple.hs @@ -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 @@ -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 diff --git a/Data/Array/Accelerate/CUDA/CodeGen/Util.hs b/Data/Array/Accelerate/CUDA/CodeGen/Util.hs --- a/Data/Array/Accelerate/CUDA/CodeGen/Util.hs +++ b/Data/Array/Accelerate/CUDA/CodeGen/Util.hs @@ -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 @@ -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) -> diff --git a/Data/Array/Accelerate/CUDA/Compile.hs b/Data/Array/Accelerate/CUDA/Compile.hs --- a/Data/Array/Accelerate/CUDA/Compile.hs +++ b/Data/Array/Accelerate/CUDA/Compile.hs @@ -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 @@ -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)) diff --git a/Data/Array/Accelerate/CUDA/Execute.hs b/Data/Array/Accelerate/CUDA/Execute.hs --- a/Data/Array/Accelerate/CUDA/Execute.hs +++ b/Data/Array/Accelerate/CUDA/Execute.hs @@ -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 --- 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 +-- 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 diff --git a/Data/Array/Accelerate/CUDA/Smart.hs b/Data/Array/Accelerate/CUDA/Smart.hs deleted file mode 100644 --- a/Data/Array/Accelerate/CUDA/Smart.hs +++ /dev/null @@ -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 --- 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 - diff --git a/Data/Array/Accelerate/CUDA/State.hs b/Data/Array/Accelerate/CUDA/State.hs --- a/Data/Array/Accelerate/CUDA/State.hs +++ b/Data/Array/Accelerate/CUDA/State.hs @@ -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 @@ -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) diff --git a/Data/Array/Accelerate/Debug.hs b/Data/Array/Accelerate/Debug.hs --- a/Data/Array/Accelerate/Debug.hs +++ b/Data/Array/Accelerate/Debug.hs @@ -1,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 +-- 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) + } diff --git a/Data/Array/Accelerate/IO.hs b/Data/Array/Accelerate/IO.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/IO.hs @@ -0,0 +1,32 @@ +-- | +-- Module : Data.Array.Accelerate.IO +-- Copyright : [2010..2011] Sean Seefried, Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Manuel M T Chakravarty +-- 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 + diff --git a/Data/Array/Accelerate/IO/BlockCopy.hs b/Data/Array/Accelerate/IO/BlockCopy.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/IO/BlockCopy.hs @@ -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 +-- 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) + diff --git a/Data/Array/Accelerate/IO/ByteString.hs b/Data/Array/Accelerate/IO/ByteString.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/IO/ByteString.hs @@ -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 +-- 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 + diff --git a/Data/Array/Accelerate/IO/Ptr.hs b/Data/Array/Accelerate/IO/Ptr.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/IO/Ptr.hs @@ -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 +-- 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 + diff --git a/Data/Array/Accelerate/Internal/Check.hs b/Data/Array/Accelerate/Internal/Check.hs --- a/Data/Array/Accelerate/Internal/Check.hs +++ b/Data/Array/Accelerate/Internal/Check.hs @@ -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 @@ -10,16 +10,18 @@ -- -- Bounds checking infrastructure -- --- Sstolen from the Vector package by Roman Leshchinskiy --- +-- Stolen from the Vector package by Roman Leshchinskiy. This code has a +-- BSD-style license. -- -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 ] diff --git a/Data/Array/Accelerate/Interpreter.hs b/Data/Array/Accelerate/Interpreter.hs --- a/Data/Array/Accelerate/Interpreter.hs +++ b/Data/Array/Accelerate/Interpreter.hs @@ -1,9 +1,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 @@ -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 + diff --git a/Data/Array/Accelerate/Language.hs b/Data/Array/Accelerate/Language.hs --- a/Data/Array/Accelerate/Language.hs +++ b/Data/Array/Accelerate/Language.hs @@ -1,9 +1,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 @@ -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 diff --git a/Data/Array/Accelerate/Prelude.hs b/Data/Array/Accelerate/Prelude.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/Prelude.hs @@ -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 +-- 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 + diff --git a/Data/Array/Accelerate/Pretty.hs b/Data/Array/Accelerate/Pretty.hs --- a/Data/Array/Accelerate/Pretty.hs +++ b/Data/Array/Accelerate/Pretty.hs @@ -1,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 +-- 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 --} diff --git a/Data/Array/Accelerate/Pretty/Graphviz.hs b/Data/Array/Accelerate/Pretty/Graphviz.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/Pretty/Graphviz.hs @@ -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 +-- 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 = "}" + diff --git a/Data/Array/Accelerate/Pretty/HTML.hs b/Data/Array/Accelerate/Pretty/HTML.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/Pretty/HTML.hs @@ -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 +-- 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" + diff --git a/Data/Array/Accelerate/Pretty/Print.hs b/Data/Array/Accelerate/Pretty/Print.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/Pretty/Print.hs @@ -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 +-- 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 +-} diff --git a/Data/Array/Accelerate/Pretty/Traverse.hs b/Data/Array/Accelerate/Pretty/Traverse.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/Pretty/Traverse.hs @@ -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 +-- 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 +-- + diff --git a/Data/Array/Accelerate/Smart.hs b/Data/Array/Accelerate/Smart.hs --- a/Data/Array/Accelerate/Smart.hs +++ b/Data/Array/Accelerate/Smart.hs @@ -1,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 --- 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 +-- 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) diff --git a/Data/Array/Accelerate/Test.hs b/Data/Array/Accelerate/Test.hs deleted file mode 100644 --- a/Data/Array/Accelerate/Test.hs +++ /dev/null @@ -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 --- 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 - diff --git a/Data/Array/Accelerate/Test/QuickCheck.hs b/Data/Array/Accelerate/Test/QuickCheck.hs deleted file mode 100644 --- a/Data/Array/Accelerate/Test/QuickCheck.hs +++ /dev/null @@ -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 --- 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 - diff --git a/Data/Array/Accelerate/Test/QuickCheck/Arbitrary.hs b/Data/Array/Accelerate/Test/QuickCheck/Arbitrary.hs deleted file mode 100644 --- a/Data/Array/Accelerate/Test/QuickCheck/Arbitrary.hs +++ /dev/null @@ -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 --- 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 - ] - diff --git a/Data/Array/Accelerate/Tuple.hs b/Data/Array/Accelerate/Tuple.hs --- a/Data/Array/Accelerate/Tuple.hs +++ b/Data/Array/Accelerate/Tuple.hs @@ -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 @@ -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) diff --git a/Data/Array/Accelerate/Type.hs b/Data/Array/Accelerate/Type.hs --- a/Data/Array/Accelerate/Type.hs +++ b/Data/Array/Accelerate/Type.hs @@ -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 @@ -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 -} + diff --git a/INSTALL b/INSTALL --- a/INSTALL +++ b/INSTALL @@ -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 diff --git a/accelerate.cabal b/accelerate.cabal --- a/accelerate.cabal +++ b/accelerate.cabal @@ -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: - + Known bugs: . + * 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 . 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 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 diff --git a/cubits/accelerate_cuda_extras.h b/cubits/accelerate_cuda_extras.h --- a/cubits/accelerate_cuda_extras.h +++ b/cubits/accelerate_cuda_extras.h @@ -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 @@ -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" diff --git a/cubits/accelerate_cuda_function.h b/cubits/accelerate_cuda_function.h --- a/cubits/accelerate_cuda_function.h +++ b/cubits/accelerate_cuda_function.h @@ -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 @@ -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__ diff --git a/cubits/accelerate_cuda_shape.h b/cubits/accelerate_cuda_shape.h --- a/cubits/accelerate_cuda_shape.h +++ b/cubits/accelerate_cuda_shape.h @@ -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 @@ -16,7 +16,7 @@ #include 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 +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 +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 +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 +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 +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 +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__ diff --git a/cubits/accelerate_cuda_stencil.h b/cubits/accelerate_cuda_stencil.h new file mode 100644 --- /dev/null +++ b/cubits/accelerate_cuda_stencil.h @@ -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 + * Stability : experimental + * + * ---------------------------------------------------------------------------*/ + +#ifndef __ACCELERATE_CUDA_STENCIL_H__ +#define __ACCELERATE_CUDA_STENCIL_H__ + +#include + +#ifdef __cplusplus + +/* + * Test if an index lies within the boundaries of a shape + */ +template +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 +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 +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 +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 diff --git a/cubits/accelerate_cuda_texture.h b/cubits/accelerate_cuda_texture.h --- a/cubits/accelerate_cuda_texture.h +++ b/cubits/accelerate_cuda_texture.h @@ -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 diff --git a/cubits/accelerate_cuda_util.h b/cubits/accelerate_cuda_util.h --- a/cubits/accelerate_cuda_util.h +++ b/cubits/accelerate_cuda_util.h @@ -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 diff --git a/cubits/backpermute.inl b/cubits/backpermute.inl --- a/cubits/backpermute.inl +++ b/cubits/backpermute.inl @@ -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 diff --git a/cubits/fold.inl b/cubits/fold.inl --- a/cubits/fold.inl +++ b/cubits/fold.inl @@ -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 * 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); + } + } } diff --git a/cubits/foldAll.inl b/cubits/foldAll.inl new file mode 100644 --- /dev/null +++ b/cubits/foldAll.inl @@ -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 + * 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 + } +} + diff --git a/cubits/foldSeg.inl b/cubits/foldSeg.inl new file mode 100644 --- /dev/null +++ b/cubits/foldSeg.inl @@ -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 + * 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); + } + } +} + diff --git a/cubits/fold_segmented.inl b/cubits/fold_segmented.inl deleted file mode 100644 --- a/cubits/fold_segmented.inl +++ /dev/null @@ -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 - * 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); - } -} - diff --git a/cubits/generate.inl b/cubits/generate.inl new file mode 100644 --- /dev/null +++ b/cubits/generate.inl @@ -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 + * 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))); + } +} + diff --git a/cubits/map.inl b/cubits/map.inl --- a/cubits/map.inl +++ b/cubits/map.inl @@ -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 diff --git a/cubits/permute.inl b/cubits/permute.inl --- a/cubits/permute.inl +++ b/cubits/permute.inl @@ -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 diff --git a/cubits/reduce.inl b/cubits/reduce.inl new file mode 100644 --- /dev/null +++ b/cubits/reduce.inl @@ -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 + * 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 + diff --git a/cubits/replicate.inl b/cubits/replicate.inl --- a/cubits/replicate.inl +++ b/cubits/replicate.inl @@ -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 diff --git a/cubits/scan.inl b/cubits/scan.inl new file mode 100644 --- /dev/null +++ b/cubits/scan.inl @@ -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 + * 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 +#include + diff --git a/cubits/scan1.inl b/cubits/scan1.inl new file mode 100644 --- /dev/null +++ b/cubits/scan1.inl @@ -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 + * Stability : experimental + * + * A Data.List-style scan without an initial value (i.e. inclusive scan) and an + * associative binary function + * + * ---------------------------------------------------------------------------*/ + +#include +#include + diff --git a/cubits/slice.inl b/cubits/slice.inl --- a/cubits/slice.inl +++ b/cubits/slice.inl @@ -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 diff --git a/cubits/stencil.inl b/cubits/stencil.inl new file mode 100644 --- /dev/null +++ b/cubits/stencil.inl @@ -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 + * 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)))); + } +} + diff --git a/cubits/stencil2.inl b/cubits/stencil2.inl new file mode 100644 --- /dev/null +++ b/cubits/stencil2.inl @@ -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 + * 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))); + } +} + diff --git a/cubits/thrust/exclusive_scan.inl b/cubits/thrust/exclusive_scan.inl new file mode 100644 --- /dev/null +++ b/cubits/thrust/exclusive_scan.inl @@ -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 + } +} + diff --git a/cubits/thrust/inclusive_scan.inl b/cubits/thrust/inclusive_scan.inl new file mode 100644 --- /dev/null +++ b/cubits/thrust/inclusive_scan.inl @@ -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(); + } +} + diff --git a/cubits/thrust/safe_scan_intervals.inl b/cubits/thrust/safe_scan_intervals.inl new file mode 100644 --- /dev/null +++ b/cubits/thrust/safe_scan_intervals.inl @@ -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 +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 +__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 + } +} + diff --git a/cubits/thrust/scan_safe.inl b/cubits/thrust/scan_safe.inl deleted file mode 100644 --- a/cubits/thrust/scan_safe.inl +++ /dev/null @@ -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 -__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 -__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 -__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; - } - __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(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(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; - } -} - diff --git a/cubits/zipWith.inl b/cubits/zipWith.inl --- a/cubits/zipWith.inl +++ b/cubits/zipWith.inl @@ -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 diff --git a/examples/rasterize/RasterizeAcc.hs b/examples/rasterize/RasterizeAcc.hs deleted file mode 100644 --- a/examples/rasterize/RasterizeAcc.hs +++ /dev/null @@ -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) - diff --git a/examples/rasterize/rasterize-test1.txt b/examples/rasterize/rasterize-test1.txt deleted file mode 100644 --- a/examples/rasterize/rasterize-test1.txt +++ /dev/null @@ -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] diff --git a/examples/rasterize/rasterize-test2.txt b/examples/rasterize/rasterize-test2.txt deleted file mode 100644 --- a/examples/rasterize/rasterize-test2.txt +++ /dev/null @@ -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] diff --git a/examples/rasterize/rasterize-test3.txt b/examples/rasterize/rasterize-test3.txt deleted file mode 100644 --- a/examples/rasterize/rasterize-test3.txt +++ /dev/null @@ -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] diff --git a/examples/rasterize/rasterize-test4.txt b/examples/rasterize/rasterize-test4.txt deleted file mode 100644 --- a/examples/rasterize/rasterize-test4.txt +++ /dev/null @@ -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] diff --git a/examples/rasterize/rasterize.hs b/examples/rasterize/rasterize.hs deleted file mode 100644 --- a/examples/rasterize/rasterize.hs +++ /dev/null @@ -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' - diff --git a/examples/simple/Makefile b/examples/simple/Makefile deleted file mode 100644 --- a/examples/simple/Makefile +++ /dev/null @@ -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) - diff --git a/examples/simple/src/DotP.hs b/examples/simple/src/DotP.hs deleted file mode 100644 --- a/examples/simple/src/DotP.hs +++ /dev/null @@ -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]] diff --git a/examples/simple/src/Filter.hs b/examples/simple/src/Filter.hs deleted file mode 100644 --- a/examples/simple/src/Filter.hs +++ /dev/null @@ -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' diff --git a/examples/simple/src/Main.hs b/examples/simple/src/Main.hs deleted file mode 100644 --- a/examples/simple/src/Main.hs +++ /dev/null @@ -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) - ] - diff --git a/examples/simple/src/Random.hs b/examples/simple/src/Random.hs deleted file mode 100644 --- a/examples/simple/src/Random.hs +++ /dev/null @@ -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 - diff --git a/examples/simple/src/SAXPY.hs b/examples/simple/src/SAXPY.hs deleted file mode 100644 --- a/examples/simple/src/SAXPY.hs +++ /dev/null @@ -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] - diff --git a/examples/simple/src/SMVM.hs b/examples/simple/src/SMVM.hs deleted file mode 100644 --- a/examples/simple/src/SMVM.hs +++ /dev/null @@ -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 - diff --git a/examples/simple/src/Square.hs b/examples/simple/src/Square.hs deleted file mode 100644 --- a/examples/simple/src/Square.hs +++ /dev/null @@ -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] - diff --git a/examples/simple/src/Stencil.hs b/examples/simple/src/Stencil.hs deleted file mode 100644 --- a/examples/simple/src/Stencil.hs +++ /dev/null @@ -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 diff --git a/examples/simple/src/Sum.hs b/examples/simple/src/Sum.hs deleted file mode 100644 --- a/examples/simple/src/Sum.hs +++ /dev/null @@ -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] - diff --git a/utils/Paths_accelerate.hs b/utils/Paths_accelerate.hs new file mode 100644 --- /dev/null +++ b/utils/Paths_accelerate.hs @@ -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 + diff --git a/utils/README b/utils/README new file mode 100644 --- /dev/null +++ b/utils/README @@ -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. diff --git a/utils/dot_ghci b/utils/dot_ghci new file mode 100644 --- /dev/null +++ b/utils/dot_ghci @@ -0,0 +1,5 @@ +:set -DACCELERATE_CUDA_BACKEND +:set -DACCELERATE_BOUNDS_CHECKS +:set -DACCELERATE_INTERNAL_CHECKS +:set -iutils +:set -Iinclude