diff --git a/Data/Array/Accelerate.hs b/Data/Array/Accelerate.hs --- a/Data/Array/Accelerate.hs +++ b/Data/Array/Accelerate.hs @@ -9,28 +9,37 @@ -- Portability : non-portable (GHC extensions) -- -- This module defines an embedded language of array computations for --- high-performance computing. Computations on multi-dimensional, regular +-- high-performance computing. Computations on multi-dimensional, regular -- arrays are expressed in the form of parameterised collective operations --- (such as maps, reductions, and permutations). These computations are online +-- (such as maps, reductions, and permutations). These computations are online -- compiled and executed on a range of architectures. -- --- /Abstract interface/ +-- [/Abstract interface:/] -- -- The types representing array computations are only exported abstractly — -- i.e., client code can generate array computations and submit them for --- for execution, but it cannot inspect these computations. This is to allow --- for more flexibility for future extensions of this library. +-- execution, but it cannot inspect these computations. This is to allow for +-- more flexibility for future extensions of this library. -- --- /Code execution/ +-- [/Code execution:/] -- --- Access to the various backends is via a 'run' function in --- backend-specific toplevel modules. Currently, we have the following: +-- Access to the various backends is via a 'run' function in backend-specific +-- top level modules. Currently, we have the following: -- -- * "Data.Array.Accelerate.Interpreter": simple interpreter in Haskell as a -- reference implementation defining the semantics of the Accelerate language -- -- * "Data.Array.Accelerate.CUDA": an implementation supporting parallel --- execution on CUDA-capable NVIDIA GPUs +-- execution on CUDA-capable NVIDIA GPUs +-- +-- [/Examples and documentation:/] +-- +-- * A (draft) tutorial is available on the GitHub wiki: +-- +-- +-- * The @accelerate-examples@ package demonstrates a range of computational +-- kernels and several complete applications: +-- -- module Data.Array.Accelerate ( diff --git a/Data/Array/Accelerate/AST.hs b/Data/Array/Accelerate/AST.hs --- a/Data/Array/Accelerate/AST.hs +++ b/Data/Array/Accelerate/AST.hs @@ -226,11 +226,15 @@ -> acc aenv arrs -> PreOpenAcc acc aenv a - -- Array-function application (to keep things simple for the moment, the function must be closed) + -- Array-function application. + -- + -- The array function is not closed at the core level because we need access + -- to free variables introduced by 'run1' style evaluators. See Issue#95. + -- Apply :: (Arrays arrs1, Arrays arrs2) - => PreAfun acc (arrs1 -> arrs2) - -> acc aenv arrs1 - -> PreOpenAcc acc aenv arrs2 + => PreOpenAfun acc aenv (arrs1 -> arrs2) + -> acc aenv arrs1 + -> PreOpenAcc acc aenv arrs2 -- Apply a backend-specific foreign function to an array, with a pure -- Accelerate version for use with other backends. The functions must be diff --git a/Data/Array/Accelerate/Interpreter.hs b/Data/Array/Accelerate/Interpreter.hs --- a/Data/Array/Accelerate/Interpreter.hs +++ b/Data/Array/Accelerate/Interpreter.hs @@ -75,15 +75,17 @@ -- | Prepare and run an embedded array program of one argument -- run1 :: (Arrays a, Arrays b) => (Sugar.Acc a -> Sugar.Acc b) -> a -> b -run1 afun = \a -> exec acc a - where - acc = Sharing.convertAccFun1 True True True afun +run1 = run' - exec :: Afun (a -> b) -> a -> b - exec (Alam (Abody f)) a = force $ evalOpenAcc f (Empty `Push` a) - exec _ _ = error "Hey type checker! We can not get here!" +-- | Prepare an n-ary embedded array program for execution, returning an n-ary +-- closure to do so. +-- +run' :: Sharing.Afunction f => f -> Sharing.AfunctionR f +run' afun = let acc = Sharing.convertAfun True True True afun + in evalOpenAfun acc Empty + -- | Stream a lazily read list of input arrays through the given program, -- collecting results as we go -- @@ -95,6 +97,13 @@ -- Array expression evaluation -- --------------------------- +-- Evaluate an open array function +-- +evalOpenAfun :: OpenAfun aenv f -> Val aenv -> f +evalOpenAfun (Alam f) aenv = \a -> evalOpenAfun f (aenv `Push` a) +evalOpenAfun (Abody b) aenv = force $ evalOpenAcc b aenv + + -- Evaluate an open array expression -- evalOpenAcc :: OpenAcc aenv a -> Val aenv -> Delayed a @@ -114,11 +123,9 @@ let tup' = force $ evalOpenAcc tup aenv :: arrs in delay $ evalPrj ix (fromTuple tup') -evalPreOpenAcc (Apply (Alam (Abody funAcc)) acc) aenv - = let !arr = force $ evalOpenAcc acc aenv - in evalOpenAcc funAcc (Empty `Push` arr) -evalPreOpenAcc (Apply _afun _acc) _aenv - = error "GHC's pattern match checker is too dumb to figure that this case is impossible" +evalPreOpenAcc (Apply f acc) aenv = + let !arr = force $ evalOpenAcc acc aenv + in delay $ evalOpenAfun f aenv arr evalPreOpenAcc (Acond cond acc1 acc2) aenv = if (evalExp cond aenv) then evalOpenAcc acc1 aenv else evalOpenAcc acc2 aenv diff --git a/Data/Array/Accelerate/Trafo.hs b/Data/Array/Accelerate/Trafo.hs --- a/Data/Array/Accelerate/Trafo.hs +++ b/Data/Array/Accelerate/Trafo.hs @@ -1,5 +1,7 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_HADDOCK hide #-} -- | @@ -17,8 +19,8 @@ -- * HOAS -> de Bruijn conversion Phase(..), phases, - convertAcc, convertAccWith, - convertAccFun1, convertAccFun1With, + convertAcc, convertAccWith, + convertAfun, convertAfunWith, -- * Fusion module Data.Array.Accelerate.Trafo.Fusion, @@ -33,10 +35,11 @@ import Data.Array.Accelerate.Smart import Data.Array.Accelerate.Debug -import Data.Array.Accelerate.Pretty ( ) -- show instances +import Data.Array.Accelerate.Pretty ( ) -- show instances import Data.Array.Accelerate.Array.Sugar ( Arrays, Elt ) import Data.Array.Accelerate.Trafo.Base -import Data.Array.Accelerate.Trafo.Fusion hiding ( convertAcc, convertAfun ) +import Data.Array.Accelerate.Trafo.Fusion hiding ( convertAcc, convertAfun ) -- to export types +import Data.Array.Accelerate.Trafo.Sharing ( Function, FunctionR, Afunction, AfunctionR ) import Data.Array.Accelerate.Trafo.Substitution import qualified Data.Array.Accelerate.AST as AST import qualified Data.Array.Accelerate.Trafo.Fusion as Fusion @@ -105,14 +108,14 @@ -- | Convert a unary function over array computations, incorporating sharing -- observation and array fusion -- -convertAccFun1 :: (Arrays a, Arrays b) => (Acc a -> Acc b) -> DelayedAfun (a -> b) -convertAccFun1 = convertAccFun1With phases +convertAfun :: Afunction f => f -> DelayedAfun (AfunctionR f) +convertAfun = convertAfunWith phases -convertAccFun1With :: (Arrays a, Arrays b) => Phase -> (Acc a -> Acc b) -> DelayedAfun (a -> b) -convertAccFun1With ok acc +convertAfunWith :: Afunction f => Phase -> f -> DelayedAfun (AfunctionR f) +convertAfunWith ok acc = Fusion.convertAfun -- `when` enableAccFusion $ Rewrite.convertSegmentsAfun `when` convertOffsetOfSegment - $ Sharing.convertAccFun1 (recoverAccSharing ok) (recoverExpSharing ok) (floatOutAccFromExp ok) acc + $ Sharing.convertAfun (recoverAccSharing ok) (recoverExpSharing ok) (floatOutAccFromExp ok) acc where when f phase | phase ok = f @@ -131,15 +134,10 @@ -- | Convert closed scalar functions, incorporating sharing observation and -- optimisation. -- -convertFun1 :: (Elt a, Elt b) => (Exp a -> Exp b) -> AST.Fun () (a -> b) -convertFun1 - = Rewrite.simplify - . Sharing.convertFun1 (recoverExpSharing phases) - -convertFun2 :: (Elt a, Elt b, Elt c) => (Exp a -> Exp b -> Exp c) -> AST.Fun () (a -> b -> c) -convertFun2 +convertFun :: Function f => f -> AST.Fun () (FunctionR f) +convertFun = Rewrite.simplify - . Sharing.convertFun2 (recoverExpSharing phases) + . Sharing.convertFun (recoverExpSharing phases) -- Pretty printing @@ -148,17 +146,14 @@ instance Arrays arrs => Show (Acc arrs) where show = withSimplStats . show . convertAcc -instance (Arrays a, Arrays b) => Show (Acc a -> Acc b) where - show = withSimplStats . show . convertAccFun1 +instance Afunction (Acc a -> f) => Show (Acc a -> f) where + show = withSimplStats . show . convertAfun instance Elt e => Show (Exp e) where show = withSimplStats . show . convertExp -instance (Elt a, Elt b) => Show (Exp a -> Exp b) where - show = withSimplStats . show . convertFun1 - -instance (Elt a, Elt b, Elt c) => Show (Exp a -> Exp b -> Exp c) where - show = withSimplStats . show . convertFun2 +instance Function (Exp a -> f) => Show (Exp a -> f) where + show = withSimplStats . show . convertFun -- Debugging diff --git a/Data/Array/Accelerate/Trafo/Sharing.hs b/Data/Array/Accelerate/Trafo/Sharing.hs --- a/Data/Array/Accelerate/Trafo/Sharing.hs +++ b/Data/Array/Accelerate/Trafo/Sharing.hs @@ -1,7 +1,9 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# OPTIONS_HADDOCK hide #-} @@ -22,8 +24,8 @@ module Data.Array.Accelerate.Trafo.Sharing ( -- * HOAS -> de Bruijn conversion - convertAcc, convertAccFun1, - convertExp, convertFun1, convertFun2, + convertAcc, convertAfun, Afunction, AfunctionR, + convertExp, convertFun, Function, FunctionR ) where @@ -106,6 +108,9 @@ incLayout EmptyLayout = EmptyLayout incLayout (PushLayout lyt ix) = PushLayout (incLayout lyt) (SuccIdx ix) +sizeLayout :: Layout env env' -> Int +sizeLayout EmptyLayout = 0 +sizeLayout (PushLayout lyt _) = 1 + sizeLayout lyt -- Conversion from HOAS to de Bruijn computation AST @@ -129,27 +134,46 @@ in convertOpenAcc config 0 [] EmptyLayout acc --- | Convert a unary function over array computations + +-- | Convert a closed function over array computations, while incorporating +-- sharing information. -- -convertAccFun1 - :: forall a b. (Arrays a, Arrays b) - => Bool -- ^ recover sharing of array computations ? - -> Bool -- ^ recover sharing of scalar expressions ? - -> Bool -- ^ always float array computations out of expressions? - -> (Acc a -> Acc b) - -> AST.Afun (a -> b) -convertAccFun1 shareAcc shareExp floatAcc f - = let config = Config shareAcc shareExp (shareAcc && floatAcc) +convertAfun :: Afunction f => Bool -> Bool -> Bool -> f -> AST.Afun (AfunctionR f) +convertAfun shareAcc shareExp floatAcc = + let config = Config shareAcc shareExp (shareAcc && floatAcc) + in aconvert config EmptyLayout - lvl = 0 - a = Atag lvl - alyt = EmptyLayout - `PushLayout` - (ZeroIdx :: Idx ((), a) a) - openF = convertOpenAcc config (lvl + 1) [lvl] alyt (f (Acc a)) - in - Alam (Abody openF) +-- Convert a HOAS fragment into de Bruijn form, binding variables into the typed +-- environment layout one binder at a time. +-- +-- NOTE: Because we convert one binder at a time left-to-right, the bound +-- variables ('vars') will have de Bruijn index _zero_ as the outermost +-- binding, and thus go to the end of the list. +-- +class Afunction f where + type AfunctionR f + aconvert :: Config -> Layout aenv aenv -> f -> AST.OpenAfun aenv (AfunctionR f) + +instance (Arrays a, Afunction r) => Afunction (Acc a -> r) where + type AfunctionR (Acc a -> r) = a -> AfunctionR r + -- + aconvert config alyt f + = let a = Acc $ Atag (sizeLayout alyt) + alyt' = incLayout alyt `PushLayout` ZeroIdx + in + Alam $ aconvert config alyt' (f a) + +instance Arrays b => Afunction (Acc b) where + type AfunctionR (Acc b) = b + -- + aconvert config alyt body + = let lvl = sizeLayout alyt + vars = [lvl-1, lvl-2 .. 0] + in + Abody $ convertOpenAcc config lvl vars alyt body + + -- | Convert an open array expression to de Bruijn form while also incorporating sharing -- information. -- @@ -219,11 +243,9 @@ -> AST.Avar (prjIdx ("de Bruijn conversion tag " ++ show i) i alyt) Pipe afun1 afun2 acc - -> let a = recoverAccSharing config - e = recoverExpSharing config - f = floatOutAcc config - boundAcc = convertAccFun1 a e f afun1 `AST.Apply` convertSharingAcc config alyt aenv acc - bodyAcc = convertAccFun1 a e f afun2 `AST.Apply` AST.OpenAcc (AST.Avar AST.ZeroIdx) + -> let alyt' = incLayout alyt `PushLayout` ZeroIdx + boundAcc = aconvert config alyt afun1 `AST.Apply` convertSharingAcc config alyt aenv acc + bodyAcc = aconvert config alyt' afun2 `AST.Apply` AST.OpenAcc (AST.Avar AST.ZeroIdx) in AST.Alet (AST.OpenAcc boundAcc) (AST.OpenAcc bodyAcc) @@ -232,7 +254,7 @@ e = recoverExpSharing config f = floatOutAcc config in - AST.Aforeign ff (convertAccFun1 a e f afun) (cvtA acc) + AST.Aforeign ff (convertAfun a e f afun) (cvtA acc) Acond b acc1 acc2 -> AST.Acond (cvtE b) (cvtA acc1) (cvtA acc2) Atuple arrs -> AST.Atuple (convertSharingAtuple config alyt aenv arrs) @@ -311,6 +333,46 @@ +-- Scalar functions +-- ---------------- + +-- | Convert a closed scalar function to de Bruijn form while incorporating +-- sharing information. +-- +-- The current design requires all free variables to be bound at the outermost +-- level --- we have no general apply term, and so lambdas are always outermost. +-- In higher-order abstract syntax, this represents an n-ary, polyvariadic +-- function. +-- +convertFun :: Function f => Bool => f -> AST.Fun () (FunctionR f) +convertFun shareExp = + let config = Config False shareExp False + in convert config EmptyLayout + + +class Function f where + type FunctionR f + convert :: Config -> Layout env env -> f -> AST.OpenFun env () (FunctionR f) + +instance (Elt a, Function r) => Function (Exp a -> r) where + type FunctionR (Exp a -> r) = a -> FunctionR r + -- + convert config lyt f + = let x = Exp $ Tag (sizeLayout lyt) + lyt' = incLayout lyt `PushLayout` ZeroIdx + in + Lam $ convert config lyt' (f x) + +instance Elt b => Function (Exp b) where + type FunctionR (Exp b) = b + -- + convert config lyt body + = let lvl = sizeLayout lyt + vars = [lvl-1, lvl-2 .. 0] + in + Body $ convertOpenExp config lvl vars lyt body + + -- Scalar expressions -- ------------------ @@ -327,44 +389,6 @@ in convertOpenExp config 0 [] EmptyLayout exp --- | Convert a closed scalar function of one parameter to de Bruijn form while --- incorporating sharing information --- -convertFun1 - :: (Elt a, Elt b) - => Bool - -> (Exp a -> Exp b) - -> AST.Fun () (a -> b) -convertFun1 shareExp f - = let config = Config False shareExp False - - lvl = 0 - x = Exp (Tag lvl) - lyt = EmptyLayout `PushLayout` ZeroIdx - body = convertOpenExp config (lvl+1) [lvl] lyt (f x) - in - Lam (Body body) - --- | Convert a closed scalar function of two parameters to de Bruijn form while --- incorporating sharing information --- -convertFun2 - :: (Elt a, Elt b, Elt c) - => Bool - -> (Exp a -> Exp b -> Exp c) - -> AST.Fun () (a -> b -> c) -convertFun2 shareExp f - = let config = Config False shareExp False - - lvl = 0 - x = Exp (Tag (lvl+1)) - y = Exp (Tag lvl) - lyt = EmptyLayout `PushLayout` SuccIdx ZeroIdx - `PushLayout` ZeroIdx - body = convertOpenExp config (lvl+2) [lvl, lvl+1] lyt (f x y) - in - Lam (Lam (Body body)) - convertOpenExp :: Elt e => Config @@ -432,7 +456,7 @@ LinearIndex a i -> AST.LinearIndex (cvtA a) (cvt i) Shape a -> AST.Shape (cvtA a) ShapeSize e -> AST.ShapeSize (cvt e) - Foreign ff f e -> AST.Foreign ff (convertFun1 (recoverExpSharing config) f) (cvt e) + Foreign ff f e -> AST.Foreign ff (convertFun (recoverExpSharing config) f) (cvt e) cvtA :: Arrays a => SharingAcc a -> AST.OpenAcc aenv a cvtA = convertSharingAcc config alyt aenv diff --git a/Data/Array/Accelerate/Trafo/Substitution.hs b/Data/Array/Accelerate/Trafo/Substitution.hs --- a/Data/Array/Accelerate/Trafo/Substitution.hs +++ b/Data/Array/Accelerate/Trafo/Substitution.hs @@ -305,7 +305,7 @@ Avar ix -> accOut (v ix) Atuple tup -> Atuple (rebuildATA rebuild v tup) Aprj tup a -> Aprj tup (rebuild v a) - Apply f a -> Apply f (rebuild v a) + Apply f a -> Apply (rebuildAfun rebuild v f) (rebuild v a) Aforeign ff afun as -> Aforeign ff afun (rebuild v as) Acond p t e -> Acond (rebuildEA rebuild v p) (rebuild v t) (rebuild v e) Use a -> Use a diff --git a/accelerate.cabal b/accelerate.cabal --- a/accelerate.cabal +++ b/accelerate.cabal @@ -1,5 +1,5 @@ Name: accelerate -Version: 0.13.0.1 +Version: 0.13.0.2 Cabal-version: >= 1.6 Tested-with: GHC >= 7.4.2 Build-type: Custom