accelerate-llvm 1.0.0.0 → 1.1.0.0
raw patch · 43 files changed
+2073/−536 lines, 43 filesdep +bytestringdep +deepseqdep +directorydep ~acceleratedep ~basedep ~containers
Dependencies added: bytestring, deepseq, directory, filepath, template-haskell
Dependency ranges changed: accelerate, base, containers, llvm-hs, llvm-hs-pure
Files
- CHANGELOG.md +24/−0
- Control/Parallel/Meta.hs +10/−11
- Control/Parallel/Meta/Resource/Backoff.hs +1/−2
- Control/Parallel/Meta/Resource/SMP.hs +4/−6
- Control/Parallel/Meta/Trans/LBS.hs +0/−1
- Control/Parallel/Meta/Worker.hs +8/−5
- Data/Array/Accelerate/LLVM/AST.hs +174/−0
- Data/Array/Accelerate/LLVM/Array/Data.hs +0/−1
- Data/Array/Accelerate/LLVM/CodeGen.hs +32/−33
- Data/Array/Accelerate/LLVM/CodeGen/Arithmetic.hs +34/−14
- Data/Array/Accelerate/LLVM/CodeGen/Array.hs +1/−2
- Data/Array/Accelerate/LLVM/CodeGen/Base.hs +7/−4
- Data/Array/Accelerate/LLVM/CodeGen/Constant.hs +1/−2
- Data/Array/Accelerate/LLVM/CodeGen/Downcast.hs +37/−31
- Data/Array/Accelerate/LLVM/CodeGen/Environment.hs +3/−1
- Data/Array/Accelerate/LLVM/CodeGen/Exp.hs +6/−3
- Data/Array/Accelerate/LLVM/CodeGen/IR.hs +4/−2
- Data/Array/Accelerate/LLVM/CodeGen/Intrinsic.hs +16/−6
- Data/Array/Accelerate/LLVM/CodeGen/Monad.hs +45/−35
- Data/Array/Accelerate/LLVM/CodeGen/Monad.hs-boot +1/−1
- Data/Array/Accelerate/LLVM/CodeGen/Permute.hs +0/−1
- Data/Array/Accelerate/LLVM/CodeGen/Skeleton.hs +40/−18
- Data/Array/Accelerate/LLVM/CodeGen/Stencil.hs +24/−24
- Data/Array/Accelerate/LLVM/CodeGen/Sugar.hs +13/−0
- Data/Array/Accelerate/LLVM/CodeGen/Type.hs +0/−1
- Data/Array/Accelerate/LLVM/Compile.hs +179/−176
- Data/Array/Accelerate/LLVM/Compile/Cache.hs +101/−0
- Data/Array/Accelerate/LLVM/Compile/Cache.hs-boot +19/−0
- Data/Array/Accelerate/LLVM/Embed.hs +280/−0
- Data/Array/Accelerate/LLVM/Execute.hs +158/−123
- Data/Array/Accelerate/LLVM/Execute/Async.hs +2/−0
- Data/Array/Accelerate/LLVM/Link.hs +203/−0
- Data/Array/Accelerate/LLVM/Link/Cache.hs +114/−0
- Data/Array/Accelerate/LLVM/State.hs +1/−1
- Data/Array/Accelerate/LLVM/State.hs-boot +17/−0
- Data/Array/Accelerate/LLVM/Target.hs +2/−3
- Data/ByteString/Short/Char8.hs +46/−0
- Data/ByteString/Short/Extra.hs +103/−0
- Data/IORef/Storable.hs +59/−0
- LLVM/AST/Type/Metadata.hs +11/−9
- LLVM/AST/Type/Name.hs +11/−6
- README.md +188/−0
- accelerate-llvm.cabal +94/−14
+ CHANGELOG.md view
@@ -0,0 +1,24 @@+# Change Log++Notable changes to the project will be documented in this file.++The format is based on [Keep a Changelog](http://keepachangelog.com/) and the+project adheres to the [Haskell Package Versioning+Policy (PVP)](https://pvp.haskell.org)++## [1.1.0.0] - 2017-09-21+### Added+ * support for GHC-8.2+ * support for LLVM-5.0++### Changed+ * internal restructuring of compile/link phases+++## [1.0.0.0] - 2017-03-31+ * initial release+++[1.1.0.0]: https://github.com/AccelerateHS/accelerate-llvm/compare/1.0.0.0...1.1.0.0+[1.0.0.0]: https://github.com/AccelerateHS/accelerate-llvm/compare/be7f91295f77434b2103c70aa1cabb6a4f2b09a8...1.0.0.0+
Control/Parallel/Meta.hs view
@@ -22,13 +22,14 @@ import Control.Monad import Control.Parallel.Meta.Worker+import Data.ByteString.Short ( ShortByteString ) import Data.Concurrent.Deque.Class import Data.Monoid-import Data.Sequence ( Seq )-import Data.Range.Range as R-import qualified Data.Vector as V+import Data.Sequence ( Seq )+import Data.Range.Range as R+import qualified Data.Vector as V -import GHC.Base ( quotInt, remInt )+import GHC.Base ( quotInt, remInt ) -- | The 'Startup' component of a 'Resource' is a callback that implements@@ -95,10 +96,10 @@ -- data Executable = Executable { runExecutable- :: String -- Function name- -> Int -- Profitable parallelism threshold (PPT)- -> Range -- The range to execute over- -> Action -- The main function to execute+ :: ShortByteString -- Function name+ -> Int -- Profitable parallelism threshold (PPT)+ -> Range -- The range to execute over+ -> Action -- The main function to execute -> IO () } @@ -213,9 +214,7 @@ -- make sure all the work queues are exhausted before exiting. _ -> do done <- exhausted workers- if done- then return ()- else loop+ unless done loop when (end > start) $ pushL (workpool me) (IE start end) loop
Control/Parallel/Meta/Resource/Backoff.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Control.Parallel.Meta.Resource.Backoff@@ -27,11 +26,11 @@ ) where import Control.Concurrent-import Data.IORef import Text.Printf import Control.Parallel.Meta import Control.Parallel.Meta.Worker+import Data.IORef.Storable import Data.Range.Range as R import qualified Data.Vector as V import qualified Data.Array.Accelerate.Debug as Debug
Control/Parallel/Meta/Resource/SMP.hs view
@@ -1,5 +1,4 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE BangPatterns #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Control.Parallel.Meta.Resource.SMP@@ -27,15 +26,14 @@ ) where -- accelerate-import Data.Range.Range import Control.Parallel.Meta import Control.Parallel.Meta.Worker-+import Data.IORef.Storable+import Data.Range.Range import qualified Data.Array.Accelerate.Debug as Debug -- standard library import Data.Concurrent.Deque.Class-import Data.IORef import System.Random.MWC import Text.Printf import qualified Data.Vector as V@@ -77,7 +75,7 @@ loop 0 = do message myId "work search failed"- modifyIORef' (consecutiveFailures me) (+1)+ modifyIORef (consecutiveFailures me) (+1) return Nothing loop n = do
Control/Parallel/Meta/Trans/LBS.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE RecordWildCards #-} {-# OPTIONS_HADDOCK hide #-} -- |
Control/Parallel/Meta/Worker.hs view
@@ -21,6 +21,7 @@ ) where -- accelerate+import Data.IORef.Storable import qualified Data.Array.Accelerate.Debug as Debug -- standard library@@ -28,7 +29,6 @@ import Control.Concurrent import Control.Exception import Control.Monad-import Data.IORef import Data.Range.Range import Data.Vector ( Vector ) import System.IO.Unsafe@@ -77,7 +77,7 @@ -- Work scheduling , workpool :: {-# UNPACK #-} !(WSDeque Range) , consecutiveFailures :: {-# UNPACK #-} !(IORef Int)- , rngState :: {-# UNPACK #-} !GenIO -- don't unpack: too large?+ , rngState :: {-# UNPACK #-} !GenIO -- TLM: don't unpack: too large? -- TODO: debug/work statistics }@@ -102,13 +102,16 @@ -- threadId the worker is spawned on, because we might have multiple work groups -- (i.e. for CPUs and GPUs) --+-- TLM: This isn't a bottleneck, but it would have been better to use something+-- like 'Data.Atomic' as in the base Accelerate package.+-- {-# NOINLINE uniqueSupply #-}-uniqueSupply :: IORef Int-uniqueSupply = unsafePerformIO $ newIORef 0+uniqueSupply :: MVar Int+uniqueSupply = unsafePerformIO $ newMVar 0 -- Generate a fresh identifier. Note that the bang pattern is important. freshId :: IO Int-freshId = atomicModifyIORef uniqueSupply (\n -> let !n' = n+1 in (n', n))+freshId = modifyMVar uniqueSupply (\n -> let !n' = n+1 in return (n', n)) -- | Create a set of workers. This is a somewhat expensive function, so it is
+ Data/Array/Accelerate/LLVM/AST.hs view
@@ -0,0 +1,174 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module : Data.Array.Accelerate.LLVM.AST+-- Copyright : [2017] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.AST (++ PreOpenAccCommand(..),+ PreOpenAccSkeleton(..),++ PreAfun, PreOpenAfun(..),+ PreFun, PreOpenFun(..),+ PreExp, PreOpenExp(..),+ Idx(..), Val(..), prj,++) where++import Data.Array.Accelerate.Array.Sugar+import Data.Array.Accelerate.Product+import Data.Array.Accelerate.AST+ ( PreOpenAfun(..), PreOpenExp(..), PreOpenFun(..), Idx(..), Val(..), PreAfun, PreFun, PreExp, prj )+++-- | Non-computational array program operations, parameterised over array+-- variables represented as de Bruijn indices.+--+data PreOpenAccCommand acc aenv a where++ Avar :: Arrays arrs+ => Idx aenv arrs+ -> PreOpenAccCommand acc aenv arrs++ Alet :: (Arrays bnd, Arrays body)+ => acc aenv bnd+ -> acc (aenv, bnd) body+ -> PreOpenAccCommand acc aenv body++ Use :: Arrays arrs+ => ArrRepr arrs+ -> PreOpenAccCommand acc aenv arrs++ Unit :: Elt e+ => PreExp acc aenv e+ -> PreOpenAccCommand acc aenv (Scalar e)++ Atuple :: (Arrays arrs, IsAtuple arrs)+ => Atuple (acc aenv) (TupleRepr arrs)+ -> PreOpenAccCommand acc aenv arrs++ Aprj :: (Arrays arrs, IsAtuple arrs, Arrays a)+ => TupleIdx (TupleRepr arrs) a+ -> acc aenv arrs+ -> PreOpenAccCommand acc aenv a++ Apply :: (Arrays as, Arrays bs)+ => PreOpenAfun acc aenv (as -> bs)+ -> acc aenv as+ -> PreOpenAccCommand acc aenv bs++ Aforeign :: (Arrays as, Arrays bs, Foreign asm)+ => asm (as -> bs)+ -> acc aenv as+ -> PreOpenAccCommand acc aenv bs++ Acond :: Arrays arrs+ => PreExp acc aenv Bool+ -> acc aenv arrs+ -> acc aenv arrs+ -> PreOpenAccCommand acc aenv arrs++ Awhile :: Arrays arrs+ => PreOpenAfun acc aenv (arrs -> Scalar Bool)+ -> PreOpenAfun acc aenv (arrs -> arrs)+ -> acc aenv arrs+ -> PreOpenAccCommand acc aenv arrs++ Reshape :: (Shape sh, Shape sh', Elt e)+ => PreExp acc aenv sh+ -> Idx aenv (Array sh' e)+ -> PreOpenAccCommand acc aenv (Array sh e)++ Unzip :: (Elt tup, Elt e)+ => TupleIdx (TupleRepr tup) e+ -> Idx aenv (Array sh tup)+ -> PreOpenAccCommand acc aenv (Array sh e)+++-- | Collective array computations parameterised over array variables+-- represented as de Bruijn indices.+--+data PreOpenAccSkeleton acc aenv a where++ Map :: (Shape sh, Elt e)+ => PreExp acc aenv sh+ -> PreOpenAccSkeleton acc aenv (Array sh e)++ Generate :: (Shape sh, Elt e)+ => PreExp acc aenv sh+ -> PreOpenAccSkeleton acc aenv (Array sh e)++ Transform :: (Shape sh, Elt e)+ => PreExp acc aenv sh+ -> PreOpenAccSkeleton acc aenv (Array sh e)++ Backpermute :: (Shape sh, Elt e)+ => PreExp acc aenv sh+ -> PreOpenAccSkeleton acc aenv (Array sh e)++ Fold :: (Shape sh, Elt e)+ => PreExp acc aenv (sh :. Int)+ -> PreOpenAccSkeleton acc aenv (Array sh e)++ Fold1 :: (Shape sh, Elt e)+ => PreExp acc aenv (sh :. Int)+ -> PreOpenAccSkeleton acc aenv (Array sh e)++ FoldSeg :: (Shape sh, Elt e)+ => PreExp acc aenv (sh :. Int)+ -> PreExp acc aenv (Z :. Int)+ -> PreOpenAccSkeleton acc aenv (Array (sh:.Int) e)++ Fold1Seg :: (Shape sh, Elt e)+ => PreExp acc aenv (sh :. Int)+ -> PreExp acc aenv (Z :. Int)+ -> PreOpenAccSkeleton acc aenv (Array (sh:.Int) e)++ Scanl :: (Shape sh, Elt e)+ => PreExp acc aenv (sh :. Int)+ -> PreOpenAccSkeleton acc aenv (Array (sh:.Int) e)++ Scanl1 :: (Shape sh, Elt e)+ => PreExp acc aenv (sh :. Int)+ -> PreOpenAccSkeleton acc aenv (Array (sh:.Int) e)++ Scanl' :: (Shape sh, Elt e)+ => PreExp acc aenv (sh :. Int)+ -> PreOpenAccSkeleton acc aenv (Array (sh:.Int) e, Array sh e)++ Scanr :: (Shape sh, Elt e)+ => PreExp acc aenv (sh :. Int)+ -> PreOpenAccSkeleton acc aenv (Array (sh:.Int) e)++ Scanr1 :: (Shape sh, Elt e)+ => PreExp acc aenv (sh :. Int)+ -> PreOpenAccSkeleton acc aenv (Array (sh:.Int) e)++ Scanr' :: (Shape sh, Elt e)+ => PreExp acc aenv (sh :. Int)+ -> PreOpenAccSkeleton acc aenv (Array (sh:.Int) e, Array sh e)++ Permute :: (Shape sh, Shape sh', Elt e)+ => PreExp acc aenv sh -- source+ -> acc aenv (Array sh' e) -- default values+ -> PreOpenAccSkeleton acc aenv (Array sh' e)++ Stencil :: (Shape sh, Elt a, Elt b)+ => Idx aenv (Array sh a)+ -> PreOpenAccSkeleton acc aenv (Array sh b)++ Stencil2 :: (Shape sh, Elt a, Elt b, Elt c)+ => Idx aenv (Array sh a)+ -> Idx aenv (Array sh b)+ -> PreOpenAccSkeleton acc aenv (Array sh c)+
Data/Array/Accelerate/LLVM/Array/Data.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}
Data/Array/Accelerate/LLVM/CodeGen.hs view
@@ -24,11 +24,10 @@ ) where -- accelerate-import Data.Array.Accelerate.AST hiding ( Val(..), prj, stencil )-import Data.Array.Accelerate.Array.Sugar hiding ( Foreign )+import Data.Array.Accelerate.AST hiding ( Val(..), prj, stencil )+import Data.Array.Accelerate.Array.Sugar hiding ( Foreign ) import Data.Array.Accelerate.Error import Data.Array.Accelerate.Trafo-import Data.Array.Accelerate.Type import Data.Array.Accelerate.LLVM.Target @@ -42,10 +41,11 @@ import Data.Array.Accelerate.LLVM.CodeGen.Permute import Data.Array.Accelerate.LLVM.CodeGen.Skeleton import Data.Array.Accelerate.LLVM.CodeGen.Sugar+import Data.Array.Accelerate.LLVM.Compile.Cache import Data.Array.Accelerate.LLVM.Foreign -- standard library-import Prelude hiding ( map, scanl, scanl1, scanr, scanr1 )+import Prelude hiding ( map, scanl, scanl1, scanr, scanr1 ) -- | Generate code for a given target architecture.@@ -54,32 +54,33 @@ llvmOfOpenAcc :: forall arch aenv arrs. (Target arch, Skeleton arch, Intrinsic arch, Foreign arch) => arch+ -> UID -> DelayedOpenAcc aenv arrs -> Gamma aenv -> Module arch aenv arrs-llvmOfOpenAcc _ Delayed{} _ = $internalError "llvmOfOpenAcc" "expected manifest array"-llvmOfOpenAcc arch (Manifest pacc) aenv = runLLVM $+llvmOfOpenAcc _ _ Delayed{} _ = $internalError "llvmOfOpenAcc" "expected manifest array"+llvmOfOpenAcc arch uid (Manifest pacc) aenv = runLLVM $ case pacc of -- Producers- Map f a -> map arch aenv (travF1 f) (travD a)- Generate _ f -> generate arch aenv (travF1 f)- Transform _ p f a -> transform arch aenv (travF1 p) (travF1 f) (travD a)- Backpermute _ p a -> backpermute arch aenv (travF1 p) (travD a)+ Map f a -> map arch uid aenv (travF1 f) (travD a)+ Generate _ f -> generate arch uid aenv (travF1 f)+ Transform _ p f a -> transform arch uid aenv (travF1 p) (travF1 f) (travD a)+ Backpermute _ p a -> backpermute arch uid aenv (travF1 p) (travD a) -- Consumers- Fold f z a -> fold arch aenv (travF2 f) (travE z) (travD a)- Fold1 f a -> fold1 arch aenv (travF2 f) (travD a)- FoldSeg f z a s -> foldSeg arch aenv (travF2 f) (travE z) (travD a) (travD s)- Fold1Seg f a s -> fold1Seg arch aenv (travF2 f) (travD a) (travD s)- Scanl f z a -> scanl arch aenv (travF2 f) (travE z) (travD a)- Scanl' f z a -> scanl' arch aenv (travF2 f) (travE z) (travD a)- Scanl1 f a -> scanl1 arch aenv (travF2 f) (travD a)- Scanr f z a -> scanr arch aenv (travF2 f) (travE z) (travD a)- Scanr' f z a -> scanr' arch aenv (travF2 f) (travE z) (travD a)- Scanr1 f a -> scanr1 arch aenv (travF2 f) (travD a)- Permute f _ p a -> permute arch aenv (travPF f) (travF1 p) (travD a)- Stencil f b a -> stencil arch aenv (travF1 f) (travB a b) (travM a)- Stencil2 f b1 a1 b2 a2 -> stencil2 arch aenv (travF2 f) (travB a1 b1) (travM a1) (travB a2 b2) (travM a2)+ Fold f z a -> fold arch uid aenv (travF2 f) (travE z) (travD a)+ Fold1 f a -> fold1 arch uid aenv (travF2 f) (travD a)+ FoldSeg f z a s -> foldSeg arch uid aenv (travF2 f) (travE z) (travD a) (travD s)+ Fold1Seg f a s -> fold1Seg arch uid aenv (travF2 f) (travD a) (travD s)+ Scanl f z a -> scanl arch uid aenv (travF2 f) (travE z) (travD a)+ Scanl' f z a -> scanl' arch uid aenv (travF2 f) (travE z) (travD a)+ Scanl1 f a -> scanl1 arch uid aenv (travF2 f) (travD a)+ Scanr f z a -> scanr arch uid aenv (travF2 f) (travE z) (travD a)+ Scanr' f z a -> scanr' arch uid aenv (travF2 f) (travE z) (travD a)+ Scanr1 f a -> scanr1 arch uid aenv (travF2 f) (travD a)+ Permute f _ p a -> permute arch uid aenv (travPF f) (travF1 p) (travD a)+ Stencil f b a -> stencil arch uid aenv (travF1 f) (travB b) (travM a)+ Stencil2 f b1 a1 b2 a2 -> stencil2 arch uid aenv (travF2 f) (travB b1) (travM a1) (travB b2) (travM a2) -- Non-computation forms: sadness Alet{} -> unexpectedError@@ -121,16 +122,14 @@ travE :: DelayedExp aenv t -> IRExp arch aenv t travE e = llvmOfOpenExp arch e Empty aenv - travB :: forall sh e. Elt e- => DelayedOpenAcc aenv (Array sh e)- -> Boundary (EltRepr e)- -> Boundary (IR e)- travB _ Clamp = Clamp- travB _ Mirror = Mirror- travB _ Wrap = Wrap- travB _ (Constant c)- = Constant- $ IR (constant (eltType (undefined::e)) c)+ travB :: forall sh e.+ PreBoundary DelayedOpenAcc aenv (Array sh e)+ -> IRBoundary arch aenv (Array sh e)+ travB Clamp = IRClamp+ travB Mirror = IRMirror+ travB Wrap = IRWrap+ travB (Constant c) = IRConstant $ IR (constant (eltType (undefined::e)) c)+ travB (Function f) = IRFunction $ travF1 f -- sadness fusionError, unexpectedError :: error
Data/Array/Accelerate/LLVM/CodeGen/Arithmetic.hs view
@@ -19,15 +19,17 @@ where -- standard/external libraries-import Prelude ( Eq, Num, Either(..), ($), (++), (==), undefined, otherwise, flip, fromInteger )+import Prelude ( Eq, Num, Either(..), ($), (==), undefined, otherwise, flip, fromInteger ) import Control.Applicative import Control.Monad-import Data.Bits ( finiteBitSize )+import Data.Bits ( finiteBitSize )+import Data.ByteString.Short ( ShortByteString )+import Data.Monoid import Data.String+import Foreign.Storable ( sizeOf ) import Text.Printf-import Foreign.Storable ( sizeOf )-import qualified Prelude as P-import qualified Data.Ord as Ord+import qualified Data.Ord as Ord+import qualified Prelude as P -- accelerate import Data.Array.Accelerate.Error@@ -269,7 +271,7 @@ popCount :: forall a. IntegralType a -> IR a -> CodeGen (IR Int) popCount i x | IntegralDict <- integralDict i- = do let ctpop = Label $ printf "llvm.ctpop.i%d" (finiteBitSize (undefined::a))+ = do let ctpop = fromString $ printf "llvm.ctpop.i%d" (finiteBitSize (undefined::a)) p = ScalarPrimType (NumScalarType (IntegralNumType i)) t = PrimType p --@@ -280,7 +282,7 @@ countLeadingZeros :: forall a. IntegralType a -> IR a -> CodeGen (IR Int) countLeadingZeros i x | IntegralDict <- integralDict i- = do let clz = Label $ printf "llvm.ctlz.i%d" (finiteBitSize (undefined::a))+ = do let clz = fromString $ printf "llvm.ctlz.i%d" (finiteBitSize (undefined::a)) p = ScalarPrimType (NumScalarType (IntegralNumType i)) t = PrimType p --@@ -291,7 +293,7 @@ countTrailingZeros :: forall a. IntegralType a -> IR a -> CodeGen (IR Int) countTrailingZeros i x | IntegralDict <- integralDict i- = do let clz = Label $ printf "llvm.cttz.i%d" (finiteBitSize (undefined::a))+ = do let clz = fromString $ printf "llvm.cttz.i%d" (finiteBitSize (undefined::a)) p = ScalarPrimType (NumScalarType (IntegralNumType i)) t = PrimType p --@@ -384,11 +386,29 @@ isNaN f (op f -> x) = do let p = ScalarPrimType (NumScalarType (FloatingNumType f)) t = type'- name <- intrinsic "isnan"+ name <- intrinsic+ $ case f of+ TypeFloat{} -> "isnanf"+ TypeCFloat{} -> "isnanf"+ TypeDouble{} -> "isnand"+ TypeCDouble{} -> "isnand" r <- call (Lam p x (Body t name)) [NoUnwind, ReadOnly] return r +isInfinite :: FloatingType a -> IR a -> CodeGen (IR Bool)+isInfinite f (op f -> x) = do+ let p = ScalarPrimType (NumScalarType (FloatingNumType f))+ t = type'+ name <- intrinsic+ $ case f of+ TypeFloat{} -> "isinff"+ TypeCFloat{} -> "isinff"+ TypeDouble{} -> "isinfd"+ TypeCDouble{} -> "isinfd"+ r <- call (Lam p x (Body t name)) [NoUnwind, ReadOnly]+ return r + -- Operators from RealFrac -- ----------------------- @@ -653,7 +673,7 @@ -- -- TLM: We should really be able to construct functions of any arity. ---mathf :: String -> FloatingType t -> IR t -> CodeGen (IR t)+mathf :: ShortByteString -> FloatingType t -> IR t -> CodeGen (IR t) mathf n f (op f -> x) = do let s = ScalarPrimType (NumScalarType (FloatingNumType f)) t = PrimType s@@ -663,7 +683,7 @@ return r -mathf2 :: String -> FloatingType t -> IR t -> IR t -> CodeGen (IR t)+mathf2 :: ShortByteString -> FloatingType t -> IR t -> IR t -> CodeGen (IR t) mathf2 n f (op f -> x) (op f -> y) = do let s = ScalarPrimType (NumScalarType (FloatingNumType f)) t = PrimType s@@ -672,12 +692,12 @@ r <- call (Lam s x (Lam s y (Body t name))) [NoUnwind, ReadOnly] return r -lm :: FloatingType t -> String -> CodeGen Label+lm :: FloatingType t -> ShortByteString -> CodeGen Label lm t n = intrinsic $ case t of- TypeFloat{} -> n++"f"- TypeCFloat{} -> n++"f"+ TypeFloat{} -> n<>"f"+ TypeCFloat{} -> n<>"f" TypeDouble{} -> n TypeCDouble{} -> n
Data/Array/Accelerate/LLVM/CodeGen/Array.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_HADDOCK hide #-} -- |@@ -77,6 +76,6 @@ writeArrayPrim :: Volatility -> Operand (Ptr e) -> Operand int -> Operand e -> CodeGen () writeArrayPrim v arr i x = do p <- instr' $ GetElementPtr arr [i]- _ <- instr' $ Store v p x+ _ <- do_ $ Store v p x return ()
Data/Array/Accelerate/LLVM/CodeGen/Base.hs view
@@ -50,6 +50,9 @@ import qualified LLVM.AST.Global as LLVM +import Data.Monoid+import Data.String+import Text.Printf import qualified Data.IntMap as IM @@ -69,14 +72,14 @@ -- | Names of array data components -- arrayName :: Name (Array sh e) -> Int -> Name e' -- for the i-th component of the ArrayData-arrayName (Name n) i = Name (n ++ ".ad" ++ show i)-arrayName (UnName n) i = arrayName (Name (show n)) i+arrayName (Name n) i = Name (n <> fromString (printf ".ad%d" i))+arrayName (UnName n) i = arrayName (fromString (show n)) i -- | Names of shape components -- shapeName :: Name (Array sh e) -> Int -> Name sh' -- for the i-th component of the shape structure-shapeName (Name n) i = Name (n ++ ".sh" ++ show i)-shapeName (UnName n) i = shapeName (Name (show n)) i+shapeName (Name n) i = Name (n <> fromString (printf ".sh%d" i))+shapeName (UnName n) i = shapeName (fromString (show n)) i -- | Names of array data elements --
Data/Array/Accelerate/LLVM/CodeGen/Constant.hs view
@@ -1,5 +1,4 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE GADTs #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.LLVM.CodeGen.Constant
Data/Array/Accelerate/LLVM/CodeGen/Downcast.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}@@ -46,6 +47,7 @@ import qualified LLVM.AST.Type.Instruction.RMW as RMW import qualified LLVM.AST.Attribute as L+import qualified LLVM.AST.AddrSpace as L import qualified LLVM.AST.CallingConvention as L import qualified LLVM.AST.Constant as LC import qualified LLVM.AST.Float as L@@ -222,7 +224,11 @@ instance Downcast Synchronisation L.SynchronizationScope where downcast SingleThread = L.SingleThread+#if MIN_VERSION_llvm_hs_pure(5,0,0)+ downcast CrossThread = L.System+#else downcast CrossThread = L.CrossThread+#endif instance Downcast MemoryOrdering L.MemoryOrdering where downcast Unordered = L.Unordered@@ -303,9 +309,9 @@ downcast = L.MetadataOperand . downcast instance Downcast Metadata L.Metadata where- downcast (MetadataStringOperand s) = L.MDString s- downcast (MetadataNodeOperand n) = L.MDNode (downcast n)- downcast (MetadataOperand o) = L.MDValue (downcast o)+ downcast (MetadataStringOperand s) = L.MDString s+ downcast (MetadataConstantOperand o) = L.MDValue (L.ConstantOperand o)+ downcast (MetadataNodeOperand n) = L.MDNode (downcast n) instance Downcast MetadataNode L.MetadataNode where downcast (MetadataNode n) = L.MetadataNode (downcast n)@@ -349,7 +355,7 @@ in (downcast t : t', r, n) (args, result, name) = trav f- ty = L.FunctionType result args False+ ty = L.PointerType (L.FunctionType result args False) (L.AddrSpace 0) in Right (L.ConstantOperand (LC.GlobalReference ty name)) @@ -421,35 +427,35 @@ downcast (FloatingNumType t) = downcast t instance Downcast (IntegralType a) L.Type where- downcast (TypeInt _) = L.IntegerType $( [| fromIntegral (finiteBitSize (undefined :: Int)) |] )- downcast (TypeInt8 _) = L.IntegerType 8- downcast (TypeInt16 _) = L.IntegerType 16- downcast (TypeInt32 _) = L.IntegerType 32- downcast (TypeInt64 _) = L.IntegerType 64- downcast (TypeWord _) = L.IntegerType $( [| fromIntegral (finiteBitSize (undefined :: Word)) |] )- downcast (TypeWord8 _) = L.IntegerType 8- downcast (TypeWord16 _) = L.IntegerType 16- downcast (TypeWord32 _) = L.IntegerType 32- downcast (TypeWord64 _) = L.IntegerType 64- downcast (TypeCShort _) = L.IntegerType 16- downcast (TypeCUShort _) = L.IntegerType 16- downcast (TypeCInt _) = L.IntegerType 32- downcast (TypeCUInt _) = L.IntegerType 32- downcast (TypeCLong _) = L.IntegerType $( [| fromIntegral (finiteBitSize (undefined :: CLong)) |] )- downcast (TypeCULong _) = L.IntegerType $( [| fromIntegral (finiteBitSize (undefined :: CULong)) |] )- downcast (TypeCLLong _) = L.IntegerType 64- downcast (TypeCULLong _) = L.IntegerType 64+ downcast TypeInt{} = L.IntegerType $( [| fromIntegral (finiteBitSize (undefined :: Int)) |] )+ downcast TypeInt8{} = L.IntegerType 8+ downcast TypeInt16{} = L.IntegerType 16+ downcast TypeInt32{} = L.IntegerType 32+ downcast TypeInt64{} = L.IntegerType 64+ downcast TypeWord{} = L.IntegerType $( [| fromIntegral (finiteBitSize (undefined :: Word)) |] )+ downcast TypeWord8{} = L.IntegerType 8+ downcast TypeWord16{} = L.IntegerType 16+ downcast TypeWord32{} = L.IntegerType 32+ downcast TypeWord64{} = L.IntegerType 64+ downcast TypeCShort{} = L.IntegerType 16+ downcast TypeCUShort{} = L.IntegerType 16+ downcast TypeCInt{} = L.IntegerType 32+ downcast TypeCUInt{} = L.IntegerType 32+ downcast TypeCLong{} = L.IntegerType $( [| fromIntegral (finiteBitSize (undefined :: CLong)) |] )+ downcast TypeCULong{} = L.IntegerType $( [| fromIntegral (finiteBitSize (undefined :: CULong)) |] )+ downcast TypeCLLong{} = L.IntegerType 64+ downcast TypeCULLong{} = L.IntegerType 64 instance Downcast (FloatingType a) L.Type where- downcast (TypeFloat _) = L.FloatingPointType 32 L.IEEE- downcast (TypeDouble _) = L.FloatingPointType 64 L.IEEE- downcast (TypeCFloat _) = L.FloatingPointType 32 L.IEEE- downcast (TypeCDouble _) = L.FloatingPointType 64 L.IEEE+ downcast TypeFloat{} = L.FloatingPointType L.FloatFP+ downcast TypeDouble{} = L.FloatingPointType L.DoubleFP+ downcast TypeCFloat{} = L.FloatingPointType L.FloatFP+ downcast TypeCDouble{} = L.FloatingPointType L.DoubleFP instance Downcast (NonNumType a) L.Type where- downcast (TypeBool _) = L.IntegerType 1- downcast (TypeChar _) = L.IntegerType 32- downcast (TypeCChar _) = L.IntegerType 8- downcast (TypeCSChar _) = L.IntegerType 8- downcast (TypeCUChar _) = L.IntegerType 8+ downcast TypeBool{} = L.IntegerType 1+ downcast TypeChar{} = L.IntegerType 32+ downcast TypeCChar{} = L.IntegerType 8+ downcast TypeCSChar{} = L.IntegerType 8+ downcast TypeCUChar{} = L.IntegerType 8
Data/Array/Accelerate/LLVM/CodeGen/Environment.hs view
@@ -16,6 +16,8 @@ where import Data.IntMap ( IntMap )+import Data.String+import Text.Printf import qualified Data.IntMap as IM import Data.Array.Accelerate.AST ( Idx(..), idxToInt )@@ -82,7 +84,7 @@ makeGamma = snd . IM.mapAccum (\n ix -> (n+1, toAval n ix)) 0 where toAval :: Int -> Idx' aenv -> (Label, Idx' aenv)- toAval n ix = (Label ("fv" ++ show n), ix)+ toAval n ix = (fromString (printf "fv%d" n), ix) -- | A free variable --
Data/Array/Accelerate/LLVM/CodeGen/Exp.hs view
@@ -165,8 +165,8 @@ go ZeroTupIdx (PairTuple _ t) (OP_Pair _ v) | Just Refl <- matchTupleType t (eltType (undefined :: e)) = v- go (SuccTupIdx ix) (PairTuple t _) (OP_Pair tup _) = go ix t tup- go _ _ _ = $internalError "prjT" "inconsistent valuation"+ go (SuccTupIdx ix) (PairTuple t _) (OP_Pair tup _) = go ix t tup+ go _ _ _ = $internalError "prjT" "inconsistent valuation" cvtT :: forall t. (Elt t, IsTuple t) => Tuple (DelayedOpenExp env aenv) (TupleRepr t) -> CodeGen (IR t) cvtT tup = IR <$> go (eltType (undefined::t)) tup@@ -182,7 +182,9 @@ = do a' <- go ta a IR b' <- cvtE b return $ OP_Pair a' b'- go _ _ = $internalError "cvtT" "impossible evaluation"+ go _ _ = $internalError "cvtT"+ $ unlines [ "impossible evaluation"+ , " possible solution: ensure that the 'EltRepr' and 'ProdRepr' instances of your data type are consistent." ] linearIndex :: (Shape sh, Elt e) => IRManifest arch aenv (Array sh e) -> IR Int -> CodeGen (IR e) linearIndex (IRManifest v) ix =@@ -343,6 +345,7 @@ PrimFloor ta tb -> A.floor ta tb =<< cvtE x PrimCeiling ta tb -> A.ceiling ta tb =<< cvtE x PrimIsNaN t -> A.isNaN t =<< cvtE x+ PrimIsInfinite t -> A.isInfinite t =<< cvtE x PrimLt t -> A.uncurry (A.lt t) =<< cvtE x PrimGt t -> A.uncurry (A.gt t) =<< cvtE x PrimLtEq t -> A.uncurry (A.lte t) =<< cvtE x
Data/Array/Accelerate/LLVM/CodeGen/IR.hs view
@@ -27,7 +27,9 @@ import Data.Array.Accelerate.Error import Data.Array.Accelerate.Array.Sugar +import qualified Data.ByteString.Short as B + -- | The datatype 'IR' represents the LLVM IR producing a value of type 'a'. -- Note that the operands comprising this value are stored in representation -- type.@@ -154,7 +156,7 @@ ir' :: dict a -> Operand a -> Operands a instance IROP Type where- op VoidType _ = LocalReference VoidType (Name []) -- TLM: ???+ op VoidType _ = LocalReference VoidType (Name B.empty) -- TLM: ??? op (PrimType t) x = op t x ir VoidType _ = IR OP_Unit@@ -163,7 +165,7 @@ ir' VoidType _ = OP_Unit ir' (PrimType t) x = ir' t x - op' VoidType _ = LocalReference VoidType (Name []) -- TLM: ???+ op' VoidType _ = LocalReference VoidType (Name B.empty) -- TLM: ??? op' (PrimType t) x = op' t x instance IROP PrimType where
Data/Array/Accelerate/LLVM/CodeGen/Intrinsic.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.LLVM.CodeGen.Intrinsic@@ -19,6 +20,8 @@ import LLVM.AST.Type.Name -- libraries+import Data.Monoid+import Data.ByteString.Short ( ShortByteString ) import Data.HashMap.Strict ( HashMap ) import qualified Data.HashMap.Strict as HashMap @@ -35,19 +38,26 @@ -- sqrt -> llvm.sqrt.f64 -- class Intrinsic arch where- intrinsicForTarget :: arch -> HashMap String Label+ intrinsicForTarget :: arch -> HashMap ShortByteString Label intrinsicForTarget _ = llvmIntrinsic -llvmIntrinsic :: HashMap String Label+llvmIntrinsic :: HashMap ShortByteString Label llvmIntrinsic = let floating base rest- = (base, Label ("llvm." ++ base ++ ".f64"))- : (base ++ "f", Label ("llvm." ++ base ++ ".f32"))- : (base ++ "l", Label ("llvm." ++ base ++ ".f128"))+ = (base, Label ("llvm." <> base <> ".f64"))+ : (base <> "f", Label ("llvm." <> base <> ".f32"))+ : (base <> "l", Label ("llvm." <> base <> ".f128")) : rest++ others+ = ("isnanf", "isnan")+ : ("isnand", "isnan")+ : ("isinff", "isinf")+ : ("isinfd", "isinf")+ : [] in- HashMap.fromList $ foldr floating []+ HashMap.fromList $ foldr floating others [ "sqrt" , "powi" , "sin"
Data/Array/Accelerate/LLVM/CodeGen/Monad.hs view
@@ -40,23 +40,26 @@ -- standard library import Control.Applicative-import Control.Monad.State.Strict+import Control.Monad.State+import Data.ByteString.Short ( ShortByteString ) import Data.Function-import Data.HashMap.Strict ( HashMap )-import Data.Map ( Map )-import Data.Sequence ( Seq )+import Data.HashMap.Strict ( HashMap )+import Data.Map ( Map )+import Data.Sequence ( Seq )+import Data.String import Data.Word-import Text.Printf import Prelude-import qualified Data.Foldable as F-import qualified Data.HashMap.Strict as HashMap-import qualified Data.Map as Map-import qualified Data.Sequence as Seq+import Text.Printf+import qualified Data.Foldable as F+import qualified Data.HashMap.Strict as HashMap+import qualified Data.Map as Map+import qualified Data.Sequence as Seq+import qualified Data.ByteString.Short as B -- accelerate import Data.Array.Accelerate.Error-import Data.Array.Accelerate.Array.Sugar ( Elt, eltType )-import qualified Data.Array.Accelerate.Debug as Debug+import Data.Array.Accelerate.Array.Sugar ( Elt, eltType )+import qualified Data.Array.Accelerate.Debug as Debug -- accelerate-llvm import LLVM.AST.Type.Instruction@@ -73,11 +76,11 @@ import Data.Array.Accelerate.LLVM.CodeGen.Module import Data.Array.Accelerate.LLVM.CodeGen.Type -import Data.Array.Accelerate.LLVM.CodeGen.Sugar ( IROpenAcc(..) )+import Data.Array.Accelerate.LLVM.CodeGen.Sugar ( IROpenAcc(..) ) -- llvm-hs-import qualified LLVM.AST as LLVM-import qualified LLVM.AST.Global as LLVM+import qualified LLVM.AST as LLVM+import qualified LLVM.AST.Global as LLVM -- Code generation@@ -89,17 +92,17 @@ -- AST, and one for each of the basic blocks that are generated during the walk. -- data CodeGenState = CodeGenState- { blockChain :: Seq Block -- blocks for this function- , symbolTable :: Map Label LLVM.Global -- global (external) function declarations- , metadataTable :: HashMap String (Seq [Maybe Metadata]) -- module metadata to be collected- , intrinsicTable :: HashMap String Label -- standard math intrinsic functions- , next :: {-# UNPACK #-} !Word -- a name supply+ { blockChain :: Seq Block -- blocks for this function+ , symbolTable :: Map Label LLVM.Global -- global (external) function declarations+ , metadataTable :: HashMap ShortByteString (Seq [Maybe Metadata]) -- module metadata to be collected+ , intrinsicTable :: HashMap ShortByteString Label -- standard math intrinsic functions+ , next :: {-# UNPACK #-} !Word -- a name supply } data Block = Block- { blockLabel :: Label -- block label- , instructions :: Seq (LLVM.Named LLVM.Instruction) -- stack of instructions- , terminator :: LLVM.Terminator -- block terminator+ { blockLabel :: {-# UNPACK #-} !Label -- block label+ , instructions :: Seq (LLVM.Named LLVM.Instruction) -- stack of instructions+ , terminator :: LLVM.Terminator -- block terminator } newtype CodeGen a = CodeGen { runCodeGen :: State CodeGenState a }@@ -111,7 +114,7 @@ :: forall arch aenv a. (Target arch, Intrinsic arch) => CodeGen (IROpenAcc arch aenv a) -> Module arch aenv a-runLLVM ll =+runLLVM ll = let initialState = CodeGenState { blockChain = initBlockChain@@ -137,7 +140,7 @@ Module { moduleMetadata = md , unModule = LLVM.Module { LLVM.moduleName = name- , LLVM.moduleSourceFileName = []+ , LLVM.moduleSourceFileName = B.empty , LLVM.moduleDataLayout = targetDataLayout (undefined::arch) , LLVM.moduleTargetTriple = targetTriple (undefined::arch) , LLVM.moduleDefinitions = definitions@@ -187,7 +190,7 @@ state $ \s -> let idx = Seq.length (blockChain s) label = let (h,t) = break (== '.') nm in (h ++ shows idx t)- next = Block (Label label) Seq.empty err+ next = Block (fromString label) Seq.empty err err = $internalError label "Block has no terminator" in ( next, s )@@ -256,10 +259,17 @@ instr ins = ir (typeOf ins) <$> instr' ins instr' :: Instruction a -> CodeGen (Operand a)-instr' ins = do- name <- freshName- instr_ $ downcast (name := ins)- return $ LocalReference (typeOf ins) name+instr' ins =+ -- LLVM-5 does not allow instructions of type void to have a name.+ case typeOf ins of+ VoidType -> do+ do_ ins+ return $ LocalReference VoidType (Name B.empty)+ --+ ty -> do+ name <- freshName+ instr_ $ downcast (name := ins)+ return $ LocalReference ty name -- | Execute an unnamed instruction --@@ -361,7 +371,7 @@ name = case LLVM.name g of LLVM.Name n -> Label n- LLVM.UnName n -> Label (show n)+ LLVM.UnName n -> Label (fromString (show n)) in modify (\s -> s { symbolTable = Map.alter unique name (symbolTable s) }) @@ -369,7 +379,7 @@ -- | Get name of the corresponding intrinsic function implementing a given C -- function. If there is no mapping, the C function name is used. ---intrinsic :: String -> CodeGen Label+intrinsic :: ShortByteString -> CodeGen Label intrinsic key = state $ \s -> let name = HashMap.lookupDefault (Label key) key (intrinsicTable s)@@ -382,7 +392,7 @@ -- | Insert a metadata key/value pair into the current module. ---addMetadata :: String -> [Maybe Metadata] -> CodeGen ()+addMetadata :: ShortByteString -> [Maybe Metadata] -> CodeGen () addMetadata key val = modify $ \s -> s { metadataTable = HashMap.insertWith (flip (Seq.><)) key (Seq.singleton val) (metadataTable s) }@@ -393,10 +403,10 @@ -- represent the metadata node definitions that will be attached to that -- definition. ---createMetadata :: HashMap String (Seq [Maybe Metadata]) -> [LLVM.Definition]+createMetadata :: HashMap ShortByteString (Seq [Maybe Metadata]) -> [LLVM.Definition] createMetadata md = build (HashMap.toList md) (Seq.empty, Seq.empty) where- build :: [(String, Seq [Maybe Metadata])]+ build :: [(ShortByteString, Seq [Maybe Metadata])] -> (Seq LLVM.Definition, Seq LLVM.Definition) -- accumulator of (names, metadata) -> [LLVM.Definition] build [] (k,d) = F.toList (k Seq.>< d)@@ -405,7 +415,7 @@ in build xs (k Seq.|> k', d Seq.>< d') meta :: Int -- number of metadata node definitions so far- -> (String, Seq [Maybe Metadata]) -- current assoc of the metadata map+ -> (ShortByteString, Seq [Maybe Metadata]) -- current assoc of the metadata map -> (LLVM.Definition, Seq LLVM.Definition) meta n (key, vals) = let node i = LLVM.MetadataNodeID (fromIntegral (i+n))
Data/Array/Accelerate/LLVM/CodeGen/Monad.hs-boot view
@@ -11,7 +11,7 @@ module Data.Array.Accelerate.LLVM.CodeGen.Monad (CodeGen) where -import Control.Monad.State.Strict+import Control.Monad.State data CodeGenState newtype CodeGen a = CodeGen { runCodeGen :: State CodeGenState a }
Data/Array/Accelerate/LLVM/CodeGen/Permute.hs view
@@ -1,7 +1,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_HADDOCK hide #-}
Data/Array/Accelerate/LLVM/CodeGen/Skeleton.hs view
@@ -22,17 +22,17 @@ import Prelude hiding ( id ) -- accelerate-import Data.Array.Accelerate.AST hiding ( Val(..), prj, stencil, stencilAccess )+import Data.Array.Accelerate.AST hiding ( Val(..), PreBoundary(..), prj, stencil ) import Data.Array.Accelerate.Array.Sugar import Data.Array.Accelerate.Type import Data.Array.Accelerate.LLVM.CodeGen.Base import Data.Array.Accelerate.LLVM.CodeGen.Environment-import Data.Array.Accelerate.LLVM.CodeGen.IR import Data.Array.Accelerate.LLVM.CodeGen.Monad import Data.Array.Accelerate.LLVM.CodeGen.Permute import Data.Array.Accelerate.LLVM.CodeGen.Stencil import Data.Array.Accelerate.LLVM.CodeGen.Sugar+import Data.Array.Accelerate.LLVM.Compile.Cache -- | A class covering code generation for all of the primitive array operations.@@ -50,12 +50,14 @@ generate :: (Shape sh, Elt e) => arch+ -> UID -> Gamma aenv -> IRFun1 arch aenv (sh -> e) -> CodeGen (IROpenAcc arch aenv (Array sh e)) transform :: (Shape sh, Shape sh', Elt a, Elt b) => arch+ -> UID -> Gamma aenv -> IRFun1 arch aenv (sh' -> sh) -> IRFun1 arch aenv (a -> b)@@ -64,6 +66,7 @@ map :: (Shape sh, Elt a, Elt b) => arch+ -> UID -> Gamma aenv -> IRFun1 arch aenv (a -> b) -> IRDelayed arch aenv (Array sh a)@@ -71,6 +74,7 @@ fold :: (Shape sh, Elt e) => arch+ -> UID -> Gamma aenv -> IRFun2 arch aenv (e -> e -> e) -> IRExp arch aenv e@@ -79,6 +83,7 @@ fold1 :: (Shape sh, Elt e) => arch+ -> UID -> Gamma aenv -> IRFun2 arch aenv (e -> e -> e) -> IRDelayed arch aenv (Array (sh:.Int) e)@@ -86,6 +91,7 @@ foldSeg :: (Shape sh, Elt e, Elt i, IsIntegral i) => arch+ -> UID -> Gamma aenv -> IRFun2 arch aenv (e -> e -> e) -> IRExp arch aenv e@@ -95,6 +101,7 @@ fold1Seg :: (Shape sh, Elt e, Elt i, IsIntegral i) => arch+ -> UID -> Gamma aenv -> IRFun2 arch aenv (e -> e -> e) -> IRDelayed arch aenv (Array (sh:.Int) e)@@ -103,6 +110,7 @@ scanl :: (Shape sh, Elt e) => arch+ -> UID -> Gamma aenv -> IRFun2 arch aenv (e -> e -> e) -> IRExp arch aenv e@@ -111,6 +119,7 @@ scanl' :: (Shape sh, Elt e) => arch+ -> UID -> Gamma aenv -> IRFun2 arch aenv (e -> e -> e) -> IRExp arch aenv e@@ -119,6 +128,7 @@ scanl1 :: (Shape sh, Elt e) => arch+ -> UID -> Gamma aenv -> IRFun2 arch aenv (e -> e -> e) -> IRDelayed arch aenv (Array (sh:.Int) e)@@ -126,6 +136,7 @@ scanr :: (Shape sh, Elt e) => arch+ -> UID -> Gamma aenv -> IRFun2 arch aenv (e -> e -> e) -> IRExp arch aenv e@@ -134,6 +145,7 @@ scanr' :: (Shape sh, Elt e) => arch+ -> UID -> Gamma aenv -> IRFun2 arch aenv (e -> e -> e) -> IRExp arch aenv e@@ -142,6 +154,7 @@ scanr1 :: (Shape sh, Elt e) => arch+ -> UID -> Gamma aenv -> IRFun2 arch aenv (e -> e -> e) -> IRDelayed arch aenv (Array (sh:.Int) e)@@ -149,6 +162,7 @@ permute :: (Shape sh, Shape sh', Elt e) => arch+ -> UID -> Gamma aenv -> IRPermuteFun arch aenv (e -> e -> e) -> IRFun1 arch aenv (sh -> sh')@@ -157,6 +171,7 @@ backpermute :: (Shape sh, Shape sh', Elt e) => arch+ -> UID -> Gamma aenv -> IRFun1 arch aenv (sh' -> sh) -> IRDelayed arch aenv (Array sh e)@@ -164,19 +179,21 @@ stencil :: (Stencil sh a stencil, Elt b) => arch+ -> UID -> Gamma aenv -> IRFun1 arch aenv (stencil -> b)- -> Boundary (IR a)+ -> IRBoundary arch aenv (Array sh a) -> IRManifest arch aenv (Array sh a) -> CodeGen (IROpenAcc arch aenv (Array sh b)) stencil2 :: (Stencil sh a stencil1, Stencil sh b stencil2, Elt c) => arch+ -> UID -> Gamma aenv -> IRFun2 arch aenv (stencil1 -> stencil2 -> c)- -> Boundary (IR a)+ -> IRBoundary arch aenv (Array sh a) -> IRManifest arch aenv (Array sh a)- -> Boundary (IR b)+ -> IRBoundary arch aenv (Array sh b) -> IRManifest arch aenv (Array sh b) -> CodeGen (IROpenAcc arch aenv (Array sh c)) @@ -197,35 +214,38 @@ defaultMap :: (Skeleton arch, Shape sh, Elt a, Elt b) => arch+ -> UID -> Gamma aenv -> IRFun1 arch aenv (a -> b) -> IRDelayed arch aenv (Array sh a) -> CodeGen (IROpenAcc arch aenv (Array sh b))-defaultMap arch aenv f a- = transform arch aenv id f a+defaultMap arch uid aenv f a+ = transform arch uid aenv id f a {-# INLINEABLE defaultBackpermute #-} defaultBackpermute :: (Skeleton arch, Shape sh, Shape sh', Elt e) => arch+ -> UID -> Gamma aenv -> IRFun1 arch aenv (sh' -> sh) -> IRDelayed arch aenv (Array sh e) -> CodeGen (IROpenAcc arch aenv (Array sh' e))-defaultBackpermute arch aenv p a- = transform arch aenv p id a+defaultBackpermute arch uid aenv p a+ = transform arch uid aenv p id a {-# INLINEABLE defaultTransform #-} defaultTransform :: (Skeleton arch, Shape sh', Elt b) => arch+ -> UID -> Gamma aenv -> IRFun1 arch aenv (sh' -> sh) -> IRFun1 arch aenv (a -> b) -> IRDelayed arch aenv (Array sh a) -> CodeGen (IROpenAcc arch aenv (Array sh' b))-defaultTransform arch aenv p f IRDelayed{..}- = generate arch aenv . IRFun1 $ \ix -> do+defaultTransform arch uid aenv p f IRDelayed{..}+ = generate arch uid aenv . IRFun1 $ \ix -> do ix' <- app1 p ix a <- app1 delayedIndex ix' app1 f a@@ -234,13 +254,14 @@ defaultStencil1 :: (Skeleton arch, Stencil sh a stencil, Elt b) => arch+ -> UID -> Gamma aenv -> IRFun1 arch aenv (stencil -> b)- -> Boundary (IR a)+ -> IRBoundary arch aenv (Array sh a) -> IRManifest arch aenv (Array sh a) -> CodeGen (IROpenAcc arch aenv (Array sh b))-defaultStencil1 arch aenv f boundary (IRManifest v)- = generate arch aenv . IRFun1 $ \ix -> do+defaultStencil1 arch uid aenv f boundary (IRManifest v)+ = generate arch uid aenv . IRFun1 $ \ix -> do sten <- stencilAccess boundary (irArray (aprj v aenv)) ix app1 f sten @@ -248,15 +269,16 @@ defaultStencil2 :: (Skeleton arch, Stencil sh a stencil1, Stencil sh b stencil2, Elt c) => arch+ -> UID -> Gamma aenv -> IRFun2 arch aenv (stencil1 -> stencil2 -> c)- -> Boundary (IR a)+ -> IRBoundary arch aenv (Array sh a) -> IRManifest arch aenv (Array sh a)- -> Boundary (IR b)+ -> IRBoundary arch aenv (Array sh b) -> IRManifest arch aenv (Array sh b) -> CodeGen (IROpenAcc arch aenv (Array sh c))-defaultStencil2 arch aenv f boundary1 (IRManifest v1) boundary2 (IRManifest v2)- = generate arch aenv . IRFun1 $ \ix -> do+defaultStencil2 arch uid aenv f boundary1 (IRManifest v1) boundary2 (IRManifest v2)+ = generate arch uid aenv . IRFun1 $ \ix -> do sten1 <- stencilAccess boundary1 (irArray (aprj v1 aenv)) ix sten2 <- stencilAccess boundary2 (irArray (aprj v2 aenv)) ix app2 f sten1 sten2
Data/Array/Accelerate/LLVM/CodeGen/Stencil.hs view
@@ -19,9 +19,9 @@ where -- accelerate-import Data.Array.Accelerate.AST hiding ( Val(..), prj, stencilAccess )+import Data.Array.Accelerate.AST hiding ( Val(..), PreBoundary(..), prj ) import Data.Array.Accelerate.Analysis.Match-import Data.Array.Accelerate.Array.Sugar hiding ( bound )+import Data.Array.Accelerate.Array.Sugar import Data.Array.Accelerate.Type import Data.Array.Accelerate.Error @@ -42,7 +42,7 @@ -- stencilAccess :: Stencil sh e stencil- => Boundary (IR e)+ => IRBoundary arch aenv (Array sh e) -> IRArray (Array sh e) -> IR sh -> CodeGen (IR stencil)@@ -103,7 +103,7 @@ -- Recursive cases. Note that because the stencil pattern is defined with -- a cons ordering, whereas shapes (indices) are defined as a snoc list, -- when we recurse on the stencil structure we must manipulate the- -- _innermost_ index component+ -- _left-most_ index component -- goR (StencilRtup3 s1 s2 s3) rf ix = let (i, ix') = uncons ix@@ -162,18 +162,21 @@ -- bounded :: (Shape sh, Elt e)- => Boundary (IR e)+ => IRBoundary arch aenv (Array sh e) -> IRArray (Array sh e) -> IR sh -> CodeGen (IR e) bounded bndy arr@IRArray{..} ix = case bndy of- Constant v ->+ IRConstant v -> if inside irArrayShape ix- then do i <- intOfIndex irArrayShape ix- readArray arr i+ then readArray arr =<< intOfIndex irArrayShape ix else return v- _ -> do+ IRFunction f ->+ if inside irArrayShape ix+ then readArray arr =<< intOfIndex irArrayShape ix+ else app1 f ix+ _ -> do ix' <- bound irArrayShape ix i <- intOfIndex irArrayShape ix' readArray arr i@@ -199,22 +202,22 @@ IR i' <- if A.lt t (IR iz) (int 0) then case bndy of- Clamp -> return (int 0)- Mirror -> A.negate numType (IR iz)- Wrap -> A.add numType (IR sz) (IR iz)- Constant _ -> $internalError "bound" "unexpected boundary condition"+ IRClamp -> return (int 0)+ IRMirror -> A.negate numType (IR iz)+ IRWrap -> A.add numType (IR sz) (IR iz)+ _ -> $internalError "bound" "unexpected boundary condition" else if A.gte t (IR iz) (IR sz) then case bndy of- Clamp -> A.sub numType (IR sz) (int 1)- Mirror -> do+ IRClamp -> A.sub numType (IR sz) (int 1)+ IRWrap -> A.sub numType (IR iz) (IR sz)+ IRMirror -> do a <- A.add numType (IR sz) (int 2) b <- A.sub numType (IR iz) a c <- A.sub numType (IR sz) b return c- Wrap -> A.sub numType (IR iz) (IR sz)- Constant _ -> $internalError "bound" "unexpected boundary condition"+ _ -> $internalError "bound" "unexpected boundary condition" else return (IR iz) return i'@@ -235,12 +238,9 @@ else return (bool False) go (SingleTuple t) sz iz | Just Refl <- matchScalarType t (scalarType :: ScalarType Int)- = if A.lt t (IR iz) (int 0)+ = if A.lt t (IR iz) (int 0) `A.lor` A.gte t (IR iz) (IR sz) then return (bool False)- else- if A.gte t (IR iz) (IR sz)- then return (bool False)- else return (bool True)+ else return (bool True) -- | otherwise = $internalError "bound" "expected shape with Int components"@@ -277,7 +277,7 @@ IR $ OP_Pair (OP_Pair (OP_Pair (OP_Pair (OP_Pair (OP_Pair (OP_Pair (OP_Pair (OP_Pair OP_Unit a) b) c) d) e) f) g) h) i --- Add an _innermost_ dimension to a shape+-- Add a _left-most_ dimension to a shape -- cons :: forall sh. Shape sh => IR Int -> IR sh -> IR (sh :. Int) cons (IR ix) (IR extent) = IR $ go (eltType (undefined::sh)) extent@@ -292,7 +292,7 @@ = $internalError "cons" "expected shape with Int components" --- Remove the _innermost_ dimension to a shape, and return the remainder+-- Remove the _left-most_ index to a shape, and return the remainder -- uncons :: forall sh. Shape sh => IR (sh :. Int) -> (IR Int, IR sh) uncons (IR extent) = let (ix, extent') = go (eltType (undefined::(sh :. Int))) extent
Data/Array/Accelerate/LLVM/CodeGen/Sugar.hs view
@@ -18,6 +18,8 @@ IROpenExp, IROpenFun1(..), IROpenFun2(..), IROpenAcc(..), IRDelayed(..), IRManifest(..), + IRBoundary(..),+ IRArray(..), ) where@@ -52,6 +54,17 @@ data IROpenFun2 arch env aenv t where IRFun2 :: { app2 :: IR a -> IR b -> IROpenExp arch ((env,a),b) aenv c } -> IROpenFun2 arch env aenv (a -> b -> c)+++-- Stencil+-- -------++data IRBoundary arch aenv t where+ IRClamp :: IRBoundary arch aenv t+ IRMirror :: IRBoundary arch aenv t+ IRWrap :: IRBoundary arch aenv t+ IRConstant :: Elt e => IR e -> IRBoundary arch aenv (Array sh e)+ IRFunction :: (Shape sh, Elt e) => IRFun1 arch aenv (sh -> e) -> IRBoundary arch aenv (Array sh e) -- Arrays
Data/Array/Accelerate/LLVM/CodeGen/Type.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.LLVM.CodeGen.Type
Data/Array/Accelerate/LLVM/Compile.hs view
@@ -22,113 +22,104 @@ Compile(..), compileAcc, compileAfun, - ExecOpenAcc(..), ExecOpenAfun,- ExecAcc, ExecAfun,- ExecExp, ExecOpenExp,- ExecFun, ExecOpenFun+ CompiledOpenAcc(..), CompiledOpenAfun,+ CompiledAcc, CompiledAfun,+ CompiledExp, CompiledOpenExp,+ CompiledFun, CompiledOpenFun ) where -- accelerate import Data.Array.Accelerate.AST-import Data.Array.Accelerate.Array.Sugar hiding ( Foreign )+import Data.Array.Accelerate.Array.Sugar hiding ( Foreign ) import Data.Array.Accelerate.Error import Data.Array.Accelerate.Product import Data.Array.Accelerate.Trafo-import qualified Data.Array.Accelerate.Array.Sugar as A+import qualified Data.Array.Accelerate.Array.Sugar as A -import Data.Array.Accelerate.LLVM.Array.Data import Data.Array.Accelerate.LLVM.CodeGen.Environment import Data.Array.Accelerate.LLVM.Foreign import Data.Array.Accelerate.LLVM.State+import qualified Data.Array.Accelerate.LLVM.AST as AST -- standard library-import Data.IntMap ( IntMap )-import Data.Monoid-import Control.Applicative hiding ( Const )-import Prelude hiding ( exp, unzip )+import Data.IntMap ( IntMap )+import Control.Applicative hiding ( Const )+import Prelude hiding ( map, unzip, zipWith, scanl, scanl1, scanr, scanr1, exp ) class Foreign arch => Compile arch where- data ExecutableR arch+ data ObjectR arch+ -- TODO: Provide serialisation facilities, for on-disk caching etc. - -- | Compile an accelerate computation into some backend-specific executable format+ -- | Compile an accelerate computation into some backend-specific code that+ -- will be used to execute the given array expression. The code is not yet+ -- linked into the running executable. -- compileForTarget :: DelayedOpenAcc aenv a -> Gamma aenv- -> LLVM arch (ExecutableR arch)+ -> LLVM arch (ObjectR arch) --- | Annotate an open array expression with the information necessary to execute--- each node directly.----data ExecOpenAcc arch aenv a where- ExecAcc :: ExecutableR arch- -> Gamma aenv- -> PreOpenAcc (ExecOpenAcc arch) aenv a- -> ExecOpenAcc arch aenv a-- EmbedAcc :: (Shape sh, Elt e)- => PreExp (ExecOpenAcc arch) aenv sh- -> ExecOpenAcc arch aenv (Array sh e)+data CompiledOpenAcc arch aenv a where+ BuildAcc :: Gamma aenv+ -> ObjectR arch+ -> AST.PreOpenAccSkeleton (CompiledOpenAcc arch) aenv a+ -> CompiledOpenAcc arch aenv a - UnzipAcc :: (Elt t, Elt e)- => TupleIdx (TupleRepr t) e- -> Idx aenv (Array sh t)- -> ExecOpenAcc arch aenv (Array sh e)+ PlainAcc :: Arrays a+ => AST.PreOpenAccCommand (CompiledOpenAcc arch) aenv a+ -> CompiledOpenAcc arch aenv a --- An annotated AST suitable for execution+-- An annotated AST with embedded build products ---type ExecAcc arch a = ExecOpenAcc arch () a-type ExecAfun arch a = PreAfun (ExecOpenAcc arch) a+type CompiledOpenAfun arch = PreOpenAfun (CompiledOpenAcc arch)+type CompiledOpenExp arch = PreOpenExp (CompiledOpenAcc arch)+type CompiledOpenFun arch = PreOpenFun (CompiledOpenAcc arch) -type ExecOpenAfun arch = PreOpenAfun (ExecOpenAcc arch)-type ExecOpenExp arch = PreOpenExp (ExecOpenAcc arch)-type ExecOpenFun arch = PreOpenFun (ExecOpenAcc arch)+type CompiledAcc arch a = CompiledOpenAcc arch () a+type CompiledAfun arch a = CompiledOpenAfun arch () a -type ExecExp arch = ExecOpenExp arch ()-type ExecFun arch = ExecOpenFun arch ()+type CompiledExp arch = CompiledOpenExp arch ()+type CompiledFun arch = CompiledOpenFun arch () --- | Initialise code generation, compilation, and data transfer (if required)--- for an array expression. The returned array computation is annotated to be--- suitable for execution on the target:------ * A list of the array variables embedded within scalar expressions------ * The compiled LLVM code required to execute the kernel+-- | Generate and compile code for an array expression. The returned expression+-- is annotated with the compilation products required to executed each+-- operation on the given target, together with the list of array variables+-- referenced from the embedded scalar expressions. -- {-# INLINEABLE compileAcc #-} compileAcc- :: (Compile arch, Remote arch)+ :: Compile arch => DelayedAcc a- -> LLVM arch (ExecAcc arch a)+ -> LLVM arch (CompiledAcc arch a) compileAcc = compileOpenAcc {-# INLINEABLE compileAfun #-} compileAfun- :: (Compile arch, Remote arch)+ :: Compile arch => DelayedAfun f- -> LLVM arch (ExecAfun arch f)+ -> LLVM arch (CompiledAfun arch f) compileAfun = compileOpenAfun {-# INLINEABLE compileOpenAfun #-} compileOpenAfun- :: (Compile arch, Remote arch)+ :: Compile arch => DelayedOpenAfun aenv f- -> LLVM arch (PreOpenAfun (ExecOpenAcc arch) aenv f)+ -> LLVM arch (CompiledOpenAfun arch aenv f) compileOpenAfun (Alam l) = Alam <$> compileOpenAfun l compileOpenAfun (Abody b) = Abody <$> compileOpenAcc b {-# INLINEABLE compileOpenAcc #-} compileOpenAcc- :: forall arch _aenv _a. (Compile arch, Remote arch)+ :: forall arch _aenv _a. Compile arch => DelayedOpenAcc _aenv _a- -> LLVM arch (ExecOpenAcc arch _aenv _a)+ -> LLVM arch (CompiledOpenAcc arch _aenv _a) compileOpenAcc = traverseAcc where -- Traverse an open array expression in depth-first order. The top-level@@ -140,104 +131,135 @@ -- array variables that were referred to within scalar sub-expressions. -- These will be required during code generation and execution. --- traverseAcc :: forall aenv arrs. DelayedOpenAcc aenv arrs -> LLVM arch (ExecOpenAcc arch aenv arrs)+ traverseAcc :: forall aenv arrs. DelayedOpenAcc aenv arrs -> LLVM arch (CompiledOpenAcc arch aenv arrs) traverseAcc Delayed{} = $internalError "compileOpenAcc" "unexpected delayed array" traverseAcc topAcc@(Manifest pacc) = case pacc of -- Environment and control flow- Avar ix -> node $ pure (Avar ix)- Alet a b -> node . pure =<< Alet <$> traverseAcc a <*> traverseAcc b- Apply f a -> node =<< liftA2 Apply <$> travAF f <*> travA a- Awhile p f a -> node =<< liftA3 Awhile <$> travAF p <*> travAF f <*> travA a- Acond p t e -> node =<< liftA3 Acond <$> travE p <*> travA t <*> travA e- Atuple tup -> node =<< liftA Atuple <$> travAtup tup- Aprj ix tup -> node =<< liftA (Aprj ix) <$> travA tup-- -- Foreign- Aforeign ff afun a -> foreignA ff afun a+ Avar ix -> plain $ pure (AST.Avar ix)+ Alet a b -> plain . pure =<< AST.Alet <$> traverseAcc a <*> traverseAcc b+ Apply f a -> plain =<< liftA2 AST.Apply <$> travAF f <*> travA a+ Awhile p f a -> plain =<< liftA3 AST.Awhile <$> travAF p <*> travAF f <*> travA a+ Acond p t e -> plain =<< liftA3 AST.Acond <$> travE p <*> travA t <*> travA e+ Atuple tup -> plain =<< liftA AST.Atuple <$> travAtup tup+ Aprj ix tup -> plain =<< liftA (AST.Aprj ix) <$> travA tup - -- Array injection- Unit e -> node =<< liftA Unit <$> travE e- Use arrs -> useRemote (toArr arrs::arrs) >> node (pure (Use arrs))+ -- Foreign arrays operations+ Aforeign ff afun a -> foreignA ff afun a - -- Index space transforms- Reshape s a -> node =<< liftA2 Reshape <$> travE s <*> travA a- Replicate slix e a -> exec =<< liftA2 (Replicate slix) <$> travE e <*> travA a- Slice slix a e -> exec =<< liftA2 (Slice slix) <$> travA a <*> travE e- Backpermute e f a -> exec =<< liftA3 Backpermute <$> travE e <*> travF f <*> travA a+ -- Array injection & manipulation+ Reshape sh a -> plain =<< liftA2 AST.Reshape <$> travE sh <*> travM a+ Unit e -> plain =<< liftA AST.Unit <$> travE e+ Use arrs -> plain $ pure (AST.Use arrs)+ Map f a+ | Just (t,x) <- unzip f a -> plain $ pure (AST.Unzip t x) + -- Skeleton operations resulting in compiled code -- Producers- Generate e f -> exec =<< liftA2 Generate <$> travE e <*> travF f- Map f a- | Just b <- unzip f a -> return b- | otherwise -> exec =<< liftA2 Map <$> travF f <*> travA a- ZipWith f a b -> exec =<< liftA3 ZipWith <$> travF f <*> travA a <*> travA b- Transform e p f a -> exec =<< liftA4 Transform <$> travE e <*> travF p <*> travF f <*> travA a+ Map f a -> build =<< liftA2 map <$> travF f <*> travD a+ Generate sh f -> build =<< liftA2 generate <$> travE sh <*> travF f+ Transform sh p f a -> build =<< liftA4 transform <$> travE sh <*> travF p <*> travF f <*> travD a+ Backpermute sh f a -> build =<< liftA3 backpermute <$> travE sh <*> travF f <*> travD a -- Consumers- Fold f z a -> exec =<< liftA3 Fold <$> travF f <*> travE z <*> travA a- Fold1 f a -> exec =<< liftA2 Fold1 <$> travF f <*> travA a- FoldSeg f e a s -> exec =<< liftA4 FoldSeg <$> travF f <*> travE e <*> travA a <*> travA s- Fold1Seg f a s -> exec =<< liftA3 Fold1Seg <$> travF f <*> travA a <*> travA s- Scanl f e a -> exec =<< liftA3 Scanl <$> travF f <*> travE e <*> travA a- Scanl' f e a -> exec =<< liftA3 Scanl' <$> travF f <*> travE e <*> travA a- Scanl1 f a -> exec =<< liftA2 Scanl1 <$> travF f <*> travA a- Scanr f e a -> exec =<< liftA3 Scanr <$> travF f <*> travE e <*> travA a- Scanr' f e a -> exec =<< liftA3 Scanr' <$> travF f <*> travE e <*> travA a- Scanr1 f a -> exec =<< liftA2 Scanr1 <$> travF f <*> travA a- Permute f d g a -> exec =<< liftA4 Permute <$> travF f <*> travA d <*> travF g <*> travA a- Stencil f b a -> exec =<< liftA2 (flip Stencil b) <$> travF f <*> travM a- Stencil2 f b1 a1 b2 a2 -> exec =<< liftA3 stencil2 <$> travF f <*> travM a1 <*> travM a2- where stencil2 f' a1' a2' = Stencil2 f' b1 a1' b2 a2'+ Fold f z a -> build =<< liftA3 fold <$> travF f <*> travE z <*> travD a+ Fold1 f a -> build =<< liftA2 fold1 <$> travF f <*> travD a+ FoldSeg f z a s -> build =<< liftA4 foldSeg <$> travF f <*> travE z <*> travD a <*> travD s+ Fold1Seg f a s -> build =<< liftA3 fold1Seg <$> travF f <*> travD a <*> travD s+ Scanl f z a -> build =<< liftA3 scanl <$> travF f <*> travE z <*> travD a+ Scanl' f z a -> build =<< liftA3 scanl' <$> travF f <*> travE z <*> travD a+ Scanl1 f a -> build =<< liftA2 scanl1 <$> travF f <*> travD a+ Scanr f z a -> build =<< liftA3 scanr <$> travF f <*> travE z <*> travD a+ Scanr' f z a -> build =<< liftA3 scanr' <$> travF f <*> travE z <*> travD a+ Scanr1 f a -> build =<< liftA2 scanr1 <$> travF f <*> travD a+ Permute f d g a -> build =<< liftA4 permute <$> travF f <*> travA d <*> travF g <*> travD a+ Stencil f x a -> build =<< liftA3 stencil1 <$> travF f <*> travB x <*> travM a+ Stencil2 f x a y b -> build =<< liftA5 stencil2 <$> travF f <*> travB x <*> travM a <*> travB y <*> travM b + -- Removed by fusion+ Replicate{} -> fusionError+ Slice{} -> fusionError+ ZipWith{} -> fusionError+ where- travA :: DelayedOpenAcc aenv a -> LLVM arch (IntMap (Idx' aenv), ExecOpenAcc arch aenv a)- travA acc = case acc of- Manifest{} -> pure <$> traverseAcc acc- Delayed{..} -> liftA2 (const EmbedAcc) <$> travF indexD <*> travE extentD+ map _ a = AST.Map a+ generate sh _ = AST.Generate sh+ transform sh _ _ _ = AST.Transform sh+ backpermute sh _ _ = AST.Backpermute sh+ fold _ _ a = AST.Fold a+ fold1 _ a = AST.Fold1 a+ foldSeg _ _ a s = AST.FoldSeg a s+ fold1Seg _ a s = AST.Fold1Seg a s+ scanl _ _ a = AST.Scanl a+ scanl1 _ a = AST.Scanl1 a+ scanl' _ _ a = AST.Scanl' a+ scanr _ _ a = AST.Scanr a+ scanr1 _ a = AST.Scanr1 a+ scanr' _ _ a = AST.Scanr' a+ permute _ d _ a = AST.Permute a d+ stencil1 _ _ a = AST.Stencil a+ stencil2 _ _ a _ b = AST.Stencil2 a b + fusionError :: error+ fusionError = $internalError "execute" $ "unexpected fusible material: " ++ showPreAccOp pacc++ travA :: DelayedOpenAcc aenv a -> LLVM arch (IntMap (Idx' aenv), CompiledOpenAcc arch aenv a)+ travA acc = pure <$> traverseAcc acc++ travD :: (Shape sh, Elt e)+ => DelayedOpenAcc aenv (Array sh e)+ -> LLVM arch (IntMap (Idx' aenv), PreExp (CompiledOpenAcc arch) aenv sh)+ travD Manifest{} = $internalError "compileOpenAcc" "expected delayed array"+ travD Delayed{..} = liftA2 (flip const) <$> travF indexD <*> travE extentD+ travM :: (Shape sh, Elt e)- => DelayedOpenAcc aenv (Array sh e) -> LLVM arch (IntMap (Idx' aenv), ExecOpenAcc arch aenv (Array sh e))- travM acc = case acc of- Manifest (Avar ix) -> (freevar ix,) <$> traverseAcc acc- _ -> $internalError "compileOpenAcc" "expected array variable"+ => DelayedOpenAcc aenv (Array sh e)+ -> LLVM arch (IntMap (Idx' aenv), Idx aenv (Array sh e))+ travM (Manifest (Avar ix)) = return (freevar ix, ix)+ travM _ = $internalError "compileOpenAcc" "expected array variable" travAF :: DelayedOpenAfun aenv f- -> LLVM arch (IntMap (Idx' aenv), PreOpenAfun (ExecOpenAcc arch) aenv f)+ -> LLVM arch (IntMap (Idx' aenv), CompiledOpenAfun arch aenv f) travAF afun = pure <$> compileOpenAfun afun travAtup :: Atuple (DelayedOpenAcc aenv) a- -> LLVM arch (IntMap (Idx' aenv), Atuple (ExecOpenAcc arch aenv) a)+ -> LLVM arch (IntMap (Idx' aenv), Atuple (CompiledOpenAcc arch aenv) a) travAtup NilAtup = return (pure NilAtup) travAtup (SnocAtup t a) = liftA2 SnocAtup <$> travAtup t <*> travA a travF :: DelayedOpenFun env aenv t- -> LLVM arch (IntMap (Idx' aenv), PreOpenFun (ExecOpenAcc arch) env aenv t)+ -> LLVM arch (IntMap (Idx' aenv), CompiledOpenFun arch env aenv t) travF (Body b) = liftA Body <$> travE b travF (Lam f) = liftA Lam <$> travF f - exec :: (IntMap (Idx' aenv), PreOpenAcc (ExecOpenAcc arch) aenv arrs)- -> LLVM arch (ExecOpenAcc arch aenv arrs)- exec (aenv, eacc) = do- let aval = makeGamma aenv- kernel <- build topAcc aval- return $! ExecAcc kernel aval eacc+ travB :: PreBoundary DelayedOpenAcc aenv t+ -> LLVM arch (IntMap (Idx' aenv), PreBoundary (CompiledOpenAcc arch) aenv t)+ travB Clamp = return $ pure Clamp+ travB Mirror = return $ pure Mirror+ travB Wrap = return $ pure Wrap+ travB (Constant c) = return $ pure (Constant c)+ travB (Function f) = liftA Function <$> travF f - node :: (IntMap (Idx' aenv'), PreOpenAcc (ExecOpenAcc arch) aenv' arrs')- -> LLVM arch (ExecOpenAcc arch aenv' arrs')- node = fmap snd . wrap+ build :: (IntMap (Idx' aenv), AST.PreOpenAccSkeleton (CompiledOpenAcc arch) aenv arrs)+ -> LLVM arch (CompiledOpenAcc arch aenv arrs)+ build (aenv, eacc) = do+ let aval = makeGamma aenv+ kernel <- compileForTarget topAcc aval+ return $! BuildAcc aval kernel eacc - wrap :: (IntMap (Idx' aenv'), PreOpenAcc (ExecOpenAcc arch) aenv' arrs')- -> LLVM arch (IntMap (Idx' aenv'), ExecOpenAcc arch aenv' arrs')- wrap = return . liftA (ExecAcc noKernel mempty)+ plain :: Arrays arrs'+ => (IntMap (Idx' aenv'), AST.PreOpenAccCommand (CompiledOpenAcc arch) aenv' arrs')+ -> LLVM arch (CompiledOpenAcc arch aenv' arrs')+ plain (_, eacc) = return (PlainAcc eacc) -- Unzips of manifest array data can be done in constant time without -- executing any array programs. We split them out here into a separate- -- case of 'ExecAcc' so that the execution phase does not have to- -- continually perform the below check (in particular; 'run1').+ -- case so that the execution phase does not have to continually perform+ -- the below check.+ -- unzip :: PreFun DelayedOpenAcc aenv (a -> b) -> DelayedOpenAcc aenv (Array sh a)- -> Maybe (ExecOpenAcc arch aenv (Array sh b))+ -> Maybe (TupleIdx (TupleRepr a) b, Idx aenv (Array sh a)) unzip f a | Lam (Body (Prj tix (Var ZeroIdx))) <- f , Delayed sh index _ <- a@@ -245,7 +267,7 @@ , Manifest (Avar ix) <- u , Lam (Body (Index v (Var ZeroIdx))) <- index , Just Refl <- match u v- = Just (UnzipAcc tix ix)+ = Just (tix, ix) unzip _ _ = Nothing @@ -254,28 +276,24 @@ -- Subsequent phases, if they encounter a foreign node, can assume that -- it is for them. Otherwise, drop this term and continue walking down -- the list of alternate implementations.+ -- foreignA :: (Arrays a, Arrays b, A.Foreign asm) => asm (a -> b) -> DelayedAfun (a -> b) -> DelayedOpenAcc aenv a- -> LLVM arch (ExecOpenAcc arch aenv b)+ -> LLVM arch (CompiledOpenAcc arch aenv b) foreignA asm f a = case foreignAcc (undefined :: arch) asm of- Just{} -> node =<< liftA (Aforeign asm err) <$> travA a+ Just{} -> plain =<< liftA (AST.Aforeign asm) <$> travA a Nothing -> traverseAcc $ Manifest (Apply (weaken absurd f) a) where absurd :: Idx () t -> Idx aenv t- absurd = absurd- err = $internalError "compile" "attempt to use fallback in foreign function"-- -- sadness- noKernel = $internalError "compile" "no kernel module for this node"-+ absurd = error "complicated stuff in simple words" -- Traverse a scalar expression -- travE :: DelayedOpenExp env aenv e- -> LLVM arch (IntMap (Idx' aenv), PreOpenExp (ExecOpenAcc arch) env aenv e)+ -> LLVM arch (IntMap (Idx' aenv), PreOpenExp (CompiledOpenAcc arch) env aenv e) travE exp = case exp of Var ix -> return $ pure (Var ix)@@ -285,53 +303,53 @@ IndexNil -> return $ pure IndexNil Foreign ff f x -> foreignE ff f x --- Let a b -> liftA2 Let <$> travE a <*> travE b- IndexCons t h -> liftA2 IndexCons <$> travE t <*> travE h- IndexHead h -> liftA IndexHead <$> travE h- IndexTail t -> liftA IndexTail <$> travE t- IndexSlice slix x s -> liftA2 (IndexSlice slix) <$> travE x <*> travE s- IndexFull slix x s -> liftA2 (IndexFull slix) <$> travE x <*> travE s- ToIndex s i -> liftA2 ToIndex <$> travE s <*> travE i- FromIndex s i -> liftA2 FromIndex <$> travE s <*> travE i- Tuple t -> liftA Tuple <$> travT t- Prj ix e -> liftA (Prj ix) <$> travE e- Cond p t e -> liftA3 Cond <$> travE p <*> travE t <*> travE e- While p f x -> liftA3 While <$> travF p <*> travF f <*> travE x- PrimApp f e -> liftA (PrimApp f) <$> travE e- Index a e -> liftA2 Index <$> travA a <*> travE e- LinearIndex a e -> liftA2 LinearIndex <$> travA a <*> travE e- Shape a -> liftA Shape <$> travA a- ShapeSize e -> liftA ShapeSize <$> travE e- Intersect x y -> liftA2 Intersect <$> travE x <*> travE y- Union x y -> liftA2 Union <$> travE x <*> travE y+ Let a b -> liftA2 Let <$> travE a <*> travE b+ IndexCons t h -> liftA2 IndexCons <$> travE t <*> travE h+ IndexHead h -> liftA IndexHead <$> travE h+ IndexTail t -> liftA IndexTail <$> travE t+ IndexSlice slix x s -> liftA2 (IndexSlice slix) <$> travE x <*> travE s+ IndexFull slix x s -> liftA2 (IndexFull slix) <$> travE x <*> travE s+ ToIndex s i -> liftA2 ToIndex <$> travE s <*> travE i+ FromIndex s i -> liftA2 FromIndex <$> travE s <*> travE i+ Tuple t -> liftA Tuple <$> travT t+ Prj ix e -> liftA (Prj ix) <$> travE e+ Cond p t e -> liftA3 Cond <$> travE p <*> travE t <*> travE e+ While p f x -> liftA3 While <$> travF p <*> travF f <*> travE x+ PrimApp f e -> liftA (PrimApp f) <$> travE e+ Index a e -> liftA2 Index <$> travA a <*> travE e+ LinearIndex a e -> liftA2 LinearIndex <$> travA a <*> travE e+ Shape a -> liftA Shape <$> travA a+ ShapeSize e -> liftA ShapeSize <$> travE e+ Intersect x y -> liftA2 Intersect <$> travE x <*> travE y+ Union x y -> liftA2 Union <$> travE x <*> travE y where travA :: (Shape sh, Elt e) => DelayedOpenAcc aenv (Array sh e)- -> LLVM arch (IntMap (Idx' aenv), ExecOpenAcc arch aenv (Array sh e))+ -> LLVM arch (IntMap (Idx' aenv), CompiledOpenAcc arch aenv (Array sh e)) travA a = do a' <- traverseAcc a return $ (bind a', a') travT :: Tuple (DelayedOpenExp env aenv) t- -> LLVM arch (IntMap (Idx' aenv), Tuple (PreOpenExp (ExecOpenAcc arch) env aenv) t)+ -> LLVM arch (IntMap (Idx' aenv), Tuple (PreOpenExp (CompiledOpenAcc arch) env aenv) t) travT NilTup = return (pure NilTup) travT (SnocTup t e) = liftA2 SnocTup <$> travT t <*> travE e travF :: DelayedOpenFun env aenv t- -> LLVM arch (IntMap (Idx' aenv), PreOpenFun (ExecOpenAcc arch) env aenv t)+ -> LLVM arch (IntMap (Idx' aenv), PreOpenFun (CompiledOpenAcc arch) env aenv t) travF (Body b) = liftA Body <$> travE b travF (Lam f) = liftA Lam <$> travF f - bind :: (Shape sh, Elt e) => ExecOpenAcc arch aenv (Array sh e) -> IntMap (Idx' aenv)- bind (ExecAcc _ _ (Avar ix)) = freevar ix- bind _ = $internalError "bind" "expected array variable"+ bind :: (Shape sh, Elt e) => CompiledOpenAcc arch aenv (Array sh e) -> IntMap (Idx' aenv)+ bind (PlainAcc (AST.Avar ix)) = freevar ix+ bind _ = $internalError "bind" "expected array variable" foreignE :: (Elt a, Elt b, A.Foreign asm) => asm (a -> b) -> DelayedFun () (a -> b) -> DelayedOpenExp env aenv a- -> LLVM arch (IntMap (Idx' aenv), PreOpenExp (ExecOpenAcc arch) env aenv b)+ -> LLVM arch (IntMap (Idx' aenv), PreOpenExp (CompiledOpenAcc arch) env aenv b) foreignE asm f x = case foreignExp (undefined :: arch) asm of Just{} -> liftA (Foreign asm err) <$> travE x@@ -339,32 +357,14 @@ _ -> error "the slow regard of silent things" where absurd :: Idx () t -> Idx aenv t- absurd = absurd- err = $internalError "foreignE" "attempt to use fallback in foreign expression"+ absurd = error "Look to my coming, at first light, on the fifth day. At dawn, look to the East." zero :: Idx ((), a) t -> Idx (env,a) t zero ZeroIdx = ZeroIdx- zero notzero = zero notzero----- Compilation--- -----------+ zero _ = error "There are three things all wise men fear: the sea in storm, a night with no moon, and the anger of a gentle man." --- | Generate code that will be used to evaluate an array computation. Pass the--- generated code to the appropriate backend handler, which may then, for--- example, compile and link the code into the running executable.------ TODO:--- * asynchronous compilation--- * kernel caching----{-# INLINEABLE build #-}-build :: forall arch aenv a. Compile arch- => DelayedOpenAcc aenv a- -> Gamma aenv- -> LLVM arch (ExecutableR arch)-build acc aenv =- compileForTarget acc aenv+ err :: CompiledFun arch () (a -> b)+ err = $internalError "foreignE" "attempt to use fallback in foreign expression" -- Applicative@@ -372,4 +372,7 @@ -- liftA4 :: Applicative f => (a -> b -> c -> d -> e) -> f a -> f b -> f c -> f d -> f e liftA4 f a b c d = f <$> a <*> b <*> c <*> d++liftA5 :: Applicative f => (a -> b -> c -> d -> e -> g) -> f a -> f b -> f c -> f d -> f e -> f g+liftA5 f a b c d g = f <$> a <*> b <*> c <*> d <*> g
+ Data/Array/Accelerate/LLVM/Compile/Cache.hs view
@@ -0,0 +1,101 @@+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module : Data.Array.Accelerate.LLVM.Compile.Cache+-- Copyright : [2017] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.Compile.Cache (++ Persistent(..), UID,+ cacheOfUID,+ cacheOfOpenAcc,+ removeCacheDirectory,++) where++import Data.Array.Accelerate.Debug+import Data.Array.Accelerate.Trafo++import Data.Array.Accelerate.LLVM.State++import Control.Monad.Trans+import Data.Version+import System.Directory+import System.FilePath+import Text.Printf++import Paths_accelerate_llvm+++-- TODO:+-- * Remove old files which have not been accessed in some time+-- * Reuse old cache files when upgrading to new versions (ala stack)++class Persistent arch where+ -- | Specify a filename template which can be used to cache files for a given+ -- backend. This should also include something to distinguish this+ -- particular backend/target from another.+ --+ targetCacheTemplate :: LLVM arch FilePath+++-- | Unique identifier for an accelerate computation+--+type UID = Int+++-- | Return the unique cache file path corresponding to a given accelerate+-- computation.+--+{-# INLINEABLE cacheOfOpenAcc #-}+cacheOfOpenAcc+ :: Persistent arch+ => DelayedOpenAcc aenv a+ -> LLVM arch (UID, FilePath)+cacheOfOpenAcc acc = do+ let uid = hashDelayedOpenAcc acc+ cacheFile <- cacheOfUID uid+ return (uid, cacheFile)+++-- | Return the unique cache file path corresponding to the unique identifier of+-- an accelerate computation.+--+{-# INLINEABLE cacheOfUID #-}+cacheOfUID+ :: Persistent arch+ => UID+ -> LLVM arch FilePath+cacheOfUID uid = do+ dbg <- liftIO $ queryFlag debug_cc+ appdir <- liftIO $ getAppUserDataDirectory "accelerate"+ template <- targetCacheTemplate+ let+ (base, file) = splitFileName template+ (name, ext) = splitExtensions file+ --+ cachepath = appdir </> "accelerate-llvm-" ++ showVersion version </> base </> if dbg then "dbg" else "rel"+ cachefile = cachepath </> printf "%s%016X" name uid <.> ext+ --+ liftIO $ createDirectoryIfMissing True cachepath+ return cachefile+++-- | Remove the cache directory+--+{-# INLINEABLE removeCacheDirectory #-}+removeCacheDirectory :: Persistent arch => LLVM arch ()+removeCacheDirectory = do+ appdir <- liftIO $ getAppUserDataDirectory "accelerate"+ template <- targetCacheTemplate+ let+ (base, _) = splitFileName template+ cachepath = appdir </> "accelerate-llvm-" ++ showVersion version </> base+ --+ liftIO $ removeDirectoryRecursive cachepath+
+ Data/Array/Accelerate/LLVM/Compile/Cache.hs-boot view
@@ -0,0 +1,19 @@+-- |+-- Module : Data.Array.Accelerate.LLVM.Compile.Cache-boot+-- Copyright : [2017] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.Compile.Cache+ where++import {-# SOURCE #-} Data.Array.Accelerate.LLVM.State++class Persistent arch++removeCacheDirectory :: Persistent arch => LLVM arch ()+
+ Data/Array/Accelerate/LLVM/Embed.hs view
@@ -0,0 +1,280 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module : Data.Array.Accelerate.LLVM.Embed+-- Copyright : [2017] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.Embed (++ Embed(..),+ embedAfun, embedOpenAfun,+ embedOpenAcc,++) where++import LLVM.AST.Type.Name++import Data.Array.Accelerate.AST ( liftIdx, liftTupleIdx, liftArrays, liftConst, liftSliceIndex, liftPrimConst, liftPrimFun )+import Data.Array.Accelerate.Array.Sugar++import Data.Array.Accelerate.LLVM.AST+import Data.Array.Accelerate.LLVM.CodeGen.Environment+import Data.Array.Accelerate.LLVM.Compile+import Data.Array.Accelerate.LLVM.Link++import Data.Typeable+import Data.ByteString.Short ( ShortByteString )+import GHC.Ptr ( Ptr(..) )+import Language.Haskell.TH ( Q, TExp )+import System.IO.Unsafe+import qualified Data.ByteString.Short.Internal as BS+import qualified Language.Haskell.TH as TH+import qualified Language.Haskell.TH.Syntax as TH++#if MIN_VERSION_containers(0,5,9)+import qualified Data.IntMap.Internal as IM+#elif MIN_VERSION_containers(0,5,8)+import qualified Data.IntMap.Base as IM+#else+import qualified Data.IntMap as IM+#endif+++class Embed arch where++ -- | Turn the compiled object into a TemplateHaskell expression, suitable for+ -- use in a splice. The splice should evaluate into the backend-specific+ -- executable representation.+ --+ embedForTarget+ :: arch+ -> ObjectR arch+ -> Q (TExp (ExecutableR arch))+++-- | Embed the compiled array function into a TemplateHaskell expression,+-- suitable for use in a splice.+--+{-# INLINEABLE embedAfun #-}+embedAfun+ :: (Embed arch, Typeable arch)+ => arch+ -> CompiledAfun arch f+ -> Q (TExp (ExecAfun arch f))+embedAfun = embedOpenAfun++{-# INLINEABLE embedOpenAfun #-}+embedOpenAfun+ :: (Embed arch, Typeable arch, Typeable aenv)+ => arch+ -> CompiledOpenAfun arch aenv f+ -> Q (TExp (ExecOpenAfun arch aenv f))+embedOpenAfun arch (Alam l) = [|| Alam $$(embedOpenAfun arch l) ||]+embedOpenAfun arch (Abody b) = [|| Abody $$(embedOpenAcc arch b) ||]++{-# INLINEABLE embedOpenAcc #-}+embedOpenAcc+ :: forall arch aenv arrs. (Embed arch, Typeable arch, Typeable aenv, Typeable arrs)+ => arch+ -> CompiledOpenAcc arch aenv arrs+ -> Q (TExp (ExecOpenAcc arch aenv arrs))+embedOpenAcc arch = liftA+ where+ liftA :: (Typeable aenv', Typeable arrs') => CompiledOpenAcc arch aenv' arrs' -> Q (TExp (ExecOpenAcc arch aenv' arrs'))+ liftA (PlainAcc pacc) = withSigE [|| EvalAcc $$(liftPreOpenAccCommand arch pacc) ||]+ liftA (BuildAcc aenv obj pacc) = withSigE [|| ExecAcc $$(liftGamma aenv) $$(embedForTarget arch obj) $$(liftPreOpenAccSkeleton arch pacc) ||]++ liftGamma :: Gamma aenv' -> Q (TExp (Gamma aenv'))+#if MIN_VERSION_containers(0,5,8)+ liftGamma IM.Nil = [|| IM.Nil ||]+ liftGamma (IM.Bin p m l r) = [|| IM.Bin p m $$(liftGamma l) $$(liftGamma r) ||]+ liftGamma (IM.Tip k v) = [|| IM.Tip k $$(liftV v) ||]+#else+ -- O(n) at runtime to reconstruct the set+ liftGamma aenv = [|| IM.fromAscList $$(liftIM (IM.toAscList aenv)) ||]+ where+ liftIM :: [(Int, (Label, Idx' aenv'))] -> Q (TExp [(Int, (Label, Idx' aenv'))])+ liftIM im = do+ im' <- mapM (\(k,v) -> TH.unTypeQ [|| (k, $$(liftV v)) ||]) im+ TH.unsafeTExpCoerce (return $ TH.ListE im')+#endif+ liftV :: (Label, Idx' aenv') -> Q (TExp (Label, Idx' aenv'))+ liftV (Label n, Idx' ix) = [|| (Label $$(liftSBS n), Idx' $$(liftIdx ix)) ||]++ -- O(n) at runtime to copy from the Addr# to the ByteArray#. We should+ -- be able to do this without copying, but I don't think the definition of+ -- ByteArray# is exported (or it is deeply magical).+ liftSBS :: ShortByteString -> Q (TExp ShortByteString)+ liftSBS bs =+ let bytes = BS.unpack bs+ len = BS.length bs+ in+ [|| unsafePerformIO $ BS.createFromPtr $$( TH.unsafeTExpCoerce [| Ptr $(TH.litE (TH.StringPrimL bytes)) |]) len ||]+++{-# INLINEABLE liftPreOpenAfun #-}+liftPreOpenAfun+ :: (Embed arch, Typeable arch, Typeable aenv)+ => arch+ -> PreOpenAfun (CompiledOpenAcc arch) aenv t+ -> Q (TExp (PreOpenAfun (ExecOpenAcc arch) aenv t))+liftPreOpenAfun arch (Alam f) = [|| Alam $$(liftPreOpenAfun arch f) ||]+liftPreOpenAfun arch (Abody b) = [|| Abody $$(embedOpenAcc arch b) ||]++{-# INLINEABLE liftPreOpenAccCommand #-}+liftPreOpenAccCommand+ :: forall arch aenv a. (Embed arch, Typeable arch, Typeable aenv)+ => arch+ -> PreOpenAccCommand (CompiledOpenAcc arch) aenv a+ -> Q (TExp (PreOpenAccCommand (ExecOpenAcc arch) aenv a))+liftPreOpenAccCommand arch pacc =+ let+ liftA :: (Typeable aenv', Typeable arrs) => CompiledOpenAcc arch aenv' arrs -> Q (TExp (ExecOpenAcc arch aenv' arrs))+ liftA = embedOpenAcc arch++ liftE :: PreExp (CompiledOpenAcc arch) aenv t -> Q (TExp (PreExp (ExecOpenAcc arch) aenv t))+ liftE = liftPreOpenExp arch++ liftAF :: PreOpenAfun (CompiledOpenAcc arch) aenv f -> Q (TExp (PreOpenAfun (ExecOpenAcc arch) aenv f))+ liftAF = liftPreOpenAfun arch++ liftAtuple :: Atuple (CompiledOpenAcc arch aenv) t -> Q (TExp (Atuple (ExecOpenAcc arch aenv) t))+ liftAtuple NilAtup = [|| NilAtup ||]+ liftAtuple (SnocAtup tup a) = [|| SnocAtup $$(liftAtuple tup) $$(liftA a) ||]+ in+ case pacc of+ Avar ix -> [|| Avar $$(liftIdx ix) ||]+ Alet bnd body -> [|| Alet $$(liftA bnd) $$(liftA body) ||]+ Use a -> [|| Use $$(liftArrays (arrays (undefined::a)) a) ||]+ Unit e -> [|| Unit $$(liftE e) ||]+ Atuple tup -> [|| Atuple $$(liftAtuple tup) ||]+ Aprj tix a -> [|| Aprj $$(liftTupleIdx tix) $$(liftA a) ||]+ Apply f a -> [|| Apply $$(liftAF f) $$(liftA a) ||]+ Aforeign asm a -> [|| Aforeign $$(liftForeign asm) $$(liftA a) ||]+ Acond p t e -> [|| Acond $$(liftE p) $$(liftA t) $$(liftA e) ||]+ Awhile p f a -> [|| Awhile $$(liftAF p) $$(liftAF f) $$(liftA a) ||]+ Reshape sh ix -> [|| Reshape $$(liftE sh) $$(liftIdx ix) ||]+ Unzip tix ix -> [|| Unzip $$(liftTupleIdx tix) $$(liftIdx ix) ||]++{-# INLINEABLE liftPreOpenAccSkeleton #-}+liftPreOpenAccSkeleton+ :: forall arch aenv a. (Embed arch, Typeable arch, Typeable aenv)+ => arch+ -> PreOpenAccSkeleton (CompiledOpenAcc arch) aenv a+ -> Q (TExp (PreOpenAccSkeleton (ExecOpenAcc arch) aenv a))+liftPreOpenAccSkeleton arch pacc =+ let+ liftA :: Typeable arrs => CompiledOpenAcc arch aenv arrs -> Q (TExp (ExecOpenAcc arch aenv arrs))+ liftA = embedOpenAcc arch++ liftE :: PreExp (CompiledOpenAcc arch) aenv t -> Q (TExp (PreExp (ExecOpenAcc arch) aenv t))+ liftE = liftPreOpenExp arch+ in+ case pacc of+ Map sh -> [|| Map $$(liftE sh) ||]+ Generate sh -> [|| Generate $$(liftE sh) ||]+ Transform sh -> [|| Transform $$(liftE sh) ||]+ Backpermute sh -> [|| Backpermute $$(liftE sh) ||]+ Fold sh -> [|| Fold $$(liftE sh) ||]+ Fold1 sh -> [|| Fold1 $$(liftE sh) ||]+ FoldSeg sa ss -> [|| FoldSeg $$(liftE sa) $$(liftE ss) ||]+ Fold1Seg sa ss -> [|| Fold1Seg $$(liftE sa) $$(liftE ss) ||]+ Scanl sh -> [|| Scanl $$(liftE sh) ||]+ Scanl1 sh -> [|| Scanl1 $$(liftE sh) ||]+ Scanl' sh -> [|| Scanl' $$(liftE sh) ||]+ Scanr sh -> [|| Scanr $$(liftE sh) ||]+ Scanr1 sh -> [|| Scanr1 $$(liftE sh) ||]+ Scanr' sh -> [|| Scanr' $$(liftE sh) ||]+ Permute sh a -> [|| Permute $$(liftE sh) $$(liftA a) ||]+ Stencil a -> [|| Stencil $$(liftIdx a) ||]+ Stencil2 a1 a2 -> [|| Stencil2 $$(liftIdx a1) $$(liftIdx a2) ||]++{-# INLINEABLE liftPreOpenFun #-}+liftPreOpenFun+ :: (Embed arch, Typeable arch, Typeable env, Typeable aenv)+ => arch+ -> PreOpenFun (CompiledOpenAcc arch) env aenv t+ -> Q (TExp (PreOpenFun (ExecOpenAcc arch) env aenv t))+liftPreOpenFun arch (Lam f) = [|| Lam $$(liftPreOpenFun arch f) ||]+liftPreOpenFun arch (Body b) = [|| Body $$(liftPreOpenExp arch b) ||]++{-# INLINEABLE liftPreOpenExp #-}+liftPreOpenExp+ :: forall arch env aenv t. (Embed arch, Typeable arch, Typeable env, Typeable aenv)+ => arch+ -> PreOpenExp (CompiledOpenAcc arch) env aenv t+ -> Q (TExp (PreOpenExp (ExecOpenAcc arch) env aenv t))+liftPreOpenExp arch pexp =+ let+ liftA :: Typeable arrs => CompiledOpenAcc arch aenv arrs -> Q (TExp (ExecOpenAcc arch aenv arrs))+ liftA = embedOpenAcc arch++ liftE :: PreOpenExp (CompiledOpenAcc arch) env aenv e -> Q (TExp (PreOpenExp (ExecOpenAcc arch) env aenv e))+ liftE = liftPreOpenExp arch++ liftF :: PreOpenFun (CompiledOpenAcc arch) env aenv f -> Q (TExp (PreOpenFun (ExecOpenAcc arch) env aenv f))+ liftF = liftPreOpenFun arch++ liftT :: Tuple (PreOpenExp (CompiledOpenAcc arch) env aenv) e -> Q (TExp (Tuple (PreOpenExp (ExecOpenAcc arch) env aenv) e))+ liftT NilTup = [|| NilTup ||]+ liftT (SnocTup tup e) = [|| SnocTup $$(liftT tup) $$(liftE e) ||]+ in+ case pexp of+ Let bnd body -> [|| Let $$(liftPreOpenExp arch bnd) $$(liftPreOpenExp arch body) ||]+ Var ix -> [|| Var $$(liftIdx ix) ||]+ Foreign asm f x -> [|| Foreign $$(liftForeign asm) $$(liftPreOpenFun arch f) $$(liftE x) ||]+ Const c -> [|| Const $$(liftConst (eltType (undefined::t)) c) ||]+ Tuple tup -> [|| Tuple $$(liftT tup) ||]+ Prj tix e -> [|| Prj $$(liftTupleIdx tix) $$(liftE e) ||]+ IndexNil -> [|| IndexNil ||]+ IndexCons sh sz -> [|| IndexCons $$(liftE sh) $$(liftE sz) ||]+ IndexHead sh -> [|| IndexHead $$(liftE sh) ||]+ IndexTail sh -> [|| IndexTail $$(liftE sh) ||]+ IndexAny -> [|| IndexAny ||]+ IndexSlice slice slix sh -> [|| IndexSlice $$(liftSliceIndex slice) $$(liftE slix) $$(liftE sh) ||]+ IndexFull slice slix sl -> [|| IndexFull $$(liftSliceIndex slice) $$(liftE slix) $$(liftE sl) ||]+ ToIndex sh ix -> [|| ToIndex $$(liftE sh) $$(liftE ix) ||]+ FromIndex sh ix -> [|| FromIndex $$(liftE sh) $$(liftE ix) ||]+ Cond p t e -> [|| Cond $$(liftE p) $$(liftE t) $$(liftE e) ||]+ While p f x -> [|| While $$(liftF p) $$(liftF f) $$(liftE x) ||]+ PrimConst t -> [|| PrimConst $$(liftPrimConst t) ||]+ PrimApp f x -> [|| PrimApp $$(liftPrimFun f) $$(liftE x) ||]+ Index a ix -> [|| Index $$(liftA a) $$(liftE ix) ||]+ LinearIndex a ix -> [|| LinearIndex $$(liftA a) $$(liftE ix) ||]+ Shape a -> [|| Shape $$(liftA a) ||]+ ShapeSize ix -> [|| ShapeSize $$(liftE ix) ||]+ Intersect sh1 sh2 -> [|| Intersect $$(liftE sh1) $$(liftE sh2) ||]+ Union sh1 sh2 -> [|| Union $$(liftE sh1) $$(liftE sh2) ||]+++-- Utilities+-- ---------++withSigE :: forall e. Typeable e => Q (TExp e) -> Q (TExp e)+withSigE e = e `sigE` typeRepToType (typeOf (undefined::e))++sigE :: Q (TExp t) -> Q TH.Type -> Q (TExp t)+sigE e t = TH.unsafeTExpCoerce $ TH.sigE (TH.unTypeQ e) t++typeRepToType :: TypeRep -> Q TH.Type+typeRepToType trep = do+ let (con, args) = splitTyConApp trep+ name = TH.Name (TH.OccName (tyConName con)) (TH.NameG TH.TcClsName (TH.PkgName (tyConPackage con)) (TH.ModName (tyConModule con)))+ --+ appsT x [] = x+ appsT x (y:xs) = appsT (TH.AppT x y) xs+ --+ resultArgs <- mapM typeRepToType args+ return (appsT (TH.ConT name) resultArgs)+
Data/Array/Accelerate/LLVM/Execute.hs view
@@ -1,9 +1,12 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.LLVM.Execute@@ -19,12 +22,12 @@ module Data.Array.Accelerate.LLVM.Execute ( Execute(..), Gamma,- executeAcc, executeAfun1,+ executeAcc, executeAfun,+ executeOpenAcc, ) where -- accelerate-import Data.Array.Accelerate.AST import Data.Array.Accelerate.Analysis.Match import Data.Array.Accelerate.Array.Representation ( SliceIndex(..) ) import Data.Array.Accelerate.Array.Sugar hiding ( Foreign )@@ -35,9 +38,10 @@ import qualified Data.Array.Accelerate.Array.Sugar as S import qualified Data.Array.Accelerate.Array.Representation as R +import Data.Array.Accelerate.LLVM.AST import Data.Array.Accelerate.LLVM.Array.Data-import Data.Array.Accelerate.LLVM.Compile import Data.Array.Accelerate.LLVM.Foreign+import Data.Array.Accelerate.LLVM.Link import Data.Array.Accelerate.LLVM.State import Data.Array.Accelerate.LLVM.CodeGen.Environment ( Gamma )@@ -200,7 +204,8 @@ -- Computations are evaluated by traversing the AST bottom up, and for each node -- distinguishing between three cases: ----- 1. If it is a Use node, we return a reference to the array data.+-- 1. If it is a Use node, asynchronously transfer the data to the remote+-- device (if necessary). -- -- 2. If it is a non-skeleton node, such as a let-binding or shape conversion, -- then execute directly by updating the environment or similar.@@ -213,31 +218,73 @@ :: forall arch a. Execute arch => ExecAcc arch a -> LLVM arch a-executeAcc acc =+executeAcc !acc = get =<< async (executeOpenAcc acc Aempty) -{-# INLINEABLE executeAfun1 #-}-executeAfun1- :: forall arch a b. (Execute arch, Arrays a)- => ExecAfun arch (a -> b)- -> a- -> LLVM arch b-executeAfun1 afun arrs = do- AsyncR _ a <- async (useRemoteAsync arrs)- executeOpenAfun1 afun Aempty a +-- Execute a variadic array function+--+{-# INLINEABLE executeAfun #-}+executeAfun+ :: ExecuteAfun arch f+ => ExecAfun arch (ExecAfunR arch f)+ -> f+executeAfun f = executeOpenAfun f (return Aempty) --- Execute an open array function of one argument+class ExecuteAfun arch f where+ type ExecAfunR arch f+ executeOpenAfun :: ExecOpenAfun arch aenv (ExecAfunR arch f) -> LLVM arch (AvalR arch aenv) -> f++instance (Remote arch, ExecuteAfun arch b) => ExecuteAfun arch (a -> b) where+ type ExecAfunR arch (a -> b) = a -> ExecAfunR arch b+ {-# INLINEABLE executeOpenAfun #-}+ executeOpenAfun Abody{} _ _ = $internalError "executeOpenAfun" "malformed array function"+ executeOpenAfun (Alam f) k arrs =+ let k' = do aenv <- k+ AsyncR _ a <- async (useRemoteAsync arrs)+ return (aenv `Apush` a)+ in+ executeOpenAfun f k'++instance Execute arch => ExecuteAfun arch (LLVM arch b) where+ type ExecAfunR arch (LLVM arch b) = b+ {-# INLINEABLE executeOpenAfun #-}+ executeOpenAfun Alam{} _ = $internalError "executeOpenAfun" "function not fully applied"+ executeOpenAfun (Abody b) k = do+ aenv <- k+ get =<< async (executeOpenAcc b aenv)+++-- NOTE: [ExecuteAfun and closed type families] ---{-# INLINEABLE executeOpenAfun1 #-}-executeOpenAfun1- :: Execute arch- => ExecOpenAfun arch aenv (a -> b)- -> AvalR arch aenv- -> AsyncR arch a- -> LLVM arch b-executeOpenAfun1 (Alam (Abody f)) aenv a = get =<< async (executeOpenAcc f (aenv `Apush` a))-executeOpenAfun1 _ _ _ = error "boop!"+-- It would be nice to use something like the following closed type family+-- instance, and implement 'executeOpenAfun' as a regular recursive function,+-- rather than as a class function.+--+-- > type family ExecAfunR arch r :: * where+-- > ExecAfunR arch (a -> b) = a -> ExecAfunR arch b+-- > ExecAfunR arch r = LLVM arch r+-- >+-- > executeOpenAfun+-- > :: Execute arch+-- > => ExecOpenAfun arch aenv f+-- > -> LLVM arch (AvalR arch aenv)+-- > -> ExecAfunR arch f+-- > executeOpenAfun (Alam f) k = \arrs -> ...+-- > executeOpenAfun (Abody b) k = do ...+--+-- However, closed type families don't quite work the way that we might think.+-- It seems that they rely on some notion of type inequality, or at least types+-- which don't have a unifier.+--+-- When we match of the `Abody` constructor, we expose a constraint of the form+-- `Arrays a, T a ~ a0`. For the type checker to figure out that+-- `a0 ~ LLVM arch a`, it needs to know that it _can not_ match on the first+-- case of the type family; i.e., that `a` can't unify with `b -> c`. Since it+-- doesn't have constraints to figure that out, it doesn't proceed and fall+-- through to the case that we want. If we had something like `a ~ Array sh e`,+-- then it could.+-- -- Execute an open array computation@@ -249,66 +296,50 @@ -> AvalR arch aenv -> StreamR arch -> LLVM arch arrs-executeOpenAcc EmbedAcc{} _ _ =- $internalError "execute" "unexpected delayed array"-executeOpenAcc (ExecAcc kernel gamma pacc) aenv stream =- case pacc of-- -- Array introduction- Use arr -> return (toArr arr)- Unit x -> newRemote Z . const =<< travE x-- -- Environment manipulation- Avar ix -> do let AsyncR event arr = aprj ix aenv- after stream event- return arr- Alet bnd body -> do bnd' <- async (executeOpenAcc bnd aenv)- body' <- executeOpenAcc body (aenv `Apush` bnd') stream- return body'- Apply f a -> executeOpenAfun1 f aenv =<< async (executeOpenAcc a aenv)- Atuple tup -> toAtuple <$> travT tup- Aprj ix tup -> evalPrj ix . fromAtuple <$> travA tup- Acond p t e -> acond t e =<< travE p- Awhile p f a -> awhile p f =<< travA a-- -- Foreign function- Aforeign asm _ a -> foreignA asm =<< travA a-- -- Producers- Map _ a -> map kernel gamma aenv stream =<< extent a- Generate sh _ -> generate kernel gamma aenv stream =<< travE sh- Transform sh _ _ _ -> transform kernel gamma aenv stream =<< travE sh- Backpermute sh _ _ -> backpermute kernel gamma aenv stream =<< travE sh- Reshape sh a -> reshape <$> travE sh <*> travA a-- -- Consumers- Fold _ _ a -> fold kernel gamma aenv stream =<< extent a- Fold1 _ a -> fold1 kernel gamma aenv stream =<< extent a- FoldSeg _ _ a s -> join $ foldSeg kernel gamma aenv stream <$> extent a <*> extent s- Fold1Seg _ a s -> join $ fold1Seg kernel gamma aenv stream <$> extent a <*> extent s- Scanl _ _ a -> scanl kernel gamma aenv stream =<< extent a- Scanr _ _ a -> scanr kernel gamma aenv stream =<< extent a- Scanl1 _ a -> scanl1 kernel gamma aenv stream =<< extent a- Scanr1 _ a -> scanr1 kernel gamma aenv stream =<< extent a- Scanl' _ _ a -> scanl' kernel gamma aenv stream =<< extent a- Scanr' _ _ a -> scanr' kernel gamma aenv stream =<< extent a- Permute _ d _ a -> join $ permute kernel gamma aenv stream (inplace d) <$> extent a <*> travA d- Stencil _ _ a -> stencil1 kernel gamma aenv stream =<< travA a- Stencil2 _ _ a _ b -> join $ stencil2 kernel gamma aenv stream <$> travA a <*> travA b+executeOpenAcc !topAcc !aenv !stream = travA topAcc+ where+ travA :: ExecOpenAcc arch aenv a -> LLVM arch a+ travA (EvalAcc pacc) =+ case pacc of+ Use arrs -> get =<< useRemoteAsync (toArr arrs) stream+ Unit x -> newRemote Z . const =<< travE x+ Avar ix -> avar ix+ Alet bnd body -> alet bnd body+ Apply f a -> travAF f =<< async (executeOpenAcc a aenv)+ Atuple tup -> toAtuple <$> travT tup+ Aprj ix tup -> evalPrj ix . fromAtuple <$> travA tup+ Acond p t e -> acond t e =<< travE p+ Awhile p f a -> awhile p f =<< travA a+ Reshape sh ix -> reshape <$> travE sh <*> avar ix+ Unzip tix ix -> unzip tix <$> avar ix+ Aforeign asm a -> aforeign asm =<< travA a - -- Removed by fusion- Replicate{} -> fusionError- Slice{} -> fusionError- ZipWith{} -> fusionError+ travA (ExecAcc !gamma !kernel pacc) =+ case pacc of+ -- Producers+ Map sh -> map kernel gamma aenv stream =<< travE sh+ Generate sh -> generate kernel gamma aenv stream =<< travE sh+ Transform sh -> transform kernel gamma aenv stream =<< travE sh+ Backpermute sh -> backpermute kernel gamma aenv stream =<< travE sh - where- fusionError :: error- fusionError = $internalError "execute" $ "unexpected fusible material: " ++ showPreAccOp pacc+ -- Consumers+ Fold sh -> fold kernel gamma aenv stream =<< travE sh+ Fold1 sh -> fold1 kernel gamma aenv stream =<< travE sh+ FoldSeg sa ss -> id =<< foldSeg kernel gamma aenv stream <$> travE sa <*> travE ss+ Fold1Seg sa ss -> id =<< fold1Seg kernel gamma aenv stream <$> travE sa <*> travE ss+ Scanl sh -> scanl kernel gamma aenv stream =<< travE sh+ Scanr sh -> scanr kernel gamma aenv stream =<< travE sh+ Scanl1 sh -> scanl1 kernel gamma aenv stream =<< travE sh+ Scanr1 sh -> scanr1 kernel gamma aenv stream =<< travE sh+ Scanl' sh -> scanl' kernel gamma aenv stream =<< travE sh+ Scanr' sh -> scanr' kernel gamma aenv stream =<< travE sh+ Permute sh d -> id =<< permute kernel gamma aenv stream (inplace d) <$> travE sh <*> travA d+ Stencil2 a b -> id =<< stencil2 kernel gamma aenv stream <$> avar a <*> avar b+ Stencil a -> stencil1 kernel gamma aenv stream =<< avar a - -- Term traversals- -- ---------------- travA :: ExecOpenAcc arch aenv a -> LLVM arch a- travA acc = executeOpenAcc acc aenv stream+ travAF :: ExecOpenAfun arch aenv (a -> b) -> AsyncR arch a -> LLVM arch b+ travAF (Alam (Abody f)) a = get =<< async (executeOpenAcc f (aenv `Apush` a))+ travAF _ _ = error "boop!" travE :: ExecExp arch aenv t -> LLVM arch t travE exp = executeExp exp aenv stream@@ -317,28 +348,25 @@ travT NilAtup = return () travT (SnocAtup t a) = (,) <$> travT t <*> travA a - -- get the extent of an embedded array- extent :: Shape sh => ExecOpenAcc arch aenv (Array sh e) -> LLVM arch sh- extent ExecAcc{} = $internalError "executeOpenAcc" "expected delayed array"- extent (EmbedAcc sh) = travE sh- extent (UnzipAcc _ ix) = let AsyncR _ a = aprj ix aenv- in return $ shape a-- inplace :: ExecOpenAcc arch aenv a -> Bool- inplace (ExecAcc _ _ Avar{}) = False- inplace _ = True-- -- Skeleton implementation- -- -----------------------+ -- Bound terms. Let-bound input arrays (Use nodes) are copied to the device+ -- asynchronously, so that they may overlap other computations if possible.+ alet :: ExecOpenAcc arch aenv bnd -> ExecOpenAcc arch (aenv, bnd) body -> LLVM arch body+ alet bnd body = do+ bnd' <- case bnd of+ EvalAcc (Use arrs) -> do AsyncR _ bnd' <- async (useRemoteAsync (toArr arrs))+ return bnd'+ _ -> async (executeOpenAcc bnd aenv)+ body' <- executeOpenAcc body (aenv `Apush` bnd') stream+ return body' - -- Change the shape of an array without altering its contents. This does not- -- execute any kernel programs.- reshape :: Shape sh => sh -> Array sh' e -> Array sh e- reshape sh (Array sh' adata)- = $boundsCheck "reshape" "shape mismatch" (size sh == R.size sh')- $ Array (fromElt sh) adata+ -- Access bound variables+ avar :: Idx aenv a -> LLVM arch a+ avar ix = do+ let AsyncR event arr = aprj ix aenv+ after stream event+ return arr - -- Array level conditional+ -- Array level conditionals acond :: ExecOpenAcc arch aenv a -> ExecOpenAcc arch aenv a -> Bool -> LLVM arch a acond yes _ True = travA yes acond _ no False = travA no@@ -350,26 +378,18 @@ -> LLVM arch a awhile p f a = do e <- checkpoint stream- r <- executeOpenAfun1 p aenv (AsyncR e a)+ r <- travAF p (AsyncR e a) ok <- indexRemote r 0- if ok then awhile p f =<< executeOpenAfun1 f aenv (AsyncR e a)+ if ok then awhile p f =<< travAF f (AsyncR e a) else return a - -- Foreign functions- foreignA :: (Arrays a, Arrays b, Foreign arch, S.Foreign asm)- => asm (a -> b)- -> a- -> LLVM arch b- foreignA asm a =- case foreignAcc (undefined :: arch) asm of- Just f -> f stream a- Nothing -> $internalError "foreignA" "failed to recover foreign function the second time"+ -- Change the shape of an array without altering its contents+ reshape :: Shape sh => sh -> Array sh' e -> Array sh e+ reshape sh (Array sh' adata)+ = $boundsCheck "reshape" "shape mismatch" (size sh == R.size sh')+ $ Array (fromElt sh) adata -executeOpenAcc (UnzipAcc tup v) aenv stream = do- let AsyncR event arr = aprj v aenv- after stream event- return $ unzip tup arr- where+ -- Pull apart the unzipped struct-of-array representation unzip :: forall t sh e. (Elt t, Elt e) => TupleIdx (TupleRepr t) e -> Array sh t -> Array sh e unzip tix (Array sh adata) = Array sh $ go tix (eltType (undefined::t)) adata where@@ -378,6 +398,21 @@ go ZeroTupIdx (PairTuple _ t) (AD_Pair _ x) | Just Refl <- matchTupleType t (eltType (undefined::e)) = x go _ _ _ = $internalError "unzip" "inconsistent valuation"++ -- Foreign functions+ aforeign :: (Arrays a, Arrays b, Foreign arch, S.Foreign asm)+ => asm (a -> b)+ -> a+ -> LLVM arch b+ aforeign asm a =+ case foreignAcc (undefined :: arch) asm of+ Just f -> f stream a+ Nothing -> $internalError "foreignA" "failed to recover foreign function the second time"++ -- Can the permutation function write directly into the results array?+ inplace :: ExecOpenAcc arch aenv a -> Bool+ inplace (EvalAcc Avar{}) = False+ inplace _ = True -- Scalar expression evaluation
Data/Array/Accelerate/LLVM/Execute/Async.hs view
@@ -68,11 +68,13 @@ -- | Wait for an asynchronous operation to complete, then return it. --+{-# INLINEABLE get #-} get :: Async arch => AsyncR arch a -> LLVM arch a get (AsyncR e a) = block e >> return a -- | Execute the given operation asynchronously in a new execution stream. --+{-# INLINEABLE async #-} async :: Async arch => (StreamR arch -> LLVM arch a) -> LLVM arch (AsyncR arch a)
+ Data/Array/Accelerate/LLVM/Link.hs view
@@ -0,0 +1,203 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module : Data.Array.Accelerate.LLVM.Link+-- Copyright : [2017] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.Link (++ Link(..),+ linkAcc, linkAfun,++ ExecOpenAcc(..), ExecOpenAfun,+ ExecAcc, ExecAfun,+ ExecExp, ExecOpenExp,+ ExecFun, ExecOpenFun++) where++-- accelerate+import Data.Array.Accelerate.Array.Sugar hiding ( Foreign )+import Data.Array.Accelerate.Error++import Data.Array.Accelerate.LLVM.AST+import Data.Array.Accelerate.LLVM.CodeGen.Environment+import Data.Array.Accelerate.LLVM.Compile+import Data.Array.Accelerate.LLVM.State++import Control.Applicative hiding ( Const )+import Control.DeepSeq+import Prelude hiding ( exp )+++class Link arch where+ data ExecutableR arch++ -- | Link a target-specific object file into the current context to produce an+ -- executable functions.+ --+ linkForTarget+ :: ObjectR arch+ -> LLVM arch (ExecutableR arch)+++-- | Annotate an open array expression with executable code loaded into the+-- target address space, suitable for execution.+--+data ExecOpenAcc arch aenv a where+ ExecAcc :: Gamma aenv+ -> ExecutableR arch+ -> PreOpenAccSkeleton (ExecOpenAcc arch) aenv a+ -> ExecOpenAcc arch aenv a++ EvalAcc :: Arrays a+ => PreOpenAccCommand (ExecOpenAcc arch) aenv a+ -> ExecOpenAcc arch aenv a++-- An AST annotated with compiled and linked functions in the target address+-- space, suitable for execution.+--+type ExecOpenAfun arch = PreOpenAfun (ExecOpenAcc arch)+type ExecOpenExp arch = PreOpenExp (ExecOpenAcc arch)+type ExecOpenFun arch = PreOpenFun (ExecOpenAcc arch)++type ExecAcc arch a = ExecOpenAcc arch () a+type ExecAfun arch a = ExecOpenAfun arch () a++type ExecExp arch = ExecOpenExp arch ()+type ExecFun arch = ExecOpenFun arch ()+++-- | Link the compiled code for an array expression into the target address+-- space. Additionally, copy input array data into the target address space.+--+{-# INLINEABLE linkAcc #-}+linkAcc+ :: Link arch+ => CompiledAcc arch a+ -> LLVM arch (ExecAcc arch a)+linkAcc = linkOpenAcc++{-# INLINEABLE linkAfun #-}+linkAfun+ :: Link arch+ => CompiledAfun arch f+ -> LLVM arch (ExecAfun arch f)+linkAfun = linkOpenAfun+++{-# INLINEABLE linkOpenAfun #-}+linkOpenAfun+ :: Link arch+ => CompiledOpenAfun arch aenv f+ -> LLVM arch (ExecOpenAfun arch aenv f)+linkOpenAfun (Alam l) = Alam <$> linkOpenAfun l+linkOpenAfun (Abody b) = Abody <$> linkOpenAcc b++{-# INLINEABLE linkOpenAcc #-}+linkOpenAcc+ :: forall arch _aenv _a. Link arch+ => CompiledOpenAcc arch _aenv _a+ -> LLVM arch (ExecOpenAcc arch _aenv _a)+linkOpenAcc = travA+ where+ travA :: forall aenv arrs. CompiledOpenAcc arch aenv arrs -> LLVM arch (ExecOpenAcc arch aenv arrs)+ travA (PlainAcc pacc) = EvalAcc <$>+ case pacc of+ Unzip tix ix -> return (Unzip tix ix)+ Avar ix -> return (Avar ix)+ Use arrs -> rnfArrs (arrays (undefined::arrs)) arrs `seq` return (Use arrs)+ Unit e -> Unit <$> travE e+ Alet a b -> Alet <$> travA a <*> travA b+ Apply f a -> Apply <$> travAF f <*> travA a+ Awhile p f a -> Awhile <$> travAF p <*> travAF f <*> travA a+ Acond p t e -> Acond <$> travE p <*> travA t <*> travA e+ Atuple tup -> Atuple <$> travAtup tup+ Aprj ix tup -> Aprj ix <$> travA tup+ Reshape s ix -> Reshape <$> travE s <*> pure ix+ Aforeign asm a -> Aforeign asm <$> travA a++ travA (BuildAcc aenv obj pacc) = ExecAcc aenv <$> linkForTarget obj <*>+ case pacc of+ Map sh -> Map <$> travE sh+ Generate sh -> Generate <$> travE sh+ Transform sh -> Transform <$> travE sh+ Backpermute sh -> Backpermute <$> travE sh+ Fold sh -> Fold <$> travE sh+ Fold1 sh -> Fold1 <$> travE sh+ FoldSeg sa ss -> FoldSeg <$> travE sa <*> travE ss+ Fold1Seg sa ss -> Fold1Seg <$> travE sa <*> travE ss+ Scanl sh -> Scanl <$> travE sh+ Scanl1 sh -> Scanl1 <$> travE sh+ Scanl' sh -> Scanl' <$> travE sh+ Scanr sh -> Scanr <$> travE sh+ Scanr1 sh -> Scanr1 <$> travE sh+ Scanr' sh -> Scanr' <$> travE sh+ Permute sh d -> Permute <$> travE sh <*> travA d+ Stencil a -> return (Stencil a)+ Stencil2 a b -> return (Stencil2 a b)++ travAF :: CompiledOpenAfun arch aenv f+ -> LLVM arch (ExecOpenAfun arch aenv f)+ travAF = linkOpenAfun++ travAtup :: Atuple (CompiledOpenAcc arch aenv) a+ -> LLVM arch (Atuple (ExecOpenAcc arch aenv) a)+ travAtup NilAtup = return NilAtup+ travAtup (SnocAtup t a) = SnocAtup <$> travAtup t <*> travA a++ travF :: CompiledOpenFun arch env aenv t+ -> LLVM arch (ExecOpenFun arch env aenv t)+ travF (Body b) = Body <$> travE b+ travF (Lam f) = Lam <$> travF f++ travE :: CompiledOpenExp arch env aenv t+ -> LLVM arch (ExecOpenExp arch env aenv t)+ travE exp =+ case exp of+ Var ix -> return (Var ix)+ Const c -> return (Const c)+ PrimConst c -> return (PrimConst c)+ IndexAny -> return IndexAny+ IndexNil -> return IndexNil+ Let a b -> Let <$> travE a <*> travE b+ IndexCons t h -> IndexCons <$> travE t <*> travE h+ IndexHead h -> IndexHead <$> travE h+ IndexTail t -> IndexTail <$> travE t+ IndexSlice slix x s -> (IndexSlice slix) <$> travE x <*> travE s+ IndexFull slix x s -> (IndexFull slix) <$> travE x <*> travE s+ ToIndex s i -> ToIndex <$> travE s <*> travE i+ FromIndex s i -> FromIndex <$> travE s <*> travE i+ Tuple t -> Tuple <$> travT t+ Prj ix e -> (Prj ix) <$> travE e+ Cond p t e -> Cond <$> travE p <*> travE t <*> travE e+ While p f x -> While <$> travF p <*> travF f <*> travE x+ PrimApp f e -> (PrimApp f) <$> travE e+ Index a e -> Index <$> travA a <*> travE e+ LinearIndex a e -> LinearIndex <$> travA a <*> travE e+ Shape a -> Shape <$> travA a+ ShapeSize e -> ShapeSize <$> travE e+ Intersect x y -> Intersect <$> travE x <*> travE y+ Union x y -> Union <$> travE x <*> travE y+ Foreign asm _ x -> Foreign asm err <$> travE x+ where err = $internalError "link" "attempt to use fallback foreign expression"++ travT :: Tuple (CompiledOpenExp arch env aenv) t+ -> LLVM arch (Tuple (ExecOpenExp arch env aenv) t)+ travT NilTup = return NilTup+ travT (SnocTup t e) = SnocTup <$> travT t <*> travE e++ rnfArrs :: ArraysR a -> a -> ()+ rnfArrs (ArraysRpair ar1 ar2) (a1, a2) = rnfArrs ar1 a1 `seq` rnfArrs ar2 a2+ rnfArrs ArraysRarray arr = rnf arr+ rnfArrs ArraysRunit () = ()+
+ Data/Array/Accelerate/LLVM/Link/Cache.hs view
@@ -0,0 +1,114 @@+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module : Data.Array.Accelerate.LLVM.Link.Cache+-- Copyright : [2017] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.Link.Cache (++ LinkCache,+ new, dlsym,++) where++import Data.Array.Accelerate.Lifetime+import Data.Array.Accelerate.Debug++import Control.Monad+import Control.Concurrent.MVar+import Data.IntMap.Strict ( IntMap )+import Prelude hiding ( lookup )+import Text.Printf+import qualified Data.IntMap.Strict as IM+++-- Simple reference-counted linker cache for function tables 'f' implemented by+-- object code 'o'.+--+data LinkCache f o = LinkCache {-# UNPACK #-} !(MVar (IntMap (Entry f o)))+data Entry f o = Entry {-# UNPACK #-} !Int !f !o+++-- Create a new linker cache+--+new :: IO (LinkCache f o)+new = LinkCache `liftM` newMVar IM.empty+++-- Return the binding addresses for the given kernel functions (by key). If the+-- functions do not already exist in the cache, the supplied continuation will+-- be run in order to generate them. This happens as a single atomic step; thus+-- the cache is thread safe.+--+dlsym :: Int -> LinkCache f o -> IO (f,o) -> IO (Lifetime f)+dlsym key cache@(LinkCache var) k = do+ modifyMVar var $ \im ->+ case IM.lookup key im of+ -- Run the supplied function to generate the object code and add to the cache+ Nothing -> do+ (f,o) <- k+ ticket <- issue key f cache+ return ( IM.insert key (Entry 1 f o) im, ticket )++ -- Return the existing object code+ Just (Entry c f o) -> do+ ticket <- issue key f cache+ return ( IM.insert key (Entry (c+1) f o) im, ticket )+++{--+-- Insert the given function table and object code into the cache. The returned+-- value must be kept alive for as long as you need the object code to live;+-- linker table entries are removed once all tickets referring to them are+-- GC'ed.+--+-- NOTE: It is an error if the entry already exists in the table. Thus, there is+-- a potential race condition between 'lookup' and 'insert'. On collision, it+-- would be fine to return a reference to the existing implementation instead+-- and discard the input values, but 'dlsym' solves this anyway.+--+insert :: Int -> f -> o -> LinkCache f o -> IO (Lifetime f)+insert key functionTable objectCode cache@(LinkCache var) = do+ ticket <- issue key functionTable cache+ modifyMVar_ var $ \im ->+ let collision = $internalError "insert" "duplicate entry"+ in return $! IM.insertWith collision key (Entry 1 functionTable objectCode) im+ --+ return ticket+++-- Check the linker cache for the given functions; if found return the+-- corresponding function table.+--+lookup :: Int -> LinkCache f o -> IO (Maybe (Lifetime f))+lookup key cache@(LinkCache var) = do+ modifyMVar var $ \im ->+ case IM.lookup key im of+ Nothing -> return (im, Nothing)+ Just (Entry c f o) -> do+ ticket <- issue key f cache+ return ( IM.insert key (Entry (c+1) f o) im, Just ticket )+--}+++-- Issue a new ticket for the given table key/function table. When the returned+-- lifetime is GC'ed it decreasing the reference count of the corresponding+-- entry, and removes it from the table entirely once the count drops to zero.+--+issue :: Int -> f -> LinkCache f o -> IO (Lifetime f)+issue key fun (LinkCache var) = do+ ticket <- newLifetime fun+ addFinalizer ticket $+ let refcount (Entry c f o)+ | c <= 1 = trace dump_ld (printf "ld: remove object code %016x" key) Nothing+ | otherwise = Just (Entry (c-1) f o)+ in+ modifyMVar_ var $ \im -> return $! IM.update refcount key im+ --+ return ticket+
Data/Array/Accelerate/LLVM/State.hs view
@@ -18,8 +18,8 @@ -- library import Control.Applicative ( Applicative ) import Control.Concurrent ( forkIO, threadDelay )-import Control.Monad.State ( StateT, MonadState, evalStateT ) import Control.Monad.Catch ( MonadCatch, MonadThrow, MonadMask )+import Control.Monad.State ( StateT, MonadState, evalStateT ) import Control.Monad.Trans ( MonadIO ) import Prelude
+ Data/Array/Accelerate/LLVM/State.hs-boot view
@@ -0,0 +1,17 @@+-- |+-- Module : Data.Array.Accelerate.LLVM.State-boot+-- Copyright : [2017] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.State+ where++import Control.Monad.State++newtype LLVM target a = LLVM { runLLVM :: StateT target IO a }+
Data/Array/Accelerate/LLVM/Target.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}@@ -17,13 +16,13 @@ module Data.Array.Accelerate.LLVM.Target where --- llvm-hs import LLVM.AST.DataLayout ( DataLayout )+import Data.ByteString.Short ( ShortByteString ) -- | Describes some target specific information needed for code generation -- class Target t where- targetTriple :: t {- dummy -} -> Maybe String+ targetTriple :: t {- dummy -} -> Maybe ShortByteString targetDataLayout :: t {- dummy -} -> Maybe DataLayout
+ Data/ByteString/Short/Char8.hs view
@@ -0,0 +1,46 @@+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module : Data.ByteString.Short.Char8+-- Copyright : [2017] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.ByteString.Short.Char8 (++ ShortByteString,+ pack,+ unpack,+ takeWhile,++) where++import Data.ByteString.Short ( ShortByteString )+import Prelude as P hiding ( takeWhile )+import qualified Data.ByteString.Internal as BI+import qualified Data.ByteString.Short as BS+import qualified Data.ByteString.Short.Extra as BS+++-- | /O(n)/ Convert a 'ShortByteString' into a list.+--+{-# INLINEABLE unpack #-}+unpack :: ShortByteString -> [Char]+unpack = P.map BI.w2c . BS.unpack++-- | /O(n)/ Convert a 'String' into a 'ShortByteString'.+--+{-# INLINEABLE pack #-}+pack :: String -> ShortByteString+pack = BS.pack . P.map BI.c2w++-- | 'takeWhile', applied to a predicate @p@ and a ShortByteString @xs@, returns+-- the longest prefix (possibly empty) of @xs@ of elements that satisfy @p@.+--+{-# INLINEABLE takeWhile #-}+takeWhile :: (Char -> Bool) -> ShortByteString -> ShortByteString+takeWhile f = BS.takeWhile (f . BI.w2c)+
+ Data/ByteString/Short/Extra.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module : Data.ByteString.Short.Extra+-- Copyright : [2017] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.ByteString.Short.Extra (++ ShortByteString,+ take,+ takeWhile,++) where++import Data.ByteString.Short ( ShortByteString )+import qualified Data.ByteString.Short as BS+import qualified Data.ByteString.Short.Internal as BI+import Prelude hiding ( take, takeWhile )++import GHC.ST+import GHC.Exts+import GHC.Word+++-- | /O(n)/ @'take' n@ applied to the ShortByteString @xs@, returns the prefix+-- of @xs@ of length @n@ as a new ShortByteString, or @xs@ itself if+-- @n > 'length' xs@+--+{-# INLINEABLE take #-}+take :: Int -> ShortByteString -> ShortByteString+take n xs+ | n >= BS.length xs = xs+ | otherwise = runST $ do+ mba <- newByteArray n+ copyByteArray (asBA xs) 0 mba 0 n+ ba <- unsafeFreezeByteArray mba+ return (asSBS ba)++-- | 'takeWhile', applied to a predicate @p@ and a ShortByteString @xs@, returns+-- the longest prefix (possibly empty) of @xs@ of elements that satisfy @p@.+--+{-# INLINEABLE takeWhile #-}+takeWhile :: (Word8 -> Bool) -> ShortByteString -> ShortByteString+takeWhile f ps = take (findIndexOrEnd (not . f) ps) ps+++-- | Return the index of the first element satisfying the predicate, otherwise+-- return the length of the string if no such element is found.+--+{-# INLINEABLE findIndexOrEnd #-}+findIndexOrEnd :: (Word8 -> Bool) -> ShortByteString -> Int+findIndexOrEnd p xs = go 0+ where+ !ba = asBA xs+ !n = BS.length xs+ --+ go !i | i >= n = i+ | p (indexWord8Array ba i) = i+ | otherwise = go (i+1)+++------------------------------------------------------------------------+-- Internal utils++asBA :: ShortByteString -> BA+asBA (BI.SBS ba#) = BA# ba#++asSBS :: BA -> ShortByteString+asSBS (BA# ba#) = BI.SBS ba#+++------------------------------------------------------------------------+-- Primop wrappers++data BA = BA# ByteArray#+data MBA s = MBA# (MutableByteArray# s)++indexWord8Array :: BA -> Int -> Word8+indexWord8Array (BA# ba#) (I# i#) = W8# (indexWord8Array# ba# i#)++newByteArray :: Int -> ST s (MBA s)+newByteArray (I# len#) =+ ST $ \s -> case newByteArray# len# s of+ (# s', mba# #) -> (# s', MBA# mba# #)++unsafeFreezeByteArray :: MBA s -> ST s BA+unsafeFreezeByteArray (MBA# mba#) =+ ST $ \s -> case unsafeFreezeByteArray# mba# s of+ (# s', ba# #) -> (# s', BA# ba# #)++copyByteArray :: BA -> Int -> MBA s -> Int -> Int -> ST s ()+copyByteArray (BA# src#) (I# src_off#) (MBA# dst#) (I# dst_off#) (I# len#) =+ ST $ \s -> case copyByteArray# src# src_off# dst# dst_off# len# s of+ s' -> (# s', () #)+
+ Data/IORef/Storable.hs view
@@ -0,0 +1,59 @@+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module : Data.IORef.Storable+-- Copyright : [2017] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--+-- A mutable reference in the 'IO' monad.+--++module Data.IORef.Storable (++ IORef,++ newIORef,+ readIORef,+ writeIORef,+ modifyIORef,++) where++import Foreign.ForeignPtr+import Foreign.Storable+import GHC.ForeignPtr+++-- | A pointer to a mutable object. Unlike 'Data.IORef.IORef', this is just+-- a pointer to the value, rather than a reference containing a boxed object.+-- This means that the value is stored strictly, and is only one pointer away.+--+data IORef a = IORef {-# UNPACK #-} !(ForeignPtr a)+++-- | Build a new 'IORef'+--+newIORef :: Storable a => a -> IO (IORef a)+newIORef v = do+ fp <- mallocPlainForeignPtr+ withForeignPtr fp $ \p -> poke p v+ return (IORef fp)++-- | Read the value of the 'IORef'+--+readIORef :: Storable a => IORef a -> IO a+readIORef (IORef fp) = withForeignPtr fp peek++-- | Write a new value into the 'IORef'+--+writeIORef :: Storable a => IORef a -> a -> IO ()+writeIORef (IORef fp) v = withForeignPtr fp $ \p -> poke p v++-- | Mutate the contents of an 'IORef'+--+modifyIORef :: Storable a => IORef a -> (a -> a) -> IO ()+modifyIORef ref f = readIORef ref >>= writeIORef ref . f+
LLVM/AST/Type/Metadata.hs view
@@ -13,20 +13,22 @@ module LLVM.AST.Type.Metadata where -import LLVM.AST.Type.Operand+import qualified LLVM.AST.Constant as LLVM import qualified LLVM.AST.Operand as LLVM +import Data.ByteString.Short ( ShortByteString ) --- | <http://llvm.org/docs/LangRef.html#metadata>++-- | Metadata does not have a type, and is not a value. ----- Metadata does not have a type, and is not a value.+-- <http://llvm.org/docs/LangRef.html#metadata> -- data MetadataNode- = MetadataNode [Maybe Metadata]- | MetadataNodeReference LLVM.MetadataNodeID+ = MetadataNode ![Maybe Metadata]+ | MetadataNodeReference {-# UNPACK #-} !LLVM.MetadataNodeID -data Metadata where- MetadataStringOperand :: String -> Metadata- MetadataOperand :: Operand a -> Metadata- MetadataNodeOperand :: MetadataNode -> Metadata+data Metadata+ = MetadataStringOperand {-# UNPACK #-} !ShortByteString+ | MetadataConstantOperand !LLVM.Constant+ | MetadataNodeOperand !MetadataNode
LLVM/AST/Type/Name.hs view
@@ -14,9 +14,10 @@ module LLVM.AST.Type.Name where +import Data.ByteString.Short ( ShortByteString ) import Data.Data-import Data.Word import Data.String+import Data.Word import Prelude @@ -46,12 +47,12 @@ -- type role Name representational data Name a- = Name String -- ^ a string name- | UnName Word -- ^ a number for a nameless thing+ = Name {-# UNPACK #-} !ShortByteString -- ^ a string name+ | UnName {-# UNPACK #-} !Word -- ^ a number for a nameless thing deriving (Eq, Ord, Read, Show, Typeable, Data) instance IsString (Name a) where- fromString = Name+ fromString = Name . fromString -- TLM: 'Name' is used a lot over the place, to refer to things like variables@@ -64,9 +65,13 @@ -- unsatisfactory... ) -- -data Label = Label String+data Label = Label {-# UNPACK #-} !ShortByteString deriving (Eq, Ord, Read, Show, Typeable, Data) instance IsString Label where- fromString = Label+ fromString = Label . fromString++instance Monoid Label where+ mempty = Label mempty+ mappend (Label x) (Label y) = Label (mappend x y)
+ README.md view
@@ -0,0 +1,188 @@+An LLVM backend for the Accelerate Array Language+=================================================++[](https://travis-ci.org/AccelerateHS/accelerate-llvm)+[](https://hackage.haskell.org/package/accelerate-llvm)+[](https://hub.docker.com/r/tmcdonell/accelerate-llvm/)+[](https://microbadger.com/images/tmcdonell/accelerate-llvm)++This package compiles Accelerate code to LLVM IR, and executes that code on+multicore CPUs as well as NVIDIA GPUs. This avoids the need to go through `nvcc`+or `clang`. For details on Accelerate, refer to the [main repository][GitHub].++We love all kinds of contributions, so feel free to open issues for missing+features as well as report (or fix!) bugs on the [issue tracker][Issues].++ [GitHub]: https://github.com/AccelerateHS/accelerate+ [Issues]: https://github.com/AccelerateHS/accelerate/issues+++ * [Dependencies](#dependencies)+ * [Docker](#docker)+ * [Installing LLVM](#installing-llvm)+ * [Homebrew](#homebrew)+ * [Debian/Ubuntu](#debianubuntu)+ * [Building from source](#building-from-source)+ * [Installing Accelerate-LLVM](#installing-accelerate-llvm)+ * [libNVVM](#libNVVM)+++Dependencies+------------++Haskell dependencies are available from Hackage, but there are several external+library dependencies that you will need to install as well:++ * [`LLVM`](http://llvm.org)+ * [`libFFI`](http://sourceware.org/libffi/) (if using the `accelerate-llvm-native` backend for multicore CPUs)+ * [`CUDA`](https://developer.nvidia.com/cuda-downloads) (if using the `accelerate-llvm-ptx` backend for NVIDIA GPUs)+++Docker+------++A [docker](https://www.docker.com) container is provided with this package+preinstalled (via stack) at `/opt/accelerate-llvm`. Note that if you wish to use+the `accelerate-llvm-ptx` GPU backend, you will need to install the [NVIDIA+docker](https://github.com/NVIDIA/nvidia-docker) plugin; see that page for more+information.++```sh+$ docker run -it tmcdonell/accelerate-llvm+```+++Installing LLVM+---------------++When installing LLVM, make sure that it includes the `libLLVM` shared library.+If you want to use the GPU targeting `accelerate-llvm-ptx` backend, make sure+you install (or build) LLVM with the 'nvptx' target.++## Homebrew++Example using [Homebrew](http://brew.sh) on macOS:++```sh+$ brew install llvm-hs/homebrew-llvm/llvm-4.0+```++## Debian/Ubuntu++For Debian/Ubuntu based Linux distributions, the LLVM.org website provides+binary distribution packages. Check [apt.llvm.org](http://apt.llvm.org) for+instructions for adding the correct package database for your OS version, and+then:++```sh+$ apt-get install llvm-4.0-dev+```++## Building from source++If your OS does not have an appropriate LLVM distribution available, you can also build from source. Detailed build instructions are available on the [LLVM.org website](http://releases.llvm.org/4.0.0/docs/CMake.html). Note that you will require at least [CMake 3.4.3](http://www.cmake.org/cmake/resources/software.html) and a recent C++ compiler; at least Clang 3.1, GCC 4.8, or Visual Studio 2015 (update 3).++ 1. Download and unpack the [LLVM-4.0 source code](http://releases.llvm.org/4.0.0/llvm-4.0.0.src.tar.xz). We'll refer to+ the path that the source tree was unpacked to as `LLVM_SRC`. Only the main+ LLVM source tree is required, but you can optionally add other components+ such as the Clang compiler or Polly loop optimiser. See the [LLVM releases](http://releases.llvm.org/download.html#4.0.0)+ page for the complete list.++ 2. Create a temporary build directory and `cd` into it, for example:+ ```sh+ $ mkdir /tmp/build+ $ cd /tmp/build+ ```++ 3. Execute the following to configure the build. Here `INSTALL_PREFIX` is+ where LLVM is to be installed, for example `/usr/local` or+ `$HOME/opt/llvm`:+ ```sh+ $ cmake $LLVM_SRC -DCMAKE_INSTALL_PREFIX=$INSTALL_PREFIX -DCMAKE_BUILD_TYPE=Release -DLLVM_ENABLE_ASSERTIONS=ON -DLLVM_BUILD_LLVM_DYLIB=ON -DLLVM_LINK_LLVM_DYLIB=ON+ ```+ See [options and variables](http://llvm.org/docs/CMake.html#options-and-variables)+ for a list of additional build parameters you can specify.++ 4. Build and install:+ ```sh+ $ cmake --build .+ $ cmake --build . --target install+ ```++ 5. For macOS only, some additional steps are useful to work around issues related+ to [System Integrity Protection](https://en.wikipedia.org/wiki/System_Integrity_Protection):+ ```sh+ cd $INSTALL_PREFIX/lib+ ln -s libLLVM.dylib libLLVM-4.0.dylib+ install_name_tool -id $PWD/libLTO.dylib libLTO.dylib+ install_name_tool -id $PWD/libLLVM.dylib libLLVM.dylib+ install_name_tool -change '@rpath/libLLVM.dylib' $PWD/libLLVM.dylib libLTO.dylib+ ```+++Installing Accelerate-LLVM+--------------------------++Once the dependencies are installed, we are ready to install `accelerate-llvm`.++For example, installation using [`stack`](http://docs.haskellstack.org/en/stable/README.html)+just requires you to point it to the appropriate configuration file:+```sh+$ ln -s stack-8.0.yaml stack.yaml+$ stack setup+$ stack install+```++Note that the version of [`llvm-hs`](https://hackage.haskell.org/package/llvm-hs)+used must match the installed version of LLVM, which is currently 4.0.+++## libNVVM++The `accelerate-llvm-ptx` backend can optionally be compiled to generate GPU+code using the `libNVVM` library, rather than LLVM's inbuilt NVPTX code+generator. `libNVVM` is a closed-source library distributed as part of the+NVIDIA CUDA toolkit, and is what the `nvcc` compiler itself uses internally when+compiling CUDA C code.++Using `libNVVM` _may_ improve GPU performance compared to the code generator+built in to LLVM. One difficulty with using it however is that since `libNVVM`+is also based on LLVM, and typically lags LLVM by several releases, you must+install `accelerate-llvm` with a "compatible" version of LLVM, which will depend+on the version of the CUDA toolkit you have installed. The following table shows+some combinations:++| | LLVM-3.3 | LLVM-3.4 | LLVM-3.5 | LLVM-3.8 | LLVM-3.9 | LLVM-4.0 |+|:------------:|:--------:|:--------:|:--------:|:--------:|:--------:|:--------:|+| **CUDA-7.0** | ⭕ | ❌ | | | | |+| **CUDA-7.5** | | ⭕ | ⭕ | ❌ | | |+| **CUDA-8.0** | | | ⭕ | ⭕ | ❌ | ❌ |++Where ⭕ = Works, and ❌ = Does not work.++Note that the above restrictions on CUDA and LLVM version exist _only_ if you+want to use the NVVM component. Otherwise, you should be free to use any+combination of CUDA and LLVM.++Also note that `accelerate-llvm-ptx` itself currently requires at least LLVM-3.5.++Using `stack`, either edit the `stack.yaml` and add the following section:++```yaml+flags:+ accelerate-llvm-ptx:+ nvvm: true+```++Or install using the following option on the command line:++```sh+$ stack install accelerate-llvm-ptx --flag accelerate-llvm-ptx:nvvm+```++If installing via `cabal`:++```sh+$ cabal install accelerate-llvm-ptx -fnvvm+```+
accelerate-llvm.cabal view
@@ -1,14 +1,72 @@ name: accelerate-llvm-version: 1.0.0.0+version: 1.1.0.0 cabal-version: >= 1.10-tested-with: GHC == 7.8.*+tested-with: GHC >= 7.10 build-type: Simple -synopsis: Accelerate backend generating LLVM+synopsis: Accelerate backend component generating LLVM IR description: This library implements direct LLVM IR generation for the /Accelerate/- language. For further information, refer to the main /Accelerate/ package:- <http://hackage.haskell.org/package/accelerate>+ language. For further information, refer to the main+ <http://hackage.haskell.org/package/accelerate accelerate> package.+ .+ [/Dependencies/]+ .+ Haskell dependencies are available from Hackage. The following external+ libraries are alse required:+ .+ * <http://llvm.org LLVM>+ .+ * <http://sourceware.org/libffi/ libFFI> (if using <http://hackage.haskell.org/package/accelerate-llvm-native accelerate-llvm-native>)+ .+ * <https://developer.nvidia.com/cuda-downloads CUDA> (if using <http://hackage.haskell.org/package/accelerate-llvm-ptx accelerate-llvm-ptx>)+ .+ [/Installing LLVM/]+ .+ /Homebrew/+ .+ Example using Homebrew on macOS:+ .+ > brew install llvm-hs/homebrew-llvm/llvm-5.0+ .+ /Debian & Ubuntu/+ .+ For Debian/Ubuntu based Linux distributions, the LLVM.org website provides+ binary distribution packages. Check <http://apt.llvm.org apt.llvm.org> for+ instructions for adding the correct package database for your OS version,+ and then:+ .+ > apt-get install llvm-5.0-dev+ .+ /Building from source/+ .+ If your OS does not have an appropriate LLVM distribution available, you can+ also build from source. Detailed build instructions are available on+ <http://releases.llvm.org/5.0.0/docs/CMake.html LLVM.org>. Make sure to+ include the cmake build options+ @-DLLVM_BUILD_LLVM_DYLIB=ON -DLLVM_LINK_LLVM_DYLIB=ON@ so that the @libLLVM@+ shared library will be built.+ .+ If using the @accelerate-llvm-ptx@ backend, also ensure that the+ @LLVM_TARGETS_TO_BUILD@ option includes the @NVPTX@ target (if not+ specified, all targets are built).+ .+ [/Installing accelerate-llvm/]+ .+ To use @accelerate-llvm@ it is important that the @llvm-hs@ package is+ installed against the @libLLVM@ shared library, rather than statically+ linked, so that we can use LLVM from GHCi and Template Haskell. This is the+ default configuration, but you can also enforce this explicitly by adding+ the following to your @stack.yaml@ file:+ .+ > flags:+ > llvm-hs:+ > shared-llvm: true+ .+ Or by specifying the @shared-llvm@ flag to cabal:+ .+ > cabal install llvm-hs -fshared-llvm+ . license: BSD3 license-file: LICENSE@@ -17,12 +75,16 @@ bug-reports: https://github.com/AccelerateHS/accelerate/issues category: Compilers/Interpreters, Concurrency, Data, Parallelism +extra-source-files:+ CHANGELOG.md+ README.md + -- Configuration flags -- ------------------- Flag debug- Default: True+ Default: False Description: Enable debug tracing message flags. Note that 'debug' must be enabled in the base 'accelerate' package as well. See the 'accelerate' package for usage@@ -33,11 +95,11 @@ Description: Enable bounds checking Flag unsafe-checks- Default: True+ Default: False Description: Enable bounds checking in unsafe operations Flag internal-checks- Default: True+ Default: False Description: Enable internal consistency checks Flag chase-lev@@ -51,6 +113,7 @@ Library exposed-modules: -- Accelerate-LLVM middle-end+ Data.Array.Accelerate.LLVM.AST Data.Array.Accelerate.LLVM.Analysis.Match Data.Array.Accelerate.LLVM.Array.Data Data.Array.Accelerate.LLVM.CodeGen@@ -73,11 +136,15 @@ Data.Array.Accelerate.LLVM.CodeGen.Sugar Data.Array.Accelerate.LLVM.CodeGen.Type Data.Array.Accelerate.LLVM.Compile+ Data.Array.Accelerate.LLVM.Compile.Cache+ Data.Array.Accelerate.LLVM.Embed Data.Array.Accelerate.LLVM.Execute Data.Array.Accelerate.LLVM.Execute.Async Data.Array.Accelerate.LLVM.Execute.Environment Data.Array.Accelerate.LLVM.Execute.Marshal Data.Array.Accelerate.LLVM.Foreign+ Data.Array.Accelerate.LLVM.Link+ Data.Array.Accelerate.LLVM.Link.Cache Data.Array.Accelerate.LLVM.State Data.Array.Accelerate.LLVM.Target Data.Array.Accelerate.LLVM.Util@@ -105,21 +172,34 @@ Control.Parallel.Meta.Resource.Single Control.Parallel.Meta.Resource.SMP Control.Parallel.Meta.Trans.LBS+ Data.IORef.Storable Data.Range.Range + -- Extras+ Data.ByteString.Short.Char8+ Data.ByteString.Short.Extra++ other-modules:+ Paths_accelerate_llvm+ build-depends:- base >= 4.7 && < 4.10+ base >= 4.7 && < 4.11 , abstract-deque >= 0.3- , accelerate == 1.0.*- , containers >= 0.5 && < 0.6+ , accelerate == 1.1.*+ , bytestring >= 0.10.4+ , containers >= 0.5 , data-default-class >= 0.0.1+ , deepseq >= 1.3+ , directory >= 1.0 , dlist >= 0.6 , exceptions >= 0.6 , fclabels >= 2.0- , llvm-hs >= 3.9- , llvm-hs-pure >= 3.9+ , filepath >= 1.0+ , llvm-hs >= 4.1 && < 5.1+ , llvm-hs-pure >= 4.1 && < 5.1 , mtl >= 2.0 , mwc-random >= 0.13+ , template-haskell , unordered-containers >= 0.2 , vector >= 0.10 @@ -154,7 +234,7 @@ source-repository this type: git- tag: 1.0.0.0+ tag: 1.1.0.0 location: https://github.com/AccelerateHS/accelerate-llvm.git -- vim: nospell