accelerate (empty) → 0.4.0
raw patch · 21 files changed
+4232/−0 lines, 21 filesdep +arraydep +basedep +ghc-primsetup-changed
Dependencies added: array, base, ghc-prim, haskell98, pretty
Files
- Data/Array/Accelerate.hs +56/−0
- Data/Array/Accelerate/AST.hs +378/−0
- Data/Array/Accelerate/Array/Data.hs +240/−0
- Data/Array/Accelerate/Array/Delayed.hs +53/−0
- Data/Array/Accelerate/Array/Representation.hs +190/−0
- Data/Array/Accelerate/Array/Sugar.hs +722/−0
- Data/Array/Accelerate/Debug.hs +26/−0
- Data/Array/Accelerate/Interpreter.hs +574/−0
- Data/Array/Accelerate/Language.hs +259/−0
- Data/Array/Accelerate/Pretty.hs +224/−0
- Data/Array/Accelerate/Smart.hs +428/−0
- Data/Array/Accelerate/Type.hs +595/−0
- INSTALL +19/−0
- LICENSE +24/−0
- Setup.hs +4/−0
- accelerate.cabal +50/−0
- examples/simple/DotP.hs +25/−0
- examples/simple/Main.hs +221/−0
- examples/simple/Makefile +12/−0
- examples/simple/SAXPY.hs +24/−0
- examples/simple/Time.hs +108/−0
+ Data/Array/Accelerate.hs view
@@ -0,0 +1,56 @@+-- |An embedded language of accelerated array computations +--+-- Copyright (c) [2008..2009] Manuel M T Chakravarty, Gabriele Keller, Sean Lee+--+-- License: BSD3+--+--- Description ---------------------------------------------------------------+--+-- Abstract interface+-- ~~~~~~~~~~~~~~~~~~+-- The types representing array computations are only exported abstractly.+-- This gives us more flexibility for later changes.+--+-- Code execution+-- ~~~~~~~~~~~~~~+-- Access to the various backends is via the 'run' function in+-- backend-specific toplevel modules. Currently, we have the following:+--+-- * 'Data.Array.Accelerate.Interpreter': simple interpreter in Haskell as a+-- reference implementation defining the semantics of the array language+++module Data.Array.Accelerate (++ -- * Scalar element types+ Int, Int8, Int16, Int32, Int64, Word, Word8, Word16, Word32, Word64, + CShort, CUShort, CInt, CUInt, CLong, CULong, CLLong, CULLong,+ Float, Double, CFloat, CDouble,+ Bool, Char, CChar, CSChar, CUChar,++ -- * Array data types+ Array, Scalar, Vector,++ -- * Array element types+ Elem,++ -- * Array shapes & indices+ Ix(..), All(..), SliceIx(..), DIM0, DIM1, DIM2, DIM3, DIM4, DIM5,+ + -- * Array operations+ shape, indexArray, fromIArray, toIArray, fromList, toList, Arrays,++ -- * Surface language+ module Data.Array.Accelerate.Language,++) where++-- friends+import Data.Array.Accelerate.Type+import Data.Array.Accelerate.Array.Sugar hiding ((!))+import qualified Data.Array.Accelerate.Array.Sugar as Sugar+import Data.Array.Accelerate.Language++-- rename as (!) is already used by the EDSL for indexing+indexArray :: Array dim e -> dim -> e+indexArray = (Sugar.!)
+ Data/Array/Accelerate/AST.hs view
@@ -0,0 +1,378 @@+{-# LANGUAGE GADTs, EmptyDataDecls, FlexibleContexts #-}++-- |Embedded array processing language: accelerate AST with de Bruijn indices+--+-- Copyright (c) [2008..2009] Manuel M T Chakravarty, Gabriele Keller, Sean Lee+--+-- License: BSD3+--+--- Description ---------------------------------------------------------------+--+-- Scalar versus collective operations+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- The embedded array processing language is a two-level language. It+-- combines a language of scalar expressions and functions with a language of+-- collective array operations. Scalar expressions are used to compute+-- arguments for collective operations and scalar functions are used to+-- parametrise higher-order, collective array operations. The two-level+-- structure, in particular, ensures that collective operations cannot be+-- parametrised with collective operations; hence, we are following a flat+-- data-parallel model. The collective operations manipulate+-- multi-dimensional arrays whose shape is explicitly tracked in their types.+-- In fact, collective operations cannot produce any values other than+-- multi-dimensional arrays; when they yield a scalar, this is in the form of+-- a 0-dimensional, singleton array. Similarly, scalar expression can -as+-- their name indicates- only produce tuples of scalar, but not arrays. +--+-- There are, however, two expression forms that take arrays as arguments. As+-- a result scalar and array expressions are recursively dependent. As we+-- cannot and don't want to compute arrays in the middle of scalar+-- computations, array computations will always be hoisted out of scalar+-- expressions. So that this is always possible, these array expressions may+-- not contain any free scalar variables. To express that condition in the+-- type structure, we use separate environments for scalar and array variables.+--+-- Programs+-- ~~~~~~~~+-- Collective array programs comprise closed expressions of array operations.+-- There is no explicit sharing in the initial AST form, but sharing is+-- introduced subsequently by common subexpression elimination and floating+-- of array computations.+--+-- Functions+-- ~~~~~~~~~+-- The array expression language is first-order and only provides limited+-- control structures to ensure that it can be efficiently executed on+-- compute-acceleration hardware, such as GPUs. To restrict functions to+-- first-order, we separate function abstraction from the main expression+-- type. Functions are represented using de Bruijn indices.+--+-- Parametric and ad-hoc polymorphism+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- The array language features paramatric polymophism (e.g., pairing and+-- projections) as well as ad-hoc polymorphism (e.g., arithmetic operations).+-- All ad-hoc polymorphic constructs include reified dictionaries (c.f.,+-- module 'Types'). Reified dictionaries also ensure that constants+-- (constructor 'Const') are representable on compute acceleration hardware.+--+-- The AST contains both reified dictionaries and type class constraints. +-- Type classes are used for array-related functionality that is uniformly+-- available for all supported types. In contrast, reified dictionaries are+-- used for functionality that is only available for certain types, such as+-- arithmetic operations.++module Data.Array.Accelerate.AST (++ -- * Typed de Bruijn indices+ Idx(..),+ + -- * Accelerated array expressions+ OpenAcc(..), Acc,+ + -- * Scalar expressions+ OpenFun(..), Fun, OpenExp(..), Exp, PrimConst(..), PrimFun(..)++) where+ +-- friends+import Data.Array.Accelerate.Type+import Data.Array.Accelerate.Array.Data (ArrayElem)+import Data.Array.Accelerate.Array.Representation+import Data.Array.Accelerate.Array.Sugar (Elem, ElemRepr)+++-- Typed de Bruijn indices+-- -----------------------++-- De Bruijn variable index projecting a specific type from a type+-- environment. Type envionments are nested pairs (..((), t1), t2, ..., tn). +--+data Idx env t where+ ZeroIdx :: Idx (env, t) t+ SuccIdx :: Idx env t -> Idx (env, s) t+++-- Array expressions+-- -----------------++-- |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+-- well-formed program.+--+-- * The let-form is used to represent the sharing discovered by common+-- subexpression elimination as well as to control evaluation order. (We+-- need to hoist array expressions out of scalar expressions - they occur in+-- scalar indexing and in determining an arrays shape.)+--+data OpenAcc aenv a where+ + -- Local binding to represent sharing and demand explicitly; this is an+ -- eager(!) binding+ Let :: OpenAcc aenv (Array dim e) -- ^bound expressions + -> OpenAcc (aenv, Array dim e) (Array dim' e') + -- ^the bound expr's scope+ -> OpenAcc aenv (Array dim' e')++ -- Variable bound by a 'Let', represented by a de Bruijn index + Avar :: Idx aenv (Array dim e)+ -> OpenAcc aenv (Array dim e)+ + -- Array Inlet (Triggers Async Host->Device Transfer if Necessary)+ Use :: Array dim e + -> OpenAcc aenv (Array dim e)++ -- Capture a Scalar (or a tuple of Scalars) in a Singleton Array + Unit :: ArrayElem e+ => Exp aenv e + -> OpenAcc 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)++ -- Replicate an array across one or more dimensions as given by the first+ -- argument+ Replicate :: Ix dim+ => SliceIndex slix sl co dim -- ^slice type specification+ -> Exp aenv slix -- ^slice value specification+ -> OpenAcc aenv (Array sl e) -- ^data to be replicated+ -> OpenAcc aenv (Array dim e)++ -- Index a subarray out of an array; i.e., the dimensions not indexed are + -- returned whole+ Index :: Ix sl+ => SliceIndex slix sl co dim -- ^slice type specification+ -> OpenAcc aenv (Array dim e) -- ^array to be indexed+ -> Exp aenv slix -- ^slice value specification+ -> OpenAcc aenv (Array sl e)++ -- Apply the given unary function to all elements of the given array+ Map :: ArrayElem e'+ => Fun aenv (e -> e') + -> OpenAcc aenv (Array dim e) + -> OpenAcc aenv (Array dim e')+ -- FIXME: generalise to mapFold++ -- 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 :: ArrayElem e3+ => Fun aenv (e1 -> e2 -> e3) + -> OpenAcc aenv (Array dim e1)+ -> OpenAcc aenv (Array dim e2)+ -> OpenAcc aenv (Array dim e3)++ -- Remove all elements from a linear array that do not satisfy the given+ -- predicate+ Filter :: Fun aenv (e -> ElemRepr Bool) + -> OpenAcc aenv (Vector e)+ -> OpenAcc aenv (Vector e)++ -- 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++ -- 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)+ Scan :: 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?++ -- 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+ -- shape; the permutation function must be total.+ --+ -- The target array is initialised from an array of default values (in case+ -- some positions in the target array are never picked by the permutation+ -- functions). Moroever, we have a combination function (in case some+ -- positions on the target array are picked multiple times by the+ -- permutation functions). The combination functions needs to be+ -- *associative* and *commutative*. + 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)++ -- 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)++-- |Closed array expression aka an array program+--+type Acc a = OpenAcc () a++ +-- Embedded expressions+-- --------------------++-- |Function abstraction+--+data OpenFun env aenv t where+ Body :: OpenExp env aenv t -> OpenFun env aenv t+ Lam :: OpenFun (env, a) aenv t -> OpenFun env aenv (a -> t)++-- |Function without free scalar variables+--+type Fun aenv t = OpenFun () aenv t++-- |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. +--+data OpenExp env aenv t where++ -- |Variable index, ranging only over tuples or scalars+ Var :: ArrayElem t+ => Idx env t + -> OpenExp env aenv t++ -- |Constant values+ Const :: Elem t+ => t -- not converted to ElemRepr yet+ -> OpenExp env aenv (ElemRepr t)++ -- |Tuples+ Pair :: (Elem s, Elem t)+ => s {- dummy to fix the type variable -}+ -> t {- dummy to fix the type variable -}+ -> OpenExp env aenv (ElemRepr s) + -> OpenExp env aenv (ElemRepr t) + -> OpenExp env aenv (ElemRepr (s, t))+ Fst :: (Elem s, Elem t)+ => s {- dummy to fix the type variable -}+ -> t {- dummy to fix the type variable -}+ -> OpenExp env aenv (ElemRepr (s, t))+ -> OpenExp env aenv (ElemRepr s)+ Snd :: (Elem s, Elem t)+ => s {- dummy to fix the type variable -}+ -> t {- dummy to fix the type variable -}+ -> OpenExp env aenv (ElemRepr (s, t))+ -> OpenExp env aenv (ElemRepr t)++ -- |Conditional expression (non-strict in 2nd and 3rd argument)+ Cond :: OpenExp env aenv (ElemRepr Bool) + -> OpenExp env aenv t + -> OpenExp env aenv t + -> OpenExp env aenv t++ -- |Primitive constants+ PrimConst :: Elem t+ => PrimConst t -> OpenExp env aenv (ElemRepr t)++ -- |Primitive scalar operations+ PrimApp :: (Elem a, Elem r)+ => PrimFun (a -> r) + -> OpenExp env aenv (ElemRepr a) + -> OpenExp env aenv (ElemRepr 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++ -- |Array shape+ -- * the array expression cannot contain any free scalar variables+ Shape :: OpenAcc aenv (Array dim e) + -> OpenExp env aenv dim+ +-- |Expression without free scalar variables+--+type Exp aenv t = OpenExp () aenv t++-- |Primitive GPU constants+--+data PrimConst ty where++ -- constants from Bounded+ PrimMinBound :: BoundedType a -> PrimConst a+ PrimMaxBound :: BoundedType a -> PrimConst a++ -- constant from Floating+ PrimPi :: FloatingType a -> PrimConst a++-- |Primitive scalar operations+--+data PrimFun sig where++ -- operators from Num+ PrimAdd :: NumType a -> PrimFun ((a, a) -> a)+ PrimSub :: NumType a -> PrimFun ((a, a) -> a)+ PrimMul :: NumType a -> PrimFun ((a, a) -> a)+ PrimNeg :: NumType a -> PrimFun (a -> a)+ PrimAbs :: NumType a -> PrimFun (a -> a)+ PrimSig :: NumType a -> PrimFun (a -> a)++ -- operators from Integral & Bits+ PrimQuot :: IntegralType a -> PrimFun ((a, a) -> a)+ PrimRem :: IntegralType a -> PrimFun ((a, a) -> a)+ PrimIDiv :: IntegralType a -> PrimFun ((a, a) -> a)+ PrimMod :: IntegralType a -> PrimFun ((a, a) -> a)+ PrimBAnd :: IntegralType a -> PrimFun ((a, a) -> a)+ PrimBOr :: IntegralType a -> PrimFun ((a, a) -> a)+ PrimBXor :: IntegralType a -> PrimFun ((a, a) -> a)+ PrimBNot :: IntegralType a -> PrimFun (a -> a)+ -- FIXME: add shifts++ -- operators from Fractional, Floating, RealFrac & RealFloat+ PrimFDiv :: FloatingType a -> PrimFun ((a, a) -> a)+ PrimRecip :: FloatingType a -> PrimFun (a -> a)+ -- FIXME: add operations from Floating, RealFrac & RealFloat++ -- relational and equality operators+ PrimLt :: ScalarType a -> PrimFun ((a, a) -> Bool)+ PrimGt :: ScalarType a -> PrimFun ((a, a) -> Bool)+ PrimLtEq :: ScalarType a -> PrimFun ((a, a) -> Bool)+ PrimGtEq :: ScalarType a -> PrimFun ((a, a) -> Bool)+ PrimEq :: ScalarType a -> PrimFun ((a, a) -> Bool)+ PrimNEq :: ScalarType a -> PrimFun ((a, a) -> Bool)+ PrimMax :: ScalarType a -> PrimFun ((a, a) -> a )+ PrimMin :: ScalarType a -> PrimFun ((a, a) -> a )++ -- logical operators+ PrimLAnd :: PrimFun ((Bool, Bool) -> Bool)+ PrimLOr :: PrimFun ((Bool, Bool) -> Bool)+ PrimLNot :: PrimFun (Bool -> Bool)++ -- character conversions+ PrimOrd :: PrimFun (Char -> Int)+ 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++ -- FIXME: what do we want to do about Enum? succ and pred are only+ -- moderatly useful without user-defined enumerations, but we want+ -- the range constructs for arrays (but that's not scalar primitives)
+ Data/Array/Accelerate/Array/Data.hs view
@@ -0,0 +1,240 @@+{-# LANGUAGE GADTs, TypeFamilies, FlexibleContexts, FlexibleInstances #-}+{-# LANGUAGE RankNTypes #-}++-- |Embedded array processing language: array data layout for linear arrays+--+-- Copyright (c) 2009 Manuel M T Chakravarty, Gabriele Keller, Sean Lee+--+-- License: BSD3+--+--- Description ---------------------------------------------------------------+--++module Data.Array.Accelerate.Array.Data (++ -- * Array operations and representations+ ArrayElem(..), ArrayData, MutableArrayData, runArrayData++) where++-- standard libraries+import Control.Monad+import Control.Monad.ST+import qualified Data.Array.IArray as IArray+import qualified Data.Array.MArray as MArray+import Data.Array.ST (STUArray)+import Data.Array.Unboxed (UArray)++-- friends+import Data.Array.Accelerate.Type+++-- |Immutable array representation+--+type ArrayData e = GArrayData (UArray Int) e++-- |Mutable array representation+--+type MutableArrayData s e = GArrayData (STUArray s Int) e++-- 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 instance GArrayData ba () = AD_Unit+data instance GArrayData ba Int = AD_Int (ba Int)+data instance GArrayData ba Int8 = AD_Int8 (ba Int8)+data instance GArrayData ba Int16 = AD_Int16 (ba Int16)+data instance GArrayData ba Int32 = AD_Int32 (ba Int32)+data instance GArrayData ba Int64 = AD_Int64 (ba Int64)+data instance GArrayData ba Word = AD_Word (ba Word)+data instance GArrayData ba Word8 = AD_Word8 (ba Word8)+data instance GArrayData ba Word16 = AD_Word16 (ba Word16)+data instance GArrayData ba Word32 = AD_Word32 (ba Word32)+data instance GArrayData ba Word64 = AD_Word64 (ba Word64)+-- data instance GArrayData ba CShort = AD_CShort (ba CShort)+-- data instance GArrayData ba CUShort = AD_CUShort (ba CUShort)+-- data instance GArrayData ba CInt = AD_CInt (ba CInt)+-- data instance GArrayData ba CUInt = AD_CUInt (ba CUInt)+-- data instance GArrayData ba CLong = AD_CLong (ba CLong)+-- data instance GArrayData ba CULong = AD_CULong (ba CULong)+-- data instance GArrayData ba CLLong = AD_CLLong (ba CLLong)+-- data instance GArrayData ba CULLong = AD_CULLong (ba CULLong)+data instance GArrayData ba Float = AD_Float (ba Float)+data instance GArrayData ba Double = AD_Double (ba Double)+-- data instance GArrayData ba CFloat = AD_CFloat (ba CFloat)+-- data instance GArrayData ba CDouble = AD_CDouble (ba CDouble)+data instance GArrayData ba Bool = AD_Bool (ba Bool)+data instance GArrayData ba Char = AD_Char (ba Char)+-- data instance GArrayData ba CChar = AD_CChar (ba CChar)+-- data instance GArrayData ba CSChar = AD_CSChar (ba CSChar)+-- data instance GArrayData ba CUChar = AD_CUChar (ba CUChar)+data instance GArrayData ba (a, b) = AD_Pair (GArrayData ba a) + (GArrayData ba b)++class ArrayElem e where+ indexArrayData :: ArrayData e -> Int -> e+ --+ newArrayData :: Int -> ST s (MutableArrayData s e)+ readArrayData :: MutableArrayData s e -> Int -> ST s e+ writeArrayData :: MutableArrayData s e -> Int -> e -> ST s ()+ unsafeFreezeArrayData :: MutableArrayData s e -> ST s (ArrayData e)++instance ArrayElem () where+ indexArrayData AD_Unit i = i `seq` ()+ newArrayData _ = return AD_Unit+ readArrayData AD_Unit i = i `seq` return ()+ writeArrayData AD_Unit i () = i `seq` return ()+ unsafeFreezeArrayData AD_Unit = return AD_Unit++instance ArrayElem Int where+ indexArrayData (AD_Int ba) i = ba IArray.! i+ newArrayData size = liftM AD_Int $ MArray.newArray_ (0, size - 1)+ 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++instance ArrayElem Int8 where+ indexArrayData (AD_Int8 ba) i = ba IArray.! i+ newArrayData size = liftM AD_Int8 $ MArray.newArray_ (0, size - 1)+ 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++instance ArrayElem Int16 where+ indexArrayData (AD_Int16 ba) i = ba IArray.! i+ newArrayData size = liftM AD_Int16 $ MArray.newArray_ (0, size - 1)+ 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++instance ArrayElem Int32 where+ indexArrayData (AD_Int32 ba) i = ba IArray.! i+ newArrayData size = liftM AD_Int32 $ MArray.newArray_ (0, size - 1)+ 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++instance ArrayElem Int64 where+ indexArrayData (AD_Int64 ba) i = ba IArray.! i+ newArrayData size = liftM AD_Int64 $ MArray.newArray_ (0, size - 1)+ 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++instance ArrayElem Word where+ indexArrayData (AD_Word ba) i = ba IArray.! i+ newArrayData size = liftM AD_Word $ MArray.newArray_ (0, size - 1)+ 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++instance ArrayElem Word8 where+ indexArrayData (AD_Word8 ba) i = ba IArray.! i+ newArrayData size = liftM AD_Word8 $ MArray.newArray_ (0, size - 1)+ 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++instance ArrayElem Word16 where+ indexArrayData (AD_Word16 ba) i = ba IArray.! i+ newArrayData size = liftM AD_Word16 $ MArray.newArray_ (0, size - 1)+ 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++instance ArrayElem Word32 where+ indexArrayData (AD_Word32 ba) i = ba IArray.! i+ newArrayData size = liftM AD_Word32 $ MArray.newArray_ (0, size - 1)+ 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++instance ArrayElem Word64 where+ indexArrayData (AD_Word64 ba) i = ba IArray.! i+ newArrayData size = liftM AD_Word64 $ MArray.newArray_ (0, size - 1)+ 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+ +-- FIXME:+-- CShort+-- CUShort+-- CInt+-- CUInt+-- CLong+-- CULong+-- CLLong+-- CULLong++instance ArrayElem Float where+ indexArrayData (AD_Float ba) i = ba IArray.! i+ newArrayData size = liftM AD_Float $ MArray.newArray_ (0, size - 1)+ 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++instance ArrayElem Double where+ indexArrayData (AD_Double ba) i = ba IArray.! i+ newArrayData size = liftM AD_Double $ MArray.newArray_ (0, size - 1)+ 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++-- FIXME:+-- CFloat+-- CDouble++instance ArrayElem Bool where+ indexArrayData (AD_Bool ba) i = ba IArray.! i+ newArrayData size = liftM AD_Bool $ MArray.newArray_ (0, size - 1)+ 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++instance ArrayElem Char where+ indexArrayData (AD_Char ba) i = ba IArray.! i+ newArrayData size = liftM AD_Char $ MArray.newArray_ (0, size - 1)+ 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++-- FIXME:+-- CChar+-- CSChar+-- CUChar++instance (ArrayElem a, ArrayElem b) => ArrayElem (a, b) where+ indexArrayData (AD_Pair a b) i = (indexArrayData a i, indexArrayData b i)+ newArrayData size + = do + a <- newArrayData size+ b <- newArrayData size+ return $ AD_Pair a b+ readArrayData (AD_Pair a b) i + = do+ x <- readArrayData a i+ y <- readArrayData b i+ return (x, y)+ writeArrayData (AD_Pair a b) i (x, y)+ = do+ writeArrayData a i x+ writeArrayData b i y+ unsafeFreezeArrayData (AD_Pair a b) + = do+ a' <- unsafeFreezeArrayData a+ b' <- unsafeFreezeArrayData b+ return $ AD_Pair a' b'++-- |Safe combination of creating and fast freezing of array data.+--+runArrayData :: ArrayElem 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)
+ Data/Array/Accelerate/Array/Delayed.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE TypeFamilies, RankNTypes #-}++-- |Embedded array processing language: delayed arrays+--+-- Copyright (c) 2009 Manuel M T Chakravarty, Gabriele Keller, Sean Lee+--+-- License: BSD3+--+--- Description ---------------------------------------------------------------+--+-- Delayed arrays are represented by their representation function, which+-- enables the simple composition of many array operations.++module Data.Array.Accelerate.Array.Delayed (++ -- * Delayed array interface+ Delayable(delay, force), Delayed(..)++) where++-- friends+import Data.Array.Accelerate.Array.Data+import Data.Array.Accelerate.Array.Representation+++-- Delayed arrays are characterised by the domain of an array and its functional+-- representation+-- ++class Delayable a where+ data Delayed a+ delay :: a -> Delayed a+ force :: Delayed a -> a+ +instance Delayable () where+ data Delayed () = DelayedUnit+ delay () = DelayedUnit+ force DelayedUnit = ()++instance Delayable (Array dim e) where+ data Delayed (Array dim e) = (Ix dim, ArrayElem e) => + DelayedArray { shapeDA :: dim+ , repfDA :: (dim -> e)+ }+ delay arr@(Array sh _) = DelayedArray sh (arr!)+ force (DelayedArray sh f) = newArray sh f+ +instance (Delayable a1, Delayable a2) => Delayable (a1, a2) where+ data Delayed (a1, a2) = DelayedPair (Delayed a1) (Delayed a2)+ delay (a1, a2) = DelayedPair (delay a1) (delay a2)+ force (DelayedPair a1 a2) = (force a1, force a2)++
+ Data/Array/Accelerate/Array/Representation.hs view
@@ -0,0 +1,190 @@+{-# LANGUAGE GADTs, TypeFamilies, FlexibleContexts, FlexibleInstances #-}++-- |Embedded array processing language: array representation+--+-- Copyright (c) [2008..2009] Manuel M T Chakravarty, Gabriele Keller, Sean Lee+--+-- License: BSD3+--+--- Description ---------------------------------------------------------------+--++module Data.Array.Accelerate.Array.Representation (++ -- * Array representation+ Array(..), Scalar, Vector,++ -- * Array shapes+ DIM0, DIM1, DIM2, ++ -- * Array indexing and slicing+ Ix(..), SliceIx(..), SliceIndex(..),++ -- * Array operations+ (!), newArray++) where++-- GHC internals+import GHC.Prim++-- friends+import Data.Array.Accelerate.Type+import Data.Array.Accelerate.Array.Data+++infixl 9 !+++-- |Arrays+-- -------++-- |Representation type for 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, ArrayElem e) + => dim -- ^extent of dimensions = shape+ -> ArrayData e -- ^data+ -> Array dim e++-- |Shorthand for common shape representations+--+type DIM0 = ()+type DIM1 = ((), Int)+type DIM2 = (((), Int), Int)++-- Special case of singleton arrays+--+type Scalar e = Array DIM0 e++-- Special case of one-dimensional arrays+--+type Vector e = Array DIM1 e+++-- |Index representation+-- -++-- |Class of index representations (which are nested pairs)+--+class 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+ index :: ix -> ix -> Int -- ^yield the index position in a linear, + -- row-major representation of the array+ -- (first argument is the shape)++ 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++ -- operations to facilitate conversion with IArray+ rangeToShape :: (ix, ix) -> ix -- convert a minpoint-maxpoint index+ -- into a shape+ shapeToRange :: ix -> (ix, ix) -- ...the converse++instance Ix () where+ dim () = 0+ size () = 1+ intersect () () = ()+ index () () = 0+ iter () f _ _ = f ()+ + rangeToShape ((), ()) = ()+ shapeToRange () = ((), ())++instance Ix ix => Ix (ix, Int) where+ dim (sh, _) = dim sh + 1+ size (sh, sz) = size sh * sz+ (sh1, sz1) `intersect` (sh2, sz2) = (sh1 `intersect` sh2, sz1 `min` sz2)+ index (sh, sz) (ix, i) + | i >= 0 && i < sz = index sh ix + size sh * i+ | otherwise + = error "Data.Array.Accelerate.Array: index out of bounds"+ iter (sh, sz) f c r = iter' 0+ where+ iter' i | i >= sz = r+ | otherwise = iter sh (\ix -> f (ix, i)) c r `c` iter' (i + 1)++ rangeToShape ((sh1, sz1), (sh2, sz2)) + = (rangeToShape (sh1, sh2), sz2 - sz1 + 1)+ shapeToRange (sh, sz) + = let (low, high) = shapeToRange sh+ in + ((low, 0), (high, sz - 1))+++-- |Slice representation+-- -++-- |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+ -- argument *value* not used; it's just a phantom value to fix the type+ sliceIndex :: sl -> SliceIndex sl + (Slice sl) + (CoSlice sl) + (SliceDim sl)++instance SliceIx () where+ type Slice () = ()+ type CoSlice () = ()+ type SliceDim () = ()+ 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)+ 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)+ sliceIndex _ = SliceFixed (sliceIndex (undefined::sl))++-- |Generalised array index, which may index only in a subset of the dimensions+-- of a shape.+--+data SliceIndex ix slice coSlice sliceDim where+ SliceNil :: SliceIndex () () () ()+ SliceAll :: + 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)+++-- Array operations+-- ----------------++-- |Array indexing+--+(!) :: Array dim e -> dim -> e+-- (Array sh adata) ! ix = adata `indexArrayData` index sh ix+-- FIXME: using this due to a bug in 6.10.x+(!) (Array sh adata) ix = adata `indexArrayData` index sh ix++-- |Create an array from its representation function+--+newArray :: (Ix dim, ArrayElem e) => dim -> (dim -> e) -> Array dim e+newArray sh f + = adata `seq` Array sh adata+ where + (adata, _) = runArrayData $ do+ arr <- newArrayData (size sh)+ let write ix = writeArrayData arr (index sh ix) (f ix) + iter sh write (>>) (return ())+ return (arr, undefined)
+ Data/Array/Accelerate/Array/Sugar.hs view
@@ -0,0 +1,722 @@+{-# LANGUAGE GADTs, TypeFamilies, FlexibleContexts, FlexibleInstances #-}+{-# LANGUAGE 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,++ -- * Class of element types and of array shapes+ Elem(..), ElemRepr, ElemRepr', FromShapeRepr,++ -- * Array shapes+ DIM0, DIM1, DIM2, DIM3, DIM4, DIM5,++ -- * Array indexing and slicing+ ShapeBase, Shape, Ix(..), All(..), SliceIx(..), convertSliceIndex,+ + -- * Conversion between the internal and surface array representation+ fromArray, toArray, Arrays(..),+ + -- * Array shape query, indexing, and conversions+ shape, (!), fromIArray, toIArray, fromList, toList++) where++-- standard library+import Data.Array.IArray (IArray)+import qualified Data.Array.IArray as IArray+import qualified Data.Ix 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+import qualified Data.Array.Accelerate.Array.Delayed as Repr+++infixl 9 !+++-- |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)++-- 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)+++-- |Surface types (tuples of scalars)+-- ----------------------------------++-- |Identifier for entire dimensions in slice descriptors+--+data All = All deriving (Typeable, Show)++class (Show a, Typeable a, + 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)++{-}+-- |Convenience functions+-- -++singletonScalarType :: IsScalar a => a -> TupleType ((), a)+singletonScalarType _ = PairTuple UnitTuple (SingleTuple scalarType)+-}+++-- |Surface arrays+-- ---------------++-- |Multi-dimensional arrays for array processing+--+data Array dim e where+ Array :: (Ix dim, Elem e) + => 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++-- |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)++-- |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)++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)++-- |Indices as n-tuples+--+class (Shape ix, Repr.Ix (ElemRepr 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+ index :: ix -> ix -> Int -- ^corresponding index into a linear, row-major + -- representation of the array (first argument+ -- is the shape)++ rangeToShape :: (ix, ix) -> ix -- convert a minpoint-maxpoint index+ -- into a shape+ shapeToRange :: ix -> (ix, ix)++ dim = Repr.dim . fromElem+ size = Repr.size . fromElem+ index sh ix = Repr.index (fromElem sh) (fromElem ix)+ + rangeToShape (low, high) + = toElem (Repr.rangeToShape (fromElem low, fromElem high))+ shapeToRange ix+ = let (low, high) = Repr.shapeToRange (fromElem ix)+ in+ (toElem low, toElem high)++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)++-- Slices -aka generalised indices- as n-tuples+--+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+++-- Conversion between internal and surface array representation+-- ------------------------------------------------------------++-- |Convert surface array representation to the internal one+--+fromArray :: Array dim e -> Repr.Array (ElemRepr dim) (ElemRepr e)+fromArray (Array shape adata) = Repr.Array (fromElem shape) adata+ +-- |Convert internal array representation to the surface one+--+toArray :: (Ix dim, Elem e)+ => Repr.Array (ElemRepr dim) (ElemRepr e) -> Array dim e+toArray (Repr.Array shape adata) = Array (toElem shape) adata+ +-- Conversion for tuples of arrays+--+class Repr.Delayable (ArraysRepr as) => Arrays as where+ type ArraysRepr as :: *+ fromArrays :: as -> ArraysRepr as+ toArrays :: ArraysRepr as -> as+ +instance Arrays () where+ type ArraysRepr () = ()+ fromArrays () = ()+ toArrays () = ()+ +instance (Ix dim, Elem e) => Arrays (Array dim e) where+ type ArraysRepr (Array dim e) = Repr.Array (ElemRepr dim) (ElemRepr e)+ fromArrays = fromArray+ toArrays = toArray++instance (Arrays as1, Arrays as2) => Arrays (as1, as2) where+ type ArraysRepr (as1, as2) = (ArraysRepr as1, ArraysRepr as2)+ fromArrays (as1, as2) = (fromArrays as1, fromArrays as2)+ toArrays (as1, as2) = (toArrays as1, toArrays as2)+++-- Array operations+-- ----------------++-- |Yield an array's shape+--+shape :: Ix dim => Array dim e -> dim+shape (Array sh _) = sh++-- |Array indexing+--+(!) :: Array dim e -> dim -> e+-- (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 sh ix)++-- |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 = Array sh adata + where+ sh = rangeToShape (IArray.bounds iarr)+ Repr.Array _ adata = Repr.newArray (fromElem sh)+ (fromElem . (iarr IArray.!) . toElem)++-- |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 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 = Array sh adata + where+ Repr.Array _ adata = Repr.newArray (fromElem sh) indexIntoList+ --+ indexIntoList ix = fromElem $ l!!(Repr.index (fromElem sh) ix)++-- |Convert an accelerated array to a list in row-major order.+--+toList :: Array dim e -> [e]+toList (Array sh adata) = Repr.iter sh' idx (.) id []+ where+ sh' = fromElem sh+ idx ix = \l -> toElem (adata `indexArrayData` Repr.index sh' ix) : l++-- Convert an array to a string+--+instance Show (Array dim e) where+ show arr@(Array sh _adata) = "Array " ++ show sh ++ " " ++ show (toList arr)
+ Data/Array/Accelerate/Debug.hs view
@@ -0,0 +1,26 @@+-- |Embedded array processing language: debugging support (internal)+--+-- Copyright (c) 2009 Manuel M T Chakravarty, Gabriele Keller, Sean Lee+--+-- License: BSD3+--+--- Description ---------------------------------------------------------------+--+-- This module provides functionality that is useful for developers of the+-- library. It is not meant for library users.++module Data.Array.Accelerate.Debug (++ dumpAcc, dumpExp++) where++-- friends+import Data.Array.Accelerate.Smart+import Data.Array.Accelerate.Pretty ()++dumpAcc :: Acc as -> String+dumpAcc = show . convertAcc++dumpExp :: Exp a -> String+dumpExp = show . convertClosedExp
+ Data/Array/Accelerate/Interpreter.hs view
@@ -0,0 +1,574 @@+{-# LANGUAGE GADTs, BangPatterns, PatternGuards #-}+{-# LANGUAGE TypeFamilies, ScopedTypeVariables, FlexibleContexts #-}++-- |Embedded array processing language: execution by a simple interpreter+--+-- Copyright (c) [2008..2009] Manuel M T Chakravarty, Gabriele Keller, Sean Lee+--+-- License: BSD3+--+--- Description ---------------------------------------------------------------+--+-- This interpreter is meant to be a reference implementation of the semantics+-- of the embedded array language. The emphasis is on defining the semantics+-- clearly, not on performance.++module Data.Array.Accelerate.Interpreter (++ -- * Interpret an array expression+ run+ +) where++-- standard libraries+import Data.Bits+import Data.Char (chr, ord)++-- friends+import Data.Array.Accelerate.Type+import Data.Array.Accelerate.Array.Data+import Data.Array.Accelerate.Array.Representation+import Data.Array.Accelerate.Array.Delayed+import Data.Array.Accelerate.AST+import qualified Data.Array.Accelerate.Smart as Sugar+import qualified Data.Array.Accelerate.Array.Sugar as Sugar+++-- Program execution+-- -----------------++-- Run a complete array program+--+run :: Sugar.Arrays a => Sugar.Acc a -> a+run = Sugar.toArrays . force . evalAcc . Sugar.convertAcc+++-- Environments+-- ------------++-- Valuation for an environment+--+data Val env where+ Empty :: Val ()+ Push :: Val env -> t -> Val (env, t)++-- 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 _ _ = + error "Data.Array.Accelerate.Interpreter: prj: inconsistent valuation"+++-- Array expression evaluation+-- ---------------------------++-- Evaluate an open array expression+--+evalOpenAcc :: Delayable a => OpenAcc aenv a -> Val aenv -> Delayed a++evalOpenAcc (Let acc1 acc2) aenv + = let !arr1 = force $ evalOpenAcc acc1 aenv+ in evalOpenAcc acc2 (aenv `Push` arr1)++evalOpenAcc (Avar idx) aenv = delay $ prj idx aenv++evalOpenAcc (Use arr) _aenv = delay arr++evalOpenAcc (Unit e) aenv = unitOp (evalExp e aenv)++evalOpenAcc (Reshape e acc) aenv + = reshapeOp (evalExp e aenv) (evalOpenAcc acc aenv)++evalOpenAcc (Replicate sliceIndex slix acc) aenv+ = replicateOp sliceIndex (evalExp slix aenv) (evalOpenAcc acc aenv)+ +evalOpenAcc (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)++evalOpenAcc (ZipWith f acc1 acc2) aenv+ = zipWithOp (evalFun f aenv) (evalOpenAcc acc1 aenv) (evalOpenAcc acc2 aenv)++evalOpenAcc (Filter p acc) aenv+ = filterOp (evalFun p aenv) (evalOpenAcc acc aenv)+ +evalOpenAcc (Fold f e acc) aenv+ = foldOp (evalFun f aenv) (evalExp e aenv) (evalOpenAcc acc aenv)++evalOpenAcc (Scan f e acc) aenv+ = scanOp (evalFun f aenv) (evalExp e aenv) (evalOpenAcc acc aenv)++evalOpenAcc (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+ = backpermuteOp (evalExp e aenv) (evalFun p aenv) (evalOpenAcc acc aenv)++-- Evaluate a closed array expressions+--+evalAcc :: Delayable a => Acc a -> Delayed a+evalAcc acc = evalOpenAcc acc Empty+++-- Array primitives+-- ----------------++unitOp :: ArrayElem e => e -> Delayed (Scalar e)+unitOp e = DelayedArray {shapeDA = (), repfDA = const e}++reshapeOp :: Ix dim => dim -> Delayed (Array dim' e) -> Delayed (Array dim e)+reshapeOp newShape darr@(DelayedArray {shapeDA = oldShape})+ | size newShape == size oldShape+ = let Array _ adata = force darr+ in + delay $ Array newShape adata+ | otherwise + = error "Data.Array.Accelerate.Interpreter.reshape: shape mismatch"++replicateOp :: Ix dim+ => SliceIndex slix sl co 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 slix sh+ + extend :: SliceIndex slix sl co dim+ -> slix + -> sl+ -> (dim, dim -> sl)+ extend SliceNil () () = ((), const ())+ extend (SliceAll sliceIndex) (slix, ()) (sl, sz) + = let (dim', pf') = extend sliceIndex slix sl+ in+ ((dim', sz), \(ix, i) -> (pf' ix, i))+ extend (SliceFixed sliceIndex) (slix, sz) sl+ = let (dim', pf') = extend sliceIndex slix sl+ in+ ((dim', sz), \(ix, _) -> pf' ix)+ +indexOp :: Ix sl+ => SliceIndex slix sl co dim + -> Delayed (Array dim e)+ -> slix + -> Delayed (Array sl e)+indexOp sliceIndex (DelayedArray sh pf) slix + = DelayedArray sh' (pf . pf')+ where+ (sh', pf') = restrict sliceIndex 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+ in+ ((sl', sz), \(ix, i) -> (pf' ix, i))+ restrict (SliceFixed sliceIndex) (slix, i) (sh, sz)+ | i < sz+ = let (sl', pf') = restrict sliceIndex slix sh+ in+ (sl', \ix -> (pf' ix, i))+ | otherwise = error "Index out of bounds"++mapOp :: ArrayElem e' + => (e -> e') + -> Delayed (Array dim e) + -> Delayed (Array dim e')+mapOp f (DelayedArray sh rf) = DelayedArray sh (f . rf)++zipWithOp :: ArrayElem 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 -> f (rf1 ix) (rf2 ix))++filterOp :: (e -> Sugar.ElemRepr Bool)+ -> Delayed (Vector e)+ -> Delayed (Vector e)+filterOp p (DelayedArray sh rf)+ = error "Data.Array.Accelerate.Interpreter: filter: not yet implemented"++foldOp :: (e -> e -> e)+ -> e+ -> Delayed (Array dim e)+ -> Delayed (Scalar e)+foldOp f e (DelayedArray sh rf)+ = unitOp $ iter sh rf f e++scanOp :: (e -> e -> e)+ -> e+ -> Delayed (Vector e)+ -> Delayed (Vector e, Scalar e)+scanOp f e (DelayedArray sh rf)+ = DelayedPair (delay $ adata `seq` Array sh adata) (unitOp final)+ where+ n = size sh+ --+ (adata, final) = runArrayData $ do+ arr <- newArrayData n+ final <- traverse arr 0 e+ return (arr, final)+ traverse arr i v+ | i >= n = return v+ | otherwise = do+ writeArrayData arr i v+ traverse arr (i + 1) (f v (rf ((), i)))+ +permuteOp :: (e -> e -> e)+ -> Delayed (Array dim' e)+ -> (dim -> dim')+ -> Delayed (Array dim e)+ -> Delayed (Array dim' e)+permuteOp f (DelayedArray dftsSh dftsPf) p (DelayedArray sh pf)+ = delay $ adata `seq` Array dftsSh adata+ where + (adata, _) + = runArrayData $ do++ -- new array in target dimension+ arr <- newArrayData (size dftsSh)++ -- initialise it with the default values+ let write ix = writeArrayData arr (index dftsSh ix) (dftsPf ix) + iter dftsSh write (>>) (return ())++ -- traverse the source dimension and project each element into+ -- the target dimension (where it gets combined with the current+ -- default)+ let update ix = do+ let i = index dftsSh (p ix)+ e <- readArrayData arr i+ writeArrayData arr i (pf ix `f` e) + iter sh update (>>) (return ())+ + -- return the updated array+ return (arr, undefined)++backpermuteOp :: Ix dim'+ => dim'+ -> (dim' -> dim)+ -> Delayed (Array dim e)+ -> Delayed (Array dim' e)+backpermuteOp sh' p (DelayedArray _sh rf)+ = DelayedArray sh' (rf . p)+++-- Expression evaluation+-- ---------------------++-- Evaluate open function+--+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` x) aenv++-- Evaluate a closed function+--+evalFun :: Fun aenv t -> Val aenv -> t+evalFun f aenv = evalOpenFun f Empty aenv++-- Evaluate an open expression+--+-- NB: The implementation of 'IndexScalar' and 'Shape' demonstrate clearly why+-- array expressions must be hoisted out of scalar expressions before code+-- execution. If these operations are in the body of a function that+-- gets mapped over an array, the array argument would be forced many times+-- leading to a large amount of wasteful recomputation.+-- +evalOpenExp :: OpenExp env aenv a -> Val env -> Val aenv -> a++evalOpenExp (Var idx) env _ = prj idx env+ +evalOpenExp (Const c) _ _ = Sugar.fromElem c++evalOpenExp (Pair ds dt e1 e2) env aenv + = evalPair ds dt (evalOpenExp e1 env aenv) (evalOpenExp e2 env aenv)++evalOpenExp (Fst ds dt e) env aenv + = evalFst ds dt (evalOpenExp e env aenv)++evalOpenExp (Snd ds dt e) env aenv + = evalSnd ds dt (evalOpenExp e env aenv)++evalOpenExp (Cond c t e) env aenv + = if Sugar.toElem (evalOpenExp c env aenv) + then evalOpenExp t env aenv+ else evalOpenExp e env aenv++evalOpenExp (PrimConst c) _ _ = Sugar.fromElem $ evalPrimConst c++evalOpenExp (PrimApp p arg) env aenv + = Sugar.fromElem $ evalPrim p (Sugar.toElem (evalOpenExp arg env aenv))++evalOpenExp (IndexScalar acc ix) env aenv + = let ix' = evalOpenExp ix env aenv+ in+ case evalOpenAcc acc aenv of+ DelayedArray sh pf -> index sh ix' `seq` pf ix'+ -- FIXME: This is ugly, but (possibly) needed to+ -- ensure bounds checking++evalOpenExp (Shape acc) _ aenv + = let Array sh _ = force $ evalOpenAcc acc aenv + in sh++-- Evaluate a closed expression+--+evalExp :: Exp aenv t -> Val aenv -> t+evalExp e aenv = evalOpenExp e Empty aenv+++-- Scalar primitives+-- -----------------++evalPrimConst :: PrimConst a -> a+evalPrimConst (PrimMinBound ty) = evalMinBound ty+evalPrimConst (PrimMaxBound ty) = evalMaxBound ty+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 (PrimFDiv ty) = evalFDiv ty+evalPrim (PrimRecip ty) = evalRecip 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+++-- Pairing+-- -------++evalPair :: forall s t. (Sugar.Elem s, Sugar.Elem t)+ => s {- dummy to fix the type variable -}+ -> t {- dummy to fix the type variable -}+ -> Sugar.ElemRepr s+ -> Sugar.ElemRepr t+ -> Sugar.ElemRepr (s, t)+evalPair _ _ x y = Sugar.fromElem (Sugar.toElem x :: s, Sugar.toElem y :: t)++evalFst :: forall s t. (Sugar.Elem s, Sugar.Elem t)+ => s {- dummy to fix the type variable -}+ -> t {- dummy to fix the type variable -}+ -> Sugar.ElemRepr (s, t)+ -> Sugar.ElemRepr s+evalFst _ _ xy = let (x, !_) = Sugar.toElem xy :: (s, t)+ in Sugar.fromElem x++evalSnd :: forall s t. (Sugar.Elem s, Sugar.Elem t)+ => s {- dummy to fix the type variable -}+ -> t {- dummy to fix the type variable -}+ -> Sugar.ElemRepr (s, t)+ -> Sugar.ElemRepr t+evalSnd _ _ xy = let (!_, y) = Sugar.toElem xy :: (s, t)+ in Sugar.fromElem y+++-- Implementation of scalar primitives+-- -----------------------------------++evalLAnd :: (Bool, Bool) -> Bool+evalLAnd (!x, !y) = x && y++evalLOr :: (Bool, Bool) -> Bool+evalLOr (!x, !y) = x || y++evalLNot :: Bool -> Bool+evalLNot x = not x++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+++-- Extract methods from reified dictionaries+-- ++-- Constant methods of Bounded+-- ++evalMinBound :: BoundedType a -> a+evalMinBound (IntegralBoundedType ty) + | IntegralDict <- integralDict ty = minBound+evalMinBound (NonNumBoundedType ty) + | NonNumDict <- nonNumDict ty = minBound++evalMaxBound :: BoundedType a -> a+evalMaxBound (IntegralBoundedType ty) + | IntegralDict <- integralDict ty = maxBound+evalMaxBound (NonNumBoundedType ty) + | NonNumDict <- nonNumDict ty = maxBound++-- Constant method of floating+-- ++evalPi :: FloatingType a -> a+evalPi ty | FloatingDict <- floatingDict ty = pi++-- Methods of Num+-- ++evalAdd :: NumType a -> ((a, a) -> a)+evalAdd (IntegralNumType ty) | IntegralDict <- integralDict ty = uncurry (+)+evalAdd (FloatingNumType ty) | FloatingDict <- floatingDict ty = uncurry (+)++evalSub :: NumType a -> ((a, a) -> a)+evalSub (IntegralNumType ty) | IntegralDict <- integralDict ty = uncurry (-)+evalSub (FloatingNumType ty) | FloatingDict <- floatingDict ty = uncurry (-)++evalMul :: NumType a -> ((a, a) -> a)+evalMul (IntegralNumType ty) | IntegralDict <- integralDict ty = uncurry (*)+evalMul (FloatingNumType ty) | FloatingDict <- floatingDict ty = uncurry (*)++evalNeg :: NumType a -> (a -> a)+evalNeg (IntegralNumType ty) | IntegralDict <- integralDict ty = negate+evalNeg (FloatingNumType ty) | FloatingDict <- floatingDict ty = negate++evalAbs :: NumType a -> (a -> a)+evalAbs (IntegralNumType ty) | IntegralDict <- integralDict ty = abs+evalAbs (FloatingNumType ty) | FloatingDict <- floatingDict ty = abs++evalSig :: NumType a -> (a -> a)+evalSig (IntegralNumType ty) | IntegralDict <- integralDict ty = signum+evalSig (FloatingNumType ty) | FloatingDict <- floatingDict ty = signum++evalQuot :: IntegralType a -> ((a, a) -> a)+evalQuot ty | IntegralDict <- integralDict ty = uncurry quot++evalRem :: IntegralType a -> ((a, a) -> a)+evalRem ty | IntegralDict <- integralDict ty = uncurry rem++evalIDiv :: IntegralType a -> ((a, a) -> a)+evalIDiv ty | IntegralDict <- integralDict ty = uncurry div++evalMod :: IntegralType a -> ((a, a) -> a)+evalMod ty | IntegralDict <- integralDict ty = uncurry mod++evalBAnd :: IntegralType a -> ((a, a) -> a)+evalBAnd ty | IntegralDict <- integralDict ty = uncurry (.&.)++evalBOr :: IntegralType a -> ((a, a) -> a)+evalBOr ty | IntegralDict <- integralDict ty = uncurry (.|.)++evalBXor :: IntegralType a -> ((a, a) -> a)+evalBXor ty | IntegralDict <- integralDict ty = uncurry xor++evalBNot :: IntegralType a -> (a -> a)+evalBNot ty | IntegralDict <- integralDict ty = complement++evalFDiv :: FloatingType a -> ((a, a) -> a)+evalFDiv ty | FloatingDict <- floatingDict ty = uncurry (/)++evalRecip :: FloatingType a -> (a -> a)+evalRecip ty | FloatingDict <- floatingDict ty = recip++evalLt :: ScalarType a -> ((a, a) -> Bool)+evalLt (NumScalarType (IntegralNumType ty)) + | IntegralDict <- integralDict ty = uncurry (<)+evalLt (NumScalarType (FloatingNumType ty)) + | FloatingDict <- floatingDict ty = uncurry (<)+evalLt (NonNumScalarType ty) + | NonNumDict <- nonNumDict ty = uncurry (<)++evalGt :: ScalarType a -> ((a, a) -> Bool)+evalGt (NumScalarType (IntegralNumType ty)) + | IntegralDict <- integralDict ty = uncurry (>)+evalGt (NumScalarType (FloatingNumType ty)) + | FloatingDict <- floatingDict ty = uncurry (>)+evalGt (NonNumScalarType ty) + | NonNumDict <- nonNumDict ty = uncurry (>)++evalLtEq :: ScalarType a -> ((a, a) -> Bool)+evalLtEq (NumScalarType (IntegralNumType ty)) + | IntegralDict <- integralDict ty = uncurry (<=)+evalLtEq (NumScalarType (FloatingNumType ty)) + | FloatingDict <- floatingDict ty = uncurry (<=)+evalLtEq (NonNumScalarType ty) + | NonNumDict <- nonNumDict ty = uncurry (<=)++evalGtEq :: ScalarType a -> ((a, a) -> Bool)+evalGtEq (NumScalarType (IntegralNumType ty)) + | IntegralDict <- integralDict ty = uncurry (>=)+evalGtEq (NumScalarType (FloatingNumType ty)) + | FloatingDict <- floatingDict ty = uncurry (>=)+evalGtEq (NonNumScalarType ty) + | NonNumDict <- nonNumDict ty = uncurry (>=)++evalEq :: ScalarType a -> ((a, a) -> Bool)+evalEq (NumScalarType (IntegralNumType ty)) + | IntegralDict <- integralDict ty = uncurry (==)+evalEq (NumScalarType (FloatingNumType ty)) + | FloatingDict <- floatingDict ty = uncurry (==)+evalEq (NonNumScalarType ty) + | NonNumDict <- nonNumDict ty = uncurry (==)++evalNEq :: ScalarType a -> ((a, a) -> Bool)+evalNEq (NumScalarType (IntegralNumType ty)) + | IntegralDict <- integralDict ty = uncurry (/=)+evalNEq (NumScalarType (FloatingNumType ty)) + | FloatingDict <- floatingDict ty = uncurry (/=)+evalNEq (NonNumScalarType ty) + | NonNumDict <- nonNumDict ty = uncurry (/=)++evalMax :: ScalarType a -> ((a, a) -> a)+evalMax (NumScalarType (IntegralNumType ty)) + | IntegralDict <- integralDict ty = uncurry max+evalMax (NumScalarType (FloatingNumType ty)) + | FloatingDict <- floatingDict ty = uncurry max+evalMax (NonNumScalarType ty) + | NonNumDict <- nonNumDict ty = uncurry max++evalMin :: ScalarType a -> ((a, a) -> a)+evalMin (NumScalarType (IntegralNumType ty)) + | IntegralDict <- integralDict ty = uncurry min+evalMin (NumScalarType (FloatingNumType ty)) + | FloatingDict <- floatingDict ty = uncurry min+evalMin (NonNumScalarType ty) + | NonNumDict <- nonNumDict ty = uncurry min
+ Data/Array/Accelerate/Language.hs view
@@ -0,0 +1,259 @@+{-# LANGUAGE FlexibleContexts, TypeFamilies, RankNTypes, ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-missing-methods #-}++-- |Embedded array processing language: user-visible language+--+-- Copyright (c) 2009 Manuel M T Chakravarty, Gabriele Keller, Sean Lee+--+-- License: BSD3+--+--- Description ---------------------------------------------------------------+--+-- We use the dictionary view of overloaded operations (such as arithmetic and+-- bit manipulation) to reify such expressions. With non-overloaded+-- operations (such as, the logical connectives) and partially overloaded+-- operations (such as comparisons), we use the standard operator names with a+-- '*' attached. We keep the standard alphanumeric names as they can be+-- easily qualified.++module Data.Array.Accelerate.Language (++ -- * Array and scalar expressions+ Acc, Exp, -- re-exporting from 'Smart'++ -- * Scalar introduction+ constant, -- re-exporting from 'Smart'++ -- * Array introduction+ use, unit,++ -- * Shape manipulation+ reshape,++ -- * Indexing+ (!),++ -- * Collective array operations+ replicate, zip, map, zipWith, filter, scan, fold, permute, backpermute,+ + -- * Instances of Bounded, Enum, Eq, Ord, Bits, Num, Real, Floating,+ -- Fractional, RealFrac, RealFloat++ -- * Methods of H98 classes that we need to redefine as their signatures+ -- change + (==*), (/=*), (<*), (<=*), (>*), (>=*), max, min,++ -- * Standard functions that we need to redefine as their signatures change+ (&&*), (||*), not++) where++-- avoid clashes with Prelude functions+import Prelude hiding (replicate, zip, map, zipWith, filter, max, min, not,+ const)+import qualified Prelude++-- standard libraries+import Data.Bits++-- friends+import Data.Array.Accelerate.Type+import Data.Array.Accelerate.Array.Sugar hiding ((!))+import Data.Array.Accelerate.Smart+++infixr 2 ||*+infixr 3 &&*+infix 4 ==*, /=*, <*, <=*, >*, >=*+infixl 9 !+++-- |Collective operations+-- ----------------------++use :: (Ix dim, Elem e) => Array dim e -> Acc (Array dim e)+use = Use++unit :: Elem e => Exp e -> Acc (Scalar e)+unit = Unit++reshape :: (Ix dim, Ix dim', Elem e) + => Exp dim + -> Acc (Array dim' e) + -> Acc (Array dim e)+reshape = Reshape++replicate :: forall slix e. (SliceIx slix, Elem e) + => Exp slix + -> Acc (Array (Slice slix) e) + -> Acc (Array (SliceDim slix) e)+replicate = Replicate (undefined::slix) (undefined::e)++(!) :: forall slix e. (SliceIx slix, Elem e) + => Acc (Array (SliceDim slix) e) + -> Exp slix + -> Acc (Array (Slice slix) e)+(!) = Index (undefined::slix) (undefined::e) ++zip :: (Ix dim, Elem a, Elem b) + => Acc (Array dim a)+ -> Acc (Array dim b)+ -> Acc (Array dim (a, b))+zip = zipWith (\x y -> x `Pair` y)++map :: (Ix dim, Elem a, Elem b) + => (Exp a -> Exp b) + -> Acc (Array dim a)+ -> Acc (Array dim b)+map = Map++zipWith :: (Ix dim, Elem a, Elem b, Elem c)+ => (Exp a -> Exp b -> Exp c) + -> Acc (Array dim a)+ -> Acc (Array dim b)+ -> Acc (Array dim c)+zipWith = ZipWith++filter :: Elem a + => (Exp a -> Exp Bool) + -> Acc (Vector a) + -> Acc (Vector a)+filter = Filter++scan :: Elem a + => (Exp a -> Exp a -> Exp a) + -> Exp a + -> Acc (Vector a)+ -> Acc (Vector a, Scalar a)+scan = Scan++fold :: Elem a + => (Exp a -> Exp a -> Exp a) + -> Exp a + -> Acc (Vector a)+ -> Acc (Scalar a)+fold = Fold++permute :: (Ix dim, Ix dim', Elem a)+ => (Exp a -> Exp a -> Exp a) + -> Acc (Array dim' a) + -> (Exp dim -> Exp dim') + -> Acc (Array dim a) + -> Acc (Array dim' a)+permute = Permute++backpermute :: (Ix dim, Ix dim', Elem a)+ => Exp dim' + -> (Exp dim' -> Exp dim) + -> Acc (Array dim a) + -> Acc (Array dim' a)+backpermute = Backpermute+++-- |Instances of all relevant H98 classes+-- --------------------------------------++instance (Elem t, IsBounded t) => Bounded (Exp t) where+ minBound = mkMinBound+ maxBound = mkMaxBound++instance (Elem t, IsScalar t) => Enum (Exp t)+-- succ = mkSucc+-- pred = mkPred+ -- FIXME: ops++instance (Elem t, IsScalar t) => Prelude.Eq (Exp t)+ -- FIXME: instance makes no sense with standard signatures++instance (Elem t, IsScalar t) => Prelude.Ord (Exp t)+ -- FIXME: instance makes no sense with standard signatures++instance (Elem 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++instance (Elem t, IsNum t) => Num (Exp t) where+ (+) = mkAdd+ (-) = mkSub+ (*) = mkMul+ negate = mkNeg+ abs = mkAbs+ signum = mkSig+ fromInteger = constant . fromInteger++instance (Elem 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+ quot = mkQuot+ rem = mkRem+ div = mkIDiv+ mod = mkMod+-- quotRem =+-- divMod =+-- toInteger = -- makes no sense++instance (Elem t, IsFloating t) => Floating (Exp t) where+ pi = mkPi+ -- FIXME: add other ops++instance (Elem t, IsFloating t) => Fractional (Exp t) where+ (/) = mkFDiv+ recip = mkRecip+ fromRational = exp . fromRational+ -- FIXME: add other ops++instance (Elem t, IsFloating t) => RealFrac (Exp t)+ -- FIXME: add ops++instance (Elem t, IsFloating t) => RealFloat (Exp t)+ -- FIXME: add ops+++-- |Methods from H98 classes, where we need other signatures+-- ---------------------------------------------------------++(==*) :: (Elem t, IsScalar t) => Exp t -> Exp t -> Exp Bool+(==*) = mkEq++(/=*) :: (Elem t, IsScalar t) => Exp t -> Exp t -> Exp Bool+(/=*) = mkNEq++-- compare :: a -> a -> Ordering -- we have no enumerations at the moment+-- compare = ...++(<*) :: (Elem t, IsScalar t) => Exp t -> Exp t -> Exp Bool+(<*) = mkLt++(>=*) :: (Elem t, IsScalar t) => Exp t -> Exp t -> Exp Bool+(>=*) = mkGtEq++(>*) :: (Elem t, IsScalar t) => Exp t -> Exp t -> Exp Bool+(>*) = mkGt++(<=*) :: (Elem t, IsScalar t) => Exp t -> Exp t -> Exp Bool+(<=*) = mkLtEq++max :: (Elem t, IsScalar t) => Exp t -> Exp t -> Exp t+max = mkMax++min :: (Elem t, IsScalar t) => Exp t -> Exp t -> Exp t+min = mkMin+++-- |Non-overloaded standard functions, where we need other signatures+-- ------------------------------------------------------------------++(&&*) :: Exp Bool -> Exp Bool -> Exp Bool+(&&*) = mkLAnd++(||*) :: Exp Bool -> Exp Bool -> Exp Bool+(||*) = mkLOr++not :: Exp Bool -> Exp Bool+not = mkLNot+
+ Data/Array/Accelerate/Pretty.hs view
@@ -0,0 +1,224 @@+{-# 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+--+--- Description ---------------------------------------------------------------+--++module Data.Array.Accelerate.Pretty (++ -- * Instances of Show++) where++-- standard libraries+import Text.PrettyPrint++-- friends+import Data.Array.Accelerate.Type+import Data.Array.Accelerate.Array.Representation+import Data.Array.Accelerate.AST+++-- |Show instances+-- ---------------++instance Show (OpenAcc aenv a) where+ show c = render $ prettyAcc 0 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 <+> text " = " <+> prettyAcc lvl acc1 <+>+ text " in " <+> prettyAcc (lvl + 1) 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 (Filter p acc) + = prettyArrOp "filter" [parens (prettyFun lvl p), prettyAccParens lvl acc]+prettyAcc lvl (Fold f e acc) + = prettyArrOp "fold" [parens (prettyFun lvl f), prettyExp lvl parens e,+ prettyAccParens lvl acc]+prettyAcc lvl (Scan f e acc) + = prettyArrOp "scan" [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]+ +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 <- [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 :: Int -> (Doc -> Doc) -> OpenExp env aenv t -> Doc+prettyExp _ _ (Var idx) = text $ "x" ++ show (idxToInt idx)+prettyExp _ _ (Const v) = text $ show v+prettyExp lvl _ e@(Pair _ _ _ _) = prettyTuple lvl e+prettyExp lvl wrap (Fst _ _ e) + = wrap $ text "fst" <+> prettyExp lvl parens e+prettyExp lvl wrap (Snd _ _ e) + = wrap $ text "snd" <+> 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 -> OpenExp env aenv t -> Doc+prettyTuple lvl e = parens $ sep (map (<> comma) (init es) ++ [last es])+ where+ es = collect e+ --+ collect :: OpenExp env aenv t -> [Doc]+ collect (Pair _ _ e1 e2) = collect e1 ++ collect e2+ collect e = [prettyExp lvl noParens e]++-- 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 (PrimFDiv _) = text "(/)"+prettyPrim (PrimRecip _) = text "recip"+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"++{-+-- Pretty print type+--+prettyAnyType :: ScalarType a -> Doc+prettyAnyType ty = text $ show ty+-}++prettyArray :: Array dim a -> Doc+prettyArray (Array sh adata) + = text "<array>"+{-+ = hang (text "Array") 2 $+ sep []+-}+++-- 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 scalar values+--+runScalarShow :: ScalarType a -> (a -> String)+runScalarShow (NumScalarType (IntegralNumType ty)) + | IntegralDict <- integralDict ty = show+runScalarShow (NumScalarType (FloatingNumType ty)) + | FloatingDict <- floatingDict ty = show+runScalarShow (NonNumScalarType ty) + | NonNumDict <- nonNumDict ty = show+-}
+ Data/Array/Accelerate/Smart.hs view
@@ -0,0 +1,428 @@+{-# LANGUAGE GADTs, TypeFamilies, ScopedTypeVariables, FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}++-- |Embedded array processing language: smart expression constructors+--+-- Copyright (c) [2008..2009] Manuel M T Chakravarty, Gabriele Keller, Sean Lee+--+-- License: BSD3+--+--- Description ---------------------------------------------------------------+--+-- 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(..), + + -- * HOAS -> de Bruijn conversion+ convertAcc, convertClosedExp,++ -- * Smart constructors for literals+ constant,++ -- * Smart constructors for constants+ mkMinBound, mkMaxBound, mkPi,++ -- * Smart constructors for primitive functions+ mkAdd, mkSub, mkMul, mkNeg, mkAbs, mkSig, mkQuot, mkRem, mkIDiv, mkMod,+ mkBAnd, mkBOr, mkBXor, mkBNot, mkFDiv, mkRecip, mkLt, mkGt, mkLtEq, mkGtEq,+ mkEq, mkNEq, mkMax, mkMin, mkLAnd, mkLOr, mkLNot,++) where++-- standard library+import Data.Maybe+import Data.Typeable++-- friends+import Data.Array.Accelerate.Type+{-+import Data.Array.Accelerate.Array.Representation hiding (+ Array(..), Scalar, Vector)+-}+import Data.Array.Accelerate.Array.Sugar+import Data.Array.Accelerate.AST hiding (OpenAcc(..), Acc, OpenExp(..), Exp)+import qualified Data.Array.Accelerate.AST as AST+import Data.Array.Accelerate.Pretty ()+++-- Monadic array computations+-- --------------------------++data Acc a where++ 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)+ => slix {- dummy to fix the type variable -}+ -> e {- dummy to fix the type variable -}+ -> Exp slix+ -> Acc (Array (Slice slix) e)+ -> Acc (Array (SliceDim slix) e)+ Index :: (SliceIx slix, Elem e)+ => slix {- dummy to fix the type variable -}+ -> e {- dummy to fix the type variable -}+ -> 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)+ Filter :: Elem e+ => (Exp e -> Exp Bool) + -> Acc (Vector e)+ -> Acc (Vector e)+ Fold :: Elem e+ => (Exp e -> Exp e -> Exp e)+ -> Exp e+ -> Acc (Array dim e)+ -> Acc (Scalar e)+ Scan :: 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)+++-- |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 (ArraysRepr a)+convertOpenAcc _ (Use array) = AST.Use (fromArray 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 slixType eType ix acc)+ = mkReplicate slixType eType + (convertExp alyt ix) (convertOpenAcc alyt acc)+convertOpenAcc alyt (Index slixType eType acc ix)+ = mkIndex slixType eType (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 (Filter p acc) + = AST.Filter (convertFun1 alyt p) (convertOpenAcc alyt acc)+convertOpenAcc alyt (Fold f e acc) + = AST.Fold (convertFun2 alyt f) (convertExp alyt e) (convertOpenAcc alyt acc)+convertOpenAcc alyt (Scan f e acc) + = AST.Scan (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)++-- |Convert a closed array expression+--+convertAcc :: Acc a -> AST.Acc (ArraysRepr 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'.+--+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+ Pair :: (Elem s, Elem t) + => Exp s -> Exp t -> Exp (s, t)+ Fst :: (Elem s, Elem t) + => Exp (s, t) -> Exp s+ Snd :: (Elem s, Elem t) + => Exp (s, t) -> Exp t+ 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 :: 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 + = error "Data.Array.Accelerate.Smart.prjIdx: internal error"++-- |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 (ElemRepr t)+convertOpenExp lyt alyt = cvt+ where+ cvt :: forall t'. Exp t' -> AST.OpenExp env aenv (ElemRepr t')+ cvt (Tag i) = AST.Var (prjIdx i lyt)+ cvt (Const v) = AST.Const v+ cvt (Pair (e1::Exp t1) + (e2::Exp t2)) = AST.Pair (undefined::t1)+ (undefined::t2)+ (cvt e1) (cvt e2)+ cvt (Fst (e::Exp (t', t2))) + = AST.Fst (undefined::t') (undefined::t2) (cvt e)+ cvt (Snd (e::Exp (t1, t'))) + = AST.Snd (undefined::t1) (undefined::t') (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 an expression closed wrt to scalar variables+--+convertExp :: Layout aenv aenv -- array environment+ -> Exp t -- expression to be converted+ -> AST.Exp aenv (ElemRepr t)+convertExp alyt = convertOpenExp EmptyLayout alyt++-- |Convert a closed expression+--+convertClosedExp :: Exp t -> AST.Exp () (ElemRepr 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 (ElemRepr a -> ElemRepr 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 (ElemRepr a -> ElemRepr b -> ElemRepr 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)++instance Show (Exp t) where+ show e + = show (convertExp EmptyLayout e :: AST.Exp () (ElemRepr t))+++-- |Smart constructors to construct representation AST forms+-- ---------------------------------------------------------++mkIndex :: forall slix e aenv. (SliceIx slix, Elem e) + => slix {- dummy to fix the type variable -}+ -> e {- dummy to fix the type variable -}+ -> AST.OpenAcc aenv (ArraysRepr (Array (SliceDim slix) e))+ -> AST.Exp aenv (ElemRepr slix)+ -> AST.OpenAcc aenv (ArraysRepr (Array (Slice slix) e))+mkIndex slix _ arr e + = AST.Index (convertSliceIndex slix (sliceIndex slix)) arr e++mkReplicate :: forall slix e aenv. (SliceIx slix, Elem e) + => slix {- dummy to fix the type variable -}+ -> e {- dummy to fix the type variable -}+ -> AST.Exp aenv (ElemRepr slix)+ -> AST.OpenAcc aenv (ArraysRepr (Array (Slice slix) e))+ -> AST.OpenAcc aenv (ArraysRepr (Array (SliceDim slix) e))+mkReplicate slix _ e arr+ = AST.Replicate (convertSliceIndex slix (sliceIndex slix)) e arr+++-- |Smart constructors to construct HOAS AST expressions+-- -----------------------------------------------------++-- |Smart constructor for literals+-- -++constant :: Elem t => t -> Exp t+constant = Const++-- |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)++-- |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` (x `Pair` y)++mkSub :: (Elem t, IsNum t) => Exp t -> Exp t -> Exp t+mkSub x y = PrimSub numType `PrimApp` (x `Pair` y)++mkMul :: (Elem t, IsNum t) => Exp t -> Exp t -> Exp t+mkMul x y = PrimMul numType `PrimApp` (x `Pair` 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` (x `Pair` y)++mkRem :: (Elem t, IsIntegral t) => Exp t -> Exp t -> Exp t+mkRem x y = PrimRem integralType `PrimApp` (x `Pair` y)++mkIDiv :: (Elem t, IsIntegral t) => Exp t -> Exp t -> Exp t+mkIDiv x y = PrimIDiv integralType `PrimApp` (x `Pair` y)++mkMod :: (Elem t, IsIntegral t) => Exp t -> Exp t -> Exp t+mkMod x y = PrimMod integralType `PrimApp` (x `Pair` y)++mkBAnd :: (Elem t, IsIntegral t) => Exp t -> Exp t -> Exp t+mkBAnd x y = PrimBAnd integralType `PrimApp` (x `Pair` y)++mkBOr :: (Elem t, IsIntegral t) => Exp t -> Exp t -> Exp t+mkBOr x y = PrimBOr integralType `PrimApp` (x `Pair` y)++mkBXor :: (Elem t, IsIntegral t) => Exp t -> Exp t -> Exp t+mkBXor x y = PrimBXor integralType `PrimApp` (x `Pair` y)++mkBNot :: (Elem t, IsIntegral t) => Exp t -> Exp t+mkBNot x = PrimBNot integralType `PrimApp` x+ -- FIXME: add shifts++-- Operators from Fractional, Floating, RealFrac & RealFloat++mkFDiv :: (Elem t, IsFloating t) => Exp t -> Exp t -> Exp t+mkFDiv x y = PrimFDiv floatingType `PrimApp` (x `Pair` y)++mkRecip :: (Elem t, IsFloating t) => Exp t -> Exp t+mkRecip x = PrimRecip floatingType `PrimApp` x+ -- 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` (x `Pair` y)++mkGt :: (Elem t, IsScalar t) => Exp t -> Exp t -> Exp Bool+mkGt x y = PrimGt scalarType `PrimApp` (x `Pair` y)++mkLtEq :: (Elem t, IsScalar t) => Exp t -> Exp t -> Exp Bool+mkLtEq x y = PrimLtEq scalarType `PrimApp` (x `Pair` y)++mkGtEq :: (Elem t, IsScalar t) => Exp t -> Exp t -> Exp Bool+mkGtEq x y = PrimGtEq scalarType `PrimApp` (x `Pair` y)++mkEq :: (Elem t, IsScalar t) => Exp t -> Exp t -> Exp Bool+mkEq x y = PrimEq scalarType `PrimApp` (x `Pair` y)++mkNEq :: (Elem t, IsScalar t) => Exp t -> Exp t -> Exp Bool+mkNEq x y = PrimLt scalarType `PrimApp` (x `Pair` y)++mkMax :: (Elem t, IsScalar t) => Exp t -> Exp t -> Exp t+mkMax x y = PrimMax scalarType `PrimApp` (x `Pair` y)++mkMin :: (Elem t, IsScalar t) => Exp t -> Exp t -> Exp t+mkMin x y = PrimMin scalarType `PrimApp` (x `Pair` y)++-- Logical operators++mkLAnd :: Exp Bool -> Exp Bool -> Exp Bool+mkLAnd x y = PrimLAnd `PrimApp` (x `Pair` y)++mkLOr :: Exp Bool -> Exp Bool -> Exp Bool+mkLOr x y = PrimLOr `PrimApp` (x `Pair` y)++mkLNot :: Exp Bool -> Exp Bool+mkLNot x = PrimLNot `PrimApp` x++-- FIXME: Character conversions++-- FIXME: Numeric conversions
+ Data/Array/Accelerate/Type.hs view
@@ -0,0 +1,595 @@+{-# LANGUAGE GADTs, TypeFamilies, FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+ -- nothing undecidable here; this is for `instance IsScalar a => IsTuple a'++-- |Embedded array processing language: data types+--+-- Copyright (c) [2008..2009] Manuel M T Chakravarty, Gabriele Keller, Sean Lee+--+-- License: BSD3+--+--- Description ---------------------------------------------------------------+--+-- Scalar types supported in array computations+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Integral types: Int, Int8, Int16, Int32, Int64, Word, Word8, Word16, Word32,+-- Word64, CShort, CUShort, CInt, CUInt, CLong, CULong, CLLong, CULLong+--+-- Floating types: Float, Double, CFloat, CDouble+--+-- Non-numeric types: Bool, Char, CChar, CSChar, CUChar+--+-- `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,+ module Data.Word,+ module Foreign.C.Types,+ module Data.Array.Accelerate.Type+) where++-- standard libraries+import Data.Bits+import Data.Int+import Data.Typeable+import Data.Word+import Foreign.C.Types (+ CChar, CSChar, CUChar, CShort, CUShort, CInt, CUInt, CLong, CULong,+ CLLong, CULLong, CFloat, CDouble)+ -- in the future, CHalf+++-- |Scalar types+-- -------------++-- |Reified dictionaries+-- -++data IntegralDict a where+ IntegralDict :: ( Bounded a, Enum a, Eq a, Ord a, Show a+ , Bits a, Integral a, Num a, Real a) + => IntegralDict a++data FloatingDict a where+ FloatingDict :: ( Enum a, Eq a, Ord a, Show a+ , Floating a, Fractional a, Num a, Real a, RealFrac a+ , RealFloat a)+ => FloatingDict a++data NonNumDict a where+ NonNumDict :: (Bounded a, Enum a, Eq a, Ord a, Show a) => NonNumDict a++-- |Scalar type representation+-- -++-- |Integral types supported in array computations.+--+data IntegralType a where+ TypeInt :: IntegralDict Int -> IntegralType Int+ TypeInt8 :: IntegralDict Int8 -> IntegralType Int8+ TypeInt16 :: IntegralDict Int16 -> IntegralType Int16+ TypeInt32 :: IntegralDict Int32 -> IntegralType Int32+ TypeInt64 :: IntegralDict Int64 -> IntegralType Int64+ TypeWord :: IntegralDict Word -> IntegralType Word+ TypeWord8 :: IntegralDict Word8 -> IntegralType Word8+ TypeWord16 :: IntegralDict Word16 -> IntegralType Word16+ TypeWord32 :: IntegralDict Word32 -> IntegralType Word32+ TypeWord64 :: IntegralDict Word64 -> IntegralType Word64+ TypeCShort :: IntegralDict CShort -> IntegralType CShort+ TypeCUShort :: IntegralDict CUShort -> IntegralType CUShort+ TypeCInt :: IntegralDict CInt -> IntegralType CInt+ TypeCUInt :: IntegralDict CUInt -> IntegralType CUInt+ TypeCLong :: IntegralDict CLong -> IntegralType CLong+ TypeCULong :: IntegralDict CULong -> IntegralType CULong+ TypeCLLong :: IntegralDict CLLong -> IntegralType CLLong+ TypeCULLong :: IntegralDict CULLong -> IntegralType CULLong++-- |Floating-point types supported in array computations.+--+data FloatingType a where+ TypeFloat :: FloatingDict Float -> FloatingType Float+ TypeDouble :: FloatingDict Double -> FloatingType Double+ TypeCFloat :: FloatingDict CFloat -> FloatingType CFloat+ TypeCDouble :: FloatingDict CDouble -> FloatingType CDouble++-- |Non-numeric types supported in array computations.+--+data NonNumType a where+ TypeBool :: NonNumDict Bool -> NonNumType Bool -- ^marshaled to CInt+ TypeChar :: NonNumDict Char -> NonNumType Char+ TypeCChar :: NonNumDict CChar -> NonNumType CChar+ TypeCSChar :: NonNumDict CSChar -> NonNumType CSChar+ TypeCUChar :: NonNumDict CUChar -> NonNumType CUChar++-- |Numeric element types implement Num & Real+--+data NumType a where+ IntegralNumType :: IntegralType a -> NumType a+ FloatingNumType :: FloatingType a -> NumType a++-- |Bounded element types implement Bounded+--+data BoundedType a where+ IntegralBoundedType :: IntegralType a -> BoundedType a+ NonNumBoundedType :: NonNumType a -> BoundedType a++-- |All scalar element types implement Eq, Ord & Enum+--+data ScalarType a where+ NumScalarType :: NumType a -> ScalarType a+ NonNumScalarType :: NonNumType a -> ScalarType a++-- |Showing type names+-- -++instance Show (IntegralType a) where+ show (TypeInt _) = "Int"+ show (TypeInt8 _) = "Int8"+ show (TypeInt16 _) = "Int16"+ show (TypeInt32 _) = "Int32"+ show (TypeInt64 _) = "Int64"+ show (TypeWord _) = "Word"+ show (TypeWord8 _) = "Word8"+ show (TypeWord16 _) = "Word16"+ show (TypeWord32 _) = "Word32"+ show (TypeWord64 _) = "Word64"+ show (TypeCShort _) = "CShort"+ show (TypeCUShort _) = "CUShort"+ show (TypeCInt _) = "CInt"+ show (TypeCUInt _) = "CUInt"+ show (TypeCLong _) = "CLong"+ show (TypeCULong _) = "CULong"+ show (TypeCLLong _) = "CLLong"+ show (TypeCULLong _) = "CULLong"++instance Show (FloatingType a) where+ show (TypeFloat _) = "Float"+ show (TypeDouble _) = "Double"+ show (TypeCFloat _) = "CFloat"+ show (TypeCDouble _) = "CDouble"++instance Show (NonNumType a) where+ show (TypeBool _) = "Bool"+ show (TypeChar _) = "Char"+ show (TypeCChar _) = "CChar"+ show (TypeCSChar _) = "CSChar"+ show (TypeCUChar _) = "CUChar"++instance Show (NumType a) where+ show (IntegralNumType ty) = show ty+ show (FloatingNumType ty) = show ty++instance Show (BoundedType a) where+ show (IntegralBoundedType ty) = show ty+ show (NonNumBoundedType ty) = show ty++instance Show (ScalarType a) where+ show (NumScalarType ty) = show ty+ show (NonNumScalarType ty) = show ty++-- |Querying scalar type representations+-- -++-- Integral types+--+class (IsScalar a, IsNum a, IsBounded a) => IsIntegral a where+ integralType :: IntegralType a++instance IsIntegral Int where+ integralType = TypeInt IntegralDict++instance IsIntegral Int8 where+ integralType = TypeInt8 IntegralDict++instance IsIntegral Int16 where+ integralType = TypeInt16 IntegralDict++instance IsIntegral Int32 where+ integralType = TypeInt32 IntegralDict++instance IsIntegral Int64 where+ integralType = TypeInt64 IntegralDict++instance IsIntegral Word where+ integralType = TypeWord IntegralDict++instance IsIntegral Word8 where+ integralType = TypeWord8 IntegralDict++instance IsIntegral Word16 where+ integralType = TypeWord16 IntegralDict++instance IsIntegral Word32 where+ integralType = TypeWord32 IntegralDict++instance IsIntegral Word64 where+ integralType = TypeWord64 IntegralDict++instance IsIntegral CShort where+ integralType = TypeCShort IntegralDict++instance IsIntegral CUShort where+ integralType = TypeCUShort IntegralDict++instance IsIntegral CInt where+ integralType = TypeCInt IntegralDict++instance IsIntegral CUInt where+ integralType = TypeCUInt IntegralDict++instance IsIntegral CLong where+ integralType = TypeCLong IntegralDict++instance IsIntegral CULong where+ integralType = TypeCULong IntegralDict++instance IsIntegral CLLong where+ integralType = TypeCLLong IntegralDict++instance IsIntegral CULLong where+ integralType = TypeCULLong IntegralDict++-- Floating types+--+class (Floating a, IsScalar a, IsNum a) => IsFloating a where+ floatingType :: FloatingType a++instance IsFloating Float where+ floatingType = TypeFloat FloatingDict++instance IsFloating Double where+ floatingType = TypeDouble FloatingDict++instance IsFloating CFloat where+ floatingType = TypeCFloat FloatingDict++instance IsFloating CDouble where+ floatingType = TypeCDouble FloatingDict++-- Non-numeric types+--+class IsNonNum a where+ nonNumType :: NonNumType a++instance IsNonNum Bool where+ nonNumType = TypeBool NonNumDict++instance IsNonNum Char where+ nonNumType = TypeChar NonNumDict++instance IsNonNum CChar where+ nonNumType = TypeCChar NonNumDict++instance IsNonNum CSChar where+ nonNumType = TypeCSChar NonNumDict++instance IsNonNum CUChar where+ nonNumType = TypeCUChar NonNumDict++-- Numeric types+--+class (Num a, IsScalar a) => IsNum a where+ numType :: NumType a++instance IsNum Int where+ numType = IntegralNumType integralType++instance IsNum Int8 where+ numType = IntegralNumType integralType++instance IsNum Int16 where+ numType = IntegralNumType integralType++instance IsNum Int32 where+ numType = IntegralNumType integralType++instance IsNum Int64 where+ numType = IntegralNumType integralType++instance IsNum Word where+ numType = IntegralNumType integralType++instance IsNum Word8 where+ numType = IntegralNumType integralType++instance IsNum Word16 where+ numType = IntegralNumType integralType++instance IsNum Word32 where+ numType = IntegralNumType integralType++instance IsNum Word64 where+ numType = IntegralNumType integralType++instance IsNum CShort where+ numType = IntegralNumType integralType++instance IsNum CUShort where+ numType = IntegralNumType integralType++instance IsNum CInt where+ numType = IntegralNumType integralType++instance IsNum CUInt where+ numType = IntegralNumType integralType++instance IsNum CLong where+ numType = IntegralNumType integralType++instance IsNum CULong where+ numType = IntegralNumType integralType++instance IsNum CLLong where+ numType = IntegralNumType integralType++instance IsNum CULLong where+ numType = IntegralNumType integralType++instance IsNum Float where+ numType = FloatingNumType floatingType++instance IsNum Double where+ numType = FloatingNumType floatingType++instance IsNum CFloat where+ numType = FloatingNumType floatingType++instance IsNum CDouble where+ numType = FloatingNumType floatingType++-- Bounded types+--+class IsBounded a where+ boundedType :: BoundedType a++instance IsBounded Int where+ boundedType = IntegralBoundedType integralType++instance IsBounded Int8 where+ boundedType = IntegralBoundedType integralType++instance IsBounded Int16 where+ boundedType = IntegralBoundedType integralType++instance IsBounded Int32 where+ boundedType = IntegralBoundedType integralType++instance IsBounded Int64 where+ boundedType = IntegralBoundedType integralType++instance IsBounded Word where+ boundedType = IntegralBoundedType integralType++instance IsBounded Word8 where+ boundedType = IntegralBoundedType integralType++instance IsBounded Word16 where+ boundedType = IntegralBoundedType integralType++instance IsBounded Word32 where+ boundedType = IntegralBoundedType integralType++instance IsBounded Word64 where+ boundedType = IntegralBoundedType integralType++instance IsBounded CShort where+ boundedType = IntegralBoundedType integralType++instance IsBounded CUShort where+ boundedType = IntegralBoundedType integralType++instance IsBounded CInt where+ boundedType = IntegralBoundedType integralType++instance IsBounded CUInt where+ boundedType = IntegralBoundedType integralType++instance IsBounded CLong where+ boundedType = IntegralBoundedType integralType++instance IsBounded CULong where+ boundedType = IntegralBoundedType integralType++instance IsBounded CLLong where+ boundedType = IntegralBoundedType integralType++instance IsBounded CULLong where+ boundedType = IntegralBoundedType integralType++instance IsBounded Bool where+ boundedType = NonNumBoundedType nonNumType++instance IsBounded Char where+ boundedType = NonNumBoundedType nonNumType++instance IsBounded CChar where+ boundedType = NonNumBoundedType nonNumType++instance IsBounded CSChar where+ boundedType = NonNumBoundedType nonNumType++instance IsBounded CUChar where+ boundedType = NonNumBoundedType nonNumType++-- All scalar type+--+class Typeable a => IsScalar a where+ scalarType :: ScalarType a++instance IsScalar Int where+ scalarType = NumScalarType numType++instance IsScalar Int8 where+ scalarType = NumScalarType numType++instance IsScalar Int16 where+ scalarType = NumScalarType numType++instance IsScalar Int32 where+ scalarType = NumScalarType numType++instance IsScalar Int64 where+ scalarType = NumScalarType numType++instance IsScalar Word where+ scalarType = NumScalarType numType++instance IsScalar Word8 where+ scalarType = NumScalarType numType++instance IsScalar Word16 where+ scalarType = NumScalarType numType++instance IsScalar Word32 where+ scalarType = NumScalarType numType++instance IsScalar Word64 where+ scalarType = NumScalarType numType++instance IsScalar CShort where+ scalarType = NumScalarType numType++instance IsScalar CUShort where+ scalarType = NumScalarType numType++instance IsScalar CInt where+ scalarType = NumScalarType numType++instance IsScalar CUInt where+ scalarType = NumScalarType numType++instance IsScalar CLong where+ scalarType = NumScalarType numType++instance IsScalar CULong where+ scalarType = NumScalarType numType++instance IsScalar CLLong where+ scalarType = NumScalarType numType++instance IsScalar CULLong where+ scalarType = NumScalarType numType++instance IsScalar Float where+ scalarType = NumScalarType numType++instance IsScalar Double where+ scalarType = NumScalarType numType++instance IsScalar CFloat where+ scalarType = NumScalarType numType++instance IsScalar CDouble where+ scalarType = NumScalarType numType++instance IsScalar Bool where+ scalarType = NonNumScalarType nonNumType++instance IsScalar Char where+ scalarType = NonNumScalarType nonNumType++instance IsScalar CChar where+ scalarType = NonNumScalarType nonNumType++instance IsScalar CSChar where+ scalarType = NonNumScalarType nonNumType++instance IsScalar CUChar where+ scalarType = NonNumScalarType nonNumType++-- |Extract reified dictionaries+-- -++integralDict :: IntegralType a -> IntegralDict a+integralDict (TypeInt dict) = dict+integralDict (TypeInt8 dict) = dict+integralDict (TypeInt16 dict) = dict+integralDict (TypeInt32 dict) = dict+integralDict (TypeInt64 dict) = dict+integralDict (TypeWord dict) = dict+integralDict (TypeWord8 dict) = dict+integralDict (TypeWord16 dict) = dict+integralDict (TypeWord32 dict) = dict+integralDict (TypeWord64 dict) = dict+integralDict (TypeCShort dict) = dict+integralDict (TypeCUShort dict) = dict+integralDict (TypeCInt dict) = dict+integralDict (TypeCUInt dict) = dict+integralDict (TypeCLong dict) = dict+integralDict (TypeCULong dict) = dict+integralDict (TypeCLLong dict) = dict+integralDict (TypeCULLong dict) = dict++floatingDict :: FloatingType a -> FloatingDict a+floatingDict (TypeFloat dict) = dict+floatingDict (TypeDouble dict) = dict+floatingDict (TypeCFloat dict) = dict+floatingDict (TypeCDouble dict) = dict++nonNumDict :: NonNumType a -> NonNumDict a+nonNumDict (TypeBool dict) = dict+nonNumDict (TypeChar dict) = dict+nonNumDict (TypeCChar dict) = dict+nonNumDict (TypeCSChar dict) = dict+nonNumDict (TypeCUChar dict) = dict++{-+-- |Vector GPU data types+-- ----------------------++data CChar1 = CChar1 CChar+data CChar2 = CChar2 CChar CChar+data CChar3 = CChar3 CChar CChar CChar+data CChar4 = CChar4 CChar CChar CChar CChar+data CSChar1 = CSChar1 CSChar+data CSChar2 = CSChar2 CSChar CSChar+data CSChar3 = CSChar3 CSChar CSChar CSChar+data CSChar4 = CSChar4 CSChar CSChar CSChar CSChar+data CUChar1 = CUChar1 CUChar+data CUChar2 = CUChar2 CUChar CUChar+data CUChar3 = CUChar3 CUChar CUChar CUChar+data CUChar4 = CUChar4 CUChar CUChar CUChar CUChar+data CShort1 = CShort1 CShort+data CShort2 = CShort2 CShort CShort+data CShort3 = CShort3 CShort CShort CShort+data CShort4 = CShort4 CShort CShort CShort CShort+data CUShort1 = CUShort1 CUShort+data CUShort2 = CUShort2 CUShort CUShort+data CUShort3 = CUShort3 CUShort CUShort CUShort+data CUShort4 = CUShort4 CUShort CUShort CUShort CUShort+data CInt1 = CInt1 CInt+data CInt2 = CInt2 CInt CInt+data CInt3 = CInt3 CInt CInt CInt+data CInt4 = CInt4 CInt CInt CInt CInt+data CUInt1 = CUInt1 CUInt+data CUInt2 = CUInt2 CUInt CUInt+data CUInt3 = CUInt3 CUInt CUInt CUInt+data CUInt4 = CUInt4 CUInt CUInt CUInt CUInt+data CLong1 = CLong1 CLong+data CLong2 = CLong2 CLong CLong+data CLong3 = CLong3 CLong CLong CLong+data CLong4 = CLong4 CLong CLong CLong CLong+data CULong1 = CULong1 CULong+data CULong2 = CULong2 CULong CULong+data CULong3 = CULong3 CULong CULong CULong+data CULong4 = CULong4 CULong CULong CULong CULong+data CLLong1 = CLLong1 CLLong+data CLLong2 = CLLong2 CLLong CLLong+data CLLong3 = CLLong3 CLLong CLLong CLLong+data CLLong4 = CLLong4 CLLong CLLong CLLong CLLong+data CULLong1 = CULLong1 CULLong+data CULLong2 = CULLong2 CULLong CULLong+data CULLong3 = CULLong3 CULLong CULLong CULLong+data CULLong4 = CULLong4 CULLong CULLong CULLong CULLong+data CFloat1 = CFloat1 CFloat+data CFloat2 = CFloat2 CFloat CFloat+data CFloat3 = CFloat3 CFloat CFloat CFloat+data CFloat4 = CFloat4 CFloat CFloat CFloat CFloat+data CDouble1 = CDouble1 CDouble+data CDouble2 = CDouble2 CDouble CDouble+data CDouble3 = CDouble3 CDouble CDouble CDouble+data CDouble4 = CDouble4 CDouble CDouble CDouble CDouble+-- in the future, vector types for CHalf+ -}
+ INSTALL view
@@ -0,0 +1,19 @@+Requirements: Glasgow Haskell Compiler (GHC), 6.10.1 or later++Standard Cabal installation:++ % runhaskell Setup.hs configure --prefix=INSTALLPATH+ % runhaskell Setup.hs build+ % runhaskell Setup.hs install+ OR+ runhaskell Setup.hs install -- user++Then, to use the library, pass the flag "-package accelerate" to GHC.++WARNING: This is at best an *alpha* release. The library isn't actually useful+ for anything at this stage, except for people interested in writing+ a backend. The API is also guaranteed to going to change a few + more times before settling down. You have been warned.+ +Direct questions at Manuel M T Chakravarty <chak@cse.unsw.edu.au>+(aka ChilliX on #haskell and friends).
+ LICENSE view
@@ -0,0 +1,24 @@+Copyright (c) [2007..2009] Manuel M T Chakravarty, Gabriele Keller & Sean Lee,+University of New South Wales. All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:+ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+ * Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.+ * Neither the name of the University of New South Wales nor the+ names of its contributors may be used to endorse or promote products+ derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS ''AS IS'' AND ANY+EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL COPYRIGHT HOLDERS BE LIABLE FOR ANY+DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND+ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,4 @@+#! /usr/bin/env runhaskell++import Distribution.Simple+main = defaultMain
+ accelerate.cabal view
@@ -0,0 +1,50 @@+Name: accelerate+Version: 0.4.0+Cabal-version: >= 1.6+Tested-with: GHC >= 6.10.1++Synopsis: An embedded language for accelerated array processing+Description: This library defines an embedded language for+ regular, multi-dimensional array computations with+ multiple backends to facilitate high-performance+ implementations. Currently, the only backend is an+ interpreter that serves as a reference implementation + of the intended semantics of the language.+License: BSD3+License-file: LICENSE+Author: Manuel M T Chakravarty, Gabriele Keller, Sean Lee+Maintainer: Manuel M T Chakravarty <chak@cse.unsw.edu.au>++Category: Compilers/Interpreters, Concurrency, Data+Stability: Experimental++Build-type: Simple+Build-depends: array, + base == 3.*, + ghc-prim, + haskell98, + pretty+Exposed-modules: Data.Array.Accelerate+ Data.Array.Accelerate.Interpreter+Other-modules: Data.Array.Accelerate.Array.Data+ Data.Array.Accelerate.Array.Delayed+ Data.Array.Accelerate.Array.Representation+ Data.Array.Accelerate.Array.Sugar+ Data.Array.Accelerate.AST+ Data.Array.Accelerate.Debug+ Data.Array.Accelerate.Language+ Data.Array.Accelerate.Pretty+ Data.Array.Accelerate.Smart+ Data.Array.Accelerate.Type+Extra-source-files: INSTALL+ examples/simple/DotP.hs+ examples/simple/Main.hs+ examples/simple/Makefile+ examples/simple/SAXPY.hs+ examples/simple/Time.hs++Ghc-options: -Wall -fno-warn-orphans -fno-warn-name-shadowing+Extensions: FlexibleContexts, FlexibleInstances, + ExistentialQuantification, GADTs, TypeFamilies, + ScopedTypeVariables, DeriveDataTypeable,+ BangPatterns, PatternGuards, TypeOperators, RankNTypes
+ examples/simple/DotP.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE ParallelListComp #-}++module DotP (dotp, dotp_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++dotp :: Vector Float -> Vector Float -> Acc (Scalar Float)+dotp xs ys + = let+ xs' = use xs+ ys' = use ys+ in+ fold (+) 0 (zipWith (*) xs' ys')++dotp_ref :: UArray Int Float + -> UArray Int Float + -> UArray () Float+dotp_ref xs ys + = listArray ((), ()) $ [sum [x * y | x <- elems xs | y <- elems ys]]
+ examples/simple/Main.hs view
@@ -0,0 +1,221 @@+{-# LANGUAGE FlexibleContexts, ParallelListComp #-}++module Main where++import Control.Exception+import Data.Array.Unboxed+import Data.Array.IArray+import System.Random++import qualified Data.Array.Accelerate as Acc+import qualified Data.Array.Accelerate.Interpreter as Interp++import Time+import SAXPY+import DotP+++-- Auxilliary array functions+-- --------------------------++-- To ensure that a singleton unboxed array is fully evaluated+-- +evaluateUScalar :: (IArray UArray e) => UArray () e -> IO ()+evaluateUScalar uarr = evaluate (uarr!()) >> return ()++-- To ensure that a singleton unboxed array is fully evaluated+-- +evaluateScalar :: Acc.Scalar e -> IO ()+evaluateScalar arr = evaluate (arr `Acc.indexArray` ()) >> return ()++-- To ensure that an unboxed array is fully evaluated, just force one element+-- +evaluateUVector :: (IArray UArray e) => UArray Int e -> IO ()+evaluateUVector uarr = evaluate (uarr!0) >> return ()++-- To ensure that an unboxed array is fully evaluated, just force one element+-- +evaluateVector :: Acc.Vector e -> IO ()+evaluateVector arr = evaluate (arr `Acc.indexArray` 0) >> return ()++randomUVector :: (Num e, Random e, IArray UArray e) => Int -> IO (UArray Int e)+randomUVector n+ = do+ rg <- newStdGen+ let -- The std random function is too slow to generate really big vectors+ -- with. Instead, we generate a short random vector and repeat that.+ randvec = take k (randomRs (-100, 100) rg)+ vec = listArray (0, n - 1) + [randvec !! (i `mod` k) | i <- [0..n - 1]]+ evaluateUVector vec+ return vec+ where+ k = 1000++convertUScalar :: (IArray UArray e, Acc.Elem e) + => UArray () e -> IO (Acc.Scalar e)+convertUScalar uarr+ = do+ let arr = Acc.fromIArray uarr+ evaluateScalar arr+ return arr++convertUVector :: (IArray UArray e, Acc.Elem e) + => UArray Int e -> IO (Acc.Vector e)+convertUVector uarr+ = do+ let arr = Acc.fromIArray uarr+ evaluateVector arr+ return arr++validate :: (Eq e, IArray UArray e, Ix ix) + => UArray ix e -> UArray ix e -> IO ()+validate arr_ref arr | arr_ref == arr = putStrLn "Valid."+ | otherwise = putStrLn "INVALID!"++validateFloats :: Ix ix+ => UArray ix Float -> UArray ix Float -> IO ()+validateFloats arr_ref arr | arr_ref `similar` arr = putStrLn "Valid."+ | otherwise = putStrLn "INVALID!"+ where+ similar arr1 arr2 = all (< epsilon) [abs ((x - y) / x) | x <- elems arr1 + | y <- elems arr2]+ epsilon = 0.0001+++-- Timing+-- ------++timeUScalar :: IArray UArray e => (() -> UArray () e) -> IO (UArray () e)+{-# NOINLINE timeUScalar #-}+timeUScalar testee + = do+ (r, time1) <- oneRun testee+ (r, time2) <- oneRun testee+ (r, time3) <- oneRun testee+ putStrLn $ showMinAvgMax milliseconds [time1, time2, time3] +++ " (wall - cpu min/avg/max in ms)"+ return r+ where+ oneRun testee = do+ start <- getTime+ let r = testee ()+ evaluateUScalar r+ end <- getTime+ return (r, end `minus` start)++timeScalar :: (IArray UArray e, Acc.Elem e)+ => (() -> Acc.Scalar e) -> IO (UArray () e)+{-# NOINLINE timeScalar #-}+timeScalar testee + = do+ (r, time1) <- oneRun testee+ (r, time2) <- oneRun testee+ (r, time3) <- oneRun testee+ putStrLn $ showMinAvgMax milliseconds [time1, time2, time3] +++ " (wall - cpu min/avg/max in ms)"+ return $ Acc.toIArray r+ where+ oneRun testee = do+ start <- getTime+ let r = testee ()+ evaluateScalar r+ end <- getTime+ return (r, end `minus` start)++timeUVector :: IArray UArray e => (() -> UArray Int e) -> IO (UArray Int e)+{-# NOINLINE timeUVector #-}+timeUVector testee + = do+ (r, time1) <- oneRun testee+ (r, time2) <- oneRun testee+ (r, time3) <- oneRun testee+ putStrLn $ showMinAvgMax milliseconds [time1, time2, time3] +++ " (wall - cpu min/avg/max in ms)"+ return r+-- where+{-# NOINLINE oneRun #-}+oneRun testee = do+ start <- getTime+ let r = testee ()+ evaluateUVector r+ end <- getTime+ return (r, end `minus` start)++timeVector :: (IArray UArray e, Acc.Elem e)+ => (() -> Acc.Vector e) -> IO (UArray Int e)+{-# NOINLINE timeVector #-}+timeVector testee + = do+ (r, time1) <- oneRun testee+ (r, time2) <- oneRun testee+ (r, time3) <- oneRun testee+ putStrLn $ showMinAvgMax milliseconds [time1, time2, time3] +++ " (wall - cpu min/avg/max in ms)"+ return $ Acc.toIArray r+ where+ oneRun testee = do+ start <- getTime+ let r = testee ()+ evaluateVector r+ end <- getTime+ return (r, end `minus` start)+++-- Tests+-- -----++test_saxpy :: Int -> IO ()+test_saxpy n+ = do+ putStrLn "== SAXPY"+ putStrLn $ "Generating data (n = " ++ show n ++ ")..."+ v1_ref <- randomUVector n+ v1 <- convertUVector v1_ref+ v2_ref <- randomUVector n+ v2 <- convertUVector v2_ref+ putStrLn "Running reference code..."+ ref_result <- timeUVector $ saxpy_ref' 1.5 v1_ref v2_ref+ putStrLn "Running Accelerate code..."+ result <- timeVector $ saxpy_interp 1.5 v1 v2+ putStrLn "Validating result..."+ validateFloats ref_result result+ where+ -- idiom with NOINLINE and extra parameter needed to prevent optimisations+ -- from sharing results over multiple runs+ {-# NOINLINE saxpy_ref' #-}+ saxpy_ref' a arr1 arr2 () = saxpy_ref a arr1 arr2+ {-# NOINLINE saxpy_interp #-}+ saxpy_interp a arr1 arr2 () = Interp.run (saxpy a arr1 arr2)++test_dotp :: Int -> IO ()+test_dotp n+ = do+ putStrLn "== Dot product"+ putStrLn $ "Generating data (n = " ++ show n ++ ")..."+ v1_ref <- randomUVector n+ v1 <- convertUVector v1_ref+ v2_ref <- randomUVector n+ v2 <- convertUVector v2_ref+ putStrLn "Running reference code..."+ ref_result <- timeUScalar $ dotp_ref' v1_ref v2_ref+ putStrLn "Running Accelerate code..."+ result <- timeScalar $ dotp_interp v1 v2+ putStrLn "Validating result..."+ validateFloats ref_result result+ where+ -- idiom with NOINLINE and extra parameter needed to prevent optimisations+ -- from sharing results over multiple runs+ {-# NOINLINE dotp_ref' #-}+ dotp_ref' arr1 arr2 () = dotp_ref arr1 arr2+ {-# NOINLINE dotp_interp #-}+ dotp_interp arr1 arr2 () = Interp.run (dotp arr1 arr2)++main :: IO ()+main+ = do+ putStrLn "Data.Array.Accelerate: simple examples"+ putStrLn "--------------------------------------"+ + test_saxpy 100000+ test_dotp 100000
+ examples/simple/Makefile view
@@ -0,0 +1,12 @@+HCFLAGS = -O -package accelerate++all:+ ghc $(HCFLAGS) -c Time.hs+ ghc $(HCFLAGS) -c SAXPY.hs+ ghc $(HCFLAGS) -c DotP.hs+ ghc $(HCFLAGS) -c Main.hs+ ghc $(HCFLAGS) -o test Main.o Time.o SAXPY.o DotP.o++clean:+ rm -f *.o *.hi time+
+ examples/simple/SAXPY.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE ParallelListComp #-}++module SAXPY (saxpy, saxpy_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++saxpy :: Float -> Vector Float -> Vector Float -> Acc (Vector Float)+saxpy alpha xs ys+ = let+ xs' = use xs+ ys' = use ys+ in + zipWith (\x y -> constant alpha * x * y) xs' ys'++saxpy_ref :: Float -> UArray Int Float -> UArray Int Float -> UArray Int Float+saxpy_ref alpha xs ys+ = listArray (bounds xs) [alpha * x * y | x <- elems xs | y <- elems ys]+
+ examples/simple/Time.hs view
@@ -0,0 +1,108 @@+-- |Auxiliary functions to time benchmarks+--+-- Copyright (c) [2007..2009] Roman Leshchinskiy, Manuel M T Chakravarty+--+-- License: BSD3+--+--- Description ---------------------------------------------------------------++module Time (+ Time,+ getTime,+ wallTime, cpuTime,+ picoseconds, milliseconds, seconds,++ minus, plus, div,+ min, max, avg,+ sum, minimum, maximum, average,+ + showTime, showMinAvgMax+) where++import System.CPUTime+import System.Time++import Prelude hiding (div, min, max, sum, minimum, maximum)+import qualified Prelude as P++infixl 6 `plus`, `minus`+infixl 7 `div`++data Time = Time { cpu_time :: Integer+ , wall_time :: Integer+ }++type TimeUnit = Integer -> Integer++picoseconds :: TimeUnit+picoseconds = id++milliseconds :: TimeUnit+milliseconds n = n `P.div` 1000000000++seconds :: TimeUnit+seconds n = n `P.div` 1000000000000++cpuTime :: TimeUnit -> Time -> Integer+cpuTime f = f . cpu_time++wallTime :: TimeUnit -> Time -> Integer+wallTime f = f . wall_time++getTime :: IO Time+getTime =+ do+ cpu <- getCPUTime+ TOD sec pico <- getClockTime+ return $ Time cpu (pico + sec * 1000000000000)++zipT :: (Integer -> Integer -> Integer) -> Time -> Time -> Time+zipT f (Time cpu1 wall1) (Time cpu2 wall2) =+ Time (f cpu1 cpu2) (f wall1 wall2)++minus :: Time -> Time -> Time+minus = zipT (-)++plus :: Time -> Time -> Time+plus = zipT (+)++div :: Time -> Int -> Time+div (Time cpu clock) n = Time (cpu `P.div` n') (clock `P.div` n')+ where+ n' = toInteger n++min :: Time -> Time -> Time+min = zipT P.min++max :: Time -> Time -> Time+max = zipT P.max++avg :: Time -> Time -> Time+avg t1 t2 = (t1 `plus` t2) `div` 2++sum :: [Time] -> Time+sum = foldr1 plus++minimum :: [Time] -> Time+minimum = foldr1 min++maximum :: [Time] -> Time+maximum = foldr1 max++average :: [Time] -> Time+average ts = sum ts `div` length ts++showTime :: TimeUnit -> Time -> String+showTime f t = show (wallTime f t) ++ "; " ++ show (cpuTime f t)+ +showMinAvgMax :: TimeUnit -> [Time] -> String+showMinAvgMax f ts = show (wallTime f min) ++ "/" ++ + show (wallTime f avg) ++ "/" +++ show (wallTime f max) ++ " - " +++ show (cpuTime f min) ++ "/" ++ + show (cpuTime f avg) ++ "/" +++ show (cpuTime f max)+ where+ min = minimum ts+ avg = average ts+ max = maximum ts