diff --git a/Data/Array/Accelerate.hs b/Data/Array/Accelerate.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate.hs @@ -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.!) diff --git a/Data/Array/Accelerate/AST.hs b/Data/Array/Accelerate/AST.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/AST.hs @@ -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) diff --git a/Data/Array/Accelerate/Array/Data.hs b/Data/Array/Accelerate/Array/Data.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/Array/Data.hs @@ -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) diff --git a/Data/Array/Accelerate/Array/Delayed.hs b/Data/Array/Accelerate/Array/Delayed.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/Array/Delayed.hs @@ -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) + + diff --git a/Data/Array/Accelerate/Array/Representation.hs b/Data/Array/Accelerate/Array/Representation.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/Array/Representation.hs @@ -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) diff --git a/Data/Array/Accelerate/Array/Sugar.hs b/Data/Array/Accelerate/Array/Sugar.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/Array/Sugar.hs @@ -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) diff --git a/Data/Array/Accelerate/Debug.hs b/Data/Array/Accelerate/Debug.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/Debug.hs @@ -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 diff --git a/Data/Array/Accelerate/Interpreter.hs b/Data/Array/Accelerate/Interpreter.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/Interpreter.hs @@ -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 diff --git a/Data/Array/Accelerate/Language.hs b/Data/Array/Accelerate/Language.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/Language.hs @@ -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 + diff --git a/Data/Array/Accelerate/Pretty.hs b/Data/Array/Accelerate/Pretty.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/Pretty.hs @@ -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 "" +{- + = 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 +-} diff --git a/Data/Array/Accelerate/Smart.hs b/Data/Array/Accelerate/Smart.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/Smart.hs @@ -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 diff --git a/Data/Array/Accelerate/Type.hs b/Data/Array/Accelerate/Type.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/Type.hs @@ -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 + -} diff --git a/INSTALL b/INSTALL new file mode 100644 --- /dev/null +++ b/INSTALL @@ -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 +(aka ChilliX on #haskell and friends). diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,4 @@ +#! /usr/bin/env runhaskell + +import Distribution.Simple +main = defaultMain diff --git a/accelerate.cabal b/accelerate.cabal new file mode 100644 --- /dev/null +++ b/accelerate.cabal @@ -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 + +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 diff --git a/examples/simple/DotP.hs b/examples/simple/DotP.hs new file mode 100644 --- /dev/null +++ b/examples/simple/DotP.hs @@ -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]] diff --git a/examples/simple/Main.hs b/examples/simple/Main.hs new file mode 100644 --- /dev/null +++ b/examples/simple/Main.hs @@ -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 diff --git a/examples/simple/Makefile b/examples/simple/Makefile new file mode 100644 --- /dev/null +++ b/examples/simple/Makefile @@ -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 + diff --git a/examples/simple/SAXPY.hs b/examples/simple/SAXPY.hs new file mode 100644 --- /dev/null +++ b/examples/simple/SAXPY.hs @@ -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] + diff --git a/examples/simple/Time.hs b/examples/simple/Time.hs new file mode 100644 --- /dev/null +++ b/examples/simple/Time.hs @@ -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