accelerate-cuda 0.12.1.2 → 0.13.0.0
raw patch · 31 files changed
+4849/−3089 lines, 31 filesdep +SafeSemaphoredep +old-timedep −containersdep ~acceleratedep ~binarydep ~bytestringbuild-type:Customsetup-changed
Dependencies added: SafeSemaphore, old-time
Dependencies removed: containers
Dependency ranges changed: accelerate, binary, bytestring, cryptohash, cuda, directory, fclabels, filepath, hashable, hashtables, language-c-quote, mainland-pretty, mtl, pretty, process, srcloc, text, transformers, unordered-containers
Files
- Data/Array/Accelerate/CUDA.hs +173/−72
- Data/Array/Accelerate/CUDA/AST.hs +102/−46
- Data/Array/Accelerate/CUDA/Analysis/Device.hs +3/−6
- Data/Array/Accelerate/CUDA/Analysis/Launch.hs +46/−39
- Data/Array/Accelerate/CUDA/Array/Data.hs +142/−66
- Data/Array/Accelerate/CUDA/Array/Nursery.hs +125/−0
- Data/Array/Accelerate/CUDA/Array/Prim.hs +126/−75
- Data/Array/Accelerate/CUDA/Array/Table.hs +89/−41
- Data/Array/Accelerate/CUDA/Async.hs +61/−0
- Data/Array/Accelerate/CUDA/CodeGen.hs +556/−302
- Data/Array/Accelerate/CUDA/CodeGen/Base.hs +298/−119
- Data/Array/Accelerate/CUDA/CodeGen/IndexSpace.hs +168/−294
- Data/Array/Accelerate/CUDA/CodeGen/Mapping.hs +34/−78
- Data/Array/Accelerate/CUDA/CodeGen/Monad.hs +93/−53
- Data/Array/Accelerate/CUDA/CodeGen/PrefixSum.hs +352/−134
- Data/Array/Accelerate/CUDA/CodeGen/Reduction.hs +480/−291
- Data/Array/Accelerate/CUDA/CodeGen/Stencil.hs +196/−131
- Data/Array/Accelerate/CUDA/CodeGen/Type.hs +47/−12
- Data/Array/Accelerate/CUDA/Compile.hs +327/−180
- Data/Array/Accelerate/CUDA/Context.hs +142/−0
- Data/Array/Accelerate/CUDA/Debug.hs +38/−11
- Data/Array/Accelerate/CUDA/Execute.hs +663/−942
- Data/Array/Accelerate/CUDA/Foreign.hs +158/−0
- Data/Array/Accelerate/CUDA/FullList.hs +44/−6
- Data/Array/Accelerate/CUDA/Persistent.hs +94/−26
- Data/Array/Accelerate/CUDA/State.hs +51/−104
- Data/Array/Accelerate/Internal/Check.hs +23/−10
- Setup.hs +17/−1
- accelerate-cuda.cabal +58/−49
- cubits/accelerate_cuda_function.h +142/−0
- cubits/accelerate_cuda_shape.h +1/−1
Data/Array/Accelerate/CUDA.hs view
@@ -1,8 +1,11 @@-{-# LANGUAGE BangPatterns, CPP, GADTs, ScopedTypeVariables #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-} -- | -- Module : Data.Array.Accelerate.CUDA -- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee--- [2009..2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell+-- [2009..2013] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell -- License : BSD3 -- -- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>@@ -10,15 +13,95 @@ -- Portability : non-portable (GHC extensions) -- -- This module implements the CUDA backend for the embedded array language--- Accelerate. Expressions are on-line translated into CUDA code, compiled, and--- executed in parallel on the GPU.+-- /Accelerate/. Expressions are on-line translated into CUDA code, compiled,+-- and executed in parallel on the GPU. -- -- The accelerate-cuda library is hosted at: <https://github.com/AccelerateHS/accelerate-cuda>. -- Comments, bug reports, and patches, are always welcome. -- ----- /NOTES:/+-- [/Data transfer:/] --+-- GPUs typically have their own attached memory, which is separate from the+-- computer's main memory. Hence, every 'Data.Array.Accelerate.use' operation+-- implies copying data to the device, and every 'run' operation must copy the+-- results of a computation back to the host.+--+-- Thus, it is best to keep all computations in the 'Acc' meta-language form and+-- only 'run' the computation once at the end, to avoid transferring (unused)+-- intermediate results.+--+-- Note that once an array has been transferred to the GPU, it will remain there+-- for as long as that array remains alive on the host. Any subsequent calls to+-- 'Data.Array.Accelerate.use' will find the array cached on the device and not+-- re-transfer the data.+--+--+-- [/Caching and performance:/]+--+-- When the program runs, the /Accelerate/ library evaluates the expression+-- passed to 'run' to make a series of CUDA kernels. Each kernel takes some+-- arrays as inputs and produces arrays as output. Each kernel is a piece of+-- CUDA code that has to be compiled and loaded onto the GPU; this can take a+-- while, so we remember which kernels we have seen before and try to re-use+-- them.+--+-- The goal is to make kernels that can be re-used. If we don't, the overhead of+-- compiling new kernels can ruin performance.+--+-- For example, consider the following implementation of the function+-- 'Data.Array.Accelerate.drop' for vectors:+--+-- > drop :: Elt e => Exp Int -> Acc (Vector e) -> Acc (Vector e)+-- > drop n arr =+-- > let n' = the (unit n)+-- > in backpermute (ilift1 (subtract n') (shape arr)) (ilift1 (+ n')) arr+--+-- Why did we go to the trouble of converting the @n@ value into a scalar array+-- using 'Data.Array.Accelerate.unit', and then immediately extracting that+-- value using 'Data.Array.Accelerate.the'?+--+-- We can look at the expression /Accelerate/ sees by evaluating the argument to+-- 'run'. Here is what a typical call to 'Data.Array.Accelerate.drop' evaluates+-- to:+--+-- >>> drop (constant 4) (use (fromList (Z:.10) [1..]))+-- let a0 = use (Array (Z :. 10) [1,2,3,4,5,6,7,8,9,10]) in+-- let a1 = unit 4+-- in backpermute+-- (let x0 = Z in x0 :. (indexHead (shape a0)) - (a1!x0))+-- (\x0 -> let x1 = Z in x1 :. (indexHead x0) + (a1!x1))+-- a0+--+-- The important thing to note is the line @let a1 = unit 4@. This corresponds+-- to the scalar array we created for the @n@ argument to+-- 'Data.Array.Accelerate.drop' and it is /outside/ the call to+-- 'Data.Array.Accelerate.backpermute'. The 'Data.Array.Accelerate.backpermute'+-- function is what turns into a CUDA kernel, and to ensure that we get the same+-- kernel each time we need the arguments to it to remain constant.+--+-- Let us see what happens if we change 'Data.Array.Accelerate.drop' to instead+-- use its argument @n@ directly:+--+-- >>> drop (constant 4) (use (fromList (Z:.10) [1..]))+-- let a0 = use (Array (Z :. 10) [1,2,3,4,5,6,7,8,9,10])+-- in backpermute (Z :. -4 + (indexHead (shape a0))) (\x0 -> Z :. 4 + (indexHead x0)) a0+--+-- Instead of @n@ being outside the call to 'Data.Array.Accelerate.backpermute',+-- it is now embedded in it. This will defeat /Accelerate/'s caching of CUDA+-- kernels. Whenever the value of @n@ changes, a new kernel will need to be+-- compiled.+--+-- The rule of thumb is to make sure that any arguments that change are always+-- passed in as arrays, not embedded in the code as constants.+--+-- How can you tell if you got it wrong? One way is to look at the code+-- directly, as in this example. Another is to use the debugging options+-- provided by the library. See debugging options below.+--+--+-- [/Hardware support:/]+-- -- CUDA devices are categorised into different \'compute capabilities\', -- indicating what operations are supported by the hardware. For example, double -- precision arithmetic is only supported on devices of compute capability 1.3@@ -29,7 +112,7 @@ -- size of 'Int' and 'Data.Word.Word' changes depending on the architecture GHC -- runs on. ----- Additional notes:+-- In particular: -- -- * 'Double' precision requires compute-1.3. --@@ -41,6 +124,25 @@ -- combine 32-bit types, or compute-1.2 for 64-bit types. Tuple components -- are resolved separately. --+--+-- [/Debugging options:/]+--+-- When the library is installed with the @-fdebug@ flag, a few extra debugging+-- options are available, input via the command line arguments. The most useful+-- ones are:+--+-- * @-dverbose:@ Print some information on the type and capabilities of the+-- GPU being used.+--+-- * @-ddump-cc:@ Print information about the CUDA kernels as they are compiled+-- and run. Using this option will indicate whether your program is+-- generating the number of kernels that you were expecting.+--+-- * @-ddump-exec:@ Print each kernel as it is being executed, with timing+-- information.+--+-- See the @accelerate-cuda.cabal@ file for the full list of options.+-- module Data.Array.Accelerate.CUDA ( @@ -51,27 +153,38 @@ -- * Asynchronous execution Async, wait, poll, cancel,- runAsync, run1Async, runAsyncIn, run1AsyncIn+ runAsync, run1Async, runAsyncIn, run1AsyncIn, + -- * Execution contexts+ Context, create, destroy,+ ) where -- standard library+#if !MIN_VERSION_base(4,6,0) import Prelude hiding ( catch )+#endif import Control.Exception import Control.Applicative-import Control.Concurrent+import Control.Monad.Trans import System.IO.Unsafe-import Foreign.CUDA.Driver ( Context ) import Foreign.CUDA.Driver.Error -- friends-import Data.Array.Accelerate.Smart ( Acc, convertAcc, convertAccFun1 )+import Data.Array.Accelerate.Trafo+import Data.Array.Accelerate.Smart ( Acc ) import Data.Array.Accelerate.Array.Sugar ( Arrays(..), ArraysR(..) ) import Data.Array.Accelerate.CUDA.Array.Data+import Data.Array.Accelerate.CUDA.Async import Data.Array.Accelerate.CUDA.State+import Data.Array.Accelerate.CUDA.Context import Data.Array.Accelerate.CUDA.Compile import Data.Array.Accelerate.CUDA.Execute +#if ACCELERATE_DEBUG+import Data.Array.Accelerate.Debug+#endif+ #include "accelerate.h" @@ -82,13 +195,7 @@ -- This will select the fastest device available on which to execute -- computations, based on compute capability and estimated maximum GFLOPS. ----- /NOTE:/--- GPUs typically have their own attached memory, which is separate from the--- computer's main memory. Hence, every 'Data.Array.Accelerate.use' operation--- implies copying data to the device, and every 'run' operation must copy the--- results of a computation back to the host. Thus, it is best to keep all--- computations in the 'Acc' meta-language form and only 'run' the computation--- once at the end, to avoid transferring (unused) intermediate results.+-- Note that it is recommended you use 'run1' whenever possible. -- run :: Arrays a => Acc a -> a run a@@ -99,7 +206,7 @@ -- return immediately without waiting for the result. The status of the -- computation can be queried using 'wait', 'poll', and 'cancel'. ----- Note that a CUDA Context can only be active no one host thread at a time. If+-- Note that a CUDA Context can be active on only one host thread at a time. If -- you want to execute multiple computations in parallel, use 'runAsyncIn'. -- runAsync :: Arrays a => Acc a -> Async a@@ -133,8 +240,8 @@ runAsyncIn :: Arrays a => Context -> Acc a -> Async a runAsyncIn ctx a = unsafePerformIO $ async execute where- acc = convertAcc a- execute = evalCUDA ctx (compileAcc acc >>= executeAcc >>= collect)+ !acc = convertAccWith config a+ execute = evalCUDA ctx (compileAcc acc >>= dumpStats >>= executeAcc >>= collect) `catch` \e -> INTERNAL_ERROR(error) "unhandled" (show (e :: CUDAException)) @@ -147,14 +254,30 @@ -- have a computation applied repeatedly to different input data, use this. If -- the function is only evaluated once, this is equivalent to 'run'. ----- > let step :: Vector a -> Vector b--- > step = run1 f--- > in--- > simulate step ...+-- To use 'run1' you must express your program as a function of one argument. If+-- your program takes more than one argument, you can use+-- 'Data.Array.Accelerate.lift' and 'Data.Array.Accelerate.unlift' to tuple up+-- the arguments. ----- See the Crystal demo, part of the 'accelerate-examples' package, for an--- example.+-- At an example, once your program is expressed as a function of one argument,+-- instead of the usual: --+-- > step :: Acc (Vector a) -> Acc (Vector b)+-- > step = ...+-- >+-- > simulate :: Vector a -> Vector b+-- > simulate xs = run $ step (use xs)+--+-- Instead write:+--+-- > simulate xs = run1 step xs+--+-- You can use the debugging options to check whether this is working+-- successfully by, for example, observing no output from the @-ddump-cc@ flag+-- at the second and subsequent invocations.+--+-- See the programs in the 'accelerate-examples' package for examples.+-- run1 :: (Arrays a, Arrays b) => (Acc a -> Acc b) -> a -> b run1 f = unsafePerformIO@@ -179,8 +302,8 @@ run1AsyncIn :: (Arrays a, Arrays b) => Context -> (Acc a -> Acc b) -> a -> Async b run1AsyncIn ctx f = \a -> unsafePerformIO $ async (execute a) where- acc = convertAccFun1 f- !afun = unsafePerformIO $ evalCUDA ctx (compileAfun1 acc)+ !acc = convertAccFun1With config f+ !afun = unsafePerformIO $ evalCUDA ctx (compileAfun acc) >>= dumpStats execute a = evalCUDA ctx (executeAfun1 afun a >>= collect) `catch` \e -> INTERNAL_ERROR(error) "unhandled" (show (e :: CUDAException))@@ -190,7 +313,7 @@ -- | Stream a lazily read list of input arrays through the given program,--- collecting results as we go.+-- collecting results as we go. -- stream :: (Arrays a, Arrays b) => (Acc a -> Acc b) -> [a] -> [b] stream f arrs@@ -208,7 +331,7 @@ -- Copy arrays from device to host. -- collect :: forall arrs. Arrays arrs => arrs -> CIO arrs-collect arrs = toArr <$> collectR (arrays (undefined :: arrs)) (fromArr arrs)+collect !arrs = toArr <$> collectR (arrays (undefined :: arrs)) (fromArr arrs) where collectR :: ArraysR a -> a -> CIO a collectR ArraysRunit () = return ()@@ -217,49 +340,27 @@ <*> collectR r2 arrs2 --- Running asynchronously--- -------------------------- We need to execute the main thread asynchronously to give finalisers a chance--- to run. Make sure to catch exceptions to avoid "blocked indefinitely on MVar"--- errors.+-- How the Accelerate program should be interpreted.+-- TODO: make sharing/fusion runtime configurable via debug flags or otherwise. ---data Async a = Async !ThreadId !(MVar (Either SomeException a))+config :: Phase+config = Phase+ { recoverAccSharing = True+ , recoverExpSharing = True+ , floatOutAccFromExp = True+ , enableAccFusion = True+ , convertOffsetOfSegment = True+ } --- Fork an action to execute asynchronously.------ TLM:--- CUDA contexts are specific to the processor on which they were created. It--- may be necessary to take this into account when forking accelerate--- computations (forkOn rather than forkIO), either by always requiring a--- specific CPU, and/or having the driver API store the processor ordinal when--- creating contexts.----async :: IO a -> IO (Async a)-async action = do- var <- newEmptyMVar- tid <- forkIO $ (putMVar var . Right =<< action)- `catch`- \e -> putMVar var (Left e)- return (Async tid var) --- | Block the calling thread until the computation completes, then return the--- result.----wait :: Async a -> IO a-wait (Async _ var) = either throwIO return =<< readMVar var---- | Test whether the asynchronous computation has already completed. If so,--- return the result, else 'Nothing'.----poll :: Async a -> IO (Maybe a)-poll (Async _ var) =- maybe (return Nothing) (either throwIO (return . Just)) =<< tryTakeMVar var---- | Cancel a running asynchronous computation.----cancel :: Async a -> IO ()-cancel (Async tid _) = throwTo tid ThreadKilled- -- TLM: catch and ignore exceptions?- -- silently do nothing if the thread has already finished?+dumpStats :: MonadIO m => a -> m a+#if ACCELERATE_DEBUG+dumpStats next = do+ stats <- liftIO simplCount+ liftIO $ traceMessage dump_simpl_stats (show stats)+ liftIO $ resetSimplCount+ return next+#else+dumpStats next = return next+#endif
Data/Array/Accelerate/CUDA/AST.hs view
@@ -1,4 +1,7 @@-{-# LANGUAGE GADTs, FlexibleInstances, TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeSynonymInstances #-} -- | -- Module : Data.Array.Accelerate.CUDA.AST -- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee@@ -7,15 +10,18 @@ -- -- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au> -- Stability : experimental--- Portability : non-partable (GHC extensions)+-- Portability : non-portable (GHC extensions) -- module Data.Array.Accelerate.CUDA.AST ( module Data.Array.Accelerate.AST,- AccKernel(..), AccBindings(..), ArrayVar(..), ExecAcc, ExecAfun, ExecOpenAcc(..),- retag + AccKernel(..), Free, Gamma(..), Idx_(..),+ ExecAcc, ExecAfun, ExecOpenAcc(..),+ ExecExp, ExecFun, ExecOpenExp, ExecOpenFun,+ freevar, makeEnvMap,+ ) where -- friends@@ -31,19 +37,22 @@ import Data.Hashable import Data.Monoid ( Monoid(..) ) import qualified Data.HashSet as Set+import qualified Data.HashMap.Strict as Map -- A non-empty list of binary objects will be used to execute a kernel. We keep -- auxiliary information together with the compiled module, such as entry point -- and execution information. ---data AccKernel a = Kernel String CUDA.Module CUDA.Fun CUDA.Occupancy (Int -> (Int,Int,Int))---- The kernel lists are monomorphic, so sometimes we need to change the phantom--- type of the object code.----retag :: AccKernel a -> AccKernel b-retag (Kernel x m f o l) = Kernel x m f o l+data AccKernel a where+ AccKernel :: !String -- __global__ entry function name+ -> {-# UNPACK #-} !CUDA.Fun -- __global__ function object+ -> {-# UNPACK #-} !CUDA.Module -- binary module+ -> {-# UNPACK #-} !CUDA.Occupancy -- occupancy analysis+ -> {-# UNPACK #-} !Int -- thread block size+ -> {-# UNPACK #-} !Int -- shared memory per block (bytes)+ -> !(Int -> Int) -- number of blocks for input problem size+ -> AccKernel a -- Kernel execution is asynchronous, barriers allow (cross-stream)@@ -51,41 +60,83 @@ -- -- data AccBarrier = AB !Stream !Event --- Array computations that were embedded within scalar expressions, and will be--- required to execute the kernel; i.e. bound to texture references or similar.++-- The set of free array variables for array computations that were embedded+-- within scalar expressions. These arrays are are required to execute the+-- kernel, by binding to texture references to similar. ---newtype AccBindings aenv = AccBindings ( Set.HashSet (ArrayVar aenv) )+type Free aenv = Set.HashSet (Idx_ aenv) -instance Monoid (AccBindings aenv) where- mempty = AccBindings ( Set.empty )- AccBindings x `mappend` AccBindings y = AccBindings ( Set.union x y )+freevar :: (Shape sh, Elt e) => Idx aenv (Array sh e) -> Free aenv+freevar = Set.singleton . Idx_ -data ArrayVar aenv where- ArrayVar :: (Shape sh, Elt e)- => Idx aenv (Array sh e)- -> ArrayVar aenv -instance Eq (ArrayVar aenv) where- ArrayVar ix1 == ArrayVar ix2 = idxToInt ix1 == idxToInt ix2+-- A mapping between environment indexes and some token identifying that array+-- in the generated code. This simply compresses the sequence of array indices+-- into a continuous range, rather than directly using the integer equivalent of+-- the de Bruijn index.+--+-- This results in generated code that is (slightly) less sensitive to the+-- placement of let bindings, ultimately leading to a higher hit rate in the+-- compilation cache.+--+newtype Gamma aenv = Gamma ( Map.HashMap (Idx_ aenv) Int )+ deriving ( Monoid ) -instance Hashable (ArrayVar aenv) where- hash (ArrayVar ix) = hash (idxToInt ix)+makeEnvMap :: Free aenv -> Gamma aenv+makeEnvMap indices+ = Gamma+ . Map.fromList+ . flip zip [0..]+-- . sortBy (compare `on` idxType)+ $ Set.toList indices+-- where+-- idxType :: Idx_ aenv -> TypeRep+-- idxType (Idx_ (_ :: Idx aenv (Array sh e))) = typeOf (undefined :: e) +-- Opaque array environment indices+--+data Idx_ aenv where+ Idx_ :: (Shape sh, Elt e) => Idx aenv (Array sh e) -> Idx_ aenv++instance Eq (Idx_ aenv) where+ Idx_ ix1 == Idx_ ix2 = idxToInt ix1 == idxToInt ix2++instance Hashable (Idx_ aenv) where+ hashWithSalt salt (Idx_ ix)+ = salt `hashWithSalt` idxToInt ix++ -- Interleave compilation & execution state annotations into an open array -- computation AST -- data ExecOpenAcc aenv a where- ExecAcc :: FL.FullList () (AccKernel a) -- executable binary objects- -> AccBindings aenv -- auxiliary arrays from the environment the kernel needs access to- -> PreOpenAcc ExecOpenAcc aenv a -- the actual computation- -> ExecOpenAcc aenv a -- the recursive knot+ ExecAcc :: {-# UNPACK #-} !(FL.FullList () (AccKernel a)) -- executable binary objects+ -> !(Gamma aenv) -- free array variables the kernel needs access to+ -> !(PreOpenAcc ExecOpenAcc aenv a) -- the actual computation+ -> ExecOpenAcc aenv a -- the recursive knot + EmbedAcc :: (Shape sh, Elt e)+ => !(PreExp ExecOpenAcc aenv sh) -- shape of the result array, used by execution+ -> ExecOpenAcc aenv (Array sh e)++ -- An annotated AST suitable for execution in the CUDA environment ---type ExecAcc a = ExecOpenAcc () a-type ExecAfun a = PreAfun ExecOpenAcc a+type ExecAcc a = ExecOpenAcc () a+type ExecAfun a = PreAfun ExecOpenAcc a +type ExecOpenExp = PreOpenExp ExecOpenAcc+type ExecOpenFun = PreOpenFun ExecOpenAcc++type ExecExp = ExecOpenExp ()+type ExecFun = ExecOpenFun ()+++-- Display the annotated AST+-- -------------------------+ instance Show (ExecOpenAcc aenv a) where show = render . prettyExecAcc 0 noParens @@ -93,23 +144,28 @@ show = render . prettyExecAfun 0 --- Display the annotated AST--- prettyExecAfun :: Int -> ExecAfun a -> Doc prettyExecAfun alvl pfun = prettyPreAfun prettyExecAcc alvl pfun prettyExecAcc :: PrettyAcc ExecOpenAcc-prettyExecAcc alvl wrap (ExecAcc _ (AccBindings fv) pacc) =- let base = prettyPreAcc prettyExecAcc alvl wrap pacc- ann = braces (freevars (Set.toList fv))- freevars = (text "fv=" <>) . brackets . hcat . punctuate comma- . map (\(ArrayVar ix) -> char 'a' <> int (idxToInt ix))- in case pacc of- Avar _ -> base- Alet _ _ -> base- Apply _ _ -> base- Acond _ _ _ -> base- Atuple _ -> base- Aprj _ _ -> base- _ -> ann <+> base+prettyExecAcc alvl wrap exec =+ case exec of+ EmbedAcc sh ->+ wrap $ hang (text "Embedded") 2+ $ sep [ prettyPreExp prettyExecAcc 0 alvl parens sh ]++ ExecAcc _ (Gamma fv) pacc ->+ let base = prettyPreAcc prettyExecAcc alvl wrap pacc+ ann = braces (freevars (Map.keys fv))+ freevars = (text "fv=" <>) . brackets . hcat . punctuate comma+ . map (\(Idx_ ix) -> char 'a' <> int (idxToInt ix))+ in+ case pacc of+ Avar{} -> base+ Alet{} -> base+ Apply{} -> base+ Acond{} -> base+ Atuple{} -> base+ Aprj{} -> base+ _ -> ann <+> base
Data/Array/Accelerate/CUDA/Analysis/Device.hs view
@@ -6,7 +6,7 @@ -- -- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au> -- Stability : experimental--- Portability : non-partable (GHC extensions)+-- Portability : non-portable (GHC extensions) -- module Data.Array.Accelerate.CUDA.Analysis.Device@@ -16,6 +16,7 @@ import Data.List import Data.Function import Foreign.CUDA.Driver.Device+import Foreign.CUDA.Analysis.Device import qualified Foreign.CUDA.Driver as CUDA @@ -45,9 +46,5 @@ -- executing in lockstep in half-warp groupings (16 ALUs). -- coresPerMultiProcessor :: DeviceProperties -> Int-coresPerMultiProcessor prp- | computeCapability prp < 2 = 8- | computeCapability prp < 2.1 = 32- | otherwise = 48-+coresPerMultiProcessor = coresPerMP . deviceResources
Data/Array/Accelerate/CUDA/Analysis/Launch.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE CPP, GADTs #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-} -- | -- Module : Data.Array.Accelerate.CUDA.Analysis.Launch -- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee@@ -7,7 +8,7 @@ -- -- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au> -- Stability : experimental--- Portability : non-partable (GHC extensions)+-- Portability : non-portable (GHC extensions) -- module Data.Array.Accelerate.CUDA.Analysis.Launch (@@ -18,6 +19,7 @@ -- friends import Data.Array.Accelerate.AST+import Data.Array.Accelerate.Trafo import Data.Array.Accelerate.Analysis.Type import Data.Array.Accelerate.Analysis.Shape @@ -39,17 +41,19 @@ -- thread. Scan operations select the largest block size of maximum occupancy. -- launchConfig- :: OpenAcc aenv a- -> CUDA.DeviceProperties+ :: DelayedOpenAcc aenv a+ -> CUDA.DeviceProperties -- the device being executed on -> CUDA.Occupancy -- kernel occupancy information- -> Int -- number of elements to configure for- -> (Int, Int, Int)-launchConfig (OpenAcc acc) dev occ = \n ->+ -> ( Int -- block size+ , Int -> Int -- number of blocks for input problem size (grid)+ , Int ) -- shared memory (bytes)+launchConfig Delayed{} _ _ = INTERNAL_ERROR(error) "launchConfig" "encountered delayed array"+launchConfig (Manifest acc) dev occ = let cta = CUDA.activeThreads occ `div` CUDA.activeThreadBlocks occ maxGrid = CUDA.multiProcessorCount dev * CUDA.activeThreadBlocks occ smem = sharedMem dev acc cta in- (cta, maxGrid `min` gridSize dev acc n cta, smem)+ (cta, \n -> maxGrid `min` gridSize dev acc n cta, smem) -- |@@ -57,12 +61,13 @@ -- combination. -- determineOccupancy- :: OpenAcc aenv a+ :: DelayedOpenAcc aenv a -> CUDA.DeviceProperties -> CUDA.Fun -- corresponding __global__ entry function -> Int -- maximum number of threads per block -> IO CUDA.Occupancy-determineOccupancy (OpenAcc acc) dev fn maxBlock = do+determineOccupancy Delayed{} _ _ _ = INTERNAL_ERROR(error) "determineOccupancy" "encountered delayed array"+determineOccupancy (Manifest acc) dev fn maxBlock = do registers <- CUDA.requires fn CUDA.NumRegs static_smem <- CUDA.requires fn CUDA.SharedSizeBytes -- static memory only return . snd $ blockSize dev acc maxBlock registers (\threads -> static_smem + dynamic_smem threads)@@ -78,7 +83,7 @@ -- blockSize :: CUDA.DeviceProperties- -> PreOpenAcc OpenAcc aenv a+ -> PreOpenAcc DelayedOpenAcc aenv a -> Int -- maximum number of threads per block -> Int -- number of registers used -> (Int -> Int) -- shared memory as a function of thread block size (bytes)@@ -87,8 +92,8 @@ CUDA.optimalBlockSizeBy dev (filter (<= lim) . strategy) (const regs) smem where strategy = case acc of- Fold _ _ _ -> CUDA.decPow2- Fold1 _ _ -> CUDA.decPow2+ Fold _ _ _ -> CUDA.incPow2+ Fold1 _ _ -> CUDA.incPow2 Scanl _ _ _ -> CUDA.incWarp Scanl' _ _ _ -> CUDA.incWarp Scanl1 _ _ -> CUDA.incWarp@@ -111,14 +116,14 @@ -- * fold: for multidimensional reductions, this is the size of the shape tail -- for 1D reductions this is the total number of elements ---gridSize :: CUDA.DeviceProperties -> PreOpenAcc OpenAcc aenv a -> Int -> Int -> Int+gridSize :: CUDA.DeviceProperties -> PreOpenAcc DelayedOpenAcc aenv a -> Int -> Int -> Int gridSize p acc@(FoldSeg _ _ _ _) size cta = split acc (size * CUDA.warpSize p) cta gridSize p acc@(Fold1Seg _ _ _) size cta = split acc (size * CUDA.warpSize p) cta-gridSize _ acc@(Fold _ _ _) size cta = if preAccDim accDim acc == 0 then split acc size cta else size-gridSize _ acc@(Fold1 _ _) size cta = if preAccDim accDim acc == 0 then split acc size cta else size+gridSize _ acc@(Fold _ _ _) size cta = if preAccDim delayedDim acc == 0 then split acc size cta else max 1 size+gridSize _ acc@(Fold1 _ _) size cta = if preAccDim delayedDim acc == 0 then split acc size cta else max 1 size gridSize _ acc size cta = split acc size cta -split :: PreOpenAcc OpenAcc aenv a -> Int -> Int -> Int+split :: acc aenv a -> Int -> Int -> Int split acc size cta = (size `between` eltsPerThread acc) `between` cta where between arr n = 1 `max` ((n + arr - 1) `div` n)@@ -130,38 +135,40 @@ -- memory usage as a function of thread block size. This can be used by the -- occupancy calculator to optimise kernel launch shape. ---sharedMem :: CUDA.DeviceProperties -> PreOpenAcc OpenAcc aenv a -> Int -> Int+sharedMem :: CUDA.DeviceProperties -> PreOpenAcc DelayedOpenAcc aenv a -> Int -> Int -- non-computation forms-sharedMem _ (Alet _ _) _ = INTERNAL_ERROR(error) "sharedMem" "Let"-sharedMem _ (Avar _) _ = INTERNAL_ERROR(error) "sharedMem" "Avar"-sharedMem _ (Apply _ _) _ = INTERNAL_ERROR(error) "sharedMem" "Apply"-sharedMem _ (Acond _ _ _) _ = INTERNAL_ERROR(error) "sharedMem" "Acond"-sharedMem _ (Atuple _) _ = INTERNAL_ERROR(error) "sharedMem" "Atuple"-sharedMem _ (Aprj _ _) _ = INTERNAL_ERROR(error) "sharedMem" "Aprj"-sharedMem _ (Use _) _ = INTERNAL_ERROR(error) "sharedMem" "Use"-sharedMem _ (Unit _) _ = INTERNAL_ERROR(error) "sharedMem" "Unit"-sharedMem _ (Reshape _ _) _ = INTERNAL_ERROR(error) "sharedMem" "Reshape"+sharedMem _ (Alet _ _) _ = INTERNAL_ERROR(error) "sharedMem" "Let"+sharedMem _ (Avar _) _ = INTERNAL_ERROR(error) "sharedMem" "Avar"+sharedMem _ (Apply _ _) _ = INTERNAL_ERROR(error) "sharedMem" "Apply"+sharedMem _ (Acond _ _ _) _ = INTERNAL_ERROR(error) "sharedMem" "Acond"+sharedMem _ (Atuple _) _ = INTERNAL_ERROR(error) "sharedMem" "Atuple"+sharedMem _ (Aprj _ _) _ = INTERNAL_ERROR(error) "sharedMem" "Aprj"+sharedMem _ (Use _) _ = INTERNAL_ERROR(error) "sharedMem" "Use"+sharedMem _ (Unit _) _ = INTERNAL_ERROR(error) "sharedMem" "Unit"+sharedMem _ (Reshape _ _) _ = INTERNAL_ERROR(error) "sharedMem" "Reshape"+sharedMem _ (Aforeign _ _ _) _ = INTERNAL_ERROR(error) "sharedMem" "Aforeign" -- skeleton nodes sharedMem _ (Generate _ _) _ = 0+sharedMem _ (Transform _ _ _ _) _ = 0 sharedMem _ (Replicate _ _ _) _ = 0-sharedMem _ (Index _ _ _) _ = 0+sharedMem _ (Slice _ _ _) _ = 0 sharedMem _ (Map _ _) _ = 0 sharedMem _ (ZipWith _ _ _) _ = 0 sharedMem _ (Permute _ _ _ _) _ = 0 sharedMem _ (Backpermute _ _ _) _ = 0 sharedMem _ (Stencil _ _ _) _ = 0 sharedMem _ (Stencil2 _ _ _ _ _) _ = 0-sharedMem _ (Fold _ _ a) blockDim = sizeOf (accType a) * blockDim-sharedMem _ (Fold1 _ a) blockDim = sizeOf (accType a) * blockDim-sharedMem _ (Scanl _ x _) blockDim = sizeOf (expType x) * blockDim-sharedMem _ (Scanr _ x _) blockDim = sizeOf (expType x) * blockDim-sharedMem _ (Scanl' _ x _) blockDim = sizeOf (expType x) * blockDim-sharedMem _ (Scanr' _ x _) blockDim = sizeOf (expType x) * blockDim-sharedMem _ (Scanl1 _ a) blockDim = sizeOf (accType a) * blockDim-sharedMem _ (Scanr1 _ a) blockDim = sizeOf (accType a) * blockDim-sharedMem p (FoldSeg _ _ a _) blockDim =- (blockDim `div` CUDA.warpSize p) * 8 + blockDim * sizeOf (accType a)+sharedMem _ (Fold _ x _) blockDim = sizeOf (delayedExpType x) * blockDim+sharedMem _ (Scanl _ x _) blockDim = sizeOf (delayedExpType x) * blockDim+sharedMem _ (Scanr _ x _) blockDim = sizeOf (delayedExpType x) * blockDim+sharedMem _ (Scanl' _ x _) blockDim = sizeOf (delayedExpType x) * blockDim+sharedMem _ (Scanr' _ x _) blockDim = sizeOf (delayedExpType x) * blockDim+sharedMem _ (Fold1 _ a) blockDim = sizeOf (delayedAccType a) * blockDim+sharedMem _ (Scanl1 _ a) blockDim = sizeOf (delayedAccType a) * blockDim+sharedMem _ (Scanr1 _ a) blockDim = sizeOf (delayedAccType a) * blockDim+sharedMem p (FoldSeg _ x _ _) blockDim =+ (blockDim `div` CUDA.warpSize p) * 8 + blockDim * sizeOf (delayedExpType x) -- TLM: why 8? I can't remember... sharedMem p (Fold1Seg _ a _) blockDim =- (blockDim `div` CUDA.warpSize p) * 8 + blockDim * sizeOf (accType a)+ (blockDim `div` CUDA.warpSize p) * 8 + blockDim * sizeOf (delayedAccType a)
Data/Array/Accelerate/CUDA/Array/Data.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -5,7 +6,7 @@ -- | -- Module : Data.Array.Accelerate.CUDA.Array.Data -- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee--- [2009..2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell+-- [2009..2013] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell -- License : BSD3 -- -- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>@@ -16,8 +17,9 @@ module Data.Array.Accelerate.CUDA.Array.Data ( -- * Array operations and representations- mallocArray, indexArray, copyArray,+ mallocArray, indexArray, useArray, useArrayAsync,+ copyArray, copyArrayPeer, copyArrayPeerAsync, peekArray, peekArrayAsync, pokeArray, pokeArrayAsync, marshalArrayData, marshalTextureData, marshalDevicePtrs,@@ -30,14 +32,16 @@ -- libraries import Prelude hiding ( fst, snd )-import Data.Label.PureM import Control.Applicative-import Control.Monad.Trans+import Control.Monad.Reader ( asks )+import Control.Monad.State ( gets )+import Control.Monad.Trans ( liftIO )+import Foreign.C.Types -- friends import Data.Array.Accelerate.Array.Data-import Data.Array.Accelerate.Array.Sugar ( Array(..), Shape, Elt, fromElt, toElt )-import Data.Array.Accelerate.Array.Representation ( size, index )+import Data.Array.Accelerate.Array.Sugar ( Array(..), Shape, Elt, toElt )+import Data.Array.Accelerate.Array.Representation ( size ) import Data.Array.Accelerate.CUDA.State import Data.Array.Accelerate.CUDA.Array.Table import qualified Data.Array.Accelerate.CUDA.Array.Prim as Prim@@ -66,44 +70,59 @@ -- Extract the state information to pass along to the primitive data handlers --+{-# INLINE run #-} run :: (Context -> MemoryTable -> IO a) -> CIO a run f = do- ctx <- gets activeContext- mt <- gets memoryTable- liftIO $ f ctx mt+ ctx <- asks activeContext+ mt <- gets memoryTable+ liftIO $! f ctx mt -- CPP hackery to generate the cases where we dispatch to the worker function handling -- elementary types. ---#define mkPrimDispatch(dispatcher,worker) \-; dispatcher ArrayEltRint = worker \-; dispatcher ArrayEltRint8 = worker \-; dispatcher ArrayEltRint16 = worker \-; dispatcher ArrayEltRint32 = worker \-; dispatcher ArrayEltRint64 = worker \-; dispatcher ArrayEltRword = worker \-; dispatcher ArrayEltRword8 = worker \-; dispatcher ArrayEltRword16 = worker \-; dispatcher ArrayEltRword32 = worker \-; dispatcher ArrayEltRword64 = worker \-; dispatcher ArrayEltRfloat = worker \-; dispatcher ArrayEltRdouble = worker \-; dispatcher ArrayEltRbool = worker \-; dispatcher ArrayEltRchar = worker \-; dispatcher _ = error "mkPrimDispatcher: not primitive"+#define mkPrimDispatch(dispatcher,worker) \+; dispatcher ArrayEltRint = worker \+; dispatcher ArrayEltRint8 = worker \+; dispatcher ArrayEltRint16 = worker \+; dispatcher ArrayEltRint32 = worker \+; dispatcher ArrayEltRint64 = worker \+; dispatcher ArrayEltRword = worker \+; dispatcher ArrayEltRword8 = worker \+; dispatcher ArrayEltRword16 = worker \+; dispatcher ArrayEltRword32 = worker \+; dispatcher ArrayEltRword64 = worker \+; dispatcher ArrayEltRfloat = worker \+; dispatcher ArrayEltRdouble = worker \+; dispatcher ArrayEltRbool = worker \+; dispatcher ArrayEltRchar = worker \+; dispatcher ArrayEltRcshort = worker \+; dispatcher ArrayEltRcushort = worker \+; dispatcher ArrayEltRcint = worker \+; dispatcher ArrayEltRcuint = worker \+; dispatcher ArrayEltRclong = worker \+; dispatcher ArrayEltRculong = worker \+; dispatcher ArrayEltRcllong = worker \+; dispatcher ArrayEltRcullong = worker \+; dispatcher ArrayEltRcfloat = worker \+; dispatcher ArrayEltRcdouble = worker \+; dispatcher ArrayEltRcchar = worker \+; dispatcher ArrayEltRcschar = worker \+; dispatcher ArrayEltRcuchar = worker \+; dispatcher _ = error "mkPrimDispatcher: not primitive" -- |Allocate a new device array to accompany the given host-side array. -- mallocArray :: (Shape dim, Elt e) => Array dim e -> CIO ()-mallocArray (Array sh adata) = run doMalloc+mallocArray (Array !sh !adata) = run doMalloc where- doMalloc ctx mt = mallocR arrayElt adata+ !n = size sh+ doMalloc !ctx !mt = mallocR arrayElt adata where mallocR :: ArrayEltR e -> ArrayData e -> IO () mallocR ArrayEltRunit _ = return () mallocR (ArrayEltRpair aeR1 aeR2) ad = mallocR aeR1 (fst ad) >> mallocR aeR2 (snd ad)- mallocR aer ad = mallocPrim aer ctx mt ad (size sh)+ mallocR aer ad = mallocPrim aer ctx mt ad n -- mallocPrim :: ArrayEltR e -> Context -> MemoryTable -> ArrayData e -> Int -> IO () mkPrimDispatch(mallocPrim,Prim.mallocArray)@@ -112,27 +131,29 @@ -- |Upload an existing array to the device -- useArray :: (Shape dim, Elt e) => Array dim e -> CIO ()-useArray (Array sh adata) = run doUse+useArray (Array !sh !adata) = run doUse where- doUse ctx mt = useR arrayElt adata+ !n = size sh+ doUse !ctx !mt = useR arrayElt adata where useR :: ArrayEltR e -> ArrayData e -> IO () useR ArrayEltRunit _ = return () useR (ArrayEltRpair aeR1 aeR2) ad = useR aeR1 (fst ad) >> useR aeR2 (snd ad)- useR aer ad = usePrim aer ctx mt ad (size sh)+ useR aer ad = usePrim aer ctx mt ad n -- usePrim :: ArrayEltR e -> Context -> MemoryTable -> ArrayData e -> Int -> IO () mkPrimDispatch(usePrim,Prim.useArray) useArrayAsync :: (Shape dim, Elt e) => Array dim e -> Maybe CUDA.Stream -> CIO ()-useArrayAsync (Array sh adata) ms = run doUse+useArrayAsync (Array !sh !adata) ms = run doUse where- doUse ctx mt = useR arrayElt adata+ !n = size sh+ doUse !ctx !mt = useR arrayElt adata where useR :: ArrayEltR e -> ArrayData e -> IO () useR ArrayEltRunit _ = return () useR (ArrayEltRpair aeR1 aeR2) ad = useR aeR1 (fst ad) >> useR aeR2 (snd ad)- useR aer ad = usePrim aer ctx mt ad (size sh) ms+ useR aer ad = usePrim aer ctx mt ad n ms -- usePrim :: ArrayEltR e -> Context -> MemoryTable -> ArrayData e -> Int -> Maybe CUDA.Stream -> IO () mkPrimDispatch(usePrim,Prim.useArrayAsync)@@ -141,21 +162,16 @@ -- |Read a single element from an array at the given row-major index. This is a -- synchronous operation. ---indexArray :: (Shape dim, Elt e) => Array dim e -> dim -> CIO e-indexArray (Array sh adata) ix = run doIndex+indexArray :: (Shape dim, Elt e) => Array dim e -> Int -> CIO e+indexArray (Array _ !adata) i = run doIndex where- i = index sh (fromElt ix)- doIndex ctx mt = toElt <$> indexR arrayElt adata+ doIndex !ctx !mt = toElt <$> indexR arrayElt adata where indexR :: ArrayEltR e -> ArrayData e -> IO e indexR ArrayEltRunit _ = return () indexR (ArrayEltRpair aeR1 aeR2) ad = (,) <$> indexR aeR1 (fst ad) <*> indexR aeR2 (snd ad) --- indexR ArrayEltRbool ad = toBool <$> Prim.indexArray ctx mt ad i- where toBool 0 = False- toBool _ = True- -- indexR ArrayEltRint ad = Prim.indexArray ctx mt ad i indexR ArrayEltRint8 ad = Prim.indexArray ctx mt ad i indexR ArrayEltRint16 ad = Prim.indexArray ctx mt ad i@@ -169,52 +185,111 @@ indexR ArrayEltRfloat ad = Prim.indexArray ctx mt ad i indexR ArrayEltRdouble ad = Prim.indexArray ctx mt ad i indexR ArrayEltRchar ad = Prim.indexArray ctx mt ad i+ --+ indexR ArrayEltRcshort ad = CShort <$> Prim.indexArray ctx mt ad i+ indexR ArrayEltRcushort ad = CUShort <$> Prim.indexArray ctx mt ad i+ indexR ArrayEltRcint ad = CInt <$> Prim.indexArray ctx mt ad i+ indexR ArrayEltRcuint ad = CUInt <$> Prim.indexArray ctx mt ad i+ indexR ArrayEltRclong ad = CLong <$> Prim.indexArray ctx mt ad i+ indexR ArrayEltRculong ad = CULong <$> Prim.indexArray ctx mt ad i+ indexR ArrayEltRcllong ad = CLLong <$> Prim.indexArray ctx mt ad i+ indexR ArrayEltRcullong ad = CULLong <$> Prim.indexArray ctx mt ad i+ indexR ArrayEltRcchar ad = CChar <$> Prim.indexArray ctx mt ad i+ indexR ArrayEltRcschar ad = CSChar <$> Prim.indexArray ctx mt ad i+ indexR ArrayEltRcuchar ad = CUChar <$> Prim.indexArray ctx mt ad i+ indexR ArrayEltRcfloat ad = CFloat <$> Prim.indexArray ctx mt ad i+ indexR ArrayEltRcdouble ad = CDouble <$> Prim.indexArray ctx mt ad i+ --+ indexR ArrayEltRbool ad = toBool <$> Prim.indexArray ctx mt ad i+ where toBool 0 = False+ toBool _ = True -- |Copy data between two device arrays. The operation is asynchronous with -- respect to the host, but will never overlap kernel execution. -- copyArray :: (Shape dim, Elt e) => Array dim e -> Array dim e -> CIO ()-copyArray (Array sh1 adata1) (Array sh2 adata2)+copyArray (Array !sh1 !adata1) (Array !sh2 !adata2) = BOUNDS_CHECK(check) "copyArray" "shape mismatch" (sh1 == sh2) $ run doCopy where- doCopy ctx mt = copyR arrayElt adata1 adata2+ !n = size sh1+ doCopy !ctx !mt = copyR arrayElt adata1 adata2 where copyR :: ArrayEltR e -> ArrayData e -> ArrayData e -> IO () copyR ArrayEltRunit _ _ = return () copyR (ArrayEltRpair aeR1 aeR2) ad1 ad2 = copyR aeR1 (fst ad1) (fst ad2) >> copyR aeR2 (snd ad1) (snd ad2)- copyR aer ad1 ad2 = copyPrim aer ctx mt ad1 ad2 (size sh1)+ copyR aer ad1 ad2 = copyPrim aer ctx mt ad1 ad2 n -- copyPrim :: ArrayEltR e -> Context -> MemoryTable -> ArrayData e -> ArrayData e -> Int -> IO () mkPrimDispatch(copyPrim,Prim.copyArray) +-- |Copy data between two device arrays which reside in different contexts. This+-- might entail copying between devices.+--+copyArrayPeer :: (Shape dim, Elt e) => Array dim e -> Context -> Array dim e -> Context -> CIO ()+copyArrayPeer (Array !sh1 !adata1) !ctxSrc (Array !sh2 !adata2) !ctxDst+ = BOUNDS_CHECK(check) "copyArrayPeer" "shape mismatch" (sh1 == sh2)+ $ run doCopy+ where+ !n = size sh1+ doCopy _ !mt = copyR arrayElt adata1 adata2+ where+ copyR :: ArrayEltR e -> ArrayData e -> ArrayData e -> IO ()+ copyR ArrayEltRunit _ _ = return ()+ copyR (ArrayEltRpair aeR1 aeR2) ad1 ad2 = copyR aeR1 (fst ad1) (fst ad2) >>+ copyR aeR2 (snd ad1) (snd ad2)+ copyR aer ad1 ad2 = copyPrim aer mt ad1 ctxSrc ad2 ctxDst n+ --+ copyPrim :: ArrayEltR e -> MemoryTable -> ArrayData e -> Context -> ArrayData e -> Context -> Int -> IO ()+ mkPrimDispatch(copyPrim,Prim.copyArrayPeer)++copyArrayPeerAsync :: (Shape dim, Elt e) => Array dim e -> Context -> Array dim e -> Context -> Maybe CUDA.Stream -> CIO ()+copyArrayPeerAsync (Array !sh1 !adata1) !ctxSrc (Array !sh2 !adata2) !ctxDst !ms+ = BOUNDS_CHECK(check) "copyArrayPeerAsync" "shape mismatch" (sh1 == sh2)+ $ run doCopy+ where+ !n = size sh1+ doCopy _ !mt = copyR arrayElt adata1 adata2+ where+ copyR :: ArrayEltR e -> ArrayData e -> ArrayData e -> IO ()+ copyR ArrayEltRunit _ _ = return ()+ copyR (ArrayEltRpair aeR1 aeR2) ad1 ad2 = copyR aeR1 (fst ad1) (fst ad2) >>+ copyR aeR2 (snd ad1) (snd ad2)+ copyR aer ad1 ad2 = copyPrim aer mt ad1 ctxSrc ad2 ctxDst n ms+ --+ copyPrim :: ArrayEltR e -> MemoryTable -> ArrayData e -> Context -> ArrayData e -> Context -> Int -> Maybe CUDA.Stream -> IO ()+ mkPrimDispatch(copyPrim,Prim.copyArrayPeerAsync)++ -- Copy data from the device into the associated Accelerate host-side array -- peekArray :: (Shape dim, Elt e) => Array dim e -> CIO ()-peekArray (Array sh adata) = run doPeek+peekArray (Array !sh !adata) = run doPeek where- doPeek ctx mt = peekR arrayElt adata+ !n = size sh+ doPeek !ctx !mt = peekR arrayElt adata where peekR :: ArrayEltR e -> ArrayData e -> IO () peekR ArrayEltRunit _ = return () peekR (ArrayEltRpair aeR1 aeR2) ad = peekR aeR1 (fst ad) >> peekR aeR2 (snd ad)- peekR aer ad = peekPrim aer ctx mt ad (size sh)+ peekR aer ad = peekPrim aer ctx mt ad n -- peekPrim :: ArrayEltR e -> Context -> MemoryTable -> ArrayData e -> Int -> IO () mkPrimDispatch(peekPrim,Prim.peekArray) peekArrayAsync :: (Shape dim, Elt e) => Array dim e -> Maybe CUDA.Stream -> CIO ()-peekArrayAsync (Array sh adata) ms = run doPeek+peekArrayAsync (Array !sh !adata) !ms = run doPeek where- doPeek ctx mt = peekR arrayElt adata+ !n = size sh+ doPeek !ctx !mt = peekR arrayElt adata where peekR :: ArrayEltR e -> ArrayData e -> IO () peekR ArrayEltRunit _ = return () peekR (ArrayEltRpair aeR1 aeR2) ad = peekR aeR1 (fst ad) >> peekR aeR2 (snd ad)- peekR aer ad = peekPrim aer ctx mt ad (size sh) ms+ peekR aer ad = peekPrim aer ctx mt ad n ms -- peekPrim :: ArrayEltR e -> Context -> MemoryTable -> ArrayData e -> Int -> Maybe CUDA.Stream -> IO () mkPrimDispatch(peekPrim,Prim.peekArrayAsync)@@ -223,27 +298,29 @@ -- Copy data from an Accelerate array into the associated device array -- pokeArray :: (Shape dim, Elt e) => Array dim e -> CIO ()-pokeArray (Array sh adata) = run doPoke+pokeArray (Array !sh !adata) = run doPoke where- doPoke ctx mt = pokeR arrayElt adata+ !n = size sh+ doPoke !ctx !mt = pokeR arrayElt adata where pokeR :: ArrayEltR e -> ArrayData e -> IO () pokeR ArrayEltRunit _ = return () pokeR (ArrayEltRpair aeR1 aeR2) ad = pokeR aeR1 (fst ad) >> pokeR aeR2 (snd ad)- pokeR aer ad = pokePrim aer ctx mt ad (size sh)+ pokeR aer ad = pokePrim aer ctx mt ad n -- pokePrim :: ArrayEltR e -> Context -> MemoryTable -> ArrayData e -> Int -> IO () mkPrimDispatch(pokePrim,Prim.pokeArray) pokeArrayAsync :: (Shape dim, Elt e) => Array dim e -> Maybe CUDA.Stream -> CIO ()-pokeArrayAsync (Array sh adata) ms = run doPoke+pokeArrayAsync (Array !sh !adata) !ms = run doPoke where- doPoke ctx mt = pokeR arrayElt adata+ !n = size sh+ doPoke !ctx !mt = pokeR arrayElt adata where pokeR :: ArrayEltR e -> ArrayData e -> IO () pokeR ArrayEltRunit _ = return () pokeR (ArrayEltRpair aeR1 aeR2) ad = pokeR aeR1 (fst ad) >> pokeR aeR2 (snd ad)- pokeR aer ad = pokePrim aer ctx mt ad (size sh) ms+ pokeR aer ad = pokePrim aer ctx mt ad n ms -- pokePrim :: ArrayEltR e -> Context -> MemoryTable -> ArrayData e -> Int -> Maybe CUDA.Stream -> IO () mkPrimDispatch(pokePrim,Prim.pokeArrayAsync)@@ -253,7 +330,7 @@ -- invocation -- marshalDevicePtrs :: ArrayElt e => ArrayData e -> Prim.DevicePtrs e -> [CUDA.FunParam]-marshalDevicePtrs adata = marshalR arrayElt adata+marshalDevicePtrs !adata = marshalR arrayElt adata where marshalR :: ArrayEltR e -> ArrayData e -> Prim.DevicePtrs e -> [CUDA.FunParam] marshalR ArrayEltRunit _ _ = []@@ -269,9 +346,9 @@ -- that can be passed to a kernel upon invocation. -- marshalArrayData :: ArrayElt e => ArrayData e -> CIO [CUDA.FunParam]-marshalArrayData adata = run doMarshal+marshalArrayData !adata = run doMarshal where- doMarshal ctx mt = marshalR arrayElt adata+ doMarshal !ctx !mt = marshalR arrayElt adata where marshalR :: ArrayEltR e -> ArrayData e -> IO [CUDA.FunParam] marshalR ArrayEltRunit _ = return []@@ -288,9 +365,9 @@ -- consumed, in projection index order --- i.e. right-to-left -- marshalTextureData :: ArrayElt e => ArrayData e -> Int -> [CUDA.Texture] -> CIO ()-marshalTextureData adata n texs = run doMarshal+marshalTextureData !adata !n !texs = run doMarshal where- doMarshal ctx mt = marshalR arrayElt adata texs >> return ()+ doMarshal !ctx !mt = marshalR arrayElt adata texs >> return () where marshalR :: ArrayEltR e -> ArrayData e -> [CUDA.Texture] -> IO Int marshalR ArrayEltRunit _ _ = return 0@@ -309,9 +386,9 @@ -- |Raw device pointers associated with a host-side array -- devicePtrsOfArrayData :: ArrayElt e => ArrayData e -> CIO (Prim.DevicePtrs e)-devicePtrsOfArrayData adata = run ptrs+devicePtrsOfArrayData !adata = run ptrs where- ptrs ctx mt = ptrsR arrayElt adata+ ptrs !ctx !mt = ptrsR arrayElt adata where ptrsR :: ArrayEltR e -> ArrayData e -> IO (Prim.DevicePtrs e) ptrsR ArrayEltRunit _ = return ()@@ -326,7 +403,7 @@ -- |Advance a set of device pointers by the given number of elements each -- advancePtrsOfArrayData :: ArrayElt e => ArrayData e -> Int -> Prim.DevicePtrs e -> Prim.DevicePtrs e-advancePtrsOfArrayData adata n = advanceR arrayElt adata+advancePtrsOfArrayData !adata !n = advanceR arrayElt adata where advanceR :: ArrayEltR e -> ArrayData e -> Prim.DevicePtrs e -> Prim.DevicePtrs e advanceR ArrayEltRunit _ _ = ()@@ -336,5 +413,4 @@ -- advancePrim :: ArrayEltR e -> ArrayData e -> Prim.DevicePtrs e -> Prim.DevicePtrs e mkPrimDispatch(advancePrim,Prim.advancePtrsOfArrayData n)-
+ Data/Array/Accelerate/CUDA/Array/Nursery.hs view
@@ -0,0 +1,125 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- |+-- Module : Data.Array.Accelerate.CUDA.Array.Nursery+-- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee+-- [2009..2013] Manuel M T Chakravarty, Gabriele Keller, 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.CUDA.Array.Nursery (++ Nursery(..), NRS, new, lookup, insert, flush,++) where++-- friends+import Data.Array.Accelerate.CUDA.FullList ( FullList(..) )+import qualified Data.Array.Accelerate.CUDA.FullList as FL+import qualified Data.Array.Accelerate.CUDA.Debug as D++-- libraries+import Prelude hiding ( lookup )+import Data.IORef+import Data.Hashable+import Control.Exception ( bracket_ )+import System.Mem.Weak ( Weak )+import Foreign.Ptr ( ptrToIntPtr )+import Foreign.CUDA.Ptr ( DevicePtr )++import qualified Foreign.CUDA.Driver as CUDA+import qualified Data.HashTable.IO as HT+++-- The nursery is a place to store device memory arrays that are no longer+-- needed. If a new array is requested of a similar size, we might return an+-- array from the nursery instead of calling into the CUDA API to allocate fresh+-- memory.+--+-- Note that pointers are also related to a specific context, so we must include+-- that when looking up the map.+--+-- Note that since there might be many arrays for the same size, each entry in+-- the map keeps a (non-empty) list of device pointers.+--+type HashTable key val = HT.BasicHashTable key val++type NRS = IORef ( HashTable (CUDA.Context, Int) (FullList () (DevicePtr ())) )+data Nursery = Nursery {-# UNPACK #-} !NRS+ {-# UNPACK #-} !(Weak NRS)++instance Hashable CUDA.Context where+ {-# INLINE hashWithSalt #-}+ hashWithSalt s (CUDA.Context ctx) = hashWithSalt s (fromIntegral (ptrToIntPtr ctx) :: Int)+++-- Generate a fresh nursery+--+new :: IO Nursery+new = do+ tbl <- HT.new+ ref <- newIORef tbl+ weak <- mkWeakIORef ref (flush tbl)+ return $! Nursery ref weak+++-- Look for a chunk of memory in the nursery of a given size (or a little bit+-- larger). If found, it is removed from the nursery and a pointer to it+-- returned.+--+{-# INLINE lookup #-}+lookup :: Int -> CUDA.Context -> Nursery -> IO (Maybe (DevicePtr ()))+lookup !n !ctx (Nursery !ref _) = do+ let !key = (ctx,n)+ --+ tbl <- readIORef ref+ mp <- HT.lookup tbl key+ case mp of+ Nothing -> return Nothing+ Just (FL () ptr rest) ->+ case rest of+ FL.Nil -> HT.delete tbl key >> return (Just ptr)+ FL.Cons () v xs -> HT.insert tbl key (FL () v xs) >> return (Just ptr)+++-- Add a device pointer to the nursery.+--+{-# INLINE insert #-}+insert :: Int -> CUDA.Context -> NRS -> DevicePtr a -> IO ()+insert !n !ctx !ref (CUDA.castDevPtr -> !ptr) = do+ let !key = (ctx, n)+ --+ tbl <- readIORef ref+ mp <- HT.lookup tbl key+ case mp of+ Nothing -> HT.insert tbl key (FL.singleton () ptr)+ Just xs -> HT.insert tbl key (FL.cons () ptr xs)+++-- Delete all entries from the nursery and free all associated device memory.+--+flush :: HashTable (CUDA.Context,Int) (FullList () (CUDA.DevicePtr ())) -> IO ()+flush !tbl =+ let clean (!key@(ctx,_),!val) = do+ bracket_ (CUDA.push ctx) CUDA.pop (FL.mapM_ (const CUDA.free) val)+ HT.delete tbl key+ in+ message "flush nursery" >> HT.mapM_ clean tbl+++-- Debug+-- -----++{-# INLINE trace #-}+trace :: String -> IO a -> IO a+trace msg next = D.message D.dump_gc ("gc: " ++ msg) >> next++{-# INLINE message #-}+message :: String -> IO ()+message s = s `trace` return ()+
Data/Array/Accelerate/CUDA/Array/Prim.hs view
@@ -6,7 +6,7 @@ -- | -- Module : Data.Array.Accelerate.CUDA.Array.Prim -- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee--- [2009..2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell+-- [2009..2013] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell -- License : BSD3 -- -- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>@@ -18,32 +18,40 @@ DevicePtrs, HostPtrs, - mallocArray, useArray, useArrayAsync, indexArray, copyArray, peekArray, peekArrayAsync,- pokeArray, pokeArrayAsync, marshalDevicePtrs, marshalArrayData, marshalTextureData,+ mallocArray, indexArray,+ useArray, useArrayAsync,+ copyArray, copyArrayPeer, copyArrayPeerAsync,+ peekArray, peekArrayAsync,+ pokeArray, pokeArrayAsync,+ marshalDevicePtrs, marshalArrayData, marshalTextureData, devicePtrsOfArrayData, advancePtrsOfArrayData ) where -- libraries-import Prelude hiding (catch, lookup)+#if MIN_VERSION_base(4,6,0)+import Prelude hiding ( lookup )+#else+import Prelude hiding ( catch, lookup )+#endif import Data.Int import Data.Word import Data.Maybe import Data.Functor import Data.Typeable import Control.Monad-import Control.Exception import System.Mem.StableName import Foreign.Ptr+import Foreign.C.Types import Foreign.Storable-import Foreign.Marshal.Alloc-import Foreign.CUDA.Driver.Error+import Foreign.Marshal.Alloc ( alloca ) import qualified Foreign.CUDA.Driver as CUDA import qualified Foreign.CUDA.Driver.Stream as CUDA import qualified Foreign.CUDA.Driver.Texture as CUDA -- friends import Data.Array.Accelerate.Array.Data+import Data.Array.Accelerate.CUDA.Context import Data.Array.Accelerate.CUDA.Array.Table import qualified Data.Array.Accelerate.CUDA.Debug as D @@ -59,10 +67,12 @@ type instance DevicePtrs () = () type instance HostPtrs () = () -#define primArrayElt(ty) \-type instance DevicePtrs ty = CUDA.DevicePtr ty ; \-type instance HostPtrs ty = CUDA.HostPtr ty ; \+#define primArrayEltAs(ty,as) \+type instance DevicePtrs ty = CUDA.DevicePtr as ; \+type instance HostPtrs ty = CUDA.HostPtr as ; \ +#define primArrayElt(ty) primArrayEltAs(ty,ty)+ primArrayElt(Int) primArrayElt(Int8) primArrayElt(Int16)@@ -75,38 +85,31 @@ primArrayElt(Word32) primArrayElt(Word64) --- FIXME:--- CShort--- CUShort--- CInt--- CUInt--- CLong--- CULong--- CLLong--- CULLong+primArrayEltAs(CShort, Int16)+primArrayEltAs(CInt, Int32)+primArrayEltAs(CLong, Int64)+primArrayEltAs(CLLong, Int64)+primArrayEltAs(CUShort, Word16)+primArrayEltAs(CUInt, Word32)+primArrayEltAs(CULong, Word64)+primArrayEltAs(CULLong, Word64) primArrayElt(Float) primArrayElt(Double)---- FIXME:--- CFloat--- CDouble--type instance HostPtrs Bool = CUDA.HostPtr Word8-type instance DevicePtrs Bool = CUDA.DevicePtr Word8+primArrayEltAs(CFloat, Float)+primArrayEltAs(CDouble, Double) primArrayElt(Char)+primArrayEltAs(CChar, Int8)+primArrayEltAs(CSChar, Int8)+primArrayEltAs(CUChar, Word8) --- FIXME:--- CChar--- CSChar--- CUChar+primArrayEltAs(Bool, Word8) type instance DevicePtrs (a,b) = (DevicePtrs a, DevicePtrs b) type instance HostPtrs (a,b) = (HostPtrs a, HostPtrs b) - -- Texture References -- ------------------ @@ -116,29 +119,55 @@ class TextureData a where format :: a -> (CUDA.Format, Int) -instance TextureData Int8 where format _ = (CUDA.Int8, 1)-instance TextureData Int16 where format _ = (CUDA.Int16, 1)-instance TextureData Int32 where format _ = (CUDA.Int32, 1)-instance TextureData Int64 where format _ = (CUDA.Int32, 2)-instance TextureData Word8 where format _ = (CUDA.Word8, 1)-instance TextureData Word16 where format _ = (CUDA.Word16, 1)-instance TextureData Word32 where format _ = (CUDA.Word32, 1)-instance TextureData Word64 where format _ = (CUDA.Word32, 2)-instance TextureData Float where format _ = (CUDA.Float, 1)-instance TextureData Double where format _ = (CUDA.Int32, 2)-instance TextureData Bool where format _ = (CUDA.Word8, 1)-#if SIZEOF_HSINT == 4-instance TextureData Int where format _ = (CUDA.Int32, 1)-#elif SIZEOF_HSINT == 8-instance TextureData Int where format _ = (CUDA.Int32, 2)-#endif+instance TextureData Int8 where format _ = (CUDA.Int8, 1)+instance TextureData Int16 where format _ = (CUDA.Int16, 1)+instance TextureData Int32 where format _ = (CUDA.Int32, 1)+instance TextureData Int64 where format _ = (CUDA.Int32, 2)+instance TextureData Word8 where format _ = (CUDA.Word8, 1)+instance TextureData Word16 where format _ = (CUDA.Word16, 1)+instance TextureData Word32 where format _ = (CUDA.Word32, 1)+instance TextureData Word64 where format _ = (CUDA.Word32, 2)+instance TextureData Float where format _ = (CUDA.Float, 1)+instance TextureData Double where format _ = (CUDA.Int32, 2)+instance TextureData Bool where format _ = (CUDA.Word8, 1)+instance TextureData CShort where format _ = (CUDA.Int16, 1)+instance TextureData CUShort where format _ = (CUDA.Word16, 1)+instance TextureData CInt where format _ = (CUDA.Int32, 1)+instance TextureData CUInt where format _ = (CUDA.Word32, 1)+instance TextureData CLong where format _ = (CUDA.Int32, 2)+instance TextureData CULong where format _ = (CUDA.Word32, 2)+instance TextureData CLLong where format _ = (CUDA.Int32, 2)+instance TextureData CULLong where format _ = (CUDA.Word32, 2)+instance TextureData CFloat where format _ = (CUDA.Float, 1)+instance TextureData CDouble where format _ = (CUDA.Int32, 2)+instance TextureData CChar where format _ = (CUDA.Int8, 1)+instance TextureData CSChar where format _ = (CUDA.Int8, 1)+instance TextureData CUChar where format _ = (CUDA.Word8, 1) #if SIZEOF_HSINT == 4-instance TextureData Word where format _ = (CUDA.Word32, 1)+instance TextureData Int where format _ = (CUDA.Int32, 1)+instance TextureData Word where format _ = (CUDA.Word32, 1) #elif SIZEOF_HSINT == 8-instance TextureData Word where format _ = (CUDA.Word32, 2)+instance TextureData Int where format _ = (CUDA.Int32, 2)+instance TextureData Word where format _ = (CUDA.Word32, 2)+#else+instance TextureData Int where+ format _ =+ case sizeOf (undefined::Int) of+ 4 -> (CUDA.Int32, 1)+ 8 -> (CUDA.Int32, 2)+instance TextureData Word where+ format _ =+ case sizeOf (undefined::Word) of+ 4 -> (CUDA.Word32, 1)+ 8 -> (CUDA.Word32, 2) #endif #if SIZEOF_HSCHAR == 4-instance TextureData Char where format _ = (CUDA.Word32, 1)+instance TextureData Char where format _ = (CUDA.Word32, 1)+#else+instance TextureData Char where+ format _ =+ case sizeOf (undefined::Char) of+ 4 -> (CUDA.Word32, 1) #endif @@ -157,16 +186,13 @@ -> Int -> IO () mallocArray !ctx !mt !ad !n0 = do- let !n = 1 `max` n0+ let !n = 1 `max` n0+ !bytes = n * sizeOf (undefined :: a) exists <- isJust <$> (lookup ctx mt ad :: IO (Maybe (CUDA.DevicePtr a))) unless exists $ do- message $ "mallocArray: " ++ showBytes (n * sizeOf (undefined::a))- ptr <- CUDA.mallocArray n `catch` \(e :: CUDAException) ->- case e of- ExitCode OutOfMemory -> reclaim mt >> CUDA.mallocArray n- _ -> throwIO e- insert ctx mt ad (ptr :: CUDA.DevicePtr a)-+ message $ "mallocArray: " ++ showBytes bytes+ _ <- malloc ctx mt ad n :: IO (CUDA.DevicePtr a)+ return () -- A combination of 'mallocArray' and 'pokeArray' to allocate space on the -- device and upload an existing array. This is specialised because if the host@@ -180,18 +206,15 @@ -> Int -> IO () useArray !ctx !mt !ad !n0 =- let src = ptrsOfArrayData ad- !n = 1 `max` n0+ let src = ptrsOfArrayData ad+ !n = 1 `max` n0+ !bytes = n * sizeOf (undefined :: a) in do exists <- isJust <$> (lookup ctx mt ad :: IO (Maybe (CUDA.DevicePtr a))) unless exists $ do- message $ "useArray/malloc: " ++ showBytes (n * sizeOf (undefined::a))- dst <- CUDA.mallocArray n `catch` \(e :: CUDAException) ->- case e of- ExitCode OutOfMemory -> reclaim mt >> CUDA.mallocArray n- _ -> throwIO e+ message $ "useArray/malloc: " ++ showBytes bytes+ dst <- malloc ctx mt ad n CUDA.pokeArray n src dst- insert ctx mt ad dst useArrayAsync@@ -203,18 +226,15 @@ -> Maybe CUDA.Stream -> IO () useArrayAsync !ctx !mt !ad !n0 !ms =- let src = CUDA.HostPtr (ptrsOfArrayData ad)- !n = 1 `max` n0+ let src = CUDA.HostPtr (ptrsOfArrayData ad)+ !n = 1 `max` n0+ !bytes = n * sizeOf (undefined :: a) in do exists <- isJust <$> (lookup ctx mt ad :: IO (Maybe (CUDA.DevicePtr a))) unless exists $ do- message $ "useArrayAsync/malloc: " ++ showBytes (n * sizeOf (undefined::a))- dst <- CUDA.mallocArray n `catch` \(e :: CUDAException) ->- case e of- ExitCode OutOfMemory -> reclaim mt >> CUDA.mallocArray n- _ -> throwIO e+ message $ "useArrayAsync/malloc: " ++ showBytes bytes+ dst <- malloc ctx mt ad n CUDA.pokeArrayAsync n src dst ms- insert ctx mt ad dst -- Read a single element from an array at the given row-major index@@ -252,6 +272,37 @@ CUDA.copyArrayAsync n src dst +-- Copy data between two device arrays that exist in different contexts and/or+-- devices.+--+copyArrayPeer+ :: forall e a b. (ArrayElt e, ArrayPtrs e ~ Ptr a, DevicePtrs e ~ CUDA.DevicePtr b, Typeable a, Typeable b, Typeable e, Storable b)+ => MemoryTable+ -> ArrayData e -> Context -- source array and context+ -> ArrayData e -> Context -- destination array and context+ -> Int -- number of array elements+ -> IO ()+copyArrayPeer !mt !from !ctxSrc !to !ctxDst !n = do+ message $ "copyArrayPeer: " ++ showBytes (n * sizeOf (undefined :: b))+ src <- devicePtrsOfArrayData ctxSrc mt from+ dst <- devicePtrsOfArrayData ctxDst mt to+ CUDA.copyArrayPeer n src (deviceContext ctxSrc) dst (deviceContext ctxDst)++copyArrayPeerAsync+ :: forall e a b. (ArrayElt e, ArrayPtrs e ~ Ptr a, DevicePtrs e ~ CUDA.DevicePtr b, Typeable a, Typeable b, Typeable e, Storable b)+ => MemoryTable+ -> ArrayData e -> Context -- source array and context+ -> ArrayData e -> Context -- destination array and context+ -> Int -- number of array elements+ -> Maybe CUDA.Stream+ -> IO ()+copyArrayPeerAsync !mt !from !ctxSrc !to !ctxDst !n !st = do+ message $ "copyArrayPeerAsync: " ++ showBytes (n * sizeOf (undefined :: b))+ src <- devicePtrsOfArrayData ctxSrc mt from+ dst <- devicePtrsOfArrayData ctxDst mt to+ CUDA.copyArrayPeerAsync n src (deviceContext ctxSrc) dst (deviceContext ctxDst) st++ -- Copy data from the device into the associated Accelerate host-side array -- peekArray@@ -291,7 +342,7 @@ -> IO () pokeArray !ctx !mt !ad !n = devicePtrsOfArrayData ctx mt ad >>= \dst -> do- message $ "pokeArrayAsync: " ++ showBytes (n * sizeOf (undefined :: a))+ message $ "pokeArray: " ++ showBytes (n * sizeOf (undefined :: a)) CUDA.pokeArray n (ptrsOfArrayData ad) dst pokeArrayAsync
Data/Array/Accelerate/CUDA/Array/Table.hs view
@@ -1,7 +1,8 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE ScopedTypeVariables #-} -- | -- Module : Data.Array.Accelerate.CUDA.Array.Table -- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee@@ -16,29 +17,39 @@ module Data.Array.Accelerate.CUDA.Array.Table ( -- Tables for host/device memory associations- MemoryTable, Context(..), new, lookup, insert, reclaim+ MemoryTable, new, lookup, malloc, insert, reclaim ) where -import Prelude hiding ( lookup )-import Data.IORef ( IORef, newIORef, readIORef, mkWeakIORef )-import Data.Maybe ( isJust )-import Data.Hashable ( Hashable(..) )-import Data.Typeable ( Typeable, gcast )-import Control.Monad ( unless )-import Control.Exception ( bracket_ )-import Control.Applicative ( (<$>) )-import System.Mem ( performGC )-import System.Mem.Weak ( Weak, mkWeak, deRefWeak, finalize )-import System.Mem.StableName ( StableName, makeStableName, hashStableName )-import Foreign.Ptr ( ptrToIntPtr )-import Foreign.CUDA.Ptr ( DevicePtr )+#if !MIN_VERSION_base(4,6,0)+import Prelude hiding ( lookup, catch )+#else+import Prelude hiding ( lookup )+#endif+import Data.IORef ( IORef, newIORef, readIORef, mkWeakIORef )+import Data.Maybe ( isJust )+import Data.Hashable ( Hashable(..) )+import Data.Typeable ( Typeable, gcast )+import Control.Monad ( unless )+import Control.Concurrent ( yield )+import Control.Exception ( bracket_, catch, throwIO )+import Control.Applicative ( (<$>) )+import System.Mem ( performGC )+import System.Mem.Weak ( Weak, mkWeak, deRefWeak, finalize )+import System.Mem.StableName ( StableName, makeStableName, hashStableName )+import Foreign.Ptr ( ptrToIntPtr )+import Foreign.Storable ( Storable, sizeOf )+import Foreign.CUDA.Ptr ( DevicePtr ) -import qualified Foreign.CUDA.Driver as CUDA-import qualified Data.HashTable.IO as HT+import Foreign.CUDA.Driver.Error+import qualified Foreign.CUDA.Driver as CUDA+import qualified Data.HashTable.IO as HT -import Data.Array.Accelerate.Array.Data ( ArrayData )-import qualified Data.Array.Accelerate.CUDA.Debug as D+import Data.Array.Accelerate.Array.Data ( ArrayData )+import Data.Array.Accelerate.CUDA.Context ( Context, weakContext, deviceContext )+import Data.Array.Accelerate.CUDA.Array.Nursery ( Nursery(..), NRS )+import qualified Data.Array.Accelerate.CUDA.Array.Nursery as N+import qualified Data.Array.Accelerate.CUDA.Debug as D #include "accelerate.h" @@ -60,12 +71,7 @@ type MT = IORef ( HashTable HostArray DeviceArray ) data MemoryTable = MemoryTable {-# UNPACK #-} !MT {-# UNPACK #-} !(Weak MT)---- The currently active context. Finaliser threads need to check if the context--- is still active before attempting to release their associated memory.----data Context = Context {-# UNPACK #-} !CUDA.Context- {-# UNPACK #-} !(Weak CUDA.Context)+ {-# UNPACK #-} !Nursery -- Arrays on the host and device --@@ -85,7 +91,8 @@ = maybe False (== a2) (gcast a1) instance Hashable HostArray where- hash (HostArray cid sn) = hashWithSalt cid sn+ hashWithSalt salt (HostArray cid sn)+ = salt `hashWithSalt` cid `hashWithSalt` sn instance Show HostArray where show (HostArray _ sn) = "Array #" ++ show (hashStableName sn)@@ -101,14 +108,15 @@ new = do tbl <- HT.new ref <- newIORef tbl+ nrs <- N.new weak <- mkWeakIORef ref (table_finalizer tbl)- return $! MemoryTable ref weak+ return $! MemoryTable ref weak nrs -- Look for the device memory corresponding to a given host-side array. -- lookup :: (Typeable a, Typeable b) => Context -> MemoryTable -> ArrayData a -> IO (Maybe (DevicePtr b))-lookup ctx (MemoryTable ref _) !arr = do+lookup ctx (MemoryTable !ref _ _) !arr = do sa <- makeStableArray ctx arr mw <- withIORef ref (`HT.lookup` sa) case mw of@@ -122,13 +130,44 @@ makeStableArray ctx arr >>= \x -> INTERNAL_ERROR(error) "lookup" $ "dead weak pair: " ++ show x +-- Allocate a new device array to be associated with the given host-side array.+-- This will attempt to use an old array from the nursery, but will otherwise+-- allocate fresh data.+--+-- Instead of allocating the exact number of elements requested, we round up to+-- a fixed chunk size; currently set at 128 elements. This means there is a+-- greater chance the nursery will get a hit, and moreover that we can search+-- the nursery for an exact size. TLM: I believe the CUDA API allocates in+-- chunks, of size 4MB.+--+malloc :: forall a b. (Typeable a, Typeable b, Storable b) => Context -> MemoryTable -> ArrayData a -> Int -> IO (DevicePtr b)+malloc !ctx mt@(MemoryTable _ _ !nursery) !ad !n = do+ let -- next highest multiple of f from x+ multiple x f = floor ((x + (f-1)) / f :: Double)+ chunk = 128++ !n' = chunk * multiple (fromIntegral n) (fromIntegral chunk)+ !bytes = n' * sizeOf (undefined :: b)+ --+ mp <- N.lookup bytes (deviceContext ctx) nursery+ ptr <- case mp of+ Just p -> trace "malloc/nursery" $ return (CUDA.castDevPtr p)+ Nothing -> trace "malloc/new" $+ CUDA.mallocArray n' `catch` \(e :: CUDAException) ->+ case e of+ ExitCode OutOfMemory -> reclaim mt >> CUDA.mallocArray n'+ _ -> throwIO e+ insert ctx mt ad ptr bytes+ return ptr++ -- Record an association between a host-side array and a new device memory area. -- The device memory will be freed when the host array is garbage collected. ---insert :: (Typeable a, Typeable b) => Context -> MemoryTable -> ArrayData a -> DevicePtr b -> IO ()-insert ctx@(Context _ weak_ctx) (MemoryTable ref weak_ref) !arr !ptr = do+insert :: (Typeable a, Typeable b) => Context -> MemoryTable -> ArrayData a -> DevicePtr b -> Int -> IO ()+insert !ctx (MemoryTable !ref !weak_ref (Nursery _ !weak_nrs)) !arr !ptr !bytes = do key <- makeStableArray ctx arr- dev <- DeviceArray `fmap` mkWeak arr ptr (Just $ finalizer weak_ctx weak_ref key ptr)+ dev <- DeviceArray `fmap` mkWeak arr ptr (Just $ finalizer (weakContext ctx) weak_ref weak_nrs key ptr bytes) tbl <- readIORef ref message $ "insert: " ++ show key HT.insert tbl key dev@@ -141,9 +180,11 @@ -- unreachable. -- reclaim :: MemoryTable -> IO ()-reclaim (MemoryTable _ weak_ref) = do+reclaim (MemoryTable _ weak_ref (Nursery nrs _)) = do (free, total) <- CUDA.getMemInfo performGC+ yield+ withIORef nrs N.flush mr <- deRefWeak weak_ref case mr of Nothing -> return ()@@ -167,8 +208,8 @@ -- the hash tables --- but we must do this first before failing to use a dead -- context. ---finalizer :: Weak CUDA.Context -> Weak MT -> HostArray -> DevicePtr b -> IO ()-finalizer !weak_ctx !weak_ref !key !ptr = do+finalizer :: Weak CUDA.Context -> Weak MT -> Weak NRS -> HostArray -> DevicePtr b -> Int -> IO ()+finalizer !weak_ctx !weak_ref !weak_nrs !key !ptr !bytes = do mr <- deRefWeak weak_ref case mr of Nothing -> message ("finalise/dead table: " ++ show key)@@ -177,7 +218,12 @@ mc <- deRefWeak weak_ctx case mc of Nothing -> message ("finalise/dead context: " ++ show key)- Just ctx -> bracket_ (CUDA.push ctx) CUDA.pop (CUDA.free ptr)+ Just ctx -> do+ --+ mn <- deRefWeak weak_nrs+ case mn of+ Nothing -> trace ("finalise/dead nursery: " ++ show key) $ bracket_ (CUDA.push ctx) CUDA.pop (CUDA.free ptr)+ Just nrs -> trace ("finalise/nursery: " ++ show key) $ N.insert bytes ctx nrs ptr table_finalizer :: HashTable HostArray DeviceArray -> IO ()@@ -191,9 +237,11 @@ {-# INLINE makeStableArray #-} makeStableArray :: Typeable a => Context -> ArrayData a -> IO HostArray-makeStableArray (Context (CUDA.Context !p) !_) !arr =- let cid = fromIntegral (ptrToIntPtr p)- in HostArray cid <$> makeStableName arr+makeStableArray !ctx !arr =+ let CUDA.Context !p = deviceContext ctx+ !cid = fromIntegral (ptrToIntPtr p)+ in+ HostArray cid <$> makeStableName arr {-# INLINE withIORef #-} withIORef :: IORef a -> (a -> IO b) -> IO b
+ Data/Array/Accelerate/CUDA/Async.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE CPP #-}+-- |+-- Module : Data.Array.Accelerate.CUDA.Async+-- Copyright : [2009..2013] Manuel M T Chakravarty, Gabriele Keller, 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.CUDA.Async+ where++#if !MIN_VERSION_base(4,6,0)+import Prelude hiding ( catch )+#endif+import Control.Exception+import Control.Concurrent+++-- We need to execute the main thread asynchronously to give finalisers a chance+-- to run. Make sure to catch exceptions to avoid "blocked indefinitely on MVar"+-- errors.+--+data Async a = Async {-# UNPACK #-} !ThreadId+ {-# UNPACK #-} !(MVar (Either SomeException a))++-- Fork an action to execute asynchronously. Moreover, this will be forked into+-- a _bound_ thread, which allows the thread to call foreign libraries that make+-- use of thread-local state, such as CUDA.+--+async :: IO a -> IO (Async a)+async action = do+ var <- newEmptyMVar+ tid <- forkOS $ (putMVar var . Right =<< action)+ `catch`+ \e -> putMVar var (Left e)+ return (Async tid var)++-- | Block the calling thread until the computation completes, then return the+-- result.+--+{-# INLINE wait #-}+wait :: Async a -> IO a+wait (Async _ var) = either throwIO return =<< readMVar var++-- | Test whether the asynchronous computation has already completed. If so,+-- return the result, else 'Nothing'.+--+{-# INLINE poll #-}+poll :: Async a -> IO (Maybe a)+poll (Async _ var) =+ maybe (return Nothing) (either throwIO (return . Just)) =<< tryTakeMVar var++-- | Cancel a running asynchronous computation.+--+{-# INLINE cancel #-}+cancel :: Async a -> IO ()+cancel (Async tid _) = throwTo tid ThreadKilled+
Data/Array/Accelerate/CUDA/CodeGen.hs view
@@ -1,4 +1,9 @@-{-# LANGUAGE CPP, GADTs, PatternGuards, ScopedTypeVariables, QuasiQuotes #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-} -- | -- Module : Data.Array.Accelerate.CUDA.CodeGen -- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee@@ -12,34 +17,35 @@ module Data.Array.Accelerate.CUDA.CodeGen ( - CUTranslSkel, codegenAcc+ CUTranslSkel, codegenAcc, ) where -- libraries-import Prelude hiding ( exp )+import Prelude hiding ( id, exp, replicate, iterate )+import Control.Applicative ( (<$>), (<*>), (<*) )+import Control.Monad.State.Strict import Data.Loc import Data.Char-import Control.Monad-import Control.Applicative hiding ( Const )-import Text.PrettyPrint.Mainland-import Language.C.Syntax ( Const(..) )+import Data.HashSet ( HashSet )+import Foreign.CUDA.Analysis import Language.C.Quote.CUDA-import qualified Data.HashSet as Set import qualified Language.C as C-import qualified Foreign.CUDA.Analysis as CUDA+import qualified Data.HashSet as Set -- friends import Data.Array.Accelerate.Type import Data.Array.Accelerate.Tuple+import Data.Array.Accelerate.Trafo import Data.Array.Accelerate.Pretty () import Data.Array.Accelerate.Analysis.Shape-import Data.Array.Accelerate.Array.Representation+import Data.Array.Accelerate.Array.Sugar ( Array, Shape, Elt, EltRepr )+import Data.Array.Accelerate.Array.Representation ( SliceIndex(..) ) import qualified Data.Array.Accelerate.Array.Sugar as Sugar import qualified Data.Array.Accelerate.Analysis.Type as Sugar import Data.Array.Accelerate.CUDA.AST hiding ( Val(..), prj )-import Data.Array.Accelerate.CUDA.CodeGen.Base+import Data.Array.Accelerate.CUDA.CodeGen.Base hiding ( shapeSize ) import Data.Array.Accelerate.CUDA.CodeGen.Type import Data.Array.Accelerate.CUDA.CodeGen.Monad import Data.Array.Accelerate.CUDA.CodeGen.Mapping@@ -47,10 +53,13 @@ import Data.Array.Accelerate.CUDA.CodeGen.PrefixSum import Data.Array.Accelerate.CUDA.CodeGen.Reduction import Data.Array.Accelerate.CUDA.CodeGen.Stencil+import Data.Array.Accelerate.CUDA.Foreign ( canExecuteExp ) #include "accelerate.h" +-- Local environments+-- data Val env where Empty :: Val () Push :: Val env -> [C.Exp] -> Val (env, s)@@ -67,352 +76,582 @@ -- | Instantiate an array computation with a set of concrete function and type -- definitions to fix the parameters of an algorithmic skeleton. The generated -- code can then be pretty-printed to file, and compiled to object code--- executable on the device.+-- executable on the device. This generates a set of __global__ device functions+-- required to compute the given computation node. ----- The code generator needs to include binding points for array references from--- scalar code. We require that the only array form allowed within expressions--- are array variables.+-- The code generator requires that the only array form allowed within scalar+-- expressions are array variables. The list of array-valued scalar inputs are+-- taken as the environment. -- -- TODO: include a measure of how much shared memory a kernel requires. ---codegenAcc :: forall aenv a.- CUDA.DeviceProperties- -> OpenAcc aenv a- -> AccBindings aenv- -> CUTranslSkel-codegenAcc dev acc (AccBindings vars) = CUTranslSkel entry (extras : fvars code)- where- fvars rest = Set.foldr (\v vs -> liftAcc acc v ++ vs) rest vars- extras = [cedecl| $esc:("#include <accelerate_cuda_extras.h>") |]- CUTranslSkel entry code = codegen acc+codegenAcc :: forall aenv arrs. DeviceProperties -> DelayedOpenAcc aenv arrs -> Gamma aenv -> [ CUTranslSkel aenv arrs ]+codegenAcc _ Delayed{} _ = INTERNAL_ERROR(error) "codegenAcc" "expected manifest array"+codegenAcc dev (Manifest pacc) aenv+ = codegen+ $ case pacc of - codegen :: OpenAcc aenv a -> CUTranslSkel- codegen (OpenAcc pacc) = case pacc of- --- -- Non-computation forms- --- Alet _ _ -> internalError- Avar _ -> internalError- Apply _ _ -> internalError- Acond _ _ _ -> internalError- Atuple _ -> internalError- Aprj _ _ -> internalError- Use _ -> internalError- Unit _ -> internalError- Reshape _ _ -> internalError+ -- Producers+ Map f a -> mkMap dev aenv <$> travF1 f <*> travD a+ Generate _ f -> mkGenerate dev aenv <$> travF1 f+ Transform _ p f a -> mkTransform dev aenv <$> travF1 p <*> travF1 f <*> travD a+ Backpermute _ p a -> mkTransform dev aenv <$> travF1 p <*> travF1 id <*> travD a - --- -- Skeleton nodes- --- Generate _ f -> mkGenerate (accDim acc) (codegenFun f)+ -- Consumers+ Fold f z a -> mkFold dev aenv <$> travF2 f <*> travE z <*> travD a+ Fold1 f a -> mkFold1 dev aenv <$> travF2 f <*> travD a+ FoldSeg f z a s -> mkFoldSeg dev aenv <$> travF2 f <*> travE z <*> travD a <*> travD s+ Fold1Seg f a s -> mkFold1Seg dev aenv <$> travF2 f <*> travD a <*> travD s+ Scanl f z a -> mkScanl dev aenv <$> travF2 f <*> travE z <*> travD a+ Scanr f z a -> mkScanr dev aenv <$> travF2 f <*> travE z <*> travD a+ Scanl' f z a -> mkScanl' dev aenv <$> travF2 f <*> travE z <*> travD a+ Scanr' f z a -> mkScanr' dev aenv <$> travF2 f <*> travE z <*> travD a+ Scanl1 f a -> mkScanl1 dev aenv <$> travF2 f <*> travD a+ Scanr1 f a -> mkScanr1 dev aenv <$> travF2 f <*> travD a+ Permute f _ p a -> mkPermute dev aenv <$> travF2 f <*> travF1 p <*> travD a+ Stencil f b a -> mkStencil dev aenv <$> travF1 f <*> travB a b+ Stencil2 f b1 a1 b2 a2 -> mkStencil2 dev aenv <$> travF2 f <*> travB a1 b1 <*> travB a2 b2 - Replicate sl _ a -> mkReplicate dimSl dimOut (extend sl) (undefined :: a)- where- dimSl = accDim a- dimOut = accDim acc- --- extend :: SliceIndex slix sl co dim -> CUExp dim- extend = CUExp [] . reverse . extend' 0+ -- Non-computation forms -> sadness+ Alet _ _ -> unexpectedError+ Avar _ -> unexpectedError+ Apply _ _ -> unexpectedError+ Acond _ _ _ -> unexpectedError+ Atuple _ -> unexpectedError+ Aprj _ _ -> unexpectedError+ Use _ -> unexpectedError+ Unit _ -> unexpectedError+ Aforeign _ _ _ -> unexpectedError+ Reshape _ _ -> unexpectedError - extend' :: Int -> SliceIndex slix sl co dim -> [C.Exp]- extend' _ (SliceNil) = []- extend' n (SliceAll sliceIdx) = mkPrj dimOut "dim" n : extend' (n+1) sliceIdx- extend' n (SliceFixed sliceIdx) = extend' (n+1) sliceIdx+ Replicate _ _ _ -> fusionError+ Slice _ _ _ -> fusionError+ ZipWith _ _ _ -> fusionError - Index sl a slix -> mkSlice dimSl dimCo dimIn0 (restrict sl) (undefined :: a)- where- dimCo = length (expType slix)- dimSl = accDim acc- dimIn0 = accDim a- --- restrict :: SliceIndex slix sl co dim -> CUExp slix- restrict = CUExp [] . reverse . restrict' (0,0)+ where+ codegen :: CUDA [CUTranslSkel aenv a] -> [CUTranslSkel aenv a]+ codegen cuda =+ let (skeletons, st) = runCUDA cuda+ addTo (CUTranslSkel name code) =+ CUTranslSkel name (Set.foldr (\h c -> [cedecl| $esc:("#include \"" ++ h ++ "\"") |] : c) code (headers st))+ in+ map addTo skeletons - restrict' :: (Int,Int) -> SliceIndex slix sl co dim -> [C.Exp]- restrict' _ (SliceNil) = []- restrict' (m,n) (SliceAll sliceIdx) = mkPrj dimSl "sl" n : restrict' (m,n+1) sliceIdx- restrict' (m,n) (SliceFixed sliceIdx) = mkPrj dimCo "co" m : restrict' (m+1,n) sliceIdx+ id :: Elt a => DelayedFun aenv (a -> a)+ id = Lam (Body (Var ZeroIdx)) - Map f _ -> mkMap (codegenFun f)- ZipWith f _ _ -> mkZipWith (accDim acc) (codegenFun f)+ -- code generation for delayed arrays+ travD :: (Shape sh, Elt e) => DelayedOpenAcc aenv (Array sh e) -> CUDA (CUDelayedAcc aenv sh e)+ travD Manifest{} = INTERNAL_ERROR(error) "codegenAcc" "expected delayed array"+ travD Delayed{..} = CUDelayed <$> travE extentD+ <*> travF1 indexD+ <*> travF1 linearIndexD - Fold f e _ ->- if accDim acc == 0- then mkFoldAll dev (codegenFun f) (Just (codegenExp e))- else mkFold dev (codegenFun f) (Just (codegenExp e))+ -- scalar code generation+ travF1 :: DelayedFun aenv (a -> b) -> CUDA (CUFun1 aenv (a -> b))+ travF1 = codegenFun1 dev aenv - Fold1 f _ ->- if accDim acc == 0- then mkFoldAll dev (codegenFun f) Nothing- else mkFold dev (codegenFun f) Nothing+ travF2 :: DelayedFun aenv (a -> b -> c) -> CUDA (CUFun2 aenv (a -> b -> c))+ travF2 = codegenFun2 dev aenv - FoldSeg f e _ s -> mkFoldSeg dev (accDim acc) (segmentsType s) (codegenFun f) (Just (codegenExp e))- Fold1Seg f _ s -> mkFoldSeg dev (accDim acc) (segmentsType s) (codegenFun f) Nothing+ travE :: DelayedExp aenv t -> CUDA (CUExp aenv t)+ travE = codegenExp dev aenv - Scanl f e _ -> mkScanl dev (codegenFun f) (Just (codegenExp e))- Scanl' f e _ -> mkScanl dev (codegenFun f) (Just (codegenExp e))- Scanl1 f _ -> mkScanl dev (codegenFun f) Nothing+ travB :: forall sh e. Elt e+ => DelayedOpenAcc aenv (Array sh e) -> Boundary (EltRepr e) -> CUDA (Boundary (CUExp aenv e))+ travB _ Clamp = return Clamp+ travB _ Mirror = return Mirror+ travB _ Wrap = return Wrap+ travB _ (Constant c) = return . Constant $ CUExp ([], codegenConst (Sugar.eltType (undefined::e)) c) - Scanr f e _ -> mkScanr dev (codegenFun f) (Just (codegenExp e))- Scanr' f e _ -> mkScanr dev (codegenFun f) (Just (codegenExp e))- Scanr1 f _ -> mkScanr dev (codegenFun f) Nothing+ -- caffeine and misery+ prim :: String+ prim = showPreAccOp pacc+ unexpectedError = INTERNAL_ERROR(error) "codegenAcc" $ "unexpected array primitive: " ++ prim+ fusionError = INTERNAL_ERROR(error) "codegenAcc" $ "unexpected fusible material: " ++ prim - Permute f _ ix a -> mkPermute dev (accDim acc) (accDim a) (codegenFun f) (codegenFun ix)- Backpermute _ f a -> mkBackpermute (accDim acc) (accDim a) (codegenFun f) (undefined :: a) - Stencil f b0 a0 -> mkStencil (accDim acc) (codegenFun f) (codegenBoundary a0 b0) (undefined :: a)- Stencil2 f b1 a1 b0 a0- -> mkStencil2 (accDim acc) (codegenFun f) (codegenBoundary a1 b1) (codegenBoundary a0 b0) (undefined :: a)+-- Scalar function abstraction+-- --------------------------- - --- -- caffeine and misery- --- internalError =- let msg = unlines ["unsupported array primitive", pretty 100 (nest 2 doc)]- pac = show acc- doc | length pac <= 250 = text pac- | otherwise = text (take 250 pac) <+> text "... {truncated}"- in- INTERNAL_ERROR(error) "codegenAcc" msg+-- Generate code for scalar function abstractions.+--+-- This is quite awkward: we have an outer monad to generate fresh variable+-- names, but since we know that even if the function in applied many times+-- (for example, collective operations such as 'fold' and 'scan'), the variables+-- will not shadow each other. Thus, we don't need fresh names at _every_+-- invocation site, so we hack this a bit to return a pure closure.+--+-- Still, there has got to be a cleaner way to do this...+--+codegenFun1+ :: forall aenv a b. DeviceProperties+ -> Gamma aenv+ -> DelayedFun aenv (a -> b)+ -> CUDA (CUFun1 aenv (a -> b))+codegenFun1 dev aenv fun+ | Lam (Body f) <- fun+ = let+ go :: Rvalue x => [x] -> Gen ([C.BlockItem], [C.Exp])+ go x = do+ code <- mapM use =<< codegenOpenExp dev aenv f (Empty `Push` map rvalue x)+ env <- getEnv+ return (env, code) - -- Generate binding points (texture references and shapes) for arrays lifted- -- from scalar expressions- --- liftAcc :: OpenAcc aenv a -> ArrayVar aenv -> [C.Definition]- liftAcc _ (ArrayVar idx) =- let avar = OpenAcc (Avar idx)- idx' = show $ idxToInt idx- sh = cshape ("sh" ++ idx') (accDim avar)- ty = accTypeTex avar- arr n = "avar" ++ idx' ++ "_a" ++ show (n::Int)- in- sh : zipWith (\t n -> cglobal t (arr n)) (reverse ty) [0..]+ (_,u,_) = locals "undefined_x" (undefined :: a)+ in do+ n <- get+ ExpST _ used _ <- execCGM (go u)+ return $ CUFun1 (mark used u)+ $ \xs -> evalState (evalCGM (go xs)) n+ --+ | otherwise+ = INTERNAL_ERROR(error) "codegenFun1" "expected unary function" - -- Shapes are still represented as C structs, so we need to generate field- -- indexing code for shapes- --- mkPrj :: Int -> String -> Int -> C.Exp- mkPrj ndim var c- | ndim <= 1 = cvar var- | otherwise = [cexp| $exp:(cvar var) . $id:('a':show c) |]+codegenFun2+ :: forall aenv a b c. DeviceProperties+ -> Gamma aenv+ -> DelayedFun aenv (a -> b -> c)+ -> CUDA (CUFun2 aenv (a -> b -> c))+codegenFun2 dev aenv fun+ | Lam (Lam (Body f)) <- fun+ = let+ go :: (Rvalue x, Rvalue y) => [x] -> [y] -> Gen ([C.BlockItem], [C.Exp])+ go x y = do+ code <- mapM use =<< codegenOpenExp dev aenv f (Empty `Push` map rvalue x `Push` map rvalue y)+ env <- getEnv+ return (env, code) + (_,u,_) = locals "undefined_x" (undefined :: a)+ (_,v,_) = locals "undefined_y" (undefined :: b)+ in do+ n <- get+ ExpST _ used _ <- execCGM (go u v)+ return $ CUFun2 (mark used u) (mark used v)+ $ \xs ys -> evalState (evalCGM (go xs ys)) n+ --+ | otherwise+ = INTERNAL_ERROR(error) "codegenFun2" "expected binary function" - -- code generation for stencil boundary conditions- --- codegenBoundary :: forall dim e. Sugar.Elt e- => OpenAcc aenv (Sugar.Array dim e) {- dummy -}- -> Boundary (Sugar.EltRepr e)- -> Boundary (CUExp e)- codegenBoundary _ Clamp = Clamp- codegenBoundary _ Mirror = Mirror- codegenBoundary _ Wrap = Wrap- codegenBoundary _ (Constant c)- = Constant . CUExp []- $ codegenConst (Sugar.eltType (undefined::e)) c +-- It is important to filter output terms of a function that will not be used.+-- Consider this pattern from the map kernel:+--+-- items:(x .=. get ix)+-- items:(set ix .=. f x)+--+-- If this is applied to the following expression where we extract the first+-- component of a 4-tuple:+--+-- map (\t -> let (x,_,_,_) = unlift t in x) vec4+--+-- Then the first line 'get ix' still reads all four components of the input+-- vector, even though only one is used. Conversely, if we directly apply the+-- data fetch to f, then the redundant reads are eliminated, but this is simply+-- inlining the read into the function body, so if the argument is used multiple+-- times so to is the data read multiple times.+--+-- The procedure for determining which variables are used is to record each+-- singleton expression produced throughout code generation to a set. It doesn't+-- matter if the expression is a variable (which we are interested in) or+-- something else. Once generation completes, we can test which of the input+-- variables also appear in the output set. Later, we integrate this information+-- when assigning to l-values: if the variable is not in the set, simply elide+-- that statement.+--+-- In the above map example, this means that the usage data is taken from 'f',+-- but applies to which results of 'get ix' are committed to memory.+--+mark :: HashSet C.Exp -> [C.Exp] -> ([a] -> [(Bool,a)])+mark used xs+ = let flags = map (\x -> x `Set.member` used) xs+ in zipWith (,) flags +visit :: [C.Exp] -> Gen [C.Exp]+visit exp+ | [x] <- exp = use x >> return exp+ | otherwise = return exp --- Scalar Expressions++-- Scalar expressions -- ------------------ --- Function abstraction+-- Generation of scalar expressions ----- Although Accelerate includes lambda abstractions, it does not include a--- general application form. That is, lambda abstractions of scalar expressions--- are only introduced as arguments to collective operations, so lambdas are--- always outermost, and can always be translated into plain C functions.+codegenExp :: DeviceProperties -> Gamma aenv -> DelayedExp aenv t -> CUDA (CUExp aenv t)+codegenExp dev aenv exp =+ evalCGM $ do+ code <- codegenOpenExp dev aenv exp Empty+ env <- getEnv+ return $! CUExp (env,code)+++-- The core of the code generator, buildings lists of untyped C expression+-- fragments. This is tricky to get right! ---codegenFun :: Fun aenv t -> CUFun t-codegenFun fun = runCGM $ codegenOpenFun (arity fun) fun Empty+codegenOpenExp+ :: forall aenv env' t'. DeviceProperties+ -> Gamma aenv+ -> DelayedOpenExp env' aenv t'+ -> Val env'+ -> Gen [C.Exp]+codegenOpenExp dev aenv = cvtE where- arity :: OpenFun env aenv t -> Int- arity (Body _) = -1- arity (Lam f) = 1 + arity f--codegenOpenFun :: Int -> OpenFun env aenv t -> Val env -> CGM (CUFun t)-codegenOpenFun _lvl (Body e) env = do- e' <- codegenOpenExp e env- env' <- environment- zipWithM_ addVar (expType e) e'- return $ CUBody (CUExp env' e')+ -- Generate code for a scalar expression in depth-first order. We run under+ -- a monad that generates fresh names and keeps track of let bindings.+ --+ cvtE :: forall env t. DelayedOpenExp env aenv t -> Val env -> Gen [C.Exp]+ cvtE exp env = visit =<<+ case exp of+ Let bnd body -> elet bnd body env+ Var ix -> return $ prj ix env+ PrimConst c -> return $ [codegenPrimConst c]+ Const c -> return $ codegenConst (Sugar.eltType (undefined::t)) c+ PrimApp f arg -> return . codegenPrim f <$> cvtE arg env+ Tuple t -> cvtT t env+ Prj i t -> prjT i t exp env+ Cond p t e -> cond p t e env+ Iterate n f x -> iterate n f x env+-- While p f x -> while p f x env -codegenOpenFun lvl (Lam (f :: OpenFun (env,a) aenv b)) env = do- let ty = eltType (undefined::a)- n = length ty- vars = map (\i -> cvar ('x':shows lvl "_a" ++ show i)) [n-1,n-2..0]- weaken- f' <- codegenOpenFun (lvl-1) f (env `Push` vars)- vars' <- subscripts lvl- return $ CULam vars' f'+ -- Shapes and indices+ IndexNil -> return []+ IndexAny -> return []+ IndexCons sh sz -> (++) <$> cvtE sh env <*> cvtE sz env+ IndexHead ix -> return . last <$> cvtE ix env+ IndexTail ix -> init <$> cvtE ix env+ IndexSlice ix slix sh -> indexSlice ix slix sh env+ IndexFull ix slix sl -> indexFull ix slix sl env+ ToIndex sh ix -> toIndex sh ix env+ FromIndex sh ix -> fromIndex sh ix env + -- Arrays and indexing+ Index acc ix -> index acc ix env+ LinearIndex acc ix -> linearIndex acc ix env+ Shape acc -> shape acc env+ ShapeSize sh -> shapeSize sh env+ Intersect sh1 sh2 -> intersect sh1 sh2 env --- Embedded scalar computations----codegenExp :: Exp aenv t -> CUExp t-codegenExp exp = runCGM $ do- e' <- codegenOpenExp exp Empty- env' <- environment- return $ CUExp env' e'+ --Foreign function+ Foreign ff _ e -> foreignE ff e env + -- The heavy lifting+ -- ----------------- -codegenOpenExp :: forall env aenv t. OpenExp env aenv t -> Val env -> CGM [C.Exp]-codegenOpenExp exp env =- case exp of- -- local binders and variable indices+ -- Scalar let expressions evaluate their terms and generate new (const)+ -- variable bindings to store these results. These are carried the monad+ -- state, which also gives us a supply of fresh names. The new names are+ -- added to the environment for use in the body via the standard Var term. --- -- NOTE: recording which variables are used is important, because the CUDA- -- compiler will not eliminate variables that are initialised but never- -- used. If this is a scalar type mark it as used immediately, otherwise- -- wait until tuple projection picks out an individual element.+ -- Note that we have not restricted the scope of these new bindings: once+ -- something is added, it remains in scope forever. We are relying on+ -- liveness analysis of the CUDA compiler to manage register pressure. --- Let a b -> do- a' <- codegenOpenExp a env- vars <- zipWithM bindVars (expType a) a'- codegenOpenExp b (env `Push` vars)- where- -- FIXME: if we are let-binding an input argument (read from global- -- array) mark that as used and return the variable name directly,- -- otherwise create a fresh binding point.- --- bindVars t x = do- p <- addVar t x- if p then return x- else bind t x-- Var ix- | [t] <- ty, [v] <- var -> addVar t v >> return var- | otherwise -> return var- where- var = prj ix env- ty = eltType (undefined :: t)+ elet :: DelayedOpenExp env aenv bnd -> DelayedOpenExp (env, bnd) aenv body -> Val env -> Gen [C.Exp]+ elet bnd body env = do+ bnd' <- cvtE bnd env+ x <- pushEnv bnd bnd'+ body' <- cvtE body (env `Push` x)+ return body' - -- Constant values+ -- Convert an open expression into a sequence of C expressions. We retain+ -- snoc-list ordering, so the element at tuple index zero is at the end of+ -- the list. Note that nested tuple structures are flattened. --- PrimConst c -> return [codegenPrimConst c]- Const c -> return (codegenConst (Sugar.eltType (undefined::t)) c)+ cvtT :: Tuple (DelayedOpenExp env aenv) t -> Val env -> Gen [C.Exp]+ cvtT tup env =+ case tup of+ NilTup -> return []+ SnocTup t e -> (++) <$> cvtT t env <*> cvtE e env - -- Primitive scalar operations+ -- Project out a tuple index. Since the nested tuple structure is flattened,+ -- this actually corresponds to slicing out a subset of the list of C+ -- expressions, rather than picking out a single element. --- PrimApp f arg -> do- x <- codegenOpenExp arg env- return [codegenPrim f x]+ prjT :: forall env t e. TupleIdx (TupleRepr t) e+ -> DelayedOpenExp env aenv t+ -> DelayedOpenExp env aenv e+ -> Val env+ -> Gen [C.Exp]+ prjT ix t e env =+ let subset = reverse+ . take (length $ expType e)+ . drop (prjToInt ix $ Sugar.preExpType Sugar.delayedAccType t)+ . reverse+ in+ subset <$> cvtE t env - -- Tuples+ -- Convert a tuple index into the corresponding integer. Since the internal+ -- representation is flat, be sure to walk over all sub components when indexing+ -- past nested tuples. --- Tuple t -> codegenTup t env- Prj idx e -> do- e' <- codegenOpenExp e env- case subset (zip e' elt) of- [(x,t)] -> addVar t x >> return [x]- xts -> return $ fst (unzip xts)- where- elt = expType e- subset = reverse- . take (length (expType exp))- . drop (prjToInt idx (Sugar.expType e))- . reverse+ prjToInt :: TupleIdx t e -> TupleType a -> Int+ prjToInt ZeroTupIdx _ = 0+ prjToInt (SuccTupIdx i) (b `PairTuple` a) = sizeTupleType a + prjToInt i b+ prjToInt _ _ = INTERNAL_ERROR(error) "prjToInt" "inconsistent valuation" - -- Conditional expression+ sizeTupleType :: TupleType a -> Int+ sizeTupleType UnitTuple = 0+ sizeTupleType (SingleTuple _) = 1+ sizeTupleType (PairTuple a b) = sizeTupleType a + sizeTupleType b++ -- Scalar conditionals. To keep the return type as an expression list we use+ -- the ternery C condition operator (?:). For tuples this is not+ -- particularly good, so the least we can do is make sure the predicate+ -- result is evaluated only once and bound to a local variable. --- Cond p t e -> do- t' <- codegenOpenExp t env- e' <- codegenOpenExp e env- p' <- codegenOpenExp p env >>= \ps ->- case ps of- [x] -> bind [cty| typename bool |] x- _ -> INTERNAL_ERROR(error) "codegenOpenExp" "expected conditional predicate"- --- let cond ty a b = addVar ty a >> addVar ty b >>- return [cexp| $exp:p' ? $exp:a : $exp:b|]- sequence $ zipWith3 cond (expType t) t' e'+ cond :: DelayedOpenExp env aenv Bool+ -> DelayedOpenExp env aenv t+ -> DelayedOpenExp env aenv t+ -> Val env -> Gen [C.Exp]+ cond p t e env = do+ p' <- cvtE p env+ ok <- single "Cond" <$> pushEnv p p'+ zipWith (\a b -> [cexp| $exp:ok ? $exp:a : $exp:b |]) <$> cvtE t env <*> cvtE e env - -- Array indices and shapes+ -- Value recursion. Two flavours. --- IndexNil -> return []- IndexAny -> return []- IndexCons sh sz -> do- sh' <- codegenOpenExp sh env- sz' <- codegenOpenExp sz env- return (sh' ++ sz')+ iterate :: DelayedOpenExp env aenv Int -- fixed iteration depth+ -> DelayedOpenExp (env,a) aenv a -- loop body+ -> DelayedOpenExp env aenv a -- initial value+ -> Val env+ -> Gen [C.Exp]+ iterate n f x env+ = do [n'] <- cvtE n env+ x' <- cvtE x env+ var_x <- mapM (\_ -> lift fresh) x'+ var_n <- lift fresh+ let seed = [cdecl| const int $id:var_n = $exp:n'; |]+ : zipWith3 (\t a v -> [cdecl| $ty:t $id:a = $exp:v; |]) (expType x) var_x x'+ acc = map cvar var_x - IndexHead ix -> do- ix' <- last <$> codegenOpenExp ix env- _ <- addVar (last (expType ix)) ix'- return [ix']+ -- generate the loop in a clean environment, so that the previous+ -- environment fragments are not included in the body+ outer <- gets bindings <* modify (\st -> st { bindings = [] })+ body <- cvtE f (env `Push` acc)+ inner <- getEnv+ i <- lift fresh - IndexTail ix -> do- ix' <- codegenOpenExp ix env- return (init ix')+ let go = C.BlockStm+ $ [cstm| for (int $id:i = 0; $id:i < $id:var_n; ++ $id:i) {+ $items:inner+ $items:(acc .=. body)+ } |] - -- Array shape and element indexing+ -- restore the outer environment, plus the new loop+ modify (\st -> st { bindings = go : map C.BlockDecl (reverse seed) ++ outer })+ return acc++{--+ while :: DelayedOpenExp (env,a) aenv Bool -- continue while predicate returns true+ -> DelayedOpenExp (env,a) aenv a -- loop body+ -> DelayedOpenExp env aenv a -- initial value+ -> Val env+ -> Gen [C.Exp]+ while p f x env+ = do x' <- cvtE x env++ var_x <- mapM (\_ -> lift fresh) x'+ var_ok <- lift fresh++ let seed = [cdecl| int $id:var_ok; |]+ : zipWith3 (\t a v -> [cdecl| $ty:t $id:a = $exp:v; |]) (expType x) var_x x'+ acc = map cvar var_x+ ok = cvar var_ok++ -- generate the loop functions in a clean environment+ outer <- gets bindings <* modify (\st -> st { bindings = [] })+ [done] <- cvtE p (env `Push` acc)+ envP <- getEnv <* modify (\st -> st { bindings = [] })+ body <- cvtE f (env `Push` acc)+ envF <- getEnv++ let go = envP+ ++ (ok .=. done)+ ++ [C.BlockStm+ [cstm| while ( $exp:ok ) {+ $items:envF+ $items:(acc .=. body)+ $items:envP+ $items:(ok .=. done)+ } |]]++ -- restore the outer environment, plus the new loop+ modify (\st -> st { bindings = reverse (map C.BlockDecl seed ++ go) ++ outer })+ return acc+--}++ -- Restrict indices based on a slice specification. In the SliceAll case we+ -- elide the presence of IndexAny from the head of slx, as this is not+ -- represented in by any C term (Any ~ []) --- ShapeSize sh -> do- sh' <- codegenOpenExp sh env- return [ ccall "size" [ccall "shape" sh'] ]+ indexSlice :: SliceIndex (EltRepr slix) sl co (EltRepr sh)+ -> DelayedOpenExp env aenv slix+ -> DelayedOpenExp env aenv sh+ -> Val env+ -> Gen [C.Exp]+ indexSlice sliceIndex slix sh env =+ let restrict :: SliceIndex slix sl co sh -> [C.Exp] -> [C.Exp] -> [C.Exp]+ restrict SliceNil _ _ = []+ restrict (SliceAll sliceIdx) slx (sz:sl) = sz : restrict sliceIdx slx sl+ restrict (SliceFixed sliceIdx) (_:slx) ( _:sl) = restrict sliceIdx slx sl+ restrict _ _ _ = INTERNAL_ERROR(error) "IndexSlice" "unexpected shapes"+ --+ slice slix' sh' = reverse $ restrict sliceIndex (reverse slix') (reverse sh')+ in+ slice <$> cvtE slix env <*> cvtE sh env - Shape arr- | OpenAcc (Avar a) <- arr ->- let ndim = accDim arr- sh = cvar ("sh" ++ show (idxToInt a))- in return $ if ndim <= 1- then [sh]- else map (\c -> [cexp| $exp:sh . $id:('a':show c) |] ) [ndim-1, ndim-2 .. 0]+ -- Extend indices based on a slice specification. In the SliceAll case we+ -- elide the presence of Any from the head of slx.+ --+ indexFull :: SliceIndex (EltRepr slix) (EltRepr sl) co sh+ -> DelayedOpenExp env aenv slix+ -> DelayedOpenExp env aenv sl+ -> Val env+ -> Gen [C.Exp]+ indexFull sliceIndex slix sl env =+ let extend :: SliceIndex slix sl co sh -> [C.Exp] -> [C.Exp] -> [C.Exp]+ extend SliceNil _ _ = []+ extend (SliceAll sliceIdx) slx (sz:sh) = sz : extend sliceIdx slx sh+ extend (SliceFixed sliceIdx) (sz:slx) sh = sz : extend sliceIdx slx sh+ extend _ _ _ = INTERNAL_ERROR(error) "IndexFull" "unexpected shapes"+ --+ replicate slix' sl' = reverse $ extend sliceIndex (reverse slix') (reverse sl')+ in+ replicate <$> cvtE slix env <*> cvtE sl env - | otherwise -> INTERNAL_ERROR(error) "codegenOpenExp" "expected array variable"+ -- Convert between linear and multidimensional indices. For the+ -- multidimensional case, we've inlined the definition of 'fromIndex'+ -- because we need to return an expression for each component.+ --+ toIndex :: DelayedOpenExp env aenv sh -> DelayedOpenExp env aenv sh -> Val env -> Gen [C.Exp]+ toIndex sh ix env = do+ sh' <- cvtE sh env+ ix' <- cvtE ix env+ return [ ccall "toIndex" [ ccall "shape" sh', ccall "shape" ix' ] ] - IndexScalar arr ix- | OpenAcc (Avar a) <- arr ->- let avar = show (idxToInt a)- sh = cvar ("sh" ++ avar)- array x = cvar ("avar" ++ avar ++ "_a" ++ show x)- elt = accTypeTex arr- n = length elt+ fromIndex :: DelayedOpenExp env aenv sh -> DelayedOpenExp env aenv Int -> Val env -> Gen [C.Exp]+ fromIndex sh ix env = do+ sh' <- cvtE sh env+ ix' <- cvtE ix env+ reverse <$> fromIndex' (reverse sh') (single "fromIndex" ix')+ where+ fromIndex' :: [C.Exp] -> C.Exp -> Gen [C.Exp]+ fromIndex' [] _ = return []+ fromIndex' [_] i = return [i]+ fromIndex' (d:ds) i = do+ i' <- bind [cty| int |] i+ ds' <- fromIndex' ds [cexp| $exp:i' / $exp:d |]+ return $ [cexp| $exp:i' % $exp:d |] : ds'++ -- Project out a single scalar element from an array. The array expression+ -- does not contain any free scalar variables (strictly flat data+ -- parallelism) and has been floated out to be replaced by an array index.+ --+ -- As we have a non-parametric array representation, be sure to bind the+ -- linear array index as it will be used to access each component of a+ -- tuple.+ --+ -- Note that after evaluating the linear array index we bind this to a fresh+ -- variable of type 'int', so there is an implicit conversion from+ -- Int -> Int32.+ --+ index :: (Shape sh, Elt e)+ => DelayedOpenAcc aenv (Array sh e)+ -> DelayedOpenExp env aenv sh+ -> Val env+ -> Gen [C.Exp]+ index acc ix env+ | Manifest (Avar idx) <- acc+ = let (sh, arr) = namesOfAvar aenv idx+ ty = accType acc in do- ix' <- codegenOpenExp ix env- v <- bind [cty| int |] (ccall "toIndex" [sh, ccall "shape" ix'])- return $ zipWith (\t x -> indexArray t (array x) v) elt [n-1, n-2 .. 0]+ ix' <- cvtE ix env+ i <- bind [cty| int |] $ ccall "toIndex" [ cvar sh, ccall "shape" ix' ]+ return $ zipWith (\t a -> indexArray dev t (cvar a) i) ty arr+ --+ | otherwise+ = INTERNAL_ERROR(error) "Index" "expected array variable" - | otherwise -> INTERNAL_ERROR(error) "codegenOpenExp" "expected array variable" + linearIndex :: (Shape sh, Elt e)+ => DelayedOpenAcc aenv (Array sh e)+ -> DelayedOpenExp env aenv Int+ -> Val env+ -> Gen [C.Exp]+ linearIndex acc ix env+ | Manifest (Avar idx) <- acc+ = let (_, arr) = namesOfAvar aenv idx+ ty = accType acc+ in do+ ix' <- cvtE ix env+ i <- bind [cty| int |] $ single "LinearIndex" ix'+ return $ zipWith (\t a -> indexArray dev t (cvar a) i) ty arr+ --+ | otherwise+ = INTERNAL_ERROR(error) "LinearIndex" "expected array variable" --- Tuples are defined as snoc-lists, so generate code right-to-left----codegenTup :: Tuple (OpenExp env aenv) t -> Val env -> CGM [C.Exp]-codegenTup tup env = case tup of- NilTup -> return []- SnocTup t e -> (++) <$> codegenTup t env <*> codegenOpenExp e env+ -- Array shapes created in this method refer to the shape of free array+ -- variables. As such, they are always passed as arguments to the kernel,+ -- not computed as part of the scalar expression. These shapes are+ -- transferred to the kernel as a structure, and so the individual fields+ -- need to be "unpacked", to work with our handling of tuple structures.+ --+ shape :: (Shape sh, Elt e) => DelayedOpenAcc aenv (Array sh e) -> Val env -> Gen [C.Exp]+ shape acc _env+ | Manifest (Avar idx) <- acc+ = return $ cshape (delayedDim acc) (cvar $ fst (namesOfAvar aenv idx)) + | otherwise+ = INTERNAL_ERROR(error) "Shape" "expected array variable" --- Convert a tuple index into the corresponding integer. Since the internal--- representation is flat, be sure to walk over all sub components when indexing--- past nested tuples.----prjToInt :: TupleIdx t e -> TupleType a -> Int-prjToInt ZeroTupIdx _ = 0-prjToInt (SuccTupIdx i) (b `PairTuple` a) = sizeTupleType a + prjToInt i b-prjToInt _ _ =- INTERNAL_ERROR(error) "prjToInt" "inconsistent valuation"+ -- The size of a shape, as the product of the extent in each dimension. The+ -- definition is inlined, but we could also call the C function helpers.+ --+ shapeSize :: DelayedOpenExp env aenv sh -> Val env -> Gen [C.Exp]+ shapeSize sh env =+ let size [] = return $ [cexp| 1 |]+ size ss = return $ foldl1 (\a b -> [cexp| $exp:a * $exp:b |]) ss+ in+ size <$> cvtE sh env -sizeTupleType :: TupleType a -> Int-sizeTupleType UnitTuple = 0-sizeTupleType (SingleTuple _) = 1-sizeTupleType (PairTuple a b) = sizeTupleType a + sizeTupleType b+ -- Intersection of two shapes, taken as the minimum in each dimension.+ --+ intersect :: forall env sh. Elt sh+ => DelayedOpenExp env aenv sh+ -> DelayedOpenExp env aenv sh+ -> Val env -> Gen [C.Exp]+ intersect sh1 sh2 env = let+ sh1' = ccastTup (Sugar.eltType (undefined::sh)) <$> cvtE sh1 env+ sh2' = ccastTup (Sugar.eltType (undefined::sh)) <$> cvtE sh2 env+ in zipWith (\a b -> ccall "min" [a,b]) <$> sh1' <*> sh2' + -- Foreign scalar functions. We need to extract any header files that might+ -- be required so they can be added to the top level definitions.+ --+ -- Additionally, we insert an explicit type cast from the foreign function+ -- result back into Accelerate types (c.f. Int vs int).+ --+ foreignE :: forall f a b env. (Sugar.Foreign f, Elt a, Elt b)+ => f a b+ -> DelayedOpenExp env aenv a+ -> Val env+ -> Gen [C.Exp]+ foreignE ff x env = case canExecuteExp ff of+ Nothing -> INTERNAL_ERROR(error) "codegenOpenExp" "Non-CUDA foreign expression encountered"+ Just f -> do+ unless (null hdr) . lift $ modify (\st -> st { headers = Set.insert hdr (headers st) })+ args <- cvtE x env+ return $ [ccall name (ccastTup (Sugar.eltType (undefined::a)) args)]+ where+ (hdr, rest) = break isSpace f+ name = if null rest then f else tail rest --- Recording which variables of a computation are actually used is important,--- particularly for stencils and arrays of tuples, because the CUDA compiler--- will not eliminate variables that are initialised but never used.------ FIXME: This dubious hack is used to inspect the expression and mark as used--- if it refers to an array input.----addVar :: C.Type -> C.Exp -> CGM Bool-addVar ty exp = case show exp of- ('x':v:'_':'a':n) | [(v',[])] <- reads [v], [(n',[])] <- reads n- -> use v' n' ty exp >> return True- ('v':n) | [(_ :: Int,[])] <- reads n- -> return True- _ -> return False+ -- Some terms demand we extract only singly typed expressions+ --+ single :: String -> [C.Exp] -> C.Exp+ single _ [x] = x+ single loc _ = INTERNAL_ERROR(error) loc "expected single expression" -- Scalar Primitives@@ -433,8 +672,10 @@ codegenPrim (PrimSig ty) [a] = codegenSig ty a codegenPrim (PrimQuot _) [a,b] = [cexp|$exp:a / $exp:b|] codegenPrim (PrimRem _) [a,b] = [cexp|$exp:a % $exp:b|]-codegenPrim (PrimIDiv _) [a,b] = ccall "idiv" [a,b]-codegenPrim (PrimMod _) [a,b] = ccall "mod" [a,b]+codegenPrim (PrimIDiv ty) [a,b] = ccall "idiv" [ccast (NumScalarType $ IntegralNumType ty) a,+ ccast (NumScalarType $ IntegralNumType ty) b]+codegenPrim (PrimMod ty) [a,b] = ccall "mod" [ccast (NumScalarType $ IntegralNumType ty) a,+ ccast (NumScalarType $ IntegralNumType ty) b] codegenPrim (PrimBAnd _) [a,b] = [cexp|$exp:a & $exp:b|] codegenPrim (PrimBOr _) [a,b] = [cexp|$exp:a | $exp:b|] codegenPrim (PrimBXor _) [a,b] = [cexp|$exp:a ^ $exp:b|]@@ -506,10 +747,10 @@ codegenIntegralScalar ty x | IntegralDict <- integralDict ty = [cexp| ( $ty:(codegenIntegralType ty) ) $exp:(cintegral x) |] codegenFloatingScalar :: FloatingType a -> a -> C.Exp-codegenFloatingScalar (TypeFloat _) x = C.Const (FloatConst (shows x "f") (toRational x) noLoc) noLoc-codegenFloatingScalar (TypeCFloat _) x = C.Const (FloatConst (shows x "f") (toRational x) noLoc) noLoc-codegenFloatingScalar (TypeDouble _) x = C.Const (DoubleConst (show x) (toRational x) noLoc) noLoc-codegenFloatingScalar (TypeCDouble _) x = C.Const (DoubleConst (show x) (toRational x) noLoc) noLoc+codegenFloatingScalar (TypeFloat _) x = C.Const (C.FloatConst (shows x "f") (toRational x) noLoc) noLoc+codegenFloatingScalar (TypeCFloat _) x = C.Const (C.FloatConst (shows x "f") (toRational x) noLoc) noLoc+codegenFloatingScalar (TypeDouble _) x = C.Const (C.DoubleConst (show x) (toRational x) noLoc) noLoc+codegenFloatingScalar (TypeCDouble _) x = C.Const (C.DoubleConst (show x) (toRational x) noLoc) noLoc codegenNonNumScalar :: NonNumType a -> a -> C.Exp codegenNonNumScalar (TypeBool _) x = cbool x@@ -640,8 +881,21 @@ ccast :: ScalarType a -> C.Exp -> C.Exp ccast ty x = [cexp|($ty:(codegenScalarType ty)) $exp:x|] +ccastTup :: TupleType e -> [C.Exp] -> [C.Exp]+ccastTup ty = fst . travTup ty+ where+ travTup :: TupleType e -> [C.Exp] -> ([C.Exp],[C.Exp])+ travTup UnitTuple xs = ([], xs)+ travTup (SingleTuple ty') (x:xs) = ([ccast ty' x], xs)+ travTup (PairTuple l r) xs = let+ (ls, xs' ) = travTup l xs+ (rs, xs'') = travTup r xs'+ in (ls ++ rs, xs'')+ travTup _ _ = INTERNAL_ERROR(error) "ccastTup" "not enough expressions to match type"++ postfix :: NumType a -> String -> String-postfix (FloatingNumType (TypeFloat _)) = (++ "f")-postfix (FloatingNumType (TypeCFloat _)) = (++ "f")-postfix _ = id+postfix (FloatingNumType (TypeFloat _)) x = x ++ "f"+postfix (FloatingNumType (TypeCFloat _)) x = x ++ "f"+postfix _ x = x
Data/Array/Accelerate/CUDA/CodeGen/Base.hs view
@@ -1,5 +1,12 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-} -- | -- Module : Data.Array.Accelerate.CUDA.CodeGen.Base -- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee@@ -8,192 +15,364 @@ -- -- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au> -- Stability : experimental--- Portability : non-partable (GHC extensions)+-- Portability : non-portable (GHC extensions) -- module Data.Array.Accelerate.CUDA.CodeGen.Base ( - -- Types- CUTranslSkel(..), CUFun(..), CUExp(..),+ -- Names and Types+ CUTranslSkel(..), CUDelayedAcc(..), CUExp(..), CUFun1(..), CUFun2(..),+ Name, namesOfArray, namesOfAvar, groupOfInt, -- Declaration generation- typename, cptr, cvar, ccall, cchar, cintegral, cbool, cdim, cglobal, cshape,- setters, getters, shared, indexArray,+ cvar, ccall, cchar, cintegral, cbool, cdim, cshape, getters, setters, shared,+ indexArray, indexHead, shapeSize, environment, arrayAsTex, arrayAsArg,+ umul24, gridSize, threadIdx, -- Mutable operations- (.=.), locals+ (.=.), locals, Lvalue(..), Rvalue(..), ) where -import Data.Loc-import Data.Char-import Data.List-import Language.C.Syntax+import Text.PrettyPrint.Mainland import Language.C.Quote.CUDA-import Text.PrettyPrint.Mainland ( Pretty(..) )+import qualified Language.C.Syntax as C+import qualified Data.HashMap.Strict as Map -import Data.Array.Accelerate.Array.Sugar ( Elt )+import Foreign.CUDA.Analysis.Device+import Data.Array.Accelerate.Array.Sugar ( Array, Shape, Elt )+import Data.Array.Accelerate.Analysis.Shape+import Data.Array.Accelerate.CUDA.CodeGen.Type+import Data.Array.Accelerate.CUDA.AST +#include "accelerate.h" --- Compilation units--- -----------------+-- Names+-- ----- +type Name = String++namesOfArray+ :: forall e. Elt e+ => Name -- name of group: typically "Out" or "InX" for some number 'X'+ -> e -- dummy+ -> (Name, [Name]) -- shape and array field names+namesOfArray grp _+ = let ty = eltType (undefined :: e)+ arr x = "arr" ++ grp ++ "_a" ++ show x+ n = length ty+ in+ ( "sh" ++ grp, map arr [n-1, n-2 .. 0] )+++namesOfAvar :: forall aenv sh e. (Shape sh, Elt e) => Gamma aenv -> Idx aenv (Array sh e) -> (Name, [Name])+namesOfAvar gamma ix = namesOfArray (groupOfAvar gamma ix) (undefined::e)++groupOfAvar :: (Shape sh, Elt e) => Gamma aenv -> Idx aenv (Array sh e) -> Name+groupOfAvar (Gamma gamma) = groupOfInt . (gamma Map.!) . Idx_++groupOfInt :: Int -> Name+groupOfInt n = "In" ++ show n+++-- Types of compilation units+-- --------------------------+ -- A CUDA compilation unit, together with the name of the main __global__ entry -- function. ---data CUTranslSkel = CUTranslSkel String [Definition]+data CUTranslSkel aenv a = CUTranslSkel Name [C.Definition] -instance Show CUTranslSkel where+instance Show (CUTranslSkel aenv a) where show (CUTranslSkel entry _) = entry -instance Pretty CUTranslSkel where+instance Pretty (CUTranslSkel aenv a) where ppr (CUTranslSkel _ code) = ppr code +-- Scalar expressions, including the environment of local let-bindings to bring+-- into scope before evaluating the body.+--+data CUExp aenv a where+ CUExp :: ([C.BlockItem], [C.Exp])+ -> CUExp aenv a --- Scalar functions and expressions, including the environment of local--- let-bindings and array data elements.+-- Scalar functions of particular arity, with local bindings. ---data CUFun a where- CUBody :: CUExp a -> CUFun a- CULam :: Elt a => [(Int, Type, Exp)] -> CUFun t -> CUFun (a -> t)+data CUFun1 aenv f where+ CUFun1 :: (Elt a, Elt b)+ => (forall x. [x] -> [(Bool,x)])+ -> (forall x. Rvalue x => [x] -> ([C.BlockItem], [C.Exp]))+ -> CUFun1 aenv (a -> b) -data CUExp e where- CUExp :: [InitGroup] -> [Exp] -> CUExp e+data CUFun2 aenv f where+ CUFun2 :: (Elt a, Elt b, Elt c)+ => (forall x. [x] -> [(Bool,x)])+ -> (forall y. [y] -> [(Bool,y)])+ -> (forall x y. (Rvalue x, Rvalue y) => [x] -> [y] -> ([C.BlockItem], [C.Exp]))+ -> CUFun2 aenv (a -> b -> c) +-- Delayed arrays+--+data CUDelayedAcc aenv sh e where+ CUDelayed :: CUExp aenv sh+ -> CUFun1 aenv (sh -> e)+ -> CUFun1 aenv (Int -> e)+ -> CUDelayedAcc aenv sh e --- Expression and Declaration generation++-- Expression and declaration generation -- ------------------------------------- -cvar :: String -> Exp+cvar :: Name -> C.Exp cvar x = [cexp|$id:x|] -ccall :: String -> [Exp] -> Exp+ccall :: Name -> [C.Exp] -> C.Exp ccall fn args = [cexp|$id:fn ($args:args)|] -typename :: String -> Type-typename name = Type (DeclSpec [] [] (Tnamed (Id name noLoc) noLoc) noLoc) (DeclRoot noLoc) noLoc--cchar :: Char -> Exp+cchar :: Char -> C.Exp cchar c = [cexp|$char:c|] -cintegral :: (Integral a, Show a) => a -> Exp+cintegral :: (Integral a, Show a) => a -> C.Exp cintegral n = [cexp|$int:n|] -cbool :: Bool -> Exp+cbool :: Bool -> C.Exp cbool = cintegral . fromEnum -cdim :: String -> Int -> Definition+cdim :: Name -> Int -> C.Definition cdim name n = [cedecl|typedef typename $id:("DIM" ++ show n) $id:name;|] +-- Disassemble a struct-shape into a list of expressions accessing the fields+cshape :: Int -> C.Exp -> [C.Exp]+cshape dim sh+ | dim == 0 = []+ | dim == 1 = [sh]+ | otherwise = map (\i -> [cexp|$exp:sh . $id:('a':show i)|]) [dim-1, dim-2 .. 0] -cglobal :: Type -> String -> Definition-cglobal ty name = [cedecl|static $ty:ty $id:name;|]+-- Calculate the size of a shape from its component dimensions+shapeSize :: Rvalue r => [r] -> C.Exp+shapeSize [] = [cexp| 1 |]+shapeSize ss = foldl1 (\a b -> [cexp| $exp:a * $exp:b |]) (map rvalue ss) -cshape :: String -> Int -> Definition-cshape name n = [cedecl| static __constant__ typename $id:("DIM" ++ show n) $id:name;|]+indexHead :: Rvalue r => [r] -> C.Exp+indexHead = rvalue . last -indexArray :: Type -> Exp -> Exp -> Exp-indexArray ty arr ix- | "double" `isSuffixOf` map toLower (show ty) = ccall "indexDArray" [arr, ix]- | otherwise = ccall "indexArray" [arr, ix] +-- Thread blocks and indices+--+umul24 :: DeviceProperties -> C.Exp -> C.Exp -> C.Exp+umul24 dev x y+ | computeCapability dev < Compute 2 0 = [cexp| __umul24($exp:x, $exp:y) |]+ | otherwise = [cexp| $exp:x * $exp:y |] --- Generate a list of variable bindings and declarations to read from the input--- arrays.+gridSize :: DeviceProperties -> C.Exp+gridSize dev+ | computeCapability dev < Compute 2 0 = [cexp| __umul24(blockDim.x, gridDim.x) |]+ | otherwise = [cexp| blockDim.x * gridDim.x |]++threadIdx :: DeviceProperties -> C.Exp+threadIdx dev+ | computeCapability dev < Compute 2 0 = [cexp| __umul24(blockDim.x, blockIdx.x) + threadIdx.x |]+ | otherwise = [cexp| blockDim.x * blockIdx.x + threadIdx.x |]+++-- Generate an array indexing expression. Depending on the hardware class, this+-- will be via direct array indexing or texture references. ----- In the case where the input array is an array of tuples, the function--- parameters naturally include all components, but the scalar declarations--- include only those indices that are used.+indexArray+ :: DeviceProperties+ -> C.Type -- array element type (Float, Double...)+ -> C.Exp -- array variable name (arrInX_Y)+ -> C.Exp -- linear index+ -> C.Exp+indexArray dev elt arr ix+ -- use the L2 cache of newer devices+ | computeCapability dev >= Compute 2 0 = [cexp| $exp:arr [ $exp:ix ] |]++ -- use the texture cache of compute 1.x devices+ | C.Type (C.DeclSpec _ _ (C.Tdouble _) _) _ _ <- elt = ccall "indexDArray" [arr, ix]+ | otherwise = ccall "indexArray" [arr, ix]+++-- Generate kernel parameters for an array valued argument, and a function to+-- linearly index this array. Note that dimensional indexing results in error. -- getters- :: Int -- base de Bruijn index- -> [Type] -- the array element type- -> [(Int, Type, Exp)] -- the variables used in the scalar expression- -> ( [Param] -- function parameters for array(s) input- , [Exp] -- variable names- , [InitGroup] -- non-const variable declarations- , String -> [Exp] -- index global array- , String -> [InitGroup] ) -- const declarations and initialisation from index-getters base arrElt expElt =- let n = length arrElt- arrParams = zipWith (\t x -> [cparam| const $ty:(cptr t) $id:(arr x) |]) arrElt [n-1, n-2 .. 0]- arr x = "arrIn" ++ shows base "_a" ++ show x- expVars = map (\(_,_,v) -> v) expElt- expDecls = map (\(_,t,v) -> [cdecl| $ty:t $id:(show v) ; |]) expElt- in- ( arrParams- , expVars- , expDecls- , \ix -> map (\(i,_,_) -> [cexp| $id:(arr i) [ $id:ix ] |] ) expElt- , \ix -> map (\(i,t,v) -> [cdecl| const $ty:t $id:(show v) = $id:(arr i) [$id:ix] ; |]) expElt- )+ :: forall aenv sh e. (Shape sh, Elt e)+ => Name -- group names+ -> Array sh e -- dummy to fix types+ -> ( [C.Param], CUDelayedAcc aenv sh e )+getters grp dummy+ = let (sh, arrs) = namesOfArray grp (undefined :: e)+ args = arrayAsArg dummy grp + dim = expDim (undefined :: Exp aenv sh)+ sh' = cshape dim (cvar sh)+ get ix = ([], map (\a -> [cexp| $id:a [ $exp:ix ] |]) arrs)+ manifest = CUDelayed (CUExp ([], sh'))+ (INTERNAL_ERROR(error) "getters" "linear indexing only")+ (CUFun1 (zip (repeat True)) (get . rvalue . head))+ in ( args, manifest ) + -- Generate function parameters and corresponding variable names for the--- components of the given output array.+-- components of the given output array. The parameter list generated is+-- suitable for marshalling an instance of "Array sh e", consisting of a group+-- name (say "Out") to be welded with a shape name "shOut" followed by the+-- non-parametric array data "arrOut_aX". -- setters- :: [Type] -- element type- -> ( [Param] -- function parameter declarations- , [Exp] -- variable name- , String -> [Exp] -> [Stm]) -- store a value to the given index-setters arrElt =- let n = length arrElt- arrVars = map (\x -> "arrOut_a" ++ show x) [n-1, n-2 .. 0]- arrParams = zipWith (\t x -> [cparam| $ty:(cptr t) $id:x |]) arrElt arrVars- set ix a x = [cstm| $id:a [$id:ix] = $exp:x; |]- in- ( arrParams- , map cvar arrVars- , \ix e -> zipWith (set ix) arrVars e- )+ :: forall sh e. (Shape sh, Elt e)+ => Name -- group names+ -> Array sh e -- dummy to fix types+ -> ([C.Param], Name -> [C.Exp])+setters grp _+ = let (sh, arrs) = namesOfArray grp (undefined :: e)+ dim = expDim (undefined :: Exp aenv sh)+ sh' = [cparam| const typename $id:("DIM" ++ show dim) $id:sh |]+ arrs' = zipWith (\t n -> [cparam| $ty:t * __restrict__ $id:n |]) (eltType (undefined :: e)) arrs+ in+ ( sh' : arrs'+ , \ix -> map (\a -> [cexp| $id:a [ $id:ix ] |]) arrs+ ) --- shared memory declaration. All dynamically allocated __shared__ memory will--- begin at the same base address. If we call this more than once, or the kernel--- itself declares some shared memory, the first parameter is a pointer to where--- the new declarations should start from.+-- All dynamically allocated __shared__ memory will begin at the same base+-- address. If we call this more than once, or the kernel itself declares some+-- shared memory, the first parameter is a pointer to where the new declarations+-- should take as the base address. -- shared- :: Int -- shared memory shadowing which input array- -> Maybe Exp -- (optional) initialise from this base address- -> Exp -- how much shared memory per type- -> [Type] -- element types- -> ( [InitGroup] -- shared memory declaration- , String -> [Exp] ) -- index shared memory-shared base = shared' ('s':shows base "_a")+ :: forall e. Elt e+ => e -- dummy type+ -> Name -- group name+ -> C.Exp -- how much shared memory per type+ -> Maybe C.Exp -- (optional) initialise from this base address+ -> ([C.InitGroup], Name -> [C.Exp]) -- shared memory declaration and indexing function+shared _ grp size mprev+ = let e:es = eltType (undefined :: e)+ x:xs = let k = length es in map (\n -> grp ++ show n) [k, k-1 .. 0] -shared' :: String -> Maybe Exp -> Exp -> [Type] -> ([InitGroup], String -> [Exp])-shared' base mprev ix elt =- ( sdecl (head elt) (head vars) : zipWith3 sdata (tail elt) (tail vars) vars- , \i -> map (\v -> [cexp| $id:v [ $id:i ] |]) vars )+ sdata t v p = [cdecl| volatile $ty:t * $id:v = ($ty:t *) & $id:p [ $exp:size ]; |]+ sbase t v+ | Just p <- mprev = [cdecl| volatile $ty:t * $id:v = ($ty:t *) $exp:p; |]+ | otherwise = [cdecl| extern volatile __shared__ $ty:t $id:v [] ; |]+ in+ ( sbase e x : zipWith3 sdata es xs (x:xs)+ , \ix -> map (\v -> [cexp| $id:v [ $id:ix ] |]) (x:xs)+ )++-- Array environment references. The method in which arrays are accessed depends+-- on the device architecture (see below). We always include the array shape+-- before the array data terms.+--+-- compute 1.x:+-- texture references of type [Definition]+--+-- compute 2.x and 3.x:+-- function arguments of type [Param]+--+-- NOTE: The environment variables must always be the first argument to the+-- kernel function, as this is where they will be marshaled during the+-- execution phase.+--+environment+ :: forall aenv. DeviceProperties+ -> Gamma aenv+ -> ([C.Definition], [C.Param])+environment dev gamma@(Gamma aenv)+ | computeCapability dev < Compute 2 0+ = Map.foldrWithKey (\(Idx_ v) _ (ds,ps) -> let (d,p) = asTex v in (d++ds, p:ps)) ([],[]) aenv++ | otherwise+ = ([], Map.foldrWithKey (\(Idx_ v) _ vs -> asArg v ++ vs) [] aenv)+ where- vars = let k = length elt in map (\n -> base ++ show n) [k-1,k-2..0]- sdecl t v- | Just p <- mprev = [cdecl| volatile $ty:(cptr t) $id:v = ( $ty:(cptr t) ) $exp:p; |]- | otherwise = [cdecl| extern volatile __shared__ $ty:t $id:v []; |]- sdata t v p = [cdecl| volatile $ty:(cptr t) $id:v = ( $ty:(cptr t) ) & $id:p [ $exp:ix ]; |]+ asTex :: forall sh e. (Shape sh, Elt e) => Idx aenv (Array sh e) -> ([C.Definition], C.Param)+ asTex ix = arrayAsTex (undefined :: Array sh e) (groupOfAvar gamma ix) + asArg :: forall sh e. (Shape sh, Elt e) => Idx aenv (Array sh e) -> [C.Param]+ asArg ix = arrayAsArg (undefined :: Array sh e) (groupOfAvar gamma ix) --- Turn a plain type into a ptr type----cptr :: Type -> Type-cptr t | Type d@(DeclSpec _ _ _ _) r@(DeclRoot _) lb <- t = Type d (Ptr [] r noLoc) lb- | otherwise = t +arrayAsTex :: forall sh e. (Shape sh, Elt e) => Array sh e -> Name -> ([C.Definition], C.Param)+arrayAsTex _ grp =+ let (sh, arrs) = namesOfArray grp (undefined :: e)+ dim = expDim (undefined :: Exp aenv sh)+ sh' = [cparam| const typename $id:("DIM" ++ show dim) $id:sh |]+ arrs' = zipWith (\t a -> [cedecl| static $ty:t $id:a; |]) (eltTypeTex (undefined :: e)) arrs+ in+ (arrs', sh') +arrayAsArg :: forall sh e. (Shape sh, Elt e) => Array sh e -> Name -> [C.Param]+arrayAsArg _ grp =+ let (sh, arrs) = namesOfArray grp (undefined :: e)+ dim = expDim (undefined :: Exp aenv sh)+ sh' = [cparam| const typename $id:("DIM" ++ show dim) $id:sh |]+ arrs' = zipWith (\t n -> [cparam| const $ty:t * __restrict__ $id:n |]) (eltType (undefined :: e)) arrs+ in+ sh' : arrs'++ -- Mutable operations -- ------------------ --- Variable assignment+-- Declare some local variables. These can be either const or mutable+-- declarations. ---(.=.) :: [Exp] -> [Exp] -> [Stm]-(.=.) = zipWith (\v e -> [cstm| $exp:v = $exp:e; |])+locals :: forall e. Elt e+ => Name+ -> e+ -> ( [(C.Type, Name)] -- const declarations+ , [C.Exp], [C.InitGroup]) -- mutable declaration and names+locals base _+ = let elt = eltType (undefined :: e)+ n = length elt+ local t v = let name = base ++ show v+ in ( (t, name), cvar name, [cdecl| $ty:t $id:name; |] )+ in+ unzip3 $ zipWith local elt [n-1, n-2 .. 0] -locals :: String -> [Type] -> ([Exp], [InitGroup])-locals base elt = unzip (zipWith local elt names)- where- suf = let n = length elt in map show [n-1,n-2..0]- names = map (\n -> base ++ "_a" ++ n) suf- local t n = ( cvar n, [cdecl| $ty:t $id:n; |] )++class Lvalue a where+ lvalue :: a -> C.Exp -> C.BlockItem++instance Lvalue C.Exp where+ lvalue x y = C.BlockStm [cstm| $exp:x = $exp:y; |]++instance Lvalue (C.Type, Name) where+ lvalue (t,x) y = C.BlockDecl [cdecl| const $ty:t $id:x = $exp:y; |]+++class Rvalue a where+ rvalue :: a -> C.Exp++instance Rvalue C.Exp where+ rvalue = id++instance Rvalue (C.Type, Name) where+ rvalue (_,x) = cvar x+++infixr 0 .=.+(.=.) :: Assign l r => l -> r -> [C.BlockItem]+(.=.) = assign++class Assign l r where+ assign :: l -> r -> [C.BlockItem]++instance (Lvalue l, Rvalue r) => Assign l r where+ assign lhs rhs = return $ lvalue lhs (rvalue rhs)++instance Assign l r => Assign (Bool,l) r where+ assign (used,lhs) rhs+ | used = assign lhs rhs+ | otherwise = []++instance Assign l r => Assign [l] [r] where+ assign [] [] = []+ assign (x:xs) (y:ys) = assign x y ++ assign xs ys+ assign _ _ = INTERNAL_ERROR(error) ".=." "argument mismatch"++instance Assign l r => Assign l ([C.BlockItem], r) where+ assign lhs (env, rhs) = env ++ assign lhs rhs
Data/Array/Accelerate/CUDA/CodeGen/IndexSpace.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE GADTs #-}+{-# LANGUAGE PatternGuards #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# OPTIONS -fno-warn-incomplete-patterns #-} -- | -- Module : Data.Array.Accelerate.CUDA.CodeGen.IndexSpace -- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee@@ -19,64 +19,134 @@ mkGenerate, -- Permutations- mkPermute, mkBackpermute,-- -- Multidimensional index and replicate- mkSlice, mkReplicate+ mkTransform, mkPermute, ) where import Data.List-import Language.C.Syntax import Language.C.Quote.CUDA-import Foreign.CUDA.Analysis+import Foreign.CUDA.Analysis.Device+import qualified Language.C.Syntax as C -import Data.Array.Accelerate.Array.Sugar ( Array, Elt )-import Data.Array.Accelerate.CUDA.CodeGen.Base+import Data.Array.Accelerate.Array.Sugar ( Array, Shape, Elt )+import Data.Array.Accelerate.Analysis.Shape+import Data.Array.Accelerate.CUDA.AST ( Gamma, Exp ) import Data.Array.Accelerate.CUDA.CodeGen.Type+import Data.Array.Accelerate.CUDA.CodeGen.Base -- Construct a new array by applying a function to each index. Each thread -- processes multiple elements, striding the array by the grid size. -- -- generate :: (Shape ix, Elt e)--- => Exp ix--- -> (Exp ix -> Exp a)+-- => Exp ix -- dimension of the result+-- -> (Exp ix -> Exp a) -- function to apply at each index -- -> Acc (Array ix a) ---mkGenerate :: forall sh e. Elt e => Int -> CUFun (sh -> e) -> CUTranslSkel-mkGenerate dimOut (CULam _ (CUBody (CUExp env fn))) =- CUTranslSkel "generate" [cunit|- $edecl:(cdim "DimOut" dimOut)+mkGenerate+ :: forall aenv sh e. (Shape sh, Elt e)+ => DeviceProperties+ -> Gamma aenv+ -> CUFun1 aenv (sh -> e)+ -> [CUTranslSkel aenv (Array sh e)]+mkGenerate dev aenv (CUFun1 _ f)+ = return+ $ CUTranslSkel "generate" [cunit| - extern "C"- __global__ void+ $esc:("#include <accelerate_cuda_extras.h>")+ $edecl:(cdim "DimOut" dim)+ $edecls:texIn++ extern "C" __global__ void generate (- $params:args,- const typename DimOut shOut+ $params:argIn,+ $params:argOut ) {- const int n = size(shOut);- const int gridSize = __umul24(blockDim.x, gridDim.x);+ const int shapeSize = size(shOut);+ const int gridSize = $exp:(gridSize dev); int ix; - for ( ix = __umul24(blockDim.x, blockIdx.x) + threadIdx.x- ; ix < n- ; ix += gridSize)+ for ( ix = $exp:(threadIdx dev)+ ; ix < shapeSize+ ; ix += gridSize ) {- $decls:shape- $decls:env- $stms:(set "ix" fn)+ const typename DimOut sh = fromIndex(shOut, ix);++ $items:(setOut "ix" .=. f sh) } } |] where- (args, _, set) = setters tyOut- tyOut = eltType (undefined :: e)- shape = fromIndex dimOut "DimOut" "shOut" "ix" "x0"+ dim = expDim (undefined :: Exp aenv sh)+ sh = cshape dim (cvar "sh")+ (texIn, argIn) = environment dev aenv+ (argOut, setOut) = setters "Out" (undefined :: Array sh e) +-- A combination map/backpermute, where the index and value transformations have+-- been separated.+--+-- transform :: (Elt a, Elt b, Shape sh, Shape sh')+-- => PreExp acc aenv sh' -- dimension of the result+-- -> PreFun acc aenv (sh' -> sh) -- index permutation function+-- -> PreFun acc aenv (a -> b) -- function to apply at each element+-- -> acc aenv (Array sh a) -- source array+-- -> PreOpenAcc acc aenv (Array sh' b)+--+mkTransform+ :: forall aenv sh sh' a b. (Shape sh, Shape sh', Elt a, Elt b)+ => DeviceProperties+ -> Gamma aenv+ -> CUFun1 aenv (sh' -> sh)+ -> CUFun1 aenv (a -> b)+ -> CUDelayedAcc aenv sh a+ -> [CUTranslSkel aenv (Array sh' b)]+mkTransform dev aenv perm fun arr+ | CUFun1 _ p <- perm+ , CUFun1 dce f <- fun+ , CUDelayed _ (CUFun1 _ get) _ <- arr+ = return+ $ CUTranslSkel "transform" [cunit|++ $esc:("#include <accelerate_cuda_extras.h>")+ $edecl:(cdim "DimOut" dimOut)+ $edecl:(cdim "DimIn" dimIn)+ $edecls:texIn++ extern "C" __global__ void+ transform+ (+ $params:argIn,+ $params:argOut+ )+ {+ const int shapeSize = size(shOut);+ const int gridSize = $exp:(gridSize dev);+ int ix;++ for ( ix = $exp:(threadIdx dev)+ ; ix < shapeSize+ ; ix += gridSize )+ {+ const typename DimOut sh_ = fromIndex(shOut, ix);+ $items:(sh .=. p sh_)+ $items:(dce x0 .=. get sh)+ $items:(setOut "ix" .=. f x0)+ }+ }+ |]+ where+ dimIn = expDim (undefined :: Exp aenv sh)+ dimOut = expDim (undefined :: Exp aenv sh')+ sh_ = cshape dimOut (cvar "sh_")+ (texIn, argIn) = environment dev aenv+ (argOut, setOut) = setters "Out" (undefined :: Array sh' b)+ (x0, _, _) = locals "x" (undefined :: a)+ (sh, _, _) = locals "sh" (undefined :: sh)++ -- Forward permutation specified by an index mapping that determines for each -- element in the source array where it should go in the target. The resultant -- array is initialised with the given defaults and any further values that are@@ -93,66 +163,75 @@ -- -> Acc (Array ix a) -- permuted array -- -> Acc (Array ix' a) ---mkPermute :: forall a ix ix'.- DeviceProperties- -> Int -- dimensionality ix'- -> Int -- dimensionality ix- -> CUFun (a -> a -> a)- -> CUFun (ix -> ix')- -> CUTranslSkel-mkPermute dev dimOut dimIn0 (CULam useFn (CULam _ (CUBody (CUExp env combine)))) (CULam _ (CUBody (CUExp envIx prj))) =- CUTranslSkel "permute" [cunit|+mkPermute+ :: forall aenv sh sh' e. (Shape sh, Shape sh', Elt e)+ => DeviceProperties+ -> Gamma aenv+ -> CUFun2 aenv (e -> e -> e)+ -> CUFun1 aenv (sh -> sh')+ -> CUDelayedAcc aenv sh e+ -> [CUTranslSkel aenv (Array sh' e)]+mkPermute dev aenv (CUFun2 dcex dcey combine) (CUFun1 _ prj) arr+ | CUDelayed (CUExp shIn) _ (CUFun1 _ get) <- arr+ = return+ $ CUTranslSkel "permute" [cunit|++ $esc:("#include <accelerate_cuda_extras.h>") $edecl:(cdim "DimOut" dimOut)- $edecl:(cdim "DimIn0" dimIn0)+ $edecl:(cdim "DimIn" dimIn)+ $edecls:texIn - extern "C"- __global__ void+ extern "C" __global__ void permute (- $params:argOut,- $params:argIn0,- const typename DimOut shOut,- const typename DimIn0 shIn0+ $params:argIn,+ $params:argOut ) {- const int shapeSize = size(shIn0);- const int gridSize = __umul24(blockDim.x, gridDim.x);+ $items:(sh .=. shIn)+ const typename DimIn shIn = $exp:(ccall "shape" (map rvalue sh));+ const int shapeSize = $exp:(shapeSize sh);+ const int gridSize = $exp:(gridSize dev); int ix; - for ( ix = __umul24(blockDim.x, blockIdx.x) + threadIdx.x- ; ix < shapeSize- ; ix += gridSize)+ for ( ix = $exp:(threadIdx dev)+ ; ix < shapeSize+ ; ix += gridSize ) { typename DimOut dst;- $decls:src- $decls:envIx- $stms:dst - if (!ignore(dst))+ const int src = fromIndex( shIn, ix );+ $items:(dst .=. prj src)++ if ( !ignore(dst) ) {+ $decls:decly+ $decls:decly'+ const int jx = toIndex(shOut, dst);- $decls:decl1- $decls:temps- $decls:env- $stms:(x1 .=. getIn0 "ix")- $stms:write+ $items:(dcex x .=. get ix)+ $items:(dcey y .=. arrOut "jx")++ $items:write } } } |] where- elt = eltType (undefined :: a)- sizeof = eltSizeOf (undefined :: a)- (argIn0, _, _, getIn0, _) = getters 0 elt useFn- (_, x1, decl1, _, _) = getters 1 elt useFn- (argOut, arrOut, setOut) = setters elt- (x0, _) = locals "x0" elt- src = fromIndex dimIn0 "DimIn0" "shIn0" "ix" "x0"- dst = project dimOut "dst" prj- sm = computeCapability dev- unsafe = setOut "jx" combine- (temps, write) = unzip $ zipWith6 apply unsafe combine elt arrOut x0 sizeof- --+ dimIn = expDim (undefined :: Exp aenv sh)+ dimOut = expDim (undefined :: Exp aenv sh')+ sizeof = eltSizeOf (undefined::e)+ (texIn, argIn) = environment dev aenv+ (argOut, arrOut) = setters "Out" (undefined :: Array sh' e)+ (sh, _, _) = locals "sh" (undefined :: sh)+ (x, _, _) = locals "x" (undefined :: e)+ (_, y, decly) = locals "y" (undefined :: e)+ (_, y', decly') = locals "_y" (undefined :: e)+ ix = [cvar "ix"]+ src = cshape dimIn (cvar "src")+ dst = cshape dimOut (cvar "dst")+ sm = computeCapability dev+ -- Apply the combining function between old and new values. If multiple -- threads attempt to write to the same location, the hardware -- write-combining mechanism will accept one transaction and all other@@ -166,230 +245,25 @@ -- Each element of a tuple is necessarily written individually, so the tuple -- as a whole is not stored atomically. --- apply set f t a z s- | Just atomicCAS <- reinterpret s- = let z' = [cexp| $id:('_':show z) |]- in- ( [cdecl| $ty:t $id:(show z), $id:(show z') = $exp:a [ $id:("jx") ]; |]- , [cstm| do { $exp:z = $exp:z';- $exp:z' = $exp:atomicCAS ( & $exp:a [ $id:("jx") ], $exp:z, $exp:f );- } while ( $exp:z != $exp:z' ); |]- )-- | otherwise- = ( [cdecl| const $ty:t $id:(show z) = $exp:a [ $id:("jx") ]; |]- , set- )- --- reinterpret :: Int -> Maybe Exp- reinterpret 4 | sm >= 1.1 = Just [cexp| $id:("atomicCAS32") |]- reinterpret 8 | sm >= 1.2 = Just [cexp| $id:("atomicCAS64") |]- reinterpret _ = Nothing----- Backwards permutation (gather) of an array according to a permutation--- function.------ backpermute :: (Shape ix, Shape ix', Elt a)--- => Exp ix' -- shape of the result array--- -> (Exp ix' -> Exp ix) -- permutation--- -> Acc (Array ix a) -- permuted array--- -> Acc (Array ix' a)----mkBackpermute :: forall ix ix' a. Elt a- => Int -- dimensionality ix'- -> Int -- dimensionality ix- -> CUFun (ix' -> ix)- -> Array ix' a -- dummy to fix type variables- -> CUTranslSkel-mkBackpermute dimOut dimIn0 (CULam _ (CUBody (CUExp env prj))) _ =- CUTranslSkel "backpermute" [cunit|- $edecl:(cdim "DimOut" dimOut)- $edecl:(cdim "DimIn0" dimIn0)-- extern "C"- __global__ void- backpermute- (- $params:argOut,- $params:argIn0,- const typename DimOut shOut,- const typename DimIn0 shIn0- )- {- const int shapeSize = size(shOut);- const int gridSize = __umul24(blockDim.x, gridDim.x);- int ix;-- for ( ix = __umul24(blockDim.x, blockIdx.x) + threadIdx.x- ; ix < shapeSize- ; ix += gridSize)- {- typename DimIn0 src;- $decls:dst- $decls:env- $stms:src- {- const int jx = toIndex(shIn0, src);- $decls:(getIn0 "jx")- $stms:(setOut "ix" (reverse x0))- }- }- }- |]- where- elt = eltType (undefined :: a)- (argOut, _, setOut) = setters elt- (argIn0, x0, _, _, getIn0) = getters 0 elt (useAll 0 elt)- dst = fromIndex dimOut "DimOut" "shOut" "ix" "x0"- src = project dimIn0 "src" prj----- Index an array with a generalised, multidimensional array index. The result--- is a new array (possibly a singleton) containing all dimensions in their--- entirety.------ slice :: (Slice slix, Elt e)--- => Acc (Array (FullShape slix) e)--- -> Exp slix--- -> Acc (Array (SliceShape slix) e)----mkSlice :: forall sl slix e. Elt e- => Int -- dimensionality sl- -> Int -- dimensionality co- -> Int -- dimensionality sh- -> CUExp slix- -> Array sl e -- dummy- -> CUTranslSkel-mkSlice dimSl dimCo dimIn0 (CUExp [] slix) _ =- CUTranslSkel "slice" [cunit|- $edecl:(cdim "Slice" dimSl)- $edecl:(cdim "CoSlice" dimCo)- $edecl:(cdim "SliceDim" dimIn0)-- extern "C"- __global__ void- slice- (- $params:argOut,- $params:argIn0,- const typename Slice slice,- const typename CoSlice co,- const typename SliceDim sliceDim- )- {- int ix;- const int shapeSize = size(slice);- const int gridSize = __umul24(blockDim.x, gridDim.x);-- for ( ix = __umul24(blockDim.x, blockIdx.x) + threadIdx.x- ; ix < shapeSize- ; ix += gridSize)- {- typename Slice sl = fromIndex(slice, ix);- typename SliceDim src;- $stms:src- {- const int jx = toIndex(sliceDim, src);- $decls:(getIn0 "jx")- $stms:(setOut "ix" x0)- }- }- }- |]- where- elt = eltType (undefined :: e)- (argOut, _, setOut) = setters elt- (argIn0, x0, _, _, getIn0) = getters 0 elt (useAll 0 elt)- src = project dimIn0 "src" slix----- Replicate an array across one or more dimensions as specified by the--- generalised array index.------ replicate :: (Slice slix, Elt e)--- => Exp slix--- -> Acc (Array (SliceShape slix) e)--- -> Acc (Array (FullShape slix) e)----mkReplicate :: forall sh slix e. Elt e- => Int -- dimensionality sl- -> Int -- dimensionality sh- -> CUExp slix- -> Array sh e -- dummy- -> CUTranslSkel-mkReplicate dimSl dimOut (CUExp _ slix) _ =- CUTranslSkel "replicate" [cunit|- $edecl:(cdim "Slice" dimSl)- $edecl:(cdim "SliceDim" dimOut)-- extern "C"- __global__ void- replicate- (- $params:argOut,- $params:argIn0,- const typename Slice slice,- const typename SliceDim sliceDim- )- {- int ix;- const int shapeSize = size(sliceDim);- const int gridSize = __umul24(blockDim.x, gridDim.x);-- for ( ix = __umul24(blockDim.x, blockIdx.x) + threadIdx.x- ; ix < shapeSize- ; ix += gridSize)- {- typename SliceDim dim = fromIndex(sliceDim, ix);- typename Slice src;- $stms:src- {- const int jx = toIndex(slice, src);- $decls:(getIn0 "jx")- $stms:(setOut "ix" x0)- }- }- }- |]- where- elt = eltType (undefined :: e)- (argOut, _, setOut) = setters elt- (argIn0, x0, _, _, getIn0) = getters 0 elt (useAll 0 elt)- src = project dimSl "src" slix------------------------------------------------------------------------------------------------------------------------------------------------------------------------- destruct shapes into separate components, since the code generator no--- longer treats tuples as structs----fromIndex :: Int -> String -> String -> String -> String -> [InitGroup]-fromIndex n dim sh ix base- | n == 1 = [[cdecl| const int $id:(base ++ "_a0") = $id:ix; |]]- | otherwise = sh0 : map (unsh . show) [0 .. n-1]- where- sh0 = [cdecl| const typename $id:dim $id:base = fromIndex( $id:sh , $id:ix ); |]- unsh c = [cdecl| const int $id:(base ++ "_a" ++ c) = $id:base . $id:('a':c); |]+ write = env ++ zipWith6 apply sizeof (arrOut "jx") fun x (dcey y) y'+ (env, fun) = combine x y + apply size out f x1 (used,y1) y1'+ | used+ , Just atomicCAS <- reinterpret size+ = C.BlockStm+ [cstm| do {+ $exp:y1' = $exp:y1;+ $exp:y1 = $exp:atomicCAS ( & $exp:out, $exp:y1', $exp:f ); --- apply expressions to the components of a shape----project :: Int -> String -> [Exp] -> [Stm]-project n sh idx- | n == 0 = [[cstm| $id:sh = 0; |]]- | [e] <- idx = [[cstm| $id:sh = $exp:e; |]]- | otherwise = zipWith (\i c -> [cstm| $id:sh . $id:('a':show c) = $exp:i; |]) idx [n-1,n-2..0]+ } while ( $exp:y1 != $exp:y1' ); |] + | otherwise+ = C.BlockStm [cstm| $exp:out = $exp:(rvalue x1); |] --- tell the getters function that we will use all the scalar components----useAll :: Int -> [Type] -> [(Int, Type, Exp)]-useAll base elt =- let n = length elt- x i = 'x' : shows base "_a" ++ show i- in- zipWith (\i t -> (i,t, cvar (x i))) [n-1, n-2 .. 0] elt+ --+ reinterpret :: Int -> Maybe C.Exp+ reinterpret 4 | sm >= Compute 1 1 = Just [cexp| $id:("atomicCAS32") |]+ reinterpret 8 | sm >= Compute 1 2 = Just [cexp| $id:("atomicCAS64") |]+ reinterpret _ = Nothing
Data/Array/Accelerate/CUDA/CodeGen/Mapping.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE GADTs #-}+{-# LANGUAGE PatternGuards #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# OPTIONS -fno-warn-incomplete-patterns #-} -- | -- Module : Data.Array.Accelerate.CUDA.CodeGen.Mapping -- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee@@ -15,14 +15,16 @@ module Data.Array.Accelerate.CUDA.CodeGen.Mapping ( - mkMap, mkZipWith+ mkMap, ) where import Language.C.Quote.CUDA-import Data.Array.Accelerate.Array.Sugar ( Elt )+import Foreign.CUDA.Analysis.Device++import Data.Array.Accelerate.Array.Sugar ( Array, Shape, Elt )+import Data.Array.Accelerate.CUDA.AST import Data.Array.Accelerate.CUDA.CodeGen.Base-import Data.Array.Accelerate.CUDA.CodeGen.Type -- Apply the given unary function to each element of an array. Each thread@@ -33,90 +35,44 @@ -- -> Acc (Array sh a) -- -> Acc (Array sh b) ---mkMap :: forall a b. Elt b => CUFun (a -> b) -> CUTranslSkel-mkMap (CULam use0 (CUBody (CUExp env fn))) =- CUTranslSkel "map" [cunit|- extern "C"- __global__ void- map- (- $params:argOut,- $params:argIn0,- const typename Ix num_elements- )- {- const int gridSize = __umul24(blockDim.x, gridDim.x);- int ix;-- for ( ix = __umul24(blockDim.x, blockIdx.x) + threadIdx.x- ; ix < num_elements- ; ix += gridSize)- {- $decls:(getIn0 "ix")- $decls:env- $stms:(setOut "ix" fn)- }- }- |]- where- tyIn0 = eltType (undefined :: a)- tyOut = eltType (undefined :: b)- (argIn0, _, _, _, getIn0) = getters 0 tyIn0 use0- (argOut, _, setOut) = setters tyOut-+mkMap :: forall aenv sh a b. (Shape sh, Elt a, Elt b)+ => DeviceProperties+ -> Gamma aenv+ -> CUFun1 aenv (a -> b)+ -> CUDelayedAcc aenv sh a+ -> [CUTranslSkel aenv (Array sh b)]+mkMap dev aenv fun arr+ | CUFun1 dce f <- fun+ , CUDelayed _ _ (CUFun1 _ get) <- arr+ = return+ $ CUTranslSkel "map" [cunit| --- Apply the given binary function element-wise to the two arrays. The extent of--- the resulting array is the intersection of the extents of the two source--- arrays. Each thread processes multiple elements, striding the array by the--- grid size.------ zipWith :: (Shape ix, Elt a, Elt b, Elt c)--- => (Exp a -> Exp b -> Exp c)--- -> Acc (Array ix a)--- -> Acc (Array ix b)--- -> Acc (Array ix c)----mkZipWith :: forall a b c. Elt c => Int -> CUFun (a -> b -> c) -> CUTranslSkel-mkZipWith dim (CULam use1 (CULam use0 (CUBody (CUExp env fn)))) =- CUTranslSkel "zipWith" [cunit|- $edecl:(cdim "DimOut" dim)- $edecl:(cdim "DimIn0" dim)- $edecl:(cdim "DimIn1" dim)+ $esc:("#include <accelerate_cuda_extras.h>")+ $edecls:texIn - extern "C"- __global__ void- zipWith+ extern "C" __global__ void+ map (- $params:argOut,- $params:argIn1,- $params:argIn0,- const typename DimOut shOut,- const typename DimIn1 shIn1,- const typename DimIn0 shIn0+ $params:argIn,+ $params:argOut ) {- const int shapeSize = size(shOut);- const int gridSize = __umul24(blockDim.x, gridDim.x);+ const int shapeSize = size(shOut);+ const int gridSize = $exp:(gridSize dev); int ix; - for ( ix = __umul24(blockDim.x, blockIdx.x) + threadIdx.x- ; ix < shapeSize- ; ix += gridSize)+ for ( ix = $exp:(threadIdx dev)+ ; ix < shapeSize+ ; ix += gridSize ) {- const int ix1 = toIndex(shIn1, fromIndex(shOut, ix));- const int ix0 = toIndex(shIn0, fromIndex(shOut, ix));- $decls:(getIn0 "ix0")- $decls:(getIn1 "ix1")- $decls:env- $stms:(setOut "ix" fn)+ $items:(dce x .=. get ix)+ $items:(setOut "ix" .=. f x) } } |] where- tyIn1 = eltType (undefined :: a)- tyIn0 = eltType (undefined :: b)- tyOut = eltType (undefined :: c)- (argIn1, _, _, _, getIn1) = getters 1 tyIn1 use1- (argIn0, _, _, _, getIn0) = getters 0 tyIn0 use0- (argOut, _, setOut) = setters tyOut+ (texIn, argIn) = environment dev aenv+ (argOut, setOut) = setters "Out" (undefined :: Array sh b)+ (x, _, _) = locals "x" (undefined :: a)+ ix = [cvar "ix"]
Data/Array/Accelerate/CUDA/CodeGen/Monad.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE BangPatterns, TemplateHaskell, QuasiQuotes #-}+{-# LANGUAGE QuasiQuotes #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.CUDA.CodeGen.Monad -- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee@@ -12,82 +13,121 @@ module Data.Array.Accelerate.CUDA.CodeGen.Monad ( - runCGM, CGM,- bind, use, weaken, environment, subscripts+ CUDA, Gen, AccST(..), ExpST(..),+ runCUDA, runCGM, evalCGM, execCGM, pushEnv, getEnv, fresh, bind, use, ) where -import Data.Label ( mkLabels )-import Data.Label.PureM+import Prelude hiding ( exp )+import Data.HashSet ( HashSet )+import Data.HashMap.Strict ( HashMap )+import Data.Hashable+import Control.Monad+import Control.Monad.State.Strict import Control.Applicative-import Control.Monad.State ( State, evalState )-import Language.C import Language.C.Quote.CUDA+import qualified Language.C as C+import qualified Data.HashSet as Set+import qualified Data.HashMap.Strict as Map -import Data.IntMap ( IntMap )-import Data.Sequence ( Seq, (|>) )-import qualified Data.IntMap as IM-import qualified Data.Sequence as S+import Data.Array.Accelerate.AST+import Data.Array.Accelerate.Trafo+import Data.Array.Accelerate.CUDA.CodeGen.Type +instance Hashable C.Exp where+ hashWithSalt salt = hashWithSalt salt . show -type CGM = State Gamma-data Gamma = Gamma- {- _unique :: {-# UNPACK #-} !Int,- _variables :: !(Seq (IntMap (Type, Exp))),- _bindings :: ![InitGroup]- }- deriving Show -$(mkLabels [''Gamma])+-- The state of the code generator monad. The outer monad is used to generate+-- fresh variable names and collect any headers required for foreign functions.+-- The inner is used to collect local environment bindings when generating code+-- for each individual scalar expression.+--+-- This separation is required so that names are unique across all generated+-- code fragments of a skeleton.+--+type CUDA = State AccST+type Gen = StateT ExpST CUDA +data AccST = AccST+ { counter :: {-# UNPACK #-} !Int+ , headers :: !(HashSet String)+ } -runCGM :: CGM a -> a-runCGM = flip evalState (Gamma 0 S.empty [])+data ExpST = ExpST+ { bindings :: [C.BlockItem]+ , terms :: !(HashSet C.Exp)+ , letterms :: !(HashMap C.Exp C.Exp)+ -- TODO: this should be a set of reverse dependencies: HashMap C.Exp [C.Exp]+ } --- Add space for another variable+-- Run the code generator with a fresh environment, returning the result and+-- final state. ---weaken :: CGM ()-weaken = modify variables (|> IM.empty)+runCUDA :: CUDA a -> (a, AccST)+runCUDA a = runState a (AccST 0 Set.empty) --- Add an expression of given type to the environment and return the (new,--- unique) binding name that can be used in place of the thing just bound.+runCGM :: Gen a -> CUDA (a, ExpST)+runCGM a = runStateT a (ExpST [] Set.empty Map.empty)++evalCGM :: Gen a -> CUDA a+evalCGM = fmap fst . runCGM++execCGM :: Gen a -> CUDA ExpST+execCGM = fmap snd . runCGM+++-- Create new binding points for the C expressions associated with the given AST+-- term, unless the term is itself a variable. ---bind :: Type -> Exp -> CGM Exp-bind t e = do- name <- fresh- modify bindings ( [cdecl| const $ty:t $id:name = $exp:e;|] : )- return [cexp|$id:name|]+-- Additionally, add these new terms to a map from the variable name to original+-- binding expression. This will be used as a reverse lookup when marking terms+-- as used.+--+pushEnv :: DelayedOpenExp env aenv t -> [C.Exp] -> Gen [C.Exp]+pushEnv exp cs =+ case exp of+ Var _ -> return cs+ Prj _ _ -> return cs+ _ -> do+ vs <- zipWithM bind (expType exp) cs+ modify (\st -> st { letterms = Map.union (Map.fromList (zip vs cs)) (letterms st) })+ return vs --- Return the environment (list of initialisation declarations). Since we--- introduce new bindings to the front of the list, need to reverse so they--- appear in usage order.+-- Return the local environment code, consisting of a list of initialisation+-- declarations and statements. During construction, these are introduced to the+-- front of the list, so reverse to get in execution order. ---environment :: CGM [InitGroup]-environment = reverse `fmap` gets bindings+getEnv :: Gen [C.BlockItem]+getEnv = reverse <$> gets bindings -- Generate a fresh variable name ---fresh :: CGM String+fresh :: CUDA String fresh = do- n <- gets unique <* modify unique (+1)- return $ 'v':show n+ n <- gets counter <* modify (\st -> st { counter = counter st + 1 })+ return $ 'v' : show n --- Mark a variable at a given base and tuple index as being used.+-- Add an expression of given type to the environment and return the (new,+-- unique) binding name that can be used in place of the thing just bound. ---use :: Int -> Int -> Type -> Exp -> CGM ()-use base prj ty var = modify variables (S.adjust (IM.insert prj (ty,var)) base)+bind :: C.Type -> C.Exp -> Gen C.Exp+bind t e = do+ name <- lift fresh+ modify (\st -> st { bindings = C.BlockDecl [cdecl| const $ty:t $id:name = $exp:e;|] : bindings st })+ return [cexp| $id:name |] --- Return the tuple components of a given variable that are actually used. These--- in snoc-list ordering, i.e. with variable zero on the right.+-- Add an expression to the set marking that it will be used to generate the+-- output value(s). If the term exists in the reverse let-map, add that binding+-- instead. ---subscripts :: Int -> CGM [(Int, Type, Exp)]-subscripts base- = reverse- . map swizzle- . IM.toList- . flip S.index base <$> gets variables- where- swizzle (i, (t,e)) = (i,t,e)+use :: C.Exp -> Gen C.Exp+use e = do+ m <- gets letterms+ case Map.lookup e m of+ Nothing -> modify (\st -> st { terms = Set.insert e (terms st) })+ Just x -> modify (\st -> st { terms = Set.insert x (terms st) })+ --+ return e
Data/Array/Accelerate/CUDA/CodeGen/PrefixSum.hs view
@@ -1,7 +1,8 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE PatternGuards #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# OPTIONS -fno-warn-incomplete-patterns #-} -- | -- Module : Data.Array.Accelerate.CUDA.CodeGen.PrefixSum -- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee@@ -16,22 +17,77 @@ module Data.Array.Accelerate.CUDA.CodeGen.PrefixSum ( -- skeletons- mkScanl, mkScanr,-- -- closets- scanBlock+ mkScanl, mkScanl1, mkScanl',+ mkScanr, mkScanr1, mkScanr', ) where -import Language.C.Syntax-import Language.C.Quote.CUDA-import Foreign.CUDA.Analysis import Data.Maybe+import Foreign.CUDA.Analysis+import Language.C.Quote.CUDA+import qualified Language.C.Syntax as C +import Data.Array.Accelerate.Array.Sugar ( Vector, Scalar, Elt, DIM1 )+import Data.Array.Accelerate.CUDA.AST import Data.Array.Accelerate.CUDA.CodeGen.Base-import Data.Array.Accelerate.CUDA.CodeGen.Type +-- Wrappers+-- --------++mkScanl, mkScanr+ :: Elt e+ => DeviceProperties+ -> Gamma aenv+ -> CUFun2 aenv (e -> e -> e)+ -> CUExp aenv e+ -> CUDelayedAcc aenv DIM1 e+ -> [CUTranslSkel aenv (Vector e)]+mkScanl dev aenv f z a =+ [ mkScan L dev aenv f (Just z) a+ , mkScanUp1 L dev aenv f a+ , mkScanUp2 L dev aenv f (Just z) ]++mkScanr dev aenv f z a =+ [ mkScan R dev aenv f (Just z) a+ , mkScanUp1 R dev aenv f a+ , mkScanUp2 R dev aenv f (Just z) ]++mkScanl1, mkScanr1+ :: Elt e+ => DeviceProperties+ -> Gamma aenv+ -> CUFun2 aenv (e -> e -> e)+ -> CUDelayedAcc aenv DIM1 e+ -> [CUTranslSkel aenv (Vector e)]+mkScanl1 dev aenv f a =+ [ mkScan L dev aenv f Nothing a+ , mkScanUp1 L dev aenv f a+ , mkScanUp2 L dev aenv f Nothing ]++mkScanr1 dev aenv f a =+ [ mkScan R dev aenv f Nothing a+ , mkScanUp1 R dev aenv f a+ , mkScanUp2 R dev aenv f Nothing ]++mkScanl', mkScanr'+ :: Elt e+ => DeviceProperties+ -> Gamma aenv+ -> CUFun2 aenv (e -> e -> e)+ -> CUExp aenv e+ -> CUDelayedAcc aenv DIM1 e+ -> [CUTranslSkel aenv (Vector e, Scalar e)]+mkScanl' dev aenv f z = map cast . mkScanl dev aenv f z+mkScanr' dev aenv f z = map cast . mkScanr dev aenv f z++cast :: CUTranslSkel aenv a -> CUTranslSkel aenv b+cast (CUTranslSkel entry code) = CUTranslSkel entry code+++-- Core implementation+-- -------------------+ data Direction = L | R deriving Eq @@ -40,11 +96,6 @@ show R = "r" -mkScanl, mkScanr :: DeviceProperties -> CUFun (a -> a -> a) -> Maybe (CUExp a) -> CUTranslSkel-mkScanl = mkScan L-mkScanr = mkScan R-- -- [OVERVIEW] -- -- Data.List-style exclusive scan, with the additional restriction that the@@ -108,65 +159,80 @@ -- * scanl1, scanr1 : no change (argSum is required, even though it will not be used Haskell-side) -- * scanl', scanr' : no change ---mkScan :: forall a.- Direction+mkScan :: forall aenv e. Elt e+ => Direction -> DeviceProperties- -> CUFun (a -> a -> a)- -> Maybe (CUExp a)- -> CUTranslSkel-mkScan dir dev (CULam _ (CULam use0 (CUBody (CUExp env combine)))) mseed =- CUTranslSkel name [cunit|- extern "C"- __global__ void- $id:name+ -> Gamma aenv+ -> CUFun2 aenv (e -> e -> e)+ -> Maybe (CUExp aenv e)+ -> CUDelayedAcc aenv DIM1 e+ -> CUTranslSkel aenv (Vector e)+mkScan dir dev aenv fun@(CUFun2 _ _ combine) mseed (CUDelayed (CUExp shIn) _ (CUFun1 _ get)) =+ CUTranslSkel scan [cunit|++ $esc:("#include <accelerate_cuda_extras.h>")+ $edecls:texIn++ extern "C" __global__ void+ $id:scan (+ $params:argIn, $params:argOut,- $params:argSum,- $params:argIn0, $params:argBlk,- typename Ix interval_size,- const typename Ix num_elements+ $params:(tail argSum) // just the pointers, no shape information ) { $decls:smem- $decls:decl0- $decls:decl1- $decls:decl2+ $decls:declx+ $decls:decly+ $decls:declz+ $items:(sh .=. shIn) + const int shapeSize = $exp:(shapeSize sh);+ const int intervalSize = (shapeSize + gridDim.x - 1) / gridDim.x;+ /*- * Read in previous result partial sum. We store the carry value in x2- * and read new values from the input array into x1, since 'scanBlock'- * will store its results into x1 on completion.+ * Read in previous result partial sum. We store the carry value in+ * temporary value 'z' and read new values from the input array into+ * 'x', since 'scanBlock' will store its results into 'y' on completion. */- int carry_in = 0;+ int carryIn = 0; if ( threadIdx.x == 0 ) {- $stm:(initialise mseed)+ $stm:initialise } - const int start = blockIdx.x * interval_size;- const int end = min(start + interval_size, num_elements);- interval_size = end - start;+ const int start = blockIdx.x * intervalSize;+ const int end = min(start + intervalSize, shapeSize);+ const int numElements = end - start;+ int seg; - for (int i = threadIdx.x; i < interval_size; i += blockDim.x)+ for ( seg = threadIdx.x+ ; seg < numElements+ ; seg += blockDim.x ) {- const int j = $id:(if left then "start + i" else "end - i - 1");- $stms:(x1 .=. getIn0 "j")+ const int ix = $id:(if dir == L then "start + seg" else "end - seg - 1") ; - if ( $exp:carry_in ) {- $stms:(x0 .=. x2)- $decls:env- $stms:(x1 .=. combine)+ /*+ * Generate the next set of values+ */+ $items:(x .=. get ix)++ /*+ * Carry in the result from the privous segment+ */+ if ( $exp:carryIn ) {+ $items:(x .=. combine z x) } /* * Store our input into shared memory and perform a cooperative * inclusive left scan. */- $stms:(sdata "threadIdx.x" .=. x1)+ $items:(sdata "threadIdx.x" .=. x) __syncthreads(); - $stms:(scanBlock dev elt Nothing (cvar "blockDim.x") sdata env combine)+ $stms:(scanBlock dev fun x y sdata Nothing) /* * Exclusive scans write the result of the previous thread to global@@ -174,122 +240,274 @@ * is the result of the last thread from the previous interval, or * the carry-in/seed value for multi-block scans. */- if ( $exp:(cbool exclusive) ) {+ if ( $exp:(cbool (isJust mseed)) ) { if ( threadIdx.x == 0 ) {- $stms:(x1 .=. x2)+ $items:(x .=. z) } else {- $stms:(x1 .=. sdata "threadIdx.x - 1")+ $items:(x .=. sdata "threadIdx.x - 1") } }- $stms:(setOut "j" x1)+ $items:(setOut "ix" .=. x) /*- * Carry the final result of this block through the set x2. If this+ * Carry the final result of this block through the set 'z'. If this * is the final interval, this is the value to write out as the * reduction result */ if ( threadIdx.x == 0 ) {- const int last = min(interval_size - i, blockDim.x) - 1;- $stms:(x2 .=. sdata "last")+ const int last = min(numElements - seg, blockDim.x) - 1;+ $items:(z .=. sdata "last") }- $id:( if not exclusive then "carry_in = 1" else [] ) ;+ $id:( if isNothing mseed then "carryIn = 1" else [] ) ; } /*- * for exclusive scans, set the overall scan result (reduction value)+ * Finally, exclusive scans set the overall scan result (reduction value) */- if ( $exp:(cbool exclusive) && threadIdx.x == 0 && blockIdx.x == $id:lastBlock ) {- $stms:(setSum .=. x2)+ if ( $exp:(cbool (isJust mseed)) && threadIdx.x == 0 && blockIdx.x == $id:lastBlock ) {+ $items:(setSum .=. z) } } |] where- name = "scan" ++ show dir ++ maybe "1" (const "") mseed- elt = eltType (undefined :: a)- (argIn0, x0, decl0, getIn0, _) = getters 0 elt use0- (argOut, _, setOut) = setters elt- setSum = totalSum "0"- (argSum, totalSum) = arrays "d_sum" elt- (argBlk, blkSum) = arrays "d_blk" elt- (x1, decl1) = locals "x1" elt- (x2, decl2) = locals "x2" elt- (smem, sdata) = shared 0 Nothing [cexp| blockDim.x |] elt- --- carry_in- | exclusive = [cexp| threadIdx.x == 0 |]- | otherwise = [cexp| threadIdx.x == 0 && carry_in |]- exclusive = isJust mseed- left = dir == L- firstBlock = if left then "0" else "gridDim.x - 1"- lastBlock = if not left then "0" else "gridDim.x - 1"- --- initialise Nothing = [cstm|- if ( blockIdx.x != $id:firstBlock ) {- $stms:(x2 .=. blkSum (if left then "blockIdx.x - 1" else "blockIdx.x + 1"))- carry_in = 1;- }- |]- initialise (Just (CUExp env' seed)) = [cstm|- if ( gridDim.x > 1 ) {- $stms:(x2 .=. blkSum "blockIdx.x")- } else {- $decls:env'- $stms:(x2 .=. seed)- }- |]+ scan = "scan" ++ show dir ++ maybe "1" (const []) mseed+ (texIn, argIn) = environment dev aenv+ (argOut, setOut) = setters "Out" (undefined :: Vector e)+ (argSum, totalSum) = setters "Sum" (undefined :: Vector e)+ (argBlk, blkSum) = setters "Blk" (undefined :: Vector e)+ (_, x, declx) = locals "x" (undefined :: e)+ (_, y, decly) = locals "y" (undefined :: e)+ (_, z, declz) = locals "z" (undefined :: e)+ (sh, _, _) = locals "sh" (undefined :: DIM1)+ (smem, sdata) = shared (undefined :: e) "sdata" [cexp| blockDim.x |] Nothing+ ix = [cvar "ix"]+ setSum = totalSum "0" + -- accessing neighbouring blocks+ firstBlock = if dir == L then "0" else "gridDim.x - 1"+ lastBlock = if dir == R then "0" else "gridDim.x - 1"+ prevBlock = if dir == L then "blockIdx.x - 1" else "blockIdx.x + 1" ------------------------------------------------------------------------------------------------------------------------------------------------------------------+ carryIn+ | isJust mseed = [cexp| threadIdx.x == 0 |]+ | otherwise = [cexp| threadIdx.x == 0 && carryIn |] --- Introduce some new array arguments and a way to index them+ -- initialise the first thread with the results of the previous block sweep+ -- or exclusive scan element+ initialise+ | Just (CUExp seed) <- mseed+ = [cstm| if ( gridDim.x > 1 ) {+ $items:(z .=. blkSum "blockIdx.x")+ } else {+ $items:(z .=. seed)+ }+ |]++ | otherwise+ = [cstm| if ( blockIdx.x != $id:firstBlock ) {+ $items:(z .=. blkSum prevBlock)+ carryIn = 1;+ }+ |]+++-- This computes the _upsweep_ phase of a multi-block scan. This is much like a+-- regular inclusive scan, except that only the final value for each interval is+-- output, rather than the entire body of the scan. Indeed, if the combination+-- function were commutative, this is equivalent to a parallel tree reduction. ---arrays :: String -> [Type] -> ([Param], String -> [Exp])-arrays base elt =- ( zipWith (\t a -> [cparam| $ty:(cptr t) $id:a |]) elt arrs- , \ix -> map (\a -> [cexp| $id:a [$id:ix] |]) arrs- )+mkScanUp1+ :: forall aenv e. Elt e+ => Direction+ -> DeviceProperties+ -> Gamma aenv+ -> CUFun2 aenv (e -> e -> e)+ -> CUDelayedAcc aenv DIM1 e+ -> CUTranslSkel aenv (Vector e)+mkScanUp1 dir dev aenv fun@(CUFun2 _ _ combine) (CUDelayed (CUExp shIn) _ (CUFun1 _ get)) =+ CUTranslSkel scan [cunit|++ $esc:("#include <accelerate_cuda_extras.h>")+ $edecls:texIn++ extern "C" __global__ void+ $id:scan+ (+ $params:argIn,+ $params:argOut+ )+ {+ $decls:smem+ $decls:declx+ $decls:decly+ $items:(sh .=. shIn)++ const int shapeSize = $exp:(shapeSize sh);+ const int intervalSize = (shapeSize + gridDim.x - 1) / gridDim.x;++ const int start = blockIdx.x * intervalSize;+ const int end = min(start + intervalSize, shapeSize);+ const int numElements = end - start;+ int carryIn = 0;+ int seg;++ for ( seg = threadIdx.x+ ; seg < numElements+ ; seg += blockDim.x )+ {+ const int ix = $id:(if dir == L then "start + seg" else "end - seg - 1") ;++ /*+ * Read in new values, combine with carry-in+ */+ $items:(x .=. get ix)++ if ( threadIdx.x == 0 && carryIn ) {+ $items:(x .=. combine y x)+ }++ /*+ * Store in shared memory and cooperatively scan+ */+ $items:(sdata "threadIdx.x" .=. x)+ __syncthreads();++ $stms:(scanBlock dev fun x y sdata Nothing)++ /*+ * Store the final result of the block to be carried in+ */+ if ( threadIdx.x == 0 ) {+ const int last = min(numElements - seg, blockDim.x) - 1;+ $items:(y .=. sdata "last")+ }+ carryIn = 1;+ }++ /*+ * Finally, the first thread writes the result of this interval+ */+ if ( threadIdx.x == 0 ) {+ $items:(setOut "blockIdx.x" .=. y)+ }+ }+ |] where- n = length elt- arrs = map (\x -> base ++ "_a" ++ show x) [n-1, n-2 .. 0]+ scan = "scan" ++ show dir ++ "Up"+ (texIn, argIn) = environment dev aenv+ (argOut, setOut) = setters "Out" (undefined :: Vector e)+ (_, x, declx) = locals "x" (undefined :: e)+ (_, y, decly) = locals "y" (undefined :: e)+ (sh, _, _) = locals "sh" (undefined :: DIM1)+ (smem, sdata) = shared (undefined :: e) "sdata" [cexp| blockDim.x |] Nothing+ ix = [cvar "ix"] --- Scan a block of results in shared memory. We hijack the standard local--- variables (x0 and x1) for the combination function. This thread must have+-- Second step of the upsweep phase: scan the interval sums to produce carry-in+-- values for each block of the final downsweep step+--+mkScanUp2+ :: forall aenv e. Elt e+ => Direction+ -> DeviceProperties+ -> Gamma aenv+ -> CUFun2 aenv (e -> e -> e)+ -> Maybe (CUExp aenv e)+ -> CUTranslSkel aenv (Vector e)+mkScanUp2 dir dev aenv f z+ = let (_, get) = getters "Blk" (undefined :: Vector e)+ in mkScan dir dev aenv f z get+++-- Block scans+-- ===========++scanBlock+ :: forall aenv e. Elt e+ => DeviceProperties+ -> CUFun2 aenv (e -> e -> e)+ -> [C.Exp] -> [C.Exp]+ -> (Name -> [C.Exp])+ -> Maybe C.Exp+ -> [C.Stm]+scanBlock dev f x0 x1 sdata mlim+ | shflOK dev (undefined :: e) = error "shfl-scan"+ | otherwise = scanBlockTree dev f x0 x1 sdata mlim+++-- Use a thread block to scan values in shared memory. Each thread must have -- already stored its initial value into shared memory. The final result for--- this thread will be stored in x1 as well as the appropriate place in shared+-- this thread will be stored in x0 as well as the appropriate place in shared -- memory. ---scanBlock :: DeviceProperties- -> [Type] -- element type- -> Maybe Exp -- partially-full block bounds check?- -> Exp -- CTA size- -> (String -> [Exp]) -- index shared memory area- -> [InitGroup] -- local environment for the..- -> [Exp] -- ..binary function- -> [Stm]-scanBlock dev elt mlim cta sdata env combine = map (scan . pow2) [0 .. maxThreads]+scanBlockTree+ :: forall aenv e. Elt e+ => DeviceProperties+ -> CUFun2 aenv (e -> e -> e)+ -> [C.Exp] -> [C.Exp] -- temporary variables x0 and x1+ -> (Name -> [C.Exp]) -- index elements from shared memory+ -> Maybe C.Exp -- partially full block bounds check?+ -> [C.Stm]+scanBlockTree dev (CUFun2 _ _ f) x0 x1 sdata mlim = map (scan . pow2) [ 0 .. maxThreads ] where- maxThreads = floor (logBase 2 (fromIntegral $ maxThreadsPerBlock dev :: Double)) :: Int- (x0, _) = locals "x0" elt- (x1, _) = locals "x1" elt- pow2 x = (2::Int) ^ x- scan n =- let inrange = maybe [cexp| threadIdx.x >= $int:n|]- (\m -> [cexp| threadIdx.x >= $int:n && threadIdx.x < $exp:m |]) mlim- ix = "threadIdx.x - " ++ show n- in- [cstm|- if ( $exp:cta > $int:n ) {- if ( $exp:inrange ) {- $stms:(x0 .=. sdata ix)- $decls:env- $stms:(x1 .=. combine)- }- __syncthreads();- $stms:(sdata "threadIdx.x" .=. x1)- __syncthreads();- }+ pow2 :: Int -> Int+ pow2 x = 2 ^ x+ maxThreads = floor (logBase 2 (fromIntegral $ maxThreadsPerBlock dev :: Double))++ inrange n+ | Just m <- mlim = [cexp| threadIdx.x >= $int:n && threadIdx.x < $exp:m |]+ | otherwise = [cexp| threadIdx.x >= $int:n |]++ scan n = [cstm|+ if ( blockDim.x > $int:n ) {+ if ( $exp:(inrange n) ) {+ $items:(x1 .=. sdata ("threadIdx.x - " ++ show n))+ $items:(x0 .=. f x1 x0)+ }+ __syncthreads();+ $items:(sdata "threadIdx.x" .=. x0)+ __syncthreads();+ } |] ++-- Shuffle scan+-- ------------++shflOK :: Elt e => DeviceProperties -> e -> Bool+shflOK _dev _ = False+-- shflOk dev dummy+-- = computeCapability dev >= Compute 3 0 && all (`elem` [4,8]) (eltSizeOf dummy)++{--+scanWarpShfl+ :: forall aenv e. Elt e+ => DeviceProperties+ -> CUFun2 aenv (e -> e -> e)+ -> [C.Exp] -> [C.Exp] -- temporary variables x0 and x1+ -> Maybe C.Exp -- partially full block bounds check+ -> C.Exp -- thread identified, usually lane or thread ID+ -> C.Stm+scanWarpShfl _dev (CUFun2 f) x0 x1 mlim tid+ = [cstm|+ for ( int z = 1; z <= warpSize; z *= 2 ) {+ $items:(x0 .=. shfl_up x1)++ if ( $exp:inrange ) {+ $items:(x1 .=. f x1 x0)+ }+ }+ |]+ where+ inrange+ | Just m <- mlim = [cexp| $exp:tid >= z && $exp:tid < $exp:m |]+ | otherwise = [cexp| $exp:tid >= z |]++ sizeof = eltSizeOf (undefined :: e)+ shfl_up = zipWith (\s x -> ccall (shfl s) [ x, cvar "z" ]) sizeof+ where+ shfl 4 = "shfl_up32"+ shfl 8 = "shfl_up64"+ shfl _ = INTERNAL_ERROR(error) "shfl_up" "I only know about 32- and 64-bit types"+--}
Data/Array/Accelerate/CUDA/CodeGen/Reduction.hs view
@@ -1,7 +1,8 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# OPTIONS -fno-warn-incomplete-patterns #-}+{-# LANGUAGE TypeOperators #-} -- | -- Module : Data.Array.Accelerate.CUDA.CodeGen.Reduction -- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee@@ -15,78 +16,149 @@ module Data.Array.Accelerate.CUDA.CodeGen.Reduction ( - -- skeletons- mkFold, mkFoldAll, mkFoldSeg,-- -- closets- reduceWarp, reduceBlock+ mkFold, mkFold1, mkFoldSeg, mkFold1Seg, ) where -import Language.C.Syntax-import Language.C.Quote.CUDA import Foreign.CUDA.Analysis+import Language.C.Quote.CUDA+import qualified Language.C.Syntax as C +import Data.Array.Accelerate.Type ( IsIntegral )+import Data.Array.Accelerate.Array.Sugar ( Array, Shape, Elt, Z(..), (:.)(..) )+import Data.Array.Accelerate.Analysis.Shape+import Data.Array.Accelerate.CUDA.AST import Data.Array.Accelerate.CUDA.CodeGen.Base import Data.Array.Accelerate.CUDA.CodeGen.Type +#include "accelerate.h" --- Reduction of an array of arbitrary rank to a single scalar value. The first--- argument needs to be an associative function to enable an efficient parallel--- implementation++-- Reduce an array along the innermost dimension. The function must be+-- associative to enable efficient parallel implementation. ----- foldAll :: (Shape sh, Elt a)--- => (Exp a -> Exp a -> Exp a)--- -> Exp a--- -> Acc (Array sh a)--- -> Acc (Scalar a)+-- fold :: (Shape ix, Elt a)+-- => (Exp a -> Exp a -> Exp a)+-- -> Exp a+-- -> Acc (Array (ix :. Int) a)+-- -> Acc (Array ix a) ----- fold1All :: (Shape sh, Elt a)--- => (Exp a -> Exp a -> Exp a)--- -> Acc (Array sh a)--- -> Acc (Scalar a)+-- fold1 :: (Shape ix, Elt a)+-- => (Exp a -> Exp a -> Exp a)+-- -> Acc (Array (ix :. Int) a)+-- -> Acc (Array ix a) ----- Each thread computes multiple elements sequentially. This reduces the overall--- cost of the algorithm while keeping the work complexity O(n) and the step--- complexity O(log n). c.f. Brent's Theorem optimisation.+-- If this is collapsing an array to a single value, we use a multi-pass+-- algorithm that splits the input data over several thread blocks. The first+-- kernel is executed once, and then the second recursively until a single value+-- is produced. ---mkFoldAll :: forall a.- DeviceProperties- -> CUFun (a -> a -> a)- -> Maybe (CUExp a) -> CUTranslSkel-mkFoldAll dev (CULam _ (CULam use0 (CUBody (CUExp env combine)))) mseed =- CUTranslSkel name [cunit|- extern "C"- __global__ void- $id:name+mkFold :: forall aenv sh e. (Shape sh, Elt e)+ => DeviceProperties+ -> Gamma aenv+ -> CUFun2 aenv (e -> e -> e)+ -> CUExp aenv e+ -> CUDelayedAcc aenv (sh :. Int) e+ -> [CUTranslSkel aenv (Array sh e)]+mkFold dev aenv f z a+ | expDim (undefined :: Exp aenv sh) > 0 = mkFoldDim dev aenv f (Just z) a+ | otherwise = mkFoldAll dev aenv f (Just z) a++mkFold1 :: forall aenv sh e. (Shape sh, Elt e)+ => DeviceProperties+ -> Gamma aenv+ -> CUFun2 aenv (e -> e -> e)+ -> CUDelayedAcc aenv (sh :. Int) e+ -> [ CUTranslSkel aenv (Array sh e) ]+mkFold1 dev aenv f a+ | expDim (undefined :: Exp aenv sh) > 0 = mkFoldDim dev aenv f Nothing a+ | otherwise = mkFoldAll dev aenv f Nothing a+++-- Reduction of an array of arbitrary rank to a single scalar value. Each thread+-- computes multiple elements sequentially. This reduces the overall cost of the+-- algorithm while keeping the work complexity O(n) and the step complexity+-- O(log n). c.f. Brent's Theorem optimisation.+--+-- Since the reduction occurs over multiple blocks, there are two phases. The+-- first pass incorporates any fused/embedded input arrays, while the second+-- recurses over a manifest array to produce a single value.+--+mkFoldAll+ :: forall aenv sh e. (Shape sh, Elt e)+ => DeviceProperties+ -> Gamma aenv+ -> CUFun2 aenv (e -> e -> e)+ -> Maybe (CUExp aenv e)+ -> CUDelayedAcc aenv (sh :. Int) e+ -> [ CUTranslSkel aenv (Array sh e) ]+mkFoldAll dev aenv f z a+ = let (_, rec) = getters "Rec" (undefined :: Array (sh:.Int) e)+ in+ [ mkFoldAll' False dev aenv f z a+ , mkFoldAll' True dev aenv f z rec ]+++mkFoldAll'+ :: forall aenv sh e. (Shape sh, Elt e)+ => Bool+ -> DeviceProperties+ -> Gamma aenv+ -> CUFun2 aenv (e -> e -> e)+ -> Maybe (CUExp aenv e)+ -> CUDelayedAcc aenv (sh :. Int) e+ -> CUTranslSkel aenv (Array sh e)+mkFoldAll' recursive dev aenv fun@(CUFun2 _ _ combine) mseed (CUDelayed (CUExp sh) _ (CUFun1 _ get))+ = CUTranslSkel foldAll [cunit|++ $esc:("#include <accelerate_cuda_extras.h>")+ $edecls:texIn++ extern "C" __global__ void+ $id:foldAll (+ $params:argIn, $params:argOut,- $params:argIn0,- const typename Ix num_elements+ $params:argRec ) {- const int gridSize = blockDim.x * gridDim.x;- int i = blockIdx.x * blockDim.x + threadIdx.x; $decls:smem- $decls:decl0- $decls:decl1+ $decls:declx+ $decls:decly + $items:(shIn .=. sh)+ const int shapeSize = $exp:(shapeSize shIn);+ const int gridSize = $exp:(gridSize dev);+ int ix = $exp:(threadIdx dev);+ /* * Reduce multiple elements per thread. The number is determined by the * number of active thread blocks (via gridDim). More blocks will result in * a larger `gridSize', and hence fewer elements per thread * * The loop stride of `gridSize' is used to maintain coalescing.+ *+ * Note that we can't simply kill threads that won't participate in the+ * reduction, as exclusive reductions of empty arrays then won't be+ * initialised with their seed element. */- if (i < num_elements)+ if ( ix < shapeSize ) {- $stms:(x1 .=. getIn0 "i")+ /*+ * Initialise the local sum, then ...+ */+ $items:(y .=. get ix) - for (i += gridSize; i < num_elements; i += gridSize)+ /*+ * ... continue striding the array, reading new values into 'x' and+ * combining into the local accumulator 'y'. The non-idiomatic+ * structure of the loop below is because we have already+ * initialised 'y' above.+ */+ for ( ix += gridSize; ix < shapeSize; ix += gridSize ) {- $stms:(x0 .=. getIn0 "i")- $decls:env- $stms:(x1 .=. combine)+ $items:(x .=. get ix)+ $items:(y .=. combine x y) } } @@ -94,202 +166,197 @@ * Each thread puts its local sum into shared memory, then threads * cooperatively reduce the shared array to a single value. */- $stms:(sdata "threadIdx.x" .=. x1)+ $items:(sdata "threadIdx.x" .=. y) __syncthreads(); - i = min(((int) num_elements) - blockIdx.x * blockDim.x, blockDim.x);- $stms:(reduceBlock dev elt "i" sdata env combine)+ ix = min(shapeSize - blockIdx.x * blockDim.x, blockDim.x);+ $stms:(reduceBlock dev fun x y sdata (cvar "ix")) /* * Write the results of this block back to global memory. If we are the last * phase of a recursive multi-block reduction, include the seed element. */- if (threadIdx.x == 0)+ if ( threadIdx.x == 0 ) {- $stms:(maybe inclusive_finish exclusive_finish mseed)+ $items:(maybe inclusive_finish exclusive_finish mseed) } } |] where- name = maybe "fold1All" (const "foldAll") mseed- elt = eltType (undefined :: a)- (argIn0, x0, decl0, getIn0, _) = getters 0 elt use0- (argOut, _, setOut) = setters elt- (x1, decl1) = locals "x1" elt- (smem, sdata) = shared 0 Nothing [cexp| blockDim.x |] elt+ foldAll = maybe "fold1All" (const "foldAll") mseed+ (texIn, argIn) = environment dev aenv+ (argOut, setOut) = setters "Out" (undefined :: Array sh e)+ (argRec, _)+ | recursive = getters "Rec" (undefined :: Array (sh:.Int) e)+ | otherwise = ([], undefined)++ (_, x, declx) = locals "x" (undefined :: e)+ (_, y, decly) = locals "y" (undefined :: e)+ (shIn, _, _) = locals "sh" (undefined :: sh :. Int)+ ix = [cvar "ix"]+ (smem, sdata) = shared (undefined :: e) "sdata" [cexp| blockDim.x |] Nothing --- inclusive_finish = setOut "blockIdx.x" x1- exclusive_finish (CUExp env' seed) = [[cstm|- if (num_elements > 0) {- if (gridDim.x == 1) {- $decls:env'- $stms:(x0 .=. seed)- $decls:env- $stms:(x1 .=. combine)+ inclusive_finish = setOut "blockIdx.x" .=. y+ exclusive_finish (CUExp seed) = C.BlockStm [cstm|+ if ( shapeSize > 0 ) {+ if ( gridDim.x == 1 ) {+ $items:(x .=. seed)+ $items:(y .=. combine x y) }- $stms:(setOut "blockIdx.x" x1)+ $items:(setOut "blockIdx.x" .=. y) } else {- $decls:env'- $stms:(setOut "blockIdx.x" seed)+ $items:(setOut "blockIdx.x" .=. seed) }- |]]+ |] : [] --- Reduction of the innermost dimension of an array of arbitrary rank. The first--- argument needs to be an associative function to enable an efficient parallel--- implementation------ fold :: (Shape ix, Elt a)--- => (Exp a -> Exp a -> Exp a)--- -> Exp a--- -> Acc (Array (ix :. Int) a)--- -> Acc (Array ix a)------ fold1 :: (Shape ix, Elt a)--- => (Exp a -> Exp a -> Exp a)--- -> Acc (Array (ix :. Int) a)--- -> Acc (Array ix a)+-- Reduction of the innermost dimension of an array of arbitrary rank. Each+-- thread block reduces along one innermost dimension index. ---mkFold :: forall a.- DeviceProperties- -> CUFun (a -> a -> a)- -> Maybe (CUExp a)- -> CUTranslSkel-mkFold dev (CULam _ (CULam use0 (CUBody (CUExp env combine)))) mseed =- CUTranslSkel name [cunit|- extern "C"- __global__ void- $id:name+mkFoldDim+ :: forall aenv sh e. (Shape sh, Elt e)+ => DeviceProperties+ -> Gamma aenv+ -> CUFun2 aenv (e -> e -> e)+ -> Maybe (CUExp aenv e)+ -> CUDelayedAcc aenv (sh :. Int) e+ -> [ CUTranslSkel aenv (Array sh e) ]+mkFoldDim dev aenv fun@(CUFun2 _ _ combine) mseed (CUDelayed (CUExp sh) _ (CUFun1 _ get))+ = return+ $ CUTranslSkel fold [cunit|++ $esc:("#include <accelerate_cuda_extras.h>")+ $edecls:texIn++ extern "C" __global__ void+ $id:fold (- $params:argOut,- $params:argIn0,- const typename Ix interval_size, // indexHead(shIn0)- const typename Ix num_intervals, // size(shOut)- const typename Ix num_elements // size(shIn0)+ $params:argIn,+ $params:argOut ) { $decls:smem- $decls:decl1- $decls:decl0+ $decls:declx+ $decls:decly + $items:(shIn .=. sh)++ const int numIntervals = size(shOut);+ const int intervalSize = $exp:(indexHead shIn);+ int ix;+ int seg;+ /* * If the intervals of an exclusive fold are empty, use all threads to * map the seed value to the output array and exit. */- $stms:(maybe [] (return . mapseed) mseed)+ $stms:(maybe [] mapseed mseed) /* * Threads in a block cooperatively reduce all elements in an interval. */- for (int seg = blockIdx.x; seg < num_intervals; seg += gridDim.x)+ for ( seg = blockIdx.x+ ; seg < numIntervals+ ; seg += gridDim.x ) {- const int start = seg * interval_size;- const int end = min(start + interval_size, num_elements);+ const int start = seg * intervalSize;+ const int end = start + intervalSize; const int n = min(end - start, blockDim.x); /*- * Kill threads that will not participate in this segment to avoid- * invalid global reads.+ * Kill threads that will not participate to avoid invalid reads.+ * Take advantage of the fact that the array is rectangular. */- if (threadIdx.x >= n)+ if ( threadIdx.x >= n ) return; /* * Ensure aligned access to global memory, and that each thread * initialises its local sum */- int i = start - (start & (warpSize - 1));+ ix = start - (start & (warpSize - 1)); - if (i == start || interval_size > blockDim.x)+ if ( ix == start || intervalSize > blockDim.x) {- i += threadIdx.x;+ ix += threadIdx.x; - if (i >= start)+ if ( ix >= start ) {- $stms:(x1 .=. getIn0 "i")+ $items:(y .=. get ix) } - if (i + blockDim.x < end)+ if ( ix + blockDim.x < end ) {- $decls:(getTmp "i + blockDim.x")+ $items:(x .=. get [cvar "ix + blockDim.x"]) - if (i >= start) {- $decls:env- $stms:(x1 .=. combine)+ if ( ix >= start ) {+ $items:(y .=. combine x y) } else {- $stms:(x1 .=. x0)+ $items:(y .=. x) } } /* * Now, iterate collecting a local sum */- for (i += 2 * blockDim.x; i < end; i += blockDim.x)+ for ( ix += 2 * blockDim.x; ix < end; ix += blockDim.x ) {- $stms:(x0 .=. getIn0 "i")- $decls:env- $stms:(x1 .=. combine)+ $items:(x .=. get ix)+ $items:(y .=. combine x y) } } else {- $stms:(x1 .=. getIn0 "start + threadIdx.x")+ $items:(y .=. get [cvar "start + threadIdx.x"]) } /* * Each thread puts its local sum into shared memory, and * cooperatively reduces this to a single value. */- $stms:(sdata "threadIdx.x" .=. x1)+ $items:(sdata "threadIdx.x" .=. y) __syncthreads(); - $stms:(reduceBlock dev elt "n" sdata env combine)+ $stms:(reduceBlock dev fun x y sdata (cvar "n")) /* * Finally, the first thread writes the result for this segment. For * exclusive reductions, we also combine with the seed element here. */- if (threadIdx.x == 0)- $stm:(maybe inclusive_finish exclusive_finish mseed)+ if ( threadIdx.x == 0 ) {+ $items:(maybe [] exclusive_finish mseed)+ $items:(setOut "seg" .=. y)+ } } } |] where- name = maybe "fold1" (const "fold") mseed- elt = eltType (undefined :: a)- (argIn0, x0, decl0, getIn0, getTmp) = getters 0 elt use0- (argOut, _, setOut) = setters elt- (x1, decl1) = locals "x1" elt- (smem, sdata) = shared 0 Nothing [cexp| blockDim.x |] elt- --- inclusive_finish = [cstm| {- $stms:(setOut "seg" x1)- } |]- exclusive_finish (CUExp env' seed) = [cstm| {- $decls:env'- $stms:(x0 .=. seed)- $decls:env- $stms:(x1 .=. combine)- $stms:(setOut "seg" x1)- } |]+ fold = maybe "fold1" (const "fold") mseed+ (texIn, argIn) = environment dev aenv+ (argOut, setOut) = setters "Out" (undefined :: Array sh e)+ (_, x, declx) = locals "x" (undefined :: e)+ (_, y, decly) = locals "y" (undefined :: e)+ (shIn, _, _) = locals "sh" (undefined :: sh :. Int)+ ix = [cvar "ix"]+ (smem, sdata) = shared (undefined :: e) "sdata" [cexp| blockDim.x |] Nothing --- mapseed (CUExp env' seed) = [cstm|- if (interval_size == 0)- {- const int gridSize = __umul24(blockDim.x, gridDim.x);- int seg;+ mapseed (CUExp seed)+ = [cstm| if ( intervalSize == 0 ) {+ const int gridSize = $exp:(gridSize dev); - for ( seg = __umul24(blockDim.x, blockIdx.x) + threadIdx.x- ; seg < num_intervals- ; seg += gridSize )- {- $decls:env'- $stms:(setOut "seg" seed)- }- return;- }|]+ for ( ix = $exp:(threadIdx dev)+ ; ix < numIntervals+ ; ix += gridSize )+ {+ $items:(setOut "ix" .=. seed)+ }+ } |] :[]+ --+ exclusive_finish (CUExp seed)+ = concat [ x .=. seed+ , y .=. combine x y ] -- Segmented reduction along the innermost dimension of an array. Performs one@@ -321,57 +388,89 @@ -- array. The i-th warp reduces values in the input array at indices -- [d_offset[i], d_offset[i+1]). ---mkFoldSeg :: forall a.- DeviceProperties- -> Int- -> Type -- of the segments array- -> CUFun (a -> a -> a)- -> Maybe (CUExp a)- -> CUTranslSkel-mkFoldSeg dev dim tySeg (CULam _ (CULam use0 (CUBody (CUExp env combine)))) mseed =- CUTranslSkel name [cunit|- $edecl:(cdim "DimOut" dim)- $edecl:(cdim "DimIn0" dim)+mkFoldSeg+ :: (Shape sh, Elt e, Elt i, IsIntegral i)+ => DeviceProperties+ -> Gamma aenv+ -> CUFun2 aenv (e -> e -> e)+ -> CUExp aenv e+ -> CUDelayedAcc aenv (sh :. Int) e+ -> CUDelayedAcc aenv (Z :. Int) i+ -> [CUTranslSkel aenv (Array (sh :. Int) e)]+mkFoldSeg dev aenv f z a s = [ mkFoldSeg' dev aenv f (Just z) a s ] +mkFold1Seg+ :: (Shape sh, Elt e, Elt i, IsIntegral i)+ => DeviceProperties+ -> Gamma aenv+ -> CUFun2 aenv (e -> e -> e)+ -> CUDelayedAcc aenv (sh :. Int) e+ -> CUDelayedAcc aenv (Z :. Int) i+ -> [CUTranslSkel aenv (Array (sh :. Int) e)]+mkFold1Seg dev aenv f a s = [ mkFoldSeg' dev aenv f Nothing a s ]+++mkFoldSeg'+ :: forall aenv sh e i. (Shape sh, Elt e, Elt i, IsIntegral i)+ => DeviceProperties+ -> Gamma aenv+ -> CUFun2 aenv (e -> e -> e)+ -> Maybe (CUExp aenv e)+ -> CUDelayedAcc aenv (sh :. Int) e+ -> CUDelayedAcc aenv (Z :. Int) i+ -> CUTranslSkel aenv (Array (sh :. Int) e)+mkFoldSeg' dev aenv fun@(CUFun2 _ _ combine) mseed+ (CUDelayed (CUExp shIn) _ (CUFun1 _ get))+ (CUDelayed _ _ (CUFun1 _ offset))+ = CUTranslSkel foldSeg [cunit|++ $esc:("#include <accelerate_cuda_extras.h>")+ $edecls:texIn+ extern "C" __global__ void- $id:name+ $id:foldSeg (- $params:argOut,- $params:argIn0,- const $ty:(cptr tySeg) d_offset,- const typename DimOut shOut,- const typename DimIn0 shIn0+ $params:argIn,+ $params:argOut ) { const int vectors_per_block = blockDim.x / warpSize;- const int num_vectors = vectors_per_block * gridDim.x;- const int thread_id = blockDim.x * blockIdx.x + threadIdx.x;+ const int num_vectors = $exp:(umul24 dev vectors_per_block gridDim);+ const int thread_id = $exp:(threadIdx dev); const int vector_id = thread_id / warpSize; const int thread_lane = threadIdx.x & (warpSize - 1); const int vector_lane = threadIdx.x / warpSize; const int num_segments = indexHead(shOut); const int total_segments = size(shOut);+ int seg;+ int ix; extern volatile __shared__ int s_ptrs[][2]; $decls:smem- $decls:decl1- $decls:decl0+ $decls:declx+ $decls:decly+ $items:(sh .=. shIn) - for (int seg = vector_id; seg < total_segments; seg += num_vectors)+ /*+ * Threads in a warp cooperatively reduce a segment+ */+ for ( seg = vector_id+ ; seg < total_segments+ ; seg += num_vectors ) { const int s = seg % num_segments;- const int base = (seg / num_segments) * indexHead(shIn0);+ const int base = (seg / num_segments) * $exp:(indexHead sh); /* * Use two threads to fetch the indices of the start and end of this- * segment. This results in single coalesced global read, instead of two- * separate transactions.+ * segment. This results in single coalesced global read. */- if (thread_lane < 2)- s_ptrs[vector_lane][thread_lane] = (int) d_offset[s + thread_lane];+ if ( thread_lane < 2 ) {+ $items:([cvar "s_ptrs[vector_lane][thread_lane]"] .=. offset [cvar "s + thread_lane"])+ } const int start = base + s_ptrs[vector_lane][0]; const int end = base + s_ptrs[vector_lane][1];@@ -380,166 +479,256 @@ /* * Each thread reads in values of this segment, accumulating a local sum */- if (num_elements > warpSize)+ if ( num_elements > warpSize ) { /* * Ensure aligned access to global memory */- int i = start - (start & (warpSize - 1)) + thread_lane;- if (i >= start)+ ix = start - (start & (warpSize - 1)) + thread_lane;++ if ( ix >= start ) {- $stms:(x1 .=. getIn0 "i")+ $items:(y .=. get ix) } /* * Subsequent reads to global memory are aligned, but make sure all * threads have initialised their local sum. */- if (i + warpSize < end)+ if ( ix + warpSize < end ) {- $decls:(getTmp "i + warpSize")+ $items:(x .=. get [cvar "ix + warpSize"]) - if (i >= start) {- $decls:env- $stms:(x1 .=. combine)+ if ( ix >= start ) {+ $items:(y .=. combine x y) } else {- $stms:(x1 .=. x0)+ $items:(y .=. x) } } /* * Now, iterate along the inner-most dimension collecting a local sum */- for (i += 2 * warpSize; i < end; i += warpSize)+ for ( ix += 2 * warpSize; ix < end; ix += warpSize ) {- $stms:(x0 .=. getIn0 "i")- $decls:env- $stms:(x1 .=. combine)+ $items:(x .=. get ix)+ $items:(y .=. combine x y) } }- else if (start + thread_lane < end)+ else if ( start + thread_lane < end ) {- $stms:(x1 .=. getIn0 "start + thread_lane")+ $items:(y .=. get [cvar "start + thread_lane"]) } /* * Store local sums into shared memory and reduce to a single value */- const int n = min(num_elements, warpSize);- $stms:(sdata "threadIdx.x" .=. x1)- $stms:(tail $ reduceWarp dev elt "n" "thread_lane" sdata env combine)+ ix = min(num_elements, warpSize);+ $items:(sdata "threadIdx.x" .=. y)+ $stms:(reduceWarp dev fun x y sdata (cvar "ix") (cvar "thread_lane")) /* * Finally, the first thread writes the result for this segment */- if (thread_lane == 0)+ if ( thread_lane == 0 ) {- $stms:(maybe inclusive_finish exclusive_finish mseed)+ $items:(maybe [] exclusive_finish mseed)+ $items:(setOut "seg" .=. y) } } } |] where- name = maybe "fold1Seg" (const "foldSeg") mseed- elt = eltType (undefined :: a)- (argIn0, x0, decl0, getIn0, getTmp) = getters 0 elt use0- (argOut, _, setOut) = setters elt- (x1, decl1) = locals "x1" elt- (smem, sdata) = shared 0 (Just $ [cexp| &s_ptrs[vectors_per_block][2] |]) [cexp| blockDim.x |] elt+ foldSeg = maybe "fold1Seg" (const "foldSeg") mseed+ (texIn, argIn) = environment dev aenv+ (argOut, setOut) = setters "Out" (undefined :: Array (sh :. Int) e)+ (_, x, declx) = locals "x" (undefined :: e)+ (_, y, decly) = locals "y" (undefined :: e)+ (sh, _, _) = locals "sh" (undefined :: sh :. Int)+ (smem, sdata) = shared (undefined :: e) "sdata" [cexp| blockDim.x |] (Just $ [cexp| &s_ptrs[vectors_per_block][2] |]) --- inclusive_finish = setOut "seg" x1- exclusive_finish (CUExp env' seed) = [cstm|- if (num_elements > 0) {- $decls:env'- $stms:(x0 .=. seed)- $decls:env- $stms:(x1 .=. combine)- } else {- $decls:env'- $stms:(x1 .=. seed)- }|] :- setOut "seg" x1-+ ix = [cvar "ix"]+ vectors_per_block = cvar "vectors_per_block"+ gridDim = cvar "gridDim.x"+ --+ exclusive_finish (CUExp seed)+ = C.BlockStm [cstm| if ( num_elements > 0 ) {+ $items:(x .=. seed)+ $items:(y .=. combine x y)+ } else {+ $items:(y .=. seed)+ } |] :[] ------------------------------------------------------------------------------------------------------------------------------------------------------------------+-- Reducers+-- -------- --- Threads of a warp run in lockstep, so there is no need to synchronise. We--- hijack the standard local variable sets (x0 and x1) for the combination--- function. The initial values must already be stored in shared memory. The--- final result is stored in x1.+-- Reductions of values stored in shared memory. ---reduceWarp :: DeviceProperties- -> [Type]- -> String -- number of elements- -> String -- thread identifier: usually the lane or thread id- -> (String -> [Exp]) -- index shared memory- -> [InitGroup] -- local binding environment for the..- -> [Exp] -- ..binary associative combination function- -> [Stm]-reduceWarp dev elt n tid sdata env combine = map (reduce . pow2) [v,v-1..0]+-- Two local (mutable) variables are also required to do the reduction. The+-- final result is stored in the second of these.+--+reduceWarp+ :: forall aenv e. Elt e+ => DeviceProperties+ -> CUFun2 aenv (e -> e -> e)+ -> [C.Exp] -> [C.Exp] -- temporary variables x0 and x1+ -> (Name -> [C.Exp]) -- index elements from shared memory+ -> C.Exp -- number of elements+ -> C.Exp -- thread identifier: usually lane or thread ID+ -> [C.Stm]+reduceWarp dev fun x0 x1 sdata n tid+ | shflOK dev (undefined :: e) = return+ $ reduceWarpShfl dev fun x0 x1 n tid+ | otherwise = reduceWarpTree dev fun x0 x1 sdata n tid+++reduceBlock+ :: forall aenv e. Elt e+ => DeviceProperties+ -> CUFun2 aenv (e -> e -> e)+ -> [C.Exp] -> [C.Exp] -- temporary variables x0 and x1+ -> (Name -> [C.Exp]) -- index elements from shared memory+ -> C.Exp -- number of elements+ -> [C.Stm]+reduceBlock dev fun x0 x1 sdata n+ | shflOK dev (undefined :: e) = reduceBlockShfl dev fun x0 x1 sdata n+ | otherwise = reduceBlockTree dev fun x0 x1 sdata n+++-- Tree reduction+-- --------------++reduceWarpTree+ :: Elt e+ => DeviceProperties+ -> CUFun2 aenv (e -> e -> e)+ -> [C.Exp] -> [C.Exp] -- temporary variables x0 and x1+ -> (Name -> [C.Exp]) -- index elements from shared memory+ -> C.Exp -- number of elements+ -> C.Exp -- thread identifier: usually lane or thread ID+ -> [C.Stm]+reduceWarpTree dev (CUFun2 _ _ f) x0 x1 sdata n tid+ = map (reduce . pow2) [v, v-1 .. 0] where- v = floor (logBase 2 (fromIntegral $ warpSize dev :: Double)) :: Int- pow2 x = (2::Int) ^ x- (x0, _) = locals "x0" elt- (x1, _) = locals "x1" elt- --+ v = floor (logBase 2 (fromIntegral $ warpSize dev :: Double))++ pow2 :: Int -> Int+ pow2 x = 2 ^ x++ reduce :: Int -> C.Stm+ reduce 0+ = [cstm| if ( $exp:tid < $exp:n ) {+ $items:(x0 .=. sdata "threadIdx.x + 1")+ $items:(x1 .=. f x1 x0)+ } |] reduce i- | i > 1- = [cstm| if ( $id:tid + $int:i < $id:n ) {- $stms:(x0 .=. sdata ("threadIdx.x + " ++ show i))- $decls:env- $stms:(x1 .=. combine)- $stms:(sdata "threadIdx.x" .=. x1)- }- |]- --- | otherwise- = [cstm| if ( $id:tid + $int:i < $id:n ) {- $stms:(x0 .=. sdata "threadIdx.x + 1")- $decls:env- $stms:(x1 .=. combine)- }- |]+ = [cstm| if ( $exp:tid + $int:i < $exp:n ) {+ $items:(x0 .=. sdata ("threadIdx.x + " ++ show i))+ $items:(x1 .=. f x1 x0)+ $items:(sdata "threadIdx.x" .=. x1)+ } |] +reduceBlockTree+ :: Elt e+ => DeviceProperties+ -> CUFun2 aenv (e -> e -> e)+ -> [C.Exp] -> [C.Exp] -- temporary variables x0 and x1+ -> (Name -> [C.Exp]) -- index elements from shared memory+ -> C.Exp -- number of elements+ -> [C.Stm]+reduceBlockTree dev fun@(CUFun2 _ _ f) x0 x1 sdata n+ = flip (foldr1 (.)) []+ $ map (reduce . pow2) [u-1, u-2 .. v] --- All threads cooperatively reduce this block's data in shared memory. We--- hijack the standard local variables (x0 and x1) for the combination function.--- The initial values must already be stored in shared memory.----reduceBlock :: DeviceProperties- -> [Type]- -> String -- number of elements- -> (String -> [Exp]) -- index shared memory- -> [InitGroup] -- local binding environment for the..- -> [Exp] -- ..binary associative function- -> [Stm]-reduceBlock dev elt n sdata env combine = map (reduce . pow2) [u-1,u-2..v] where- u = floor (logBase 2 (fromIntegral $ maxThreadsPerBlock dev :: Double)) :: Int- v = floor (logBase 2 (fromIntegral $ warpSize dev :: Double)) :: Int- pow2 x = (2::Int) ^ x- (x0, _) = locals "x0" elt- (x1, _) = locals "x1" elt- --- reduce i+ u = floor (logBase 2 (fromIntegral $ maxThreadsPerBlock dev :: Double))+ v = floor (logBase 2 (fromIntegral $ warpSize dev :: Double))++ pow2 :: Int -> Int+ pow2 x = 2 ^ x++ reduce :: Int -> [C.Stm] -> [C.Stm]+ reduce i rest | i > warpSize dev- = [cstm| if ( $id:n > $int:i ) {- if ( threadIdx.x + $int:i < $id:n ) {- $stms:(x0 .=. sdata ("threadIdx.x + " ++ show i))- $decls:env- $stms:(x1 .=. combine)- $stms:(sdata "threadIdx.x" .=. x1)- }- __syncthreads();- }- |]- --+ = [cstm| if ( threadIdx.x + $int:i < $exp:n ) {+ $items:(x0 .=. sdata ("threadIdx.x + " ++ show i))+ $items:(x1 .=. f x1 x0)+ $items:(sdata "threadIdx.x" .=. x1)+ } |]+ : [cstm| __syncthreads(); |]+ : rest+ | otherwise = [cstm| if ( threadIdx.x < $int:(warpSize dev) ) {- $stms:(reduceWarp dev elt n "threadIdx.x" sdata env combine)+ $stms:(reduceWarpTree dev fun x0 x1 sdata n (cvar "threadIdx.x"))+ } |]+ : rest+++-- Butterfly reduction+-- -------------------++shflOK :: Elt e => DeviceProperties -> e -> Bool+shflOK _dev _ = False+-- shflOK dev dummy+-- = computeCapability dev >= Compute 3 0 && all (`elem` [4,8]) (eltSizeOf dummy)+++-- Reduction using the __shfl_xor() operation for exchanging variables between+-- threads of a without use of shared memory. The exchange occurs simultaneously+-- for all active threads within the wrap, moving 4 bytes of data per thread.+-- 8-byte quantities are broken into two separate transfers.+--+reduceWarpShfl+ :: forall aenv e. Elt e+ => DeviceProperties+ -> CUFun2 aenv (e -> e -> e)+ -> [C.Exp] -> [C.Exp]+ -> C.Exp+ -> C.Exp+ -> C.Stm+reduceWarpShfl _dev (CUFun2 _ _ f) x0 x1 n tid+ = [cstm| for ( int z = warpSize/2; z >= 1; z /= 2 ) {+ $items:(x0 .=. shfl_xor x1)++ if ( $exp:tid + z < $exp:n ) {+ $items:(x1 .=. f x1 x0) }- |]+ } |]+ where+ sizeof = eltSizeOf (undefined :: e)+ shfl_xor = zipWith (\s x -> ccall (shfl s) [ x, cvar "z" ]) sizeof+ where+ shfl 4 = "shfl_xor32"+ shfl 8 = "shfl_xor64"+ shfl _ = INTERNAL_ERROR(error) "shfl_xor" "I only know about 32- and 64-bit types"+++-- Reduce a block of values in butterfly fashion using __shfl_xor(). Each warp+-- calculates a local reduction, and the first thread of a warp writes its+-- result into shared memory. The first warp then reduces these values to the+-- final result.+--+reduceBlockShfl+ :: forall aenv e. Elt e+ => DeviceProperties+ -> CUFun2 aenv (e -> e -> e)+ -> [C.Exp] -> [C.Exp]+ -> (Name -> [C.Exp])+ -> C.Exp+ -> [C.Stm]+reduceBlockShfl dev fun x0 x1 sdata n+ = reduceWarpShfl dev fun x0 x1 n (cvar "threadIdx.x")+ : [cstm| if ( (threadIdx.x & warpSize - 1) == 0 ) {+ $items:(sdata "threadIdx.x / warpSize" .=. x1)+ } |]+ : [cstm| __syncthreads(); |]+ : [cstm| if ( threadIdx.x < warpSize ) {+ $items:(x1 .=. sdata "threadIdx.x")+ $exp:n = ($exp:n + warpSize - 1) / warpSize;+ $stm:(reduceWarpShfl dev fun x0 x1 n (cvar "threadIdx.x"))+ } |]+ : []
Data/Array/Accelerate/CUDA/CodeGen/Stencil.hs view
@@ -2,9 +2,8 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# OPTIONS -fno-warn-incomplete-patterns #-} -- |--- Module : Data.Array.Accelerate.CUDA.CodeGen.Mapping+-- Module : Data.Array.Accelerate.CUDA.CodeGen.Stencil -- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee -- [2009..2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell -- License : BSD3@@ -20,26 +19,28 @@ ) where -import Language.C.Syntax+import Control.Applicative+import Control.Monad.State.Strict+import Foreign.CUDA.Analysis import Language.C.Quote.CUDA+import qualified Language.C.Syntax as C -import Data.Array.Accelerate.Type-import Data.Array.Accelerate.AST ( OpenAcc, Fun, Stencil )-import Data.Array.Accelerate.Array.Sugar ( Array, Elt, shapeToList )+import Data.Array.Accelerate.Type ( Boundary(..) )+import Data.Array.Accelerate.Array.Sugar ( Array, Shape, Elt, shapeToList )+import Data.Array.Accelerate.Analysis.Shape+import Data.Array.Accelerate.Analysis.Stencil+import Data.Array.Accelerate.CUDA.AST hiding ( stencil, stencilAccess ) import Data.Array.Accelerate.CUDA.CodeGen.Base import Data.Array.Accelerate.CUDA.CodeGen.Type -import qualified Data.Array.Accelerate.Analysis.Stencil as Stencil-import qualified Data.Array.IArray as IArray - -- Map a stencil over an array. In contrast to 'map', the domain of a stencil -- function is an entire /neighbourhood/ of each array element. Neighbourhoods -- are sub-arrays centred around a focal point. They are not necessarily--- rectangular, but they are symmetric in each dimension and have an extent of--- at least three in each dimensions — due to the symmetry requirement, the--- extent is necessarily odd. The focal point is the array position that is--- determined by the stencil.+-- rectangular, but they are symmetric and have an extent of at least three in+-- each dimensions. Due to this symmetry requirement, the extent is necessarily+-- odd. The focal point is the array position that determines the single output+-- element for each application of the stencil. -- -- For those array positions where the neighbourhood extends past the boundaries -- of the source array, a boundary condition determines the contents of the@@ -51,54 +52,59 @@ -- -> Acc (Array ix a) -- source array -- -> Acc (Array ix b) -- destination array ----- To improve performance, the input array(s) are read through the texture--- cache.+-- To improve performance on older (1.x series) devices, the input array(s) are+-- read through the texture cache. ---mkStencil :: forall sh stencil a b. (Stencil sh a stencil, Elt b)- => Int- -> CUFun (stencil -> b)- -> Boundary (CUExp a)- -> Array sh b {- dummy -}- -> CUTranslSkel-mkStencil dim (CULam use0 (CUBody (CUExp env stencil))) boundary _ =- CUTranslSkel "stencil" [cunit|+mkStencil+ :: forall aenv sh stencil a b. (Stencil sh a stencil, Elt b)+ => DeviceProperties+ -> Gamma aenv+ -> CUFun1 aenv (stencil -> b)+ -> Boundary (CUExp aenv a)+ -> [CUTranslSkel aenv (Array sh b)]+mkStencil dev aenv (CUFun1 dce f) boundary+ = return+ $ CUTranslSkel "stencil" [cunit|++ $esc:("#include <accelerate_cuda_extras.h>") $edecl:(cdim "Shape" dim)- $edecls:arrIn0+ $edecls:texIn+ $edecls:texStencil - extern "C"- __global__ void+ extern "C" __global__ void stencil (+ $params:argIn, $params:argOut,- const typename Shape shIn0+ $params:argStencil ) {- const int shapeSize = size(shIn0);- const int gridSize = __umul24(blockDim.x, gridDim.x);- int i;+ const int shapeSize = size(shOut);+ const int gridSize = $exp:(gridSize dev);+ int ix; - for ( i = __umul24(blockDim.x, blockIdx.x) + threadIdx.x- ; i < shapeSize- ; i += gridSize )+ for ( ix = $exp:(threadIdx dev)+ ; ix < shapeSize+ ; ix += gridSize ) {- const typename Shape ix = fromIndex(shIn0, i);- $decls:(getIn0 "ix")- $decls:env- $stms:(setOut "i" stencil)+ const typename Shape sh = fromIndex( shOut, ix );+ $items:(dce xs .=. stencil sh)+ $items:(setOut "ix" .=. f xs) } } |] where- tyOut = eltType (undefined :: b)- stencilIn0 = eltTypeTex (undefined :: a)- (argOut, _, setOut) = setters tyOut- (arrIn0, getIn0) = stencilAccess 0 dim stencilIn0 use0 boundary offsets- --- offsets = map shapeToList p0- p0 = Stencil.offsets (undefined :: Fun aenv (stencil -> b))- (undefined :: OpenAcc aenv (Array sh a))+ dim = expDim (undefined :: Exp aenv sh)+ (texIn, argIn) = environment dev aenv+ (argOut, setOut) = setters "Out" (undefined :: Array sh b)+ ix = cvar "ix"+ sh = cvar "sh"+ (xs,_,_) = locals "x" (undefined :: stencil)+ dx = offsets (undefined :: Fun aenv (stencil -> b)) (undefined :: OpenAcc aenv (Array sh a)) + (texStencil, argStencil, stencil) = stencilAccess True "Stencil" "w" dev dx ix boundary dce + -- Map a binary stencil of an array. The extent of the resulting array is the -- intersection of the extents of the two source arrays. --@@ -112,112 +118,171 @@ -- -> Acc (Array ix b) -- source array #2 -- -> Acc (Array ix c) -- destination array ---mkStencil2 :: forall sh stencil1 stencil0 a b c.- (Stencil sh a stencil1, Stencil sh b stencil0, Elt c)- => Int- -> CUFun (stencil1 -> stencil0 -> c)- -> Boundary (CUExp a)- -> Boundary (CUExp b)- -> Array sh c {- dummy -}- -> CUTranslSkel-mkStencil2 dim (CULam use1 (CULam use0 (CUBody (CUExp env stencil)))) boundary1 boundary0 _ =- CUTranslSkel "stencil2" [cunit|+mkStencil2+ :: forall aenv sh stencil1 stencil2 a b c.+ (Stencil sh a stencil1, Stencil sh b stencil2, Elt c)+ => DeviceProperties+ -> Gamma aenv+ -> CUFun2 aenv (stencil1 -> stencil2 -> c)+ -> Boundary (CUExp aenv a)+ -> Boundary (CUExp aenv b)+ -> [CUTranslSkel aenv (Array sh c)]+mkStencil2 dev aenv (CUFun2 dce1 dce2 f) boundary1 boundary2+ = return+ $ CUTranslSkel "stencil2" [cunit|++ $esc:("#include <accelerate_cuda_extras.h>") $edecl:(cdim "Shape" dim)- $edecls:arrIn0- $edecls:arrIn1+ $edecls:texIn+ $edecls:texS1+ $edecls:texS2 - extern "C"- __global__ void+ extern "C" __global__ void stencil2 (+ $params:argIn, $params:argOut,- const typename Shape shOut,- const typename Shape shIn1,- const typename Shape shIn0+ $params:argS1,+ $params:argS2 ) {- const int shapeSize = size(shOut);- const int gridSize = __umul24(blockDim.x, gridDim.x);- int i;+ const int shapeSize = size(shOut);+ const int gridSize = $exp:(gridSize dev);+ int ix; - for ( i = __umul24(blockDim.x, blockIdx.x) + threadIdx.x- ; i < shapeSize- ; i += gridSize )+ for ( ix = $exp:(threadIdx dev)+ ; ix < shapeSize+ ; ix += gridSize ) {- const typename Shape ix = fromIndex(shOut, i);- $decls:(getIn0 "ix")- $decls:(getIn1 "ix")- $decls:env- $stms:(setOut "i" stencil)+ const typename Shape sh = fromIndex( shOut, ix );++ $items:(dce1 xs .=. stencil1 sh)+ $items:(dce2 ys .=. stencil2 sh)+ $items:(setOut "ix" .=. f xs ys) } } |] where- tyOut = eltType (undefined :: c)- stencilIn0 = eltTypeTex (undefined :: b)- stencilIn1 = eltTypeTex (undefined :: a)- (argOut, _, setOut) = setters tyOut- (arrIn0, getIn0) = stencilAccess 0 dim stencilIn0 use0 boundary0 offsets0- (arrIn1, getIn1) = stencilAccess 1 dim stencilIn1 use1 boundary1 offsets1- --- offsets0 = map shapeToList p0- offsets1 = map shapeToList p1- (p1, p0) = Stencil.offsets2 (undefined :: Fun aenv (stencil1 -> stencil0 -> c))- (undefined :: OpenAcc aenv (Array sh a))- (undefined :: OpenAcc aenv (Array sh b))+ dim = expDim (undefined :: Exp aenv sh)+ (texIn, argIn) = environment dev aenv+ (argOut, setOut) = setters "Out" (undefined :: Array sh c)+ ix = cvar "ix"+ sh = cvar "sh"+ (xs,_,_) = locals "x" (undefined :: stencil1)+ (ys,_,_) = locals "y" (undefined :: stencil2) + (dx1, dx2) = offsets2 (undefined :: Fun aenv (stencil1 -> stencil2 -> c))+ (undefined :: OpenAcc aenv (Array sh a))+ (undefined :: OpenAcc aenv (Array sh b)) ------------------------------------------------------------------------------------------------------------------------------------------------------------------+ (texS1, argS1, stencil1) = stencilAccess False "Stencil1" "w" dev dx1 ix boundary1 dce1+ (texS2, argS2, stencil2) = stencilAccess False "Stencil2" "z" dev dx2 ix boundary2 dce2 ++-- Generate declarations for reading in a stencil pattern surrounding a given+-- focal point. The first parameter determines whether it is safe to use linear+-- indexing at the centroid position. This is true for:+--+-- * stencil1+-- * stencil2 if both input stencil have the same dimensionality+-- stencilAccess- :: Int -- array de Bruijn index- -> Int -- array dimensionality- -> [Type] -- array type (texture memory)- -> [(Int, Type, Exp)] -- the variables used in the scalar expression- -> Boundary (CUExp a) -- how to handle boundary array access- -> [[Int]] -- all stencil index offsets, top left to bottom right- -> ( [Definition] -- texture-reference definitions- , String -> [InitGroup] ) -- array indexing-stencilAccess base dim stencil subs boundary shx =- ( textures- , \ix -> concatMap (get ix) subs )+ :: forall aenv sh e. (Shape sh, Elt e)+ => Bool -- linear indexing at centroid?+ -> Name -- array group name+ -> Name -- secondary group name, for fresh variables+ -> DeviceProperties -- properties of currently executing device+ -> [sh] -- list of offset indices+ -> C.Exp -- linear index of the centroid+ -> Boundary (CUExp aenv e) -- stencil boundary condition+ -> ([C.Exp] -> [(Bool,C.Exp)]) -- dead code elimination flags for this var+ -> ( [C.Definition] -- input arrays as texture references; or+ , [C.Param] -- function arguments+ , (C.Exp -> ([C.BlockItem], [C.Exp])) ) -- read data at a given shape centroid+stencilAccess linear grp grp' dev shx centroid boundary dce+ = (texStencil, argStencil, stencil) where- n = length stencil- sh = "shIn" ++ show base- arr x = "arrIn" ++ shows base "_a" ++ show (x `mod` n)- textures = zipWith cglobal stencil (map arr [n-1, n-2 .. 0])+ stencil ix = flip evalState 0 $ do+ (envs, xs) <- mapAndUnzipM (access ix . shapeToList) shx++ let (envs', xs') = unzip+ $ eliminate+ $ zip envs+ $ unconcat (map length xs)+ $ dce (concat xs)++ return ( concat envs', concat xs' )++ -- Filter unused components of the stencil. Environment bindings are shared+ -- between tuple components of each cursor position, so filter these out+ -- only if all elements of that position are unused. --- offsets :: IArray.Array Int [Int]- offsets = IArray.listArray (0, length shx-1) shx+ unconcat :: [Int] -> [a] -> [[a]]+ unconcat [] _ = []+ unconcat (n:ns) xs = let (h,t) = splitAt n xs in h : unconcat ns t++ eliminate :: [ ([C.BlockItem], [(Bool, C.Exp)]) ] -> [ ([C.BlockItem], [C.Exp]) ]+ eliminate [] = []+ eliminate ((e,v):xs) = (e', x) : eliminate xs+ where+ (flags, x) = unzip v+ e' | or flags = e+ | otherwise = []++ -- Generate the entire stencil, including any local environment bindings --- get ix (i,t,v) = case boundary of- Clamp -> bounded "clamp"- Mirror -> bounded "mirror"- Wrap -> bounded "wrap"- Constant (CUExp _ c) -> inRange c+ access :: C.Exp -> [Int] -> State Int ([C.BlockItem], [C.Exp])+ access ix dx = case boundary of+ Clamp -> bounded "clamp"+ Mirror -> bounded "mirror"+ Wrap -> bounded "wrap"+ Constant (CUExp (_,c)) -> inrange c -- constant value: no environment possible+ where- j = 'j':shows base "_a" ++ show i- k = 'k':shows base "_a" ++ show i- --+ focus = all (==0) dx+ dim = expDim (undefined :: Exp aenv sh)+ cursor+ | all (==0) dx = ix+ | otherwise = ccall "shape"+ $ zipWith (\a b -> [cexp| $exp:a + $int:b |]) (cshape dim ix) (reverse dx)+ bounded f- = [cdecl| const int $id:j = $exp:ix'; |]- : [cdecl| const $ty:t $id:(show v) = $exp:(indexArray t (cvar (arr i)) (cvar j)); |]- : []- where- ix' = case offsets IArray.! div i n of- ks | all (== 0) ks -> [cexp| toIndex( $id:sh, ix ) |]- | otherwise -> [cexp| toIndex( $id:sh, $exp:(ccall f [cvar sh, cursor ks]) ) |]- --- inRange c = case offsets IArray.! div i n of- ks | all (== 0) ks -> let f = indexArray t (cvar (arr i)) (ccall "toIndex" [cvar sh, cvar "ix"])- in [[cdecl| const $ty:t $id:(show v) = $exp:f; |]]- | otherwise -> [cdecl| const typename Shape $id:j = $exp:(cursor ks); |]- : [cdecl| const typename bool $id:k = inRange( $id:sh, $id:j ); |]- : [cdecl| const $ty:t $id:(show v) = $id:k ? $exp:(indexArray t (cvar (arr i)) (ccall "toIndex" [cvar sh, cvar j]))- : $exp:(reverse c !! mod i n); |]- : []- --- cursor [c] = [cexp| $id:ix + $int:c |]- cursor cs = ccall "shape" $ zipWith (\a c -> [cexp| $id:ix . $id:('a':show a) + $int:c |]) [dim-1,dim-2..0] cs+ | focus && linear = return $ ( [], getStencil centroid )+ | otherwise = do+ j <- fresh+ return ( if focus then [C.BlockDecl [cdecl| const int $id:j = toIndex( $id:shIn, $exp:ix ); |]]+ else [C.BlockDecl [cdecl| const int $id:j = toIndex( $id:shIn, $exp:(ccall f [cvar shIn, cursor]) ); |]]+ , getStencil (cvar j) )++ inrange cs+ | focus && linear = return ( [], getStencil centroid )+ | focus = do+ j <- fresh+ return ( [C.BlockDecl [cdecl| const int $id:j = toIndex( $id:shIn, $exp:ix ); |]]+ , getStencil (cvar j) )++ | otherwise = do+ j <- fresh+ i <- fresh+ p <- fresh+ return $ ( [ C.BlockDecl [cdecl| const typename Shape $id:j = $exp:cursor; |]+ , C.BlockDecl [cdecl| const typename bool $id:p = inRange( $id:shIn, $id:j ); |]+ , C.BlockDecl [cdecl| const int $id:i = toIndex( $id:shIn, $id:j ); |] ]+ , zipWith (\a c -> [cexp| $id:p ? $exp:a : $exp:c |]) (getStencil (cvar i)) cs )++ -- Extra parameters for accessing the stencil data. We are doing things a+ -- little out of the ordinary, so don't get this "for free". sadface.+ --+ getStencil ix = zipWith (\t a -> indexArray dev t a ix) (eltType (undefined :: e)) (map cvar stencilIn)+ (shIn, stencilIn) = namesOfArray grp (undefined :: e)+ (texStencil, argStencil)+ | computeCapability dev < Compute 2 0 = let (d,p) = arrayAsTex (undefined :: Array sh e) grp in (d,[p])+ | otherwise = ([], arrayAsArg (undefined :: Array sh e) grp)++ -- Generate a fresh variable name+ --+ fresh :: State Int Name+ fresh = do+ n <- get <* modify (+1)+ return $ grp' ++ show n
Data/Array/Accelerate/CUDA/CodeGen/Type.hs view
@@ -1,6 +1,7 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE QuasiQuotes #-} -- | -- Module : Data.Array.Accelerate.CUDA.CodeGen -- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee@@ -26,9 +27,8 @@ ) where -- friends-import Data.Array.Accelerate.AST import Data.Array.Accelerate.Type-import Data.Array.Accelerate.CUDA.CodeGen.Base+import Data.Array.Accelerate.Trafo import qualified Data.Array.Accelerate.Array.Sugar as Sugar import qualified Data.Array.Accelerate.Analysis.Type as Sugar @@ -36,20 +36,27 @@ import Language.C.Quote.CUDA import qualified Language.C as C +#if !defined(SIZEOF_HSINT) || !defined(SIZEOF_HSCHAR)+import Foreign.Storable+#endif #include "accelerate.h" +typename :: String -> C.Type+typename name = [cty| typename $id:name |]+ -- Surface element types -- --------------------- -accType :: OpenAcc aenv (Sugar.Array dim e) -> [C.Type]-accType = codegenTupleType . Sugar.accType -expType :: OpenExp aenv env t -> [C.Type]-expType = codegenTupleType . Sugar.expType+accType :: DelayedOpenAcc aenv (Sugar.Array dim e) -> [C.Type]+accType = codegenTupleType . Sugar.delayedAccType -segmentsType :: OpenAcc aenv (Sugar.Segments i) -> C.Type+expType :: DelayedOpenExp aenv env t -> [C.Type]+expType = codegenTupleType . Sugar.preExpType Sugar.delayedAccType++segmentsType :: DelayedOpenAcc aenv (Sugar.Segments i) -> C.Type segmentsType seg | [s] <- accType seg = s | otherwise = INTERNAL_ERROR(error) "accType" "non-scalar segment type"@@ -106,11 +113,21 @@ codegenIntegralType (TypeInt _) = typename "Int32" #elif SIZEOF_HSINT == 8 codegenIntegralType (TypeInt _) = typename "Int64"+#else+codegenIntegralType (TypeInt _) = typename+ $ case sizeOf (undefined :: Int) of+ 4 -> "Int32"+ 8 -> "Int64" #endif #if SIZEOF_HSINT == 4 codegenIntegralType (TypeWord _) = typename "Word32" #elif SIZEOF_HSINT == 8 codegenIntegralType (TypeWord _) = typename "Word64"+#else+codegenIntegralType (TypeWord _) = typename+ $ case sizeOf (undefined :: Int) of+ 4 -> "Word32"+ 8 -> "Word64" #endif codegenFloatingType :: FloatingType a -> C.Type@@ -123,6 +140,10 @@ codegenNonNumType (TypeBool _) = typename "Word8" #if SIZEOF_HSCHAR == 4 codegenNonNumType (TypeChar _) = typename "Word32"+#else+codegenNonNumType (TypeChar _) = typename+ $ case sizeOf (undefined :: Char) of+ 4 -> "Word32" #endif codegenNonNumType (TypeCChar _) = [cty|char|] codegenNonNumType (TypeCSChar _) = [cty|signed char|]@@ -132,8 +153,8 @@ -- Texture types -- ------------- -accTypeTex :: OpenAcc aenv (Sugar.Array dim e) -> [C.Type]-accTypeTex = codegenTupleTex . Sugar.accType+accTypeTex :: DelayedOpenAcc aenv (Sugar.Array dim e) -> [C.Type]+accTypeTex = codegenTupleTex . Sugar.delayedAccType -- Implementation@@ -172,11 +193,21 @@ codegenIntegralTex (TypeInt _) = typename "TexInt32" #elif SIZEOF_HSINT == 8 codegenIntegralTex (TypeInt _) = typename "TexInt64"+#else+codegenIntegralTex (TypeInt _) = typename+ $ case sizeOf (undefined :: Int) of+ 4 -> "TexInt32"+ 8 -> "TexInt64" #endif #if SIZEOF_HSINT == 4 codegenIntegralTex (TypeWord _) = typename "TexWord32" #elif SIZEOF_HSINT == 8 codegenIntegralTex (TypeWord _) = typename "TexWord64"+#else+codegenIntegralTex (TypeWord _) = typename+ $ case sizeOf (undefined :: Word) of+ 4 -> "TexWord32"+ 8 -> "TexWord64" #endif @@ -191,6 +222,10 @@ codegenNonNumTex (TypeBool _) = typename "TexWord8" #if SIZEOF_HSCHAR == 4 codegenNonNumTex (TypeChar _) = typename "TexWord32"+#else+codegenNonNumTex (TypeChar _) = typename+ $ case sizeOf (undefined :: Char) of+ 4 -> "TexWord32" #endif codegenNonNumTex (TypeCChar _) = typename "TexCChar" codegenNonNumTex (TypeCSChar _) = typename "TexCSChar"
Data/Array/Accelerate/CUDA/Compile.hs view
@@ -1,4 +1,9 @@-{-# LANGUAGE CPP, GADTs, TupleSections, ScopedTypeVariables #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-} -- | -- Module : Data.Array.Accelerate.CUDA.Compile -- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee@@ -7,216 +12,213 @@ -- -- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au> -- Stability : experimental--- Portability : non-partable (GHC extensions)+-- Portability : non-portable (GHC extensions) -- module Data.Array.Accelerate.CUDA.Compile ( -- * generate and compile kernels to realise a computation- compileAcc, compileAfun1+ compileAcc, compileAfun ) where #include "accelerate.h" -- friends-import Data.Array.Accelerate.Type import Data.Array.Accelerate.Tuple-+import Data.Array.Accelerate.Trafo import Data.Array.Accelerate.CUDA.AST import Data.Array.Accelerate.CUDA.State import Data.Array.Accelerate.CUDA.CodeGen import Data.Array.Accelerate.CUDA.Array.Sugar import Data.Array.Accelerate.CUDA.Analysis.Launch-import Data.Array.Accelerate.CUDA.FullList as FL-import Data.Array.Accelerate.CUDA.Persistent as KT-import qualified Data.Array.Accelerate.CUDA.Debug as D+import Data.Array.Accelerate.CUDA.Foreign ( canExecute, canExecuteExp )+import Data.Array.Accelerate.CUDA.Persistent as KT+import qualified Data.Array.Accelerate.CUDA.FullList as FL+import qualified Data.Array.Accelerate.CUDA.Debug as D -- libraries import Numeric-import Prelude hiding ( exp, catch )-import Control.Applicative hiding ( Const )+import Prelude hiding ( exp, scanl, scanr )+import Control.Applicative hiding ( Const ) import Control.Exception import Control.Monad-import Control.Monad.Trans-import Crypto.Hash.MD5 ( hashlazy )-import Data.Label.PureM-import Data.List+import Control.Monad.Reader ( asks )+import Control.Monad.State ( gets )+import Control.Monad.Trans ( liftIO, MonadIO )+import Control.Concurrent+import Crypto.Hash.MD5 ( hashlazy )+import Data.List ( intercalate ) import Data.Maybe import Data.Monoid import System.Directory-import System.Exit ( ExitCode(..) )+import System.Exit ( ExitCode(..) ) import System.FilePath import System.IO+import System.IO.Error import System.IO.Unsafe+import System.Time import System.Process-import Text.PrettyPrint.Mainland ( ppr, renderCompact, displayLazyText )-import qualified Data.HashSet as Set-import qualified Data.ByteString as B-import qualified Data.Text.Lazy as T-import qualified Data.Text.Lazy.IO as T-import qualified Data.Text.Lazy.Encoding as T-import qualified Foreign.CUDA.Driver as CUDA-import qualified Foreign.CUDA.Analysis as CUDA+import Text.PrettyPrint.Mainland ( ppr, renderCompact, displayLazyText )+import qualified Data.ByteString as B+import qualified Data.Text.Lazy as T+import qualified Data.Text.Lazy.IO as T+import qualified Data.Text.Lazy.Encoding as T+import qualified Control.Concurrent.MSem as Q+import qualified Foreign.CUDA.Driver as CUDA+import qualified Foreign.CUDA.Analysis as CUDA +import GHC.Conc ( getNumProcessors )+ #ifdef VERSION_unix import System.Posix.Process #else import System.Win32.Process #endif -import Paths_accelerate_cuda ( getDataDir )+#ifndef SIZEOF_HSINT+import Foreign.Storable+#endif +import Paths_accelerate_cuda ( getDataDir ) + -- | Initiate code generation, compilation, and data transfer for an array -- expression. The returned array computation is annotated so to be suitable for -- execution in the CUDA environment. This includes: -- -- * list of array variables embedded within scalar expressions+-- -- * kernel object(s) required to executed the kernel ---compileAcc :: Acc a -> CIO (ExecAcc a)-compileAcc acc = prepareAcc acc+compileAcc :: DelayedAcc a -> CIO (ExecAcc a)+compileAcc = prepareOpenAcc +compileAfun :: DelayedAfun f -> CIO (ExecAfun f)+compileAfun = prepareOpenAfun -compileAfun1 :: Afun (a -> b) -> CIO (ExecAfun (a -> b))-compileAfun1 (Alam (Abody b)) = Alam . Abody <$> prepareAcc b-compileAfun1 _ =- error "Hope (noun): something that happens to facts when the world refuses to agree" +prepareOpenAfun :: DelayedOpenAfun aenv f -> CIO (PreOpenAfun ExecOpenAcc aenv f)+prepareOpenAfun (Alam l) = Alam <$> prepareOpenAfun l+prepareOpenAfun (Abody b) = Abody <$> prepareOpenAcc b -prepareAcc :: OpenAcc aenv a -> CIO (ExecOpenAcc aenv a)-prepareAcc rootAcc = traverseAcc rootAcc++prepareOpenAcc :: DelayedOpenAcc aenv a -> CIO (ExecOpenAcc aenv a)+prepareOpenAcc = traverseAcc where- -- Traverse an open array expression in depth-first order+ -- Traverse an open array expression in depth-first order. The top-level+ -- function traverseAcc is intended for manifest arrays that we will+ -- generate CUDA code for. Array valued subterms, which might be manifest or+ -- delayed, are handled separately. -- -- The applicative combinators are used to gloss over that we are passing -- around the AST nodes together with a set of free variable indices that -- are merged at every step. --- traverseAcc :: forall aenv a. OpenAcc aenv a -> CIO (ExecOpenAcc aenv a)- traverseAcc acc@(OpenAcc pacc) = do-- let exec :: (AccBindings aenv, PreOpenAcc ExecOpenAcc aenv a) -> CIO (ExecOpenAcc aenv a)- exec (var, eacc) = do- kernel <- build acc var- return $ ExecAcc (FL.singleton () kernel) var eacc-- node :: (AccBindings aenv, PreOpenAcc ExecOpenAcc aenv a) -> CIO (ExecOpenAcc aenv a)- node (_, eacc) = return $ ExecAcc noKernel mempty eacc-+ traverseAcc :: forall aenv arrs. DelayedOpenAcc aenv arrs -> CIO (ExecOpenAcc aenv arrs)+ traverseAcc Delayed{} = INTERNAL_ERROR(error) "prepareOpenAcc" "unexpected delayed array"+ traverseAcc topAcc@(Manifest pacc) = case pacc of- --- -- Environment manipulations- --+ -- Environment and control flow Avar ix -> node $ pure (Avar ix)-- --- -- Let bindings- --- Alet a b -> node . pure =<< Alet <$> traverseAcc a <*> traverseAcc b- Apply f a -> node . pure =<< Apply <$> compileAfun1 f <*> traverseAcc a+ Alet a b -> node . pure =<< Alet <$> traverseAcc a <*> traverseAcc b+ Apply f a -> node . pure =<< Apply <$> compileAfun f <*> traverseAcc a Acond p t e -> node =<< liftA3 Acond <$> travE p <*> travA t <*> travA e-- --- -- Tuples- -- Atuple tup -> node =<< liftA Atuple <$> travAtup tup Aprj ix tup -> node =<< liftA (Aprj ix) <$> travA tup - --+ -- Foreign+ Aforeign ff afun a -> node =<< foreignA ff afun a+ -- Array injection- --- Use arrs -> use (arrays (undefined::a)) arrs >> node (pure $ Use arrs)- where- use :: ArraysR a' -> a' -> CIO ()- use ArraysRunit () = return ()- use ArraysRarray arr = useArray arr- use (ArraysRpair r1 r2) (a1, a2) = use r1 a1 >> use r2 a2+ Unit e -> node =<< liftA Unit <$> travE e+ Use arrs -> use (arrays (undefined::arrs)) arrs >> node (pure $ Use arrs) - --- -- Computation nodes- --+ -- Index space transforms Reshape s a -> node =<< liftA2 Reshape <$> travE s <*> travA a- Unit e -> node =<< liftA Unit <$> travE e- Generate e f -> exec =<< liftA2 Generate <$> travE e <*> travF f Replicate slix e a -> exec =<< liftA2 (Replicate slix) <$> travE e <*> travA a- Index slix a e -> exec =<< liftA2 (Index slix) <$> travA a <*> travE e+ 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++ -- Producers+ Generate e f -> exec =<< liftA2 Generate <$> travE e <*> travF f Map f a -> 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++ -- 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 (segments s)- Fold1Seg f a s -> exec =<< liftA3 Fold1Seg <$> travF f <*> travA a <*> travA (segments s)- Permute f a g b -> exec =<< liftA4 Permute <$> travF f <*> travA a <*> travF g <*> travA b- Backpermute e f a -> exec =<< liftA3 Backpermute <$> travE e <*> 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 <*> travA a Stencil2 f b1 a1 b2 a2 -> exec =<< liftA3 stencil2 <$> travF f <*> travA a1 <*> travA a2 where stencil2 f' a1' a2' = Stencil2 f' b1 a1' b2 a2' - -- TODO: write helper functions to clean these up- Scanl f e a -> do- ExecAcc (FL _ scan _) var eacc <- exec =<< liftA3 Scanl <$> travF f <*> travE e <*> travA a- add <- build (OpenAcc (Fold1 f mat)) var- return $ ExecAcc (cons () add $ FL.singleton () scan) var eacc-- Scanl' f e a -> do- ExecAcc (FL _ scan _) var eacc <- exec =<< liftA3 Scanl' <$> travF f <*> travE e <*> travA a- add <- build (OpenAcc (Fold1 f mat)) var- return $ ExecAcc (cons () (retag add) $ FL.singleton () scan) var eacc-- Scanl1 f a -> do- ExecAcc (FL _ scan1 _) var eacc <- exec =<< liftA2 Scanl1 <$> travF f <*> travA a- add <- build (OpenAcc (Fold1 f mat)) var- return $ ExecAcc (cons () add $ FL.singleton () scan1) var eacc+ where+ use :: ArraysR a -> a -> CIO ()+ use ArraysRunit () = return ()+ use ArraysRarray arr = useArray arr+ use (ArraysRpair r1 r2) (a1, a2) = use r1 a1 >> use r2 a2 - Scanr f e a -> do- ExecAcc (FL _ scan _) var eacc <- exec =<< liftA3 Scanr <$> travF f <*> travE e <*> travA a- add <- build (OpenAcc (Fold1 f mat)) var- return $ ExecAcc (cons () add $ FL.singleton () scan) var eacc+ exec :: (Free aenv, PreOpenAcc ExecOpenAcc aenv arrs) -> CIO (ExecOpenAcc aenv arrs)+ exec (aenv, eacc) = do+ let gamma = makeEnvMap aenv+ kernel <- build topAcc gamma+ return $! ExecAcc (fullOfList kernel) gamma eacc - Scanr' f e a -> do- ExecAcc (FL _ scan _) var eacc <- exec =<< liftA3 Scanr' <$> travF f <*> travE e <*> travA a- add <- build (OpenAcc (Fold1 f mat)) var- return $ ExecAcc (cons () (retag add) $ FL.singleton () scan) var eacc+ node :: (Free aenv', PreOpenAcc ExecOpenAcc aenv' arrs') -> CIO (ExecOpenAcc aenv' arrs')+ node = fmap snd . wrap - Scanr1 f a -> do- ExecAcc (FL _ scan1 _) var eacc <- exec =<< liftA2 Scanr1 <$> travF f <*> travA a- add <- build (OpenAcc (Fold1 f mat)) var- return $ ExecAcc (cons () add $ FL.singleton () scan1) var eacc+ wrap :: (Free aenv', PreOpenAcc ExecOpenAcc aenv' arrs') -> CIO (Free aenv', ExecOpenAcc aenv' arrs')+ wrap = return . liftA (ExecAcc noKernel mempty) - where- travA :: OpenAcc aenv' a' -> CIO (AccBindings aenv', ExecOpenAcc aenv' a')- travA a = pure <$> traverseAcc a+ travA :: DelayedOpenAcc aenv a -> CIO (Free aenv, ExecOpenAcc aenv a)+ travA acc = case acc of+ Manifest{} -> pure <$> traverseAcc acc+ Delayed{..} -> liftA2 (const EmbedAcc) <$> travF indexD <*> travE extentD - travAtup :: Atuple (OpenAcc aenv') a' -> CIO (AccBindings aenv', Atuple (ExecOpenAcc aenv') a')+ travAtup :: Atuple (DelayedOpenAcc aenv) a -> CIO (Free aenv, Atuple (ExecOpenAcc aenv) a) travAtup NilAtup = return (pure NilAtup) travAtup (SnocAtup t a) = liftA2 SnocAtup <$> travAtup t <*> travA a - travF :: OpenFun env aenv t -> CIO (AccBindings aenv, PreOpenFun ExecOpenAcc env aenv t)+ travF :: DelayedOpenFun env aenv t -> CIO (Free aenv, PreOpenFun ExecOpenAcc env aenv t) travF (Body b) = liftA Body <$> travE b travF (Lam f) = liftA Lam <$> travF f - segments :: forall i. (Elt i, IsIntegral i)- => OpenAcc aenv (Segments i) -> OpenAcc aenv (Segments i)- segments = OpenAcc . Scanl plus (Const (fromElt (0::i)))-- plus :: (Elt i, IsIntegral i) => PreOpenFun OpenAcc () aenv (i -> i -> i)- plus = Lam (Lam (Body (PrimAdd numType- `PrimApp`- Tuple (NilTup `SnocTup` Var (SuccIdx ZeroIdx)- `SnocTup` Var ZeroIdx))))+ noKernel :: FL.FullList () (AccKernel a)+ noKernel = FL.FL () (INTERNAL_ERROR(error) "compile" "no kernel module for this node") FL.Nil - mat :: Elt e => OpenAcc aenv (Array DIM2 e)- mat = OpenAcc $ Use ((), Array (((),0),0) undefined)+ fullOfList :: [a] -> FL.FullList () a+ fullOfList [] = INTERNAL_ERROR(error) "fullList" "empty list"+ fullOfList [x] = FL.singleton () x+ fullOfList (x:xs) = FL.cons () x (fullOfList xs) - noKernel :: FullList () (AccKernel a)- noKernel = FL () (INTERNAL_ERROR(error) "compile" "no kernel module for this node") Nil+ -- If it is a foreign call for the CUDA backend, don't bother compiling+ -- the pure version+ --+ foreignA :: (Arrays a, Arrays r, Foreign f)+ => f a r+ -> DelayedAfun (a -> r)+ -> DelayedOpenAcc aenv a+ -> CIO (Free aenv, PreOpenAcc ExecOpenAcc aenv r)+ foreignA ff afun a = case canExecute ff of+ Nothing -> liftA2 (Aforeign ff) <$> pure <$> compileAfun afun <*> travA a+ Just _ -> liftA (Aforeign ff err) <$> travA a+ where+ err = INTERNAL_ERROR(error) "compile" "Executing pure version of a CUDA foreign function" -- Traverse a scalar expression --- travE :: OpenExp env aenv e- -> CIO (AccBindings aenv, PreOpenExp ExecOpenAcc env aenv e)+ travE :: DelayedOpenExp env aenv e+ -> CIO (Free aenv, PreOpenExp ExecOpenAcc env aenv e) travE exp = case exp of Var ix -> return $ pure (Var ix)@@ -224,32 +226,82 @@ PrimConst c -> return $ pure (PrimConst c) IndexAny -> return $ pure IndexAny 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- 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- PrimApp f e -> liftA (PrimApp f) <$> travE e- IndexScalar a e -> liftA2 IndexScalar <$> travA a <*> travE e- Shape a -> liftA Shape <$> travA a- ShapeSize e -> liftA ShapeSize <$> travE e+ 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+ Iterate n f x -> liftA3 Iterate <$> travE n <*> travE f <*> travE x+-- While p f x -> liftA3 While <$> travE p <*> travE 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+ where travA :: (Shape sh, Elt e)- => OpenAcc aenv (Array sh e) -> CIO (AccBindings aenv, ExecOpenAcc aenv (Array sh e))+ => DelayedOpenAcc aenv (Array sh e)+ -> CIO (Free aenv, ExecOpenAcc aenv (Array sh e)) travA a = do a' <- traverseAcc a return $ (bind a', a') - travT :: Tuple (OpenExp env aenv) t- -> CIO (AccBindings aenv, Tuple (PreOpenExp ExecOpenAcc env aenv) t)+ travT :: Tuple (DelayedOpenExp env aenv) t+ -> CIO (Free aenv, Tuple (PreOpenExp ExecOpenAcc env aenv) t) travT NilTup = return (pure NilTup) travT (SnocTup t e) = liftA2 SnocTup <$> travT t <*> travE e - bind :: (Shape sh, Elt e) => ExecOpenAcc aenv (Array sh e) -> AccBindings aenv- bind (ExecAcc _ _ (Avar ix)) = AccBindings ( Set.singleton (ArrayVar ix) )+ travF :: DelayedOpenFun env aenv t -> CIO (Free aenv, PreOpenFun ExecOpenAcc env aenv t)+ travF (Body b) = liftA Body <$> travE b+ travF (Lam f) = liftA Lam <$> travF f++ foreignE :: (Elt a, Elt b, Foreign f)+ => f a b+ -> DelayedFun () (a -> b)+ -> DelayedOpenExp env aenv a+ -> CIO (Free aenv, PreOpenExp ExecOpenAcc env aenv b)+ foreignE ff f x = case canExecuteExp ff of+ -- If it's a foreign function that we can generate code from, just+ -- leave it alone. As the pure function is closed, the array+ -- environment needs to be replaced with one of the right type.+ --+ Just _ -> liftA2 (Foreign ff) <$> pure <$> snd <$> travF f <*> travE x++ -- If the foreign function is not intended for this backend, this node+ -- needs to be replaced by a pure accelerate node giving the same+ -- result. Due to the lack of an 'apply' node in the scalar language,+ -- this is done by substitution.+ --+ Nothing -> travE (apply f x)+ where+ -- Twiddle the environment variables+ --+ apply :: DelayedFun () (a -> b) -> DelayedOpenExp env aenv a -> DelayedOpenExp env aenv b+ apply (Lam (Body b)) e = Let e $ weakenEA rebuildAcc wAcc $ weakenE wExp b+ apply _ _ = error "This was a triumph."++ -- As the expression we want to weaken is closed with respect to the array+ -- environment, the index manipulation function becomes a dummy argument.+ --+ wAcc :: Idx () t -> Idx aenv t+ wAcc _ = error "I'm making a note here:"++ wExp :: Idx ((),a) t -> Idx (env,a) t+ wExp ZeroIdx = ZeroIdx+ wExp _ = error "HUGE SUCCESS"++ bind :: (Shape sh, Elt e) => ExecOpenAcc aenv (Array sh e) -> Free aenv+ bind (ExecAcc _ _ (Avar ix)) = freevar ix bind _ = INTERNAL_ERROR(error) "bind" "expected array variable" @@ -268,12 +320,18 @@ -- evaluates and blocks on the external compiler only once the compiled object -- is truly needed. ---build :: OpenAcc aenv a -> AccBindings aenv -> CIO (AccKernel a)-build acc fvar = do- dev <- gets deviceProps+build :: DelayedOpenAcc aenv a -> Gamma aenv -> CIO [AccKernel a]+build acc aenv = do+ dev <- asks deviceProperties+ mapM (build1 acc) (codegenAcc dev acc aenv)++build1 :: DelayedOpenAcc aenv a -> CUTranslSkel aenv a -> CIO (AccKernel a)+build1 acc code = do+ dev <- asks deviceProperties table <- gets kernelTable- (entry,key) <- compile table dev acc fvar- let (mdl,fun,occ) = unsafePerformIO $ do+ (entry,key) <- compile table dev code+ let (cta,blocks,smem) = launchConfig acc dev occ+ (mdl,fun,occ) = unsafePerformIO $ do m <- link table key f <- CUDA.getFun m entry l <- CUDA.requires f CUDA.MaxKernelThreadsPerBlock@@ -281,7 +339,7 @@ D.when D.dump_cc (stats entry f o) return (m,f,o) --- return $ Kernel entry mdl fun occ (launchConfig acc dev occ)+ return $ AccKernel entry fun mdl occ cta smem blocks where stats name fn occ = do regs <- CUDA.requires fn CUDA.NumRegs@@ -296,9 +354,10 @@ ++ shows (CUDA.activeWarps occ) " warps in " ++ shows (CUDA.activeThreadBlocks occ) " blocks" --- -- make sure kernel/stats are printed together+ -- make sure kernel/stats are printed together. Use 'intercalate' rather+ -- than 'unlines' to avoid a trailing newline. --- message $ intercalate "\n" [msg1, " ... " ++ msg2]+ message $ intercalate "\n ... " [msg1, msg2] -- Link a compiled binary and update the associated kernel entry in the hash@@ -312,12 +371,17 @@ ctx <- CUDA.get entry <- fromMaybe intErr `fmap` KT.lookup table key case entry of- CompileProcess cufile pid -> do+ CompileProcess cufile done -> do -- Wait for the compiler to finish and load the binary object into the- -- current context+ -- current context. --+ -- A forked thread will fill the MVar once the external compilation+ -- process completes, but only the main thread executes kernels. Hence,+ -- only one thread will ever attempt to take the MVar in order to link+ -- the binary object.+ -- message "waiting for nvcc..."- waitFor pid+ takeMVar done let cubin = replaceExtension cufile ".cubin" bin <- B.readFile cubin mdl <- CUDA.loadData bin@@ -328,11 +392,14 @@ KT.insert table key $! KernelObject bin (FL.singleton ctx mdl) KT.persist cubin key - -- Remove temporary build products+ -- Remove temporary build products.+ -- If compiling kernels with debugging symbols, leave the source files+ -- in place so that they can be referenced by 'cuda-gdb'. --- removeFile cufile- removeDirectory (dropFileName cufile)- `catch` \(_ :: IOError) -> return () -- directory not empty+ D.unless D.debug_cc $ do+ removeFile cufile+ removeDirectory (dropFileName cufile)+ `catchIOError` \_ -> return () -- directory not empty return mdl @@ -351,54 +418,37 @@ -- Generate and compile code for a single open array expression ---compile :: KernelTable- -> CUDA.DeviceProperties- -> OpenAcc aenv a- -> AccBindings aenv- -> CIO (String, KernelKey)-compile table dev acc fvar = do+compile :: KernelTable -> CUDA.DeviceProperties -> CUTranslSkel aenv a -> CIO (String, KernelKey)+compile table dev cunit = do exists <- isJust `fmap` liftIO (KT.lookup table key) unless exists $ do message $ unlines [ show key, T.unpack code ] nvcc <- fromMaybe (error "nvcc: command not found") <$> liftIO (findExecutable "nvcc") (file,hdl) <- openTemporaryFile "dragon.cu" -- rawr! flags <- compileFlags file- (_,_,_,pid) <- liftIO $ do- message $ "execute: " ++ nvcc ++ " " ++ unwords flags- T.hPutStr hdl code `finally` hClose hdl- createProcess (proc nvcc flags) `onException` removeFile file+ done <- liftIO $ do+ T.hPutStr hdl code `finally` hClose hdl+ enqueueProcess nvcc flags `onException` removeFile file --- liftIO $ KT.insert table key (CompileProcess file pid)+ liftIO $ KT.insert table key (CompileProcess file done) -- return (entry, key) where- cunit = codegenAcc dev acc fvar entry = show cunit key = (CUDA.computeCapability dev, hashlazy (T.encodeUtf8 code) ) code = displayLazyText . renderCompact $ ppr cunit --- Wait for the compilation process to finish----waitFor :: ProcessHandle -> IO ()-waitFor pid = do- status <- waitForProcess pid- case status of- ExitSuccess -> return ()- ExitFailure c -> error $ "nvcc terminated abnormally (" ++ show c ++ ")"-- -- Determine the appropriate command line flags to pass to the compiler process. -- This is dependent on the host architecture and device capabilities. -- compileFlags :: FilePath -> CIO [String] compileFlags cufile = do- arch <- CUDA.computeCapability `fmap` gets deviceProps- ddir <- liftIO getDataDir- return $ filter (not . null) $+ CUDA.Compute m n <- CUDA.computeCapability `fmap` asks deviceProperties+ ddir <- liftIO getDataDir+ return $ filter (not . null) $ [ "-I", ddir </> "cubits"- , "--compiler-options", "-fno-strict-aliasing"- , "-arch=sm_" ++ show (round (arch * 10) :: Int)+ , "-arch=sm_" ++ show m ++ show n , "-cubin" , "-o", cufile `replaceExtension` "cubin" , if D.mode D.dump_cc then "" else "--disable-warnings"@@ -410,6 +460,10 @@ machine = "-m32" #elif SIZEOF_HSINT == 8 machine = "-m64"+#else+ machine = case sizeOf (undefined :: Int) of+ 4 -> "-m32"+ 8 -> "-m64" #endif @@ -428,8 +482,101 @@ getProcessID = getProcessId #endif ++-- Worker pool+-- -----------++{-# NOINLINE pool #-}+pool :: Q.MSem Int+pool = unsafePerformIO $ Q.new =<< getNumProcessors++-- Queue a system process to be executed and return an MVar flag that will be+-- filled once the process completes. The task will only be launched once there+-- is a worker available from the pool. This ensures we don't run out of process+-- handles or flood the IO bus, degrading performance.+--+enqueueProcess :: FilePath -> [String] -> IO (MVar ())+enqueueProcess nvcc flags = do+ mvar <- newEmptyMVar+ _ <- forkIO $ do++ -- wait for a worker to become available+ (_, queueT) <- time $ Q.wait pool+ ccBegin <- getTime+ (_,_,_,pid) <- createProcess (proc nvcc flags)++ -- asynchronously notify the queue when the compiler has completed+ _ <- forkIO $ do++ -- Wait for the process to complete+ --+ waitFor pid+ ccEnd <- getTime++ let ccT = diffTime ccBegin ccEnd+ msg2 = nvcc ++ " " ++ unwords flags+ msg1 = "queue: " ++ D.showFFloatSIBase (Just 3) 1000 queueT "s, "+ ++ "execute: " ++ D.showFFloatSIBase (Just 3) 1000 ccT "s"++ message $ intercalate "\n ... " [msg1, msg2]++ -- If there was an error (compilation failed) then this spot in the queue+ -- is never released and the MVar never signalled that compilation is+ -- done. This means you'll get a "blocked indefinitely on MVar" error, but+ -- since the compiler failed in the first places that is somewhat moot.+ --+ Q.signal pool+ putMVar mvar ()++ return ()+ --+ return mvar+++-- Wait for a (compilation) process to finish+--+waitFor :: ProcessHandle -> IO ()+waitFor pid = do+ status <- waitForProcess pid+ case status of+ ExitSuccess -> return ()+ ExitFailure c -> error $ "nvcc terminated abnormally (" ++ show c ++ ")"++ -- Debug -- -----++-- Get the current wall clock time in picoseconds since the epoch+--+{-# INLINE getTime #-}+getTime :: IO Integer+#ifdef ACCELERATE_DEBUG+getTime = do+ TOD sec pico <- getClockTime+ return $! pico + sec * 1000000000000+#else+getTime = return 0+#endif++-- Return the difference between the first and second (later) time in seconds+--+{-# INLINE diffTime #-}+diffTime :: Integer -> Integer -> Double+diffTime t1 t2 = fromIntegral (t2 - t1) * 1E-12++-- Return the number of seconds of wall-clock time it took to execute the given+-- action. Makes sure to `deepseq` or otherwise fully evaluate the action before+-- returning from the task, otherwise there is a good chance you'll just pass a+-- suspension out and the elapsed time will be zero.+--+time :: IO a -> IO (a, Double)+{-# NOINLINE time #-}+time p = do+ start <- getTime+ res <- p+ end <- getTime+ return $ (res, diffTime start end)+ {-# INLINE message #-} message :: MonadIO m => String -> m ()
+ Data/Array/Accelerate/CUDA/Context.hs view
@@ -0,0 +1,142 @@+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+-- |+-- Module : Data.Array.Accelerate.CUDA.Context+-- Copyright : [2013] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--+-- This module defines the execution context of an Accelerate computation in the+-- CUDA backend+--++module Data.Array.Accelerate.CUDA.Context (++ -- An execution context+ Context(..), create, push, destroy,+ keepAlive,++) where++-- friends+import Data.Array.Accelerate.CUDA.Debug ( message, verbose, dump_gc, showFFloatSIBase )+import Data.Array.Accelerate.CUDA.Analysis.Device++-- system+import Data.Function ( on )+import Control.Exception ( bracket_ )+import Control.Concurrent ( forkIO, threadDelay )+import Control.Monad ( when )+import GHC.Exts ( Ptr(..), mkWeak# )+import GHC.Base ( IO(..) )+import GHC.Weak ( Weak(..) )+import Text.PrettyPrint+import qualified Foreign.CUDA.Driver as CUDA hiding ( device )+import qualified Foreign.CUDA.Driver.Context as CUDA+++-- | The execution context+--+data Context = Context {+ deviceProperties :: {-# UNPACK #-} !CUDA.DeviceProperties, -- information on hardware resources+ deviceContext :: {-# UNPACK #-} !CUDA.Context, -- device execution context+ weakContext :: {-# UNPACK #-} !(Weak CUDA.Context) -- weak pointer to the context (for memory management)+ }++instance Eq Context where+ (==) = (==) `on` deviceContext+++-- | Create a new CUDA context associated with the calling thread+--+create :: CUDA.Device -> [CUDA.ContextFlag] -> IO Context+create dev flags = do+ ctx <- CUDA.create dev flags >> CUDA.pop >>= keepAlive+ prp <- CUDA.props dev+ weak <- mkWeakContext ctx $ do+ message dump_gc $ "gc: finalise context #" ++ show (CUDA.useContext ctx)+ CUDA.destroy ctx+ message dump_gc $ "gc: initialise context #" ++ show (CUDA.useContext ctx)++ -- Generated code does not take particular advantage of shared memory, so+ -- for devices that support it use those banks as an L1 cache instead.+ --+ -- TODO: Perhaps make this a command line switch: -fprefer-[l1,shared]+ -- TODO: Make the occupancy calculator aware of adjustable shared memory+ --+ when (CUDA.computeCapability prp >= CUDA.Compute 2 0)+ $ bracket_ (CUDA.push ctx) CUDA.pop (CUDA.setCacheConfig CUDA.PreferL1)++ message verbose (deviceInfo dev prp)+ return $! Context prp ctx weak+++-- | Destroy the specified context. This will fail if the context is more than+-- single attachment.+--+{-# INLINE destroy #-}+destroy :: Context -> IO ()+destroy = CUDA.destroy . deviceContext++-- | Push the given context onto the CPU's thread stack of current contexts. The+-- context must be floating (via 'pop'), i.e. not attached to any thread.+--+{-# INLINE push #-}+push :: Context -> IO ()+push = CUDA.push . deviceContext+++-- Make a weak pointer to a CUDA context. We need to be careful to put the+-- finaliser on the underlying pointer, rather than the box around it as+-- 'mkWeak' will do, because unpacking the context will cause the finaliser to+-- fire prematurely.+--+mkWeakContext :: CUDA.Context -> IO () -> IO (Weak CUDA.Context)+mkWeakContext c@(CUDA.Context (Ptr c#)) f = IO $ \s ->+ case mkWeak# c# c f s of (# s', w #) -> (# s', Weak w #)+++-- Make sure the GC knows that we want to keep this thing alive past the end of+-- 'evalCUDA'.+--+-- We may want to introduce some way to actually shut this down if, for example,+-- the object has not been accessed in a while, and so let it be collected.+--+-- Broken in ghci-7.6.1 Mac OS X due to bug #7299.+--+keepAlive :: a -> IO a+keepAlive x = forkIO (caffeine x) >> return x+ where+ caffeine hit = do threadDelay (5 * 1000 * 1000) -- microseconds = 5 seconds+ caffeine hit+++-- Debugging+-- ---------++-- Nicely format a summary of the selected CUDA device, example:+--+-- Device 0: GeForce 9600M GT (compute capability 1.1)+-- 4 multiprocessors @ 1.25GHz (32 cores), 512MB global memory+--+deviceInfo :: CUDA.Device -> CUDA.DeviceProperties -> String+deviceInfo dev prp = render $ reset <>+ devID <> colon <+> vcat [ name <+> parens compute+ , processors <+> at <+> text clock <+> parens cores <> comma <+> memory+ ]+ where+ name = text (CUDA.deviceName prp)+ compute = text "compute capatability" <+> text (show $ CUDA.computeCapability prp)+ devID = text "Device" <+> int (fromIntegral $ CUDA.useDevice dev) -- hax+ processors = int (CUDA.multiProcessorCount prp) <+> text "multiprocessors"+ cores = int (CUDA.multiProcessorCount prp * coresPerMultiProcessor prp) <+> text "cores"+ memory = text mem <+> text "global memory"+ --+ clock = showFFloatSIBase (Just 2) 1000 (fromIntegral $ CUDA.clockRate prp * 1000 :: Double) "Hz"+ mem = showFFloatSIBase (Just 0) 1024 (fromIntegral $ CUDA.totalGlobalMem prp :: Double) "B"+ at = char '@'+ reset = zeroWidthText "\r"+
Data/Array/Accelerate/CUDA/Debug.hs view
@@ -1,4 +1,6 @@-{-# LANGUAGE CPP, TemplateHaskell, TypeOperators #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeOperators #-} {-# OPTIONS -fno-warn-unused-imports #-} {-# OPTIONS -fno-warn-unused-binds #-} -- |@@ -9,7 +11,7 @@ -- -- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au> -- Stability : experimental--- Portability : non-partable (GHC extensions)+-- Portability : non-portable (GHC extensions) -- -- Hijack some command line arguments to pass runtime debugging options. This -- might cause problems for users of the library...@@ -19,7 +21,7 @@ showFFloatSIBase, - message, event, when, mode,+ message, trace, event, when, unless, mode, verbose, flush_cache, dump_gc, dump_cc, debug_cc, dump_exec, @@ -67,35 +69,41 @@ data Flags = Flags {- -- phase control+ -- debugging _dump_gc :: !Bool -- garbage collection & memory management , _dump_cc :: !Bool -- compilation & linking , _debug_cc :: !Bool -- compile device code with debug symbols , _dump_exec :: !Bool -- kernel execution-- -- general options , _verbose :: !Bool -- additional status messages++ -- general options / functionality , _flush_cache :: !Bool -- delete the persistent cache directory+ , _fast_math :: !Bool -- use faster, less accurate maths library operations } $(mkLabels [''Flags]) -flags :: [OptDescr (Flags -> Flags)]-flags =- [ Option [] ["ddump-gc"] (NoArg (set dump_gc True)) "print device memory management trace"+allFlags :: [OptDescr (Flags -> Flags)]+allFlags =+ [+ -- debugging+ Option [] ["ddump-gc"] (NoArg (set dump_gc True)) "print device memory management trace" , Option [] ["ddump-cc"] (NoArg (set dump_cc True)) "print generated code and compilation information" , Option [] ["ddebug-cc"] (NoArg (set debug_cc True)) "generate debug information for device code" , Option [] ["ddump-exec"] (NoArg (set dump_exec True)) "print kernel execution trace" , Option [] ["dverbose"] (NoArg (set verbose True)) "print additional information"++ -- functionality / optimisation , Option [] ["fflush-cache"] (NoArg (set flush_cache True)) "delete the persistent cache directory"+ , Option [] ["ffast-math"] (NoArg (set fast_math True)) "use faster, less accurate maths library operations" ] initialise :: IO Flags initialise = parse `fmap` getArgs where- defaults = Flags False False False False False False+ defaults = Flags False False False False False False False parse = foldl parse1 defaults- parse1 opts x = case filter (\(Option _ [f] _ _) -> x `isPrefixOf` ('-':f)) flags of+ parse1 opts x = case filter (\(Option _ [f] _ _) -> x `isPrefixOf` ('-':f)) allFlags of [Option _ _ (NoArg go) _] -> go opts _ -> opts -- not specified, or ambiguous @@ -133,6 +141,15 @@ event _ _ = return () #endif +{-# INLINE trace #-}+trace :: (Flags :-> Bool) -> String -> a -> a+#ifdef ACCELERATE_DEBUG+trace f str next = unsafePerformIO (message f str) `seq` next+#else+trace _ _ next = next+#endif++ {-# INLINE when #-} when :: MonadIO m => (Flags :-> Bool) -> m () -> m () #ifdef ACCELERATE_DEBUG@@ -141,5 +158,15 @@ | otherwise = return () #else when _ _ = return ()+#endif++{-# INLINE unless #-}+unless :: MonadIO m => (Flags :-> Bool) -> m () -> m ()+#ifdef ACCELERATE_DEBUG+unless f action+ | mode f = return ()+ | otherwise = action+#else+unless _ action = action #endif
Data/Array/Accelerate/CUDA/Execute.hs view
@@ -3,946 +3,667 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE IncoherentInstances #-}-{-# LANGUAGE OverlappingInstances #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE UndecidableInstances #-}-{-# OPTIONS -fno-warn-orphans #-}--- |--- Module : Data.Array.Accelerate.CUDA.Execute--- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee--- [2009..2012] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell--- License : BSD3------ Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>--- Stability : experimental--- Portability : non-partable (GHC extensions)-----module Data.Array.Accelerate.CUDA.Execute (-- -- * Execute a computation under a CUDA environment- executeAcc, executeAfun1--) where----- friends-import Data.Array.Accelerate.Type-import Data.Array.Accelerate.Tuple-import Data.Array.Accelerate.Array.Representation hiding (Shape, sliceIndex)-import qualified Data.Array.Accelerate.Interpreter as I-import qualified Data.Array.Accelerate.Array.Data as AD-import qualified Data.Array.Accelerate.Array.Representation as R--import Data.Array.Accelerate.CUDA.AST-import Data.Array.Accelerate.CUDA.State-import Data.Array.Accelerate.CUDA.FullList ( FullList(..), List(..) )-import Data.Array.Accelerate.CUDA.Array.Data-import Data.Array.Accelerate.CUDA.Array.Sugar hiding- (dim, size, index, shapeToList, sliceIndex)-import qualified Data.Array.Accelerate.CUDA.Array.Sugar as Sugar-import qualified Data.Array.Accelerate.CUDA.Debug as D ( message, dump_exec )----- libraries-import Prelude hiding ( sum, exp )-import Control.Applicative hiding ( Const )-import Control.Monad-import Control.Monad.Trans-import System.IO.Unsafe-import qualified Data.HashSet as Set--import Foreign ( Ptr, Storable )-import qualified Foreign as F-import qualified Foreign.CUDA.Driver as CUDA--#include "accelerate.h"----- Array expression evaluation--- ------------------------------- Computations are evaluated by traversing the AST bottom-up, and for each node--- distinguishing between three cases:------ 1. If it is a Use node, return a reference to the device memory holding the--- array data------ 2. If it is a non-skeleton node, such as a let-binding or shape conversion,--- this is executed directly by updating the environment or similar------ 3. If it is a skeleton node, the associated binary object is retrieved,--- memory allocated for the result, and the kernel(s) that implement the--- skeleton are invoked------- Evaluate a closed array expression----executeAcc :: Arrays a => ExecAcc a -> CIO a-executeAcc acc = executeOpenAcc acc Empty---- Evaluate an expression with free array variables----executeAfun1 :: forall a b. (Arrays a, Arrays b) => ExecAfun (a -> b) -> a -> CIO b-executeAfun1 (Alam (Abody f)) arrs = do- applyArraysR useArray (arrays (undefined::a)) (fromArr arrs)- executeOpenAcc f (Empty `Push` arrs)--executeAfun1 _ _ =- error "the sword comes out after you swallow it, right?"----- Evaluate an open array expression----executeOpenAcc :: ExecOpenAcc aenv a -> Val aenv -> CIO a-executeOpenAcc (ExecAcc kernelList@(FL _ kernel _) bindings acc) aenv =- case acc of- --- -- (1) Array introduction- --- Use arr -> return (toArr arr)-- --- -- (2) Environment manipulation- --- Avar ix -> return (prj ix aenv)-- Alet a b -> do- a0 <- executeOpenAcc a aenv- executeOpenAcc b (aenv `Push` a0)-- Atuple tup -> toTuple <$> executeAtuple tup aenv-- Aprj ix tup -> do- arrs <- executeOpenAcc tup aenv- return $! executeAprj ix (fromTuple arrs)-- Apply (Alam (Abody f)) a -> do- a0 <- executeOpenAcc a aenv- executeOpenAcc f (Empty `Push` a0)- Apply _ _ -> error "Awww... the sky is crying"-- Acond p t e -> do- cond <- executeExp p aenv- if cond then executeOpenAcc t aenv- else executeOpenAcc e aenv-- Reshape e a -> do- ix <- executeExp e aenv- a0 <- executeOpenAcc a aenv- reshapeOp ix a0-- Unit e ->- unitOp =<< executeExp e aenv-- --- -- (3) Array computations- --- Generate e _ ->- generateOp kernel bindings aenv =<< executeExp e aenv-- Replicate sliceIndex e a -> do- slix <- executeExp e aenv- a0 <- executeOpenAcc a aenv- replicateOp kernel bindings aenv sliceIndex slix a0-- Index sliceIndex a e -> do- slix <- executeExp e aenv- a0 <- executeOpenAcc a aenv- indexOp kernel bindings aenv sliceIndex a0 slix-- Map _ a -> do- a0 <- executeOpenAcc a aenv- mapOp kernel bindings aenv a0-- ZipWith _ a b -> do- a1 <- executeOpenAcc a aenv- a0 <- executeOpenAcc b aenv- zipWithOp kernel bindings aenv a1 a0-- Fold _ _ a -> do- a0 <- executeOpenAcc a aenv- foldOp kernel bindings aenv a0-- Fold1 _ a -> do- a0 <- executeOpenAcc a aenv- fold1Op kernel bindings aenv a0-- FoldSeg _ _ a s -> do- a0 <- executeOpenAcc a aenv- s0 <- executeOpenAcc s aenv- foldSegOp kernel bindings aenv a0 s0-- Fold1Seg _ a s -> do- a0 <- executeOpenAcc a aenv- s0 <- executeOpenAcc s aenv- fold1SegOp kernel bindings aenv a0 s0-- Scanl _ _ a -> do- a0 <- executeOpenAcc a aenv- scanOp L kernelList bindings aenv a0-- Scanl' _ _ a -> do- a0 <- executeOpenAcc a aenv- scan'Op kernelList bindings aenv a0-- Scanl1 _ a -> do- a0 <- executeOpenAcc a aenv- scan1Op kernelList bindings aenv a0-- Scanr _ _ a -> do- a0 <- executeOpenAcc a aenv- scanOp R kernelList bindings aenv a0-- Scanr' _ _ a -> do- a0 <- executeOpenAcc a aenv- scan'Op kernelList bindings aenv a0-- Scanr1 _ a -> do- a0 <- executeOpenAcc a aenv- scan1Op kernelList bindings aenv a0-- Permute _ a _ b -> do- a0 <- executeOpenAcc a aenv- a1 <- executeOpenAcc b aenv- permuteOp kernel bindings aenv a0 a1-- Backpermute e _ a -> do- sh <- executeExp e aenv- a0 <- executeOpenAcc a aenv- backpermuteOp kernel bindings aenv sh a0-- Stencil _ _ a -> do- a0 <- executeOpenAcc a aenv- stencilOp kernel bindings aenv a0-- Stencil2 _ _ a _ b -> do- a1 <- executeOpenAcc a aenv- a0 <- executeOpenAcc b aenv- stencil2Op kernel bindings aenv a1 a0---- Tuples evaluation----executeAtuple :: Atuple (ExecOpenAcc aenv) t -> Val aenv -> CIO t-executeAtuple NilAtup _ = return ()-executeAtuple (SnocAtup t a) aenv = (,) <$> executeAtuple t aenv- <*> executeOpenAcc a aenv--executeAprj :: TupleIdx arrs a -> arrs -> a-executeAprj ZeroTupIdx (_, a) = a-executeAprj (SuccTupIdx ix) (t, _) = executeAprj ix t----- Implementation of primitive array operations--- ----------------------------------------------reshapeOp- :: Shape dim- => dim- -> Array dim' e- -> CIO (Array dim e)-reshapeOp newShape (Array oldShape adata)- = BOUNDS_CHECK(check) "reshape" "shape mismatch" (Sugar.size newShape == size oldShape)- $ return $ Array (fromElt newShape) adata---unitOp- :: Elt e- => e- -> CIO (Scalar e)-unitOp v = newArray Z (const v)---generateOp- :: (Shape dim, Elt e)- => AccKernel (Array dim e)- -> AccBindings aenv- -> Val aenv- -> dim- -> CIO (Array dim e)-generateOp kernel bindings aenv sh = do- res@(Array _ out) <- allocateArray sh- execute kernel bindings aenv (Sugar.size sh)- (((), out)- , sh)- return res---replicateOp- :: forall aenv e dim sl co slix. (Shape dim, Elt slix)- => AccKernel (Array dim e)- -> AccBindings aenv- -> Val aenv- -> SliceIndex (EltRepr slix) (EltRepr sl) co (EltRepr dim)- -> slix- -> Array sl e- -> CIO (Array dim e)-replicateOp kernel bindings aenv sliceIndex slix (Array sh0 in0) = do- let sh = toElt $ extend sliceIndex (fromElt slix) sh0- sl = toElt sh0 :: sl- res@(Array _ out) <- allocateArray sh- execute kernel bindings aenv (Sugar.size sh)- (((((), out)- , in0)- , sl)- , sh)- return res- where- extend :: SliceIndex slix' sl' co' dim' -> slix' -> sl' -> dim'- extend (SliceNil) () () = ()- extend (SliceAll sliceIdx) (slx,()) (sl,sz) = (extend sliceIdx slx sl, sz)- extend (SliceFixed sliceIdx) (slx,sz) sl = (extend sliceIdx slx sl, sz)---indexOp- :: forall sl co slix aenv dim e. (Shape sl, Elt slix)- => AccKernel (Array sl e)- -> AccBindings aenv- -> Val aenv- -> SliceIndex (EltRepr slix) (EltRepr sl) co (EltRepr dim)- -> Array dim e- -> slix- -> CIO (Array sl e)-indexOp kernel bindings aenv sliceIndex (Array sh0 in0) slix = do- let sz = toElt sh0 :: dim- sh = toElt $ restrict sliceIndex (fromElt slix) sh0 :: sl- sl = Sugar.listToShape $ convertSlix sliceIndex (fromElt slix) :: sl- res@(Array _ out) <- allocateArray sh- execute kernel bindings aenv (Sugar.size sh)- ((((((), out)- , in0)- , sh)- , sl)- , sz)- return res- where- restrict :: SliceIndex slix' sl' co' dim' -> slix' -> dim' -> sl'- restrict (SliceNil) () () = ()- restrict (SliceAll sliceIdx) (slx,()) (sh,sz) = (restrict sliceIdx slx sh, sz)- restrict (SliceFixed sliceIdx) (slx,i) (sh,sz)- = BOUNDS_CHECK(checkIndex) "slice" i sz $ restrict sliceIdx slx sh- --- convertSlix :: SliceIndex slix' sl' co' dim' -> slix' -> [Int]- convertSlix (SliceNil) () = []- convertSlix (SliceAll sliceIdx) (s,()) = convertSlix sliceIdx s- convertSlix (SliceFixed sliceIdx) (s,i) = i : convertSlix sliceIdx s---mapOp- :: Elt e- => AccKernel (Array dim e)- -> AccBindings aenv- -> Val aenv- -> Array dim e'- -> CIO (Array dim e)-mapOp kernel bindings aenv (Array sh0 in0) = do- res@(Array _ out) <- allocateArray (toElt sh0)- execute kernel bindings aenv (size sh0)- ((((), out)- , in0)- , convertIx (size sh0))- return res--zipWithOp- :: forall aenv dim a b c. Elt c- => AccKernel (Array dim c)- -> AccBindings aenv- -> Val aenv- -> Array dim a- -> Array dim b- -> CIO (Array dim c)-zipWithOp kernel bindings aenv (Array sh1 in1) (Array sh0 in0) = do- res@(Array sh out) <- allocateArray $ toElt (sh1 `intersect` sh0)- execute kernel bindings aenv (size sh)- (((((((), out)- , in1)- , in0)- , toElt sh :: dim)- , toElt sh1 :: dim)- , toElt sh0 :: dim)- return res--foldOp, fold1Op- :: forall dim e aenv. Shape dim- => AccKernel (Array dim e)- -> AccBindings aenv- -> Val aenv- -> Array (dim:.Int) e- -> CIO (Array dim e)-fold1Op kernel bindings aenv in0@(Array (_,sz) _)- = BOUNDS_CHECK(check) "fold1" "empty array" (sz > 0)- $ foldOp kernel bindings aenv in0--foldOp kernel bindings aenv (Array sh0 in0)- -- A recursive multi-block reduction when collapsing to a single value- --- | dim sh0 == 1 = do- let numElements = size sh0- (_,numBlocks,_) = configure kernel (size sh0)- res@(Array _ out) <- allocateArray (toElt (fst sh0,numBlocks)) :: CIO (Array (dim:.Int) e)- execute kernel bindings aenv numElements- ((((), out)- , in0)- , convertIx numElements)- if numBlocks > 1 then foldOp kernel bindings aenv res- else return (Array (fst sh0) out)- --- -- Reduction over the innermost dimension of an array (single pass operation)- --- | otherwise = do- let (sh, sz) = sh0- interval_size = sz- num_intervals = size sh- num_elements = size sh0- res@(Array _ out) <- allocateArray $ toElt sh- execute kernel bindings aenv (num_intervals `max` 1)- ((((((), out)- , in0)- , convertIx interval_size)- , convertIx num_intervals)- , convertIx num_elements)- return res--foldSegOp, fold1SegOp- :: forall aenv dim e i. Shape dim- => AccKernel (Array (dim:.Int) e)- -> AccBindings aenv- -> Val aenv- -> Array (dim:.Int) e- -> Segments i- -> CIO (Array (dim:.Int) e)-fold1SegOp kernel bindings aenv in0 seg =- foldSegOp kernel bindings aenv in0 seg--foldSegOp kernel bindings aenv (Array sh0 in0) (Array shs seg) = do- res@(Array sh out) <- allocateArray $ toElt (fst sh0, size shs-1)- --- message $ "foldSeg: shOut = (" ++ showShape (toElt sh :: dim :. Int) ++ ")"- ++ ", shIn0 = (" ++ showShape (toElt sh0 :: dim :. Int) ++ ")"- execute kernel bindings aenv (size sh)- ((((((), out)- , in0)- , seg)- , toElt sh :: dim :. Int)- , toElt sh0 :: dim :. Int)- return res---data ScanDirection = L | R--scanOp- :: forall aenv e. Elt e- => ScanDirection- -> FullList () (AccKernel (Vector e))- -> AccBindings aenv- -> Val aenv- -> Vector e- -> CIO (Vector e)-scanOp dir (FL _ kfold1' (Cons _ kscan Nil)) bindings aenv (Array sh0 in0) = do- let (_,num_intervals,_) = configure kscan num_elements- a_out@(Array _ out) <- allocateArray (Z :. num_elements + 1)- (Array _ blk) <- allocateArray (Z :. num_intervals) :: CIO (Vector e)- d_out <- devicePtrsOfArrayData out- --- -- depending on whether we are a left or right scan, we need to manipulate the- -- pointers that specify the final element and main scan body- --- let interval_size = (num_elements + num_intervals - 1) `div` num_intervals- body = marshalDevicePtrs out d_body- sum = marshalDevicePtrs out d_sum- (d_body, d_sum) =- case dir of- L -> (d_out, advancePtrsOfArrayData out num_elements d_out)- R -> (advancePtrsOfArrayData out 1 d_out, d_out)- --- -- If the array is sized such that there is only a single interval, the first- -- phase of calculating a per-interval carry-in value can be skipped- --- when (num_intervals > 1) $ do- -- Compute the interval sum. Since we use associative operations, this can- -- be done as a reduction instead of requiring a full left-/right-scan.- message $ "scan phase 1: interval_size = " ++ shows interval_size- ", num_intervals = " ++ shows num_intervals- ", num_elements = " ++ show num_elements- execute kfold1 bindings aenv num_elements- ((((((), blk)- , in0)- , convertIx interval_size)- , convertIx num_intervals)- , convertIx num_elements)-- --- -- Inclusive scan of the per-interval results to compute each segment's- -- carry-in value.- execute kscan bindings aenv 1- (((((((), blk)- , sum)- , blk)- , blk) -- not used, just need the right number of arguments- , convertIx num_intervals)- , convertIx num_intervals)-- --- -- Prefix-sum of the input array, using interval carry-in values.- message $ "scan phase 2: interval_size = " ++ shows interval_size- ", num_elements = " ++ show num_elements- execute kscan bindings aenv num_elements- (((((((), body)- , sum)- , in0)- , blk)- , convertIx interval_size)- , convertIx num_elements)- return a_out- where- num_elements = size sh0- kfold1 = retag kfold1' :: AccKernel (Vector e)--- kscan1 = retag kscan1' :: AccKernel (Vector e)--scanOp _ _ _ _ _ = error "I'll just pretend to hug you until you get here."---scan'Op- :: forall aenv e. Elt e- => FullList () (AccKernel (Vector e, Scalar e))- -> AccBindings aenv- -> Val aenv- -> Vector e- -> CIO (Vector e, Scalar e)-scan'Op (FL _ kfold1' (Cons _ kscan Nil)) bindings aenv (Array sh0 in0) = do- let (_,num_intervals,_) = configure kscan num_elements- (Array _ blk) <- allocateArray (Z :. num_intervals) :: CIO (Vector e)- a_out@(Array _ out) <- allocateArray (Z :. num_elements)- a_sum@(Array _ sum) <- allocateArray Z- let interval_size = (num_elements + num_intervals - 1) `div` num_intervals- --- -- see comments in 'scanOp'- when (num_intervals > 1) $ do- message $ "scan phase 1: interval_size = " ++ shows interval_size- ", num_intervals = " ++ shows num_intervals- ", num_elements = " ++ show num_elements- execute kfold1 bindings aenv num_elements- ((((((), blk)- , in0)- , convertIx interval_size)- , convertIx num_intervals)- , convertIx num_elements)- --- execute kscan bindings aenv 1- (((((((), blk)- , sum)- , blk)- , blk) -- not used- , convertIx num_intervals)- , convertIx num_intervals)- --- message $ "scan phase 2: interval_size = " ++ shows interval_size- ", num_elements = " ++ show num_elements- execute kscan bindings aenv num_elements- (((((((), out)- , sum)- , in0)- , blk)- , convertIx interval_size)- , convertIx num_elements)- return (a_out, a_sum)- where- num_elements = size sh0- kfold1 = retag kfold1' :: AccKernel (Vector e)--scan'Op _ _ _ _ = error "If I promise not to kill you, can I have a hug?"---scan1Op- :: forall aenv e. Elt e- => FullList () (AccKernel (Vector e))- -> AccBindings aenv- -> Val aenv- -> Vector e- -> CIO (Vector e)-scan1Op (FL _ kfold1' (Cons _ kscan1 Nil)) bindings aenv (Array sh0 in0) = do- let (_,num_intervals,_) = configure kscan1 num_elements- (Array _ sum) <- allocateArray Z :: CIO (Scalar e)- (Array _ blk) <- allocateArray (Z :. num_intervals) :: CIO (Vector e)- a_out@(Array _ out) <- allocateArray (Z :. num_elements)- let interval_size = (num_elements + num_intervals - 1) `div` num_intervals- --- -- see comments in 'scanOp'- when (num_intervals > 1) $ do- message $ "scan phase 1: interval_size = " ++ shows interval_size- ", num_intervals = " ++ shows num_intervals- ", num_elements = " ++ show num_elements- execute kfold1 bindings aenv num_elements- ((((((), blk)- , in0)- , convertIx interval_size)- , convertIx num_intervals)- , convertIx num_elements)- --- execute kscan1 bindings aenv 1- (((((((), blk)- , sum)- , blk)- , blk) -- not used- , convertIx num_intervals)- , convertIx num_intervals)- --- message $ "scan phase 2: interval_size = " ++ shows interval_size- ", num_elements = " ++ show num_elements- execute kscan1 bindings aenv num_elements- (((((((), out)- , sum)- , in0)- , blk)- , convertIx interval_size)- , convertIx num_elements)- return a_out- where- num_elements = size sh0- kfold1 = retag kfold1' :: AccKernel (Vector e)--scan1Op _ _ _ _ = error "If you get wet, you'll get sick."---permuteOp- :: forall aenv dim dim' e. Elt e- => AccKernel (Array dim' e)- -> AccBindings aenv- -> Val aenv- -> Array dim' e -- default values- -> Array dim e -- permuted array- -> CIO (Array dim' e)-permuteOp kernel bindings aenv in0@(Array sh0 _) (Array sh1 in1) = do- res@(Array _ out) <- allocateArray (toElt sh0)- copyArray in0 res- execute kernel bindings aenv (size sh0)- (((((), out)- , in1)- , toElt sh0 :: dim')- , toElt sh1 :: dim)- return res--backpermuteOp- :: forall aenv dim dim' e. (Shape dim', Elt e)- => AccKernel (Array dim' e)- -> AccBindings aenv- -> Val aenv- -> dim'- -> Array dim e- -> CIO (Array dim' e)-backpermuteOp kernel bindings aenv dim' (Array sh0 in0) = do- res@(Array sh out) <- allocateArray dim'- execute kernel bindings aenv (size sh)- (((((), out)- , in0)- , toElt sh :: dim')- , toElt sh0 :: dim)- return res--stencilOp- :: forall aenv dim a b. Elt b- => AccKernel (Array dim b)- -> AccBindings aenv- -> Val aenv- -> Array dim a- -> CIO (Array dim b)-stencilOp kernel bindings aenv in0@(Array sh0 _) = do- res@(Array _ out) <- allocateArray (toElt sh0)- bindAcc 0 kernel in0- execute kernel bindings aenv (size sh0)- (((), out)- , toElt sh0 :: dim)- return res--stencil2Op- :: forall aenv dim a b c. Elt c- => AccKernel (Array dim c)- -> AccBindings aenv- -> Val aenv- -> Array dim a- -> Array dim b- -> CIO (Array dim c)-stencil2Op kernel bindings aenv in1@(Array sh1 _) in0@(Array sh0 _) = do- res@(Array sh out) <- allocateArray $ toElt (sh1 `intersect` sh0)- bindAcc 1 kernel in1- bindAcc 0 kernel in0- execute kernel bindings aenv (size sh)- (((((), out)- , toElt sh :: dim)- , toElt sh1 :: dim)- , toElt sh0 :: dim)- return res----- Expression evaluation--- ------------------------- Evaluate an open expression----executeOpenExp :: PreOpenExp ExecOpenAcc env aenv t -> Val env -> Val aenv -> CIO t-executeOpenExp exp env aenv = do- case exp of- -- Local binders and variable indices, ranging over tuples and scalars- Var ix -> return $! prj ix env- Let x e -> do- x' <- executeOpenExp x env aenv- executeOpenExp e (env `Push` x') aenv-- -- Constant values- Const c -> return $! toElt c- PrimConst c -> return $! I.evalPrimConst c-- -- Primitive scalar operations- PrimApp fun arg -> do- x <- executeOpenExp arg env aenv- return $! I.evalPrim fun x-- -- Tuples- Tuple tup -> do- t <- executeTuple tup env aenv- return $! toTuple t-- Prj ix e -> do- t <- executeOpenExp e env aenv- return $! I.evalPrj ix (fromTuple t)-- -- Conditional expression- Cond p t e -> do- p' <- executeOpenExp p env aenv- case p' of- True -> executeOpenExp t env aenv- False -> executeOpenExp e env aenv-- -- Array indices and shapes- IndexAny -> return Sugar.Any- IndexNil -> return Z- IndexCons sh sz -> do- sh' <- executeOpenExp sh env aenv- sz' <- executeOpenExp sz env aenv- return $! sh' :. sz'-- IndexHead sh -> do- (_ :. ix) <- executeOpenExp sh env aenv- return $! ix-- IndexTail sh -> do- (ix :. _) <- executeOpenExp sh env aenv- return $! ix-- -- Array shape and element indexing- IndexScalar acc ix -> do- arr' <- executeOpenAcc acc aenv- ix' <- executeOpenExp ix env aenv- indexArray arr' ix'-- Shape acc -> do- (Array sh _) <- executeOpenAcc acc aenv- return $! toElt sh-- ShapeSize e -> do- sh <- executeOpenExp e env aenv- return $! size (fromElt sh)----- Evaluate a closed expression----executeExp :: PreExp ExecOpenAcc aenv t -> Val aenv -> CIO t-executeExp e = executeOpenExp e Empty----- Tuple evaluation----executeTuple :: Tuple (PreOpenExp ExecOpenAcc env aenv) t -> Val env -> Val aenv -> CIO t-executeTuple NilTup _ _ = return ()-executeTuple (t `SnocTup` e) env aenv = (,) <$> executeTuple t env aenv- <*> executeOpenExp e env aenv----- Array references in scalar code--- ----------------------------------- All CUDA devices have between 6-8KB of read-only texture memory per--- multiprocessor. Since all arrays in Accelerate are immutable, we can always--- access input arrays through the texture cache to reduce global memory demand--- when accesses do not follow the regular patterns required for coalescing.------ This is great for older 1.x series devices, but compute 2.x devices have a--- dedicated 768KB L2 cache, as well as a configurable L1 cache of 16/48KB--- (combined with shared memory). What we really want is for the code generator--- to pass all inputs either as textures or global arrays, depending on what--- device we are currently targeting.-----bindAcc :: Int -> AccKernel a -> Array dim a' -> CIO ()-bindAcc base (Kernel _ mdl _ _ _) (Array sh ad) =- let arr n = "arrIn" ++ show base ++ "_a" ++ show (n::Int)- tex = CUDA.getTex mdl . arr- in- marshalTextureData ad (size sh) =<< liftIO (sequence' $ map tex [0..])---bindAccEnv :: AccKernel a -> Val aenv -> AccBindings aenv -> CIO ()-bindAccEnv (Kernel _ mdl _ _ _) aenv (AccBindings vars) = mapM_ bindAvar (Set.toList vars)- where- bindAvar (ArrayVar idx) =- let idx' = show $ idxToInt idx- Array sh ad = prj idx aenv- --- bindDim = liftIO $- CUDA.getPtr mdl ("sh" ++ idx') >>=- CUDA.pokeListArray (convertSh sh) . fst- --- arr n = "avar" ++ idx' ++ "_a" ++ show (n::Int)- tex = CUDA.getTex mdl . arr- bindTex = marshalTextureData ad (size sh) =<< liftIO (sequence' $ map tex [0..])- in- bindDim >> bindTex----- Kernel execution--- -------------------- Data which can be marshalled as arguments to a kernel invocation.----class Marshalable a where- marshal :: a -> CIO [CUDA.FunParam]--instance Marshalable () where- marshal _ = return []--#define primMarshalable(ty) \-instance Marshalable (ty) where { \- marshal x = return [CUDA.VArg x] }--primMarshalable(Int)-primMarshalable(Int8)-primMarshalable(Int16)-primMarshalable(Int32)-primMarshalable(Int64)-primMarshalable(Word)-primMarshalable(Word8)-primMarshalable(Word16)-primMarshalable(Word32)-primMarshalable(Word64)-primMarshalable(Float)-primMarshalable(Double)-primMarshalable(Ptr a)-primMarshalable(CUDA.DevicePtr a)--instance Marshalable CUDA.FunParam where- marshal x = return [x]--instance AD.ArrayElt e => Marshalable (AD.ArrayData e) where- marshal = marshalArrayData--instance Marshalable a => Marshalable [a] where- marshal = concatMapM marshal--instance (Marshalable a, Marshalable b) => Marshalable (a,b) where- marshal (a,b) = (++) <$> marshal a <*> marshal b----- This requires incoherent instances \=----instance Shape sh => Storable sh where- sizeOf sh = F.sizeOf (undefined::Int32) * (1 `max` Sugar.dim sh)- alignment _ = F.alignment (undefined::Int32)- poke p sh = F.pokeArray (F.castPtr p) (convertSh (fromElt sh))--instance Shape sh => Marshalable sh where- marshal sh = return [CUDA.VArg sh]----- What launch parameters should we use to execute the kernel with a number of--- array elements?----configure :: AccKernel a -> Int -> (Int, Int, Int)-configure (Kernel _ !_ !_ !_ !launchConfig) !n = launchConfig n----- Link the binary object implementing the computation, configure the kernel--- launch parameters, and initiate the computation. This also handles lifting--- and binding of array references from scalar expressions.----execute :: Marshalable args- => AccKernel a -- The binary module implementing this kernel- -> AccBindings aenv -- Array variables embedded in scalar expressions- -> Val aenv- -> Int- -> args- -> CIO ()-execute kernel@(Kernel _ !_ !_ !_ !_) !bindings !aenv !n !args = do- bindAccEnv kernel aenv bindings- launch kernel (configure kernel n) args----- Execute a device function, with the given thread configuration and function--- parameters. The tuple contains (threads per block, grid size, shared memory)----launch :: Marshalable args => AccKernel a -> (Int,Int,Int) -> args -> CIO ()-launch (Kernel entry _ !fn _ _) !(cta, grid, smem) !a = do- message $ entry ++ " <<< " ++ shows grid ", " ++ shows cta ", " ++ shows smem " >>>"- --- args <- marshal a- liftIO $ CUDA.launchKernel fn (grid,1,1) (cta,1,1) smem Nothing args----- Auxiliary functions--- ----------------------- Generalise concatMap for teh monadz----concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]-concatMapM f xs = concat `liftM` mapM f xs---- A lazier version of 'Control.Monad.sequence'----sequence' :: [IO a] -> IO [a]-sequence' = foldr k (return [])- where k m ms = do { x <- m; xs <- unsafeInterleaveIO ms; return (x:xs) }---- Extract shape dimensions as a list of integers. Singleton dimensions are--- considered to be of unit size.------ Internally, Accelerate uses snoc-based tuple projection, while the data--- itself is stored in reading order. Ensure we match the behaviour of regular--- tuples and code generation thereof.----convertSh :: R.Shape sh => sh -> [Int32]-convertSh = post . shapeToList- where- post [] = [1]- post xs = reverse (map convertIx xs)--convertIx :: Int -> Int32-convertIx ix = INTERNAL_ASSERT "convertIx" (ix <= intmax) (fromIntegral ix)- where intmax = fromIntegral (maxBound :: Int32)----- Apply a function to all components of an Arrays structure----applyArraysR- :: (forall sh e. (Shape sh, Elt e) => Array sh e -> CIO ())- -> ArraysR arrs- -> arrs- -> CIO ()-applyArraysR _ ArraysRunit () = return ()-applyArraysR f (ArraysRpair r1 r0) (a1, a0) = applyArraysR f r1 a1 >> applyArraysR f r0 a0-applyArraysR f ArraysRarray arr = f arr----- Debug--- -------{-# INLINE trace #-}-trace :: String -> CIO a -> CIO a-trace msg next = D.message D.dump_exec ("exec: " ++ msg) >> next--{-# INLINE message #-}-message :: String -> CIO ()-message s = s `trace` return ()+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- |+-- Module : Data.Array.Accelerate.CUDA.Execute+-- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee+-- [2009..2012] Manuel M T Chakravarty, Gabriele Keller, 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.CUDA.Execute (++ -- * Execute a computation under a CUDA environment+ executeAcc, executeAfun1++) where++-- friends+import Data.Array.Accelerate.CUDA.AST+import Data.Array.Accelerate.CUDA.State+import Data.Array.Accelerate.CUDA.FullList ( FullList(..), List(..) )+import Data.Array.Accelerate.CUDA.Array.Data+import Data.Array.Accelerate.CUDA.Array.Sugar+import Data.Array.Accelerate.CUDA.Foreign ( canExecute )+import Data.Array.Accelerate.CUDA.CodeGen.Base ( Name, namesOfArray, groupOfInt )+import qualified Data.Array.Accelerate.CUDA.Array.Prim as Prim+#ifdef ACCELERATE_DEBUG+import qualified Data.Array.Accelerate.CUDA.Debug as D+#endif++import Data.Array.Accelerate.Tuple+import Data.Array.Accelerate.Interpreter ( evalPrim, evalPrimConst, evalPrj )+import Data.Array.Accelerate.Array.Data ( ArrayElt, ArrayData )+import Data.Array.Accelerate.Array.Representation ( SliceIndex(..) )+import qualified Data.Array.Accelerate.Array.Representation as R+++-- standard library+import Prelude hiding ( exp, sum, iterate )+import Control.Applicative hiding ( Const )+import Control.Monad ( join, when, liftM )+import Control.Monad.Reader ( asks )+import Control.Monad.Trans ( MonadIO, liftIO )+import System.IO.Unsafe ( unsafeInterleaveIO )+import Data.Int+import Data.Word+import Data.Maybe++import Foreign.Ptr ( Ptr, castPtr )+import Foreign.Storable ( Storable(..) )+import Foreign.CUDA.Analysis.Device ( DeviceProperties, computeCapability, Compute(..) )+import qualified Foreign.CUDA.Driver as CUDA+import qualified Foreign.Marshal.Array as F+import qualified Data.HashMap.Strict as Map++#ifdef ACCELERATE_DEBUG+import Control.Monad ( void )+import Control.Concurrent ( forkIO )+import System.CPUTime+import qualified Foreign.CUDA.Driver.Event as Event+#endif++#include "accelerate.h"+++-- Array expression evaluation+-- ---------------------------++-- Computations are evaluated by traversing the AST bottom-up, and for each node+-- distinguishing between three cases:+--+-- 1. If it is a Use node, return a reference to the device memory holding the+-- array data+--+-- 2. If it is a non-skeleton node, such as a let-binding or shape conversion,+-- this is executed directly by updating the environment or similar+--+-- 3. If it is a skeleton node, the associated binary object is retrieved,+-- memory allocated for the result, and the kernel(s) that implement the+-- skeleton are invoked+--+executeAcc :: Arrays a => ExecAcc a -> CIO a+executeAcc !acc = executeOpenAcc acc Empty++executeAfun1 :: (Arrays a, Arrays b) => ExecAfun (a -> b) -> a -> CIO b+executeAfun1 !afun !arrs+ | Alam (Abody f) <- afun+ = do useArrays (arrays arrs) (fromArr arrs)+ executeOpenAcc f (Empty `Push` arrs)++ | otherwise+ = error "the sword comes out after you swallow it, right?"++ where+ useArrays :: ArraysR arrs -> arrs -> CIO ()+ useArrays ArraysRunit () = return ()+ useArrays (ArraysRpair r1 r0) (a1, a0) = useArrays r1 a1 >> useArrays r0 a0+ useArrays ArraysRarray arr = useArray arr+++-- Evaluate an open array computation+--+executeOpenAcc+ :: forall aenv arrs.+ ExecOpenAcc aenv arrs+ -> Val aenv+ -> CIO arrs+executeOpenAcc EmbedAcc{} _+ = INTERNAL_ERROR(error) "execute" "unexpected delayed array"+executeOpenAcc (ExecAcc (FL () kernel more) !gamma !pacc) !aenv+ = case pacc of++ -- Array introduction+ Use arr -> return (toArr arr)+ Unit x -> newArray Z . const =<< travE x++ -- Environment manipulation+ Avar ix -> return (prj ix aenv)+ Alet bnd body -> executeOpenAcc body . (aenv `Push`) =<< travA bnd+ Atuple tup -> toTuple <$> travT tup+ Aprj ix tup -> evalPrj ix . fromTuple <$> travA tup+ Apply f a -> executeAfun1 f =<< travA a+ Acond p t e -> travE p >>= \x -> if x then travA t else travA e++ -- Foreign+ Aforeign ff afun a -> fromMaybe (executeAfun1 afun) (canExecute ff) =<< travA a++ -- Producers+ Map _ a -> executeOp =<< extent a+ Generate sh _ -> executeOp =<< travE sh+ Transform sh _ _ _ -> executeOp =<< travE sh+ Backpermute sh _ _ -> executeOp =<< travE sh+ Reshape sh a -> reshapeOp <$> travE sh <*> travA a++ -- Consumers+ Fold _ _ a -> foldOp =<< extent a+ Fold1 _ a -> fold1Op =<< extent a+ FoldSeg _ _ a s -> join $ foldSegOp <$> extent a <*> extent s+ Fold1Seg _ a s -> join $ foldSegOp <$> extent a <*> extent s+ Scanl1 _ a -> scan1Op =<< extent a+ Scanr1 _ a -> scan1Op =<< extent a+ Scanl' _ _ a -> scan'Op =<< extent a+ Scanr' _ _ a -> scan'Op =<< extent a+ Scanl _ _ a -> scanOp True =<< extent a+ Scanr _ _ a -> scanOp False =<< extent a+ Permute _ d _ a -> join $ permuteOp <$> extent a <*> travA d+ Stencil _ _ a -> stencilOp =<< travA a+ Stencil2 _ _ a1 _ a2 -> join $ stencil2Op <$> travA a1 <*> travA a2++ -- Removed by fusion+ Replicate _ _ _ -> fusionError+ Slice _ _ _ -> fusionError+ ZipWith _ _ _ -> fusionError++ where+ fusionError = INTERNAL_ERROR(error) "executeOpenAcc" "unexpected fusible matter"++ -- term traversals+ travA :: ExecOpenAcc aenv a -> CIO a+ travA !acc = executeOpenAcc acc aenv++ travE :: ExecExp aenv t -> CIO t+ travE !exp = executeExp exp aenv++ travT :: Atuple (ExecOpenAcc aenv) t -> CIO t+ travT NilAtup = return ()+ travT (SnocAtup !t !a) = (,) <$> travT t <*> travA a++ -- get the extent of an embedded array+ extent :: Shape sh => ExecOpenAcc aenv (Array sh e) -> CIO sh+ extent ExecAcc{} = INTERNAL_ERROR(error) "executeOpenAcc" "expected delayed array"+ extent (EmbedAcc sh) = travE sh++ -- Skeleton implementation+ -- -----------------------++ -- Execute a skeleton that has no special requirements: thread decomposition+ -- is based on the given shape.+ --+ executeOp :: (Shape sh, Elt e) => sh -> CIO (Array sh e)+ executeOp !sh = do+ out <- allocateArray sh+ execute kernel gamma aenv (size sh) out+ return out++ -- Change the shape of an array without altering its contents. This does not+ -- execute any kernel programs.+ --+ reshapeOp :: Shape sh => sh -> Array sh' e -> Array sh e+ reshapeOp sh (Array sh' adata)+ = BOUNDS_CHECK(check) "reshape" "shape mismatch" (size sh == R.size sh')+ $ Array (fromElt sh) adata++ -- Executing fold operations depend on whether we are recursively collapsing+ -- to a single value using multiple thread blocks, or a multidimensional+ -- single-pass reduction where there is one block per inner dimension.+ --+ fold1Op :: (Shape sh, Elt e) => (sh :. Int) -> CIO (Array sh e)+ fold1Op !sh@(_ :. sz)+ = BOUNDS_CHECK(check) "fold1" "empty array" (sz > 0)+ $ foldOp sh++ foldOp :: (Shape sh, Elt e) => (sh :. Int) -> CIO (Array sh e)+ foldOp !(!sh :. sz)+ | dim sh > 0 = executeOp sh+ | otherwise+ = let !numElements = size sh * sz+ (_,!numBlocks,_) = configure kernel numElements+ in do+ out <- allocateArray (sh :. numBlocks)+ execute kernel gamma aenv numElements out+ foldRec out++ -- Recursive step(s) of a multi-block reduction+ --+ foldRec :: (Shape sh, Elt e) => Array (sh:.Int) e -> CIO (Array sh e)+ foldRec arr@(Array _ !adata)+ | Cons _ rec _ <- more+ = let sh :. sz = shape arr+ !numElements = size sh * sz+ (_,!numBlocks,_) = configure rec numElements+ in if sz <= 1+ then return $ Array (fromElt sh) adata+ else do+ out <- allocateArray (sh :. numBlocks)+ execute rec gamma aenv numElements (out, arr)+ foldRec out++ | otherwise+ = INTERNAL_ERROR(error) "foldRec" "missing phase-2 kernel module"++ -- Segmented reduction. Subtract one from the size of the segments vector as+ -- this is the result of an exclusive scan to calculate segment offsets.+ --+ foldSegOp :: (Shape sh, Elt e) => (sh :. Int) -> (Z :. Int) -> CIO (Array (sh :. Int) e)+ foldSegOp (!sh :. _) !(Z :. sz) = executeOp (sh :. sz - 1)++ -- Scans, all variations on a theme.+ --+ scanOp :: Elt e => Bool -> (Z :. Int) -> CIO (Vector e)+ scanOp !left !(Z :. numElements) = do+ arr@(Array _ adata) <- allocateArray (Z :. numElements + 1)+ out <- devicePtrsOfArrayData adata+ let (!body, !sum)+ | left = (out, advancePtrsOfArrayData adata numElements out)+ | otherwise = (advancePtrsOfArrayData adata 1 out, out)+ --+ scanCore numElements arr body sum+ return arr++ scan1Op :: forall e. Elt e => (Z :. Int) -> CIO (Vector e)+ scan1Op !(Z :. numElements) = do+ arr@(Array _ adata) <- allocateArray (Z :. numElements + 1) :: CIO (Vector e)+ body <- devicePtrsOfArrayData adata+ let sum {- to fix type -} = advancePtrsOfArrayData adata numElements body+ --+ scanCore numElements arr body sum+ return (Array ((),numElements) adata)++ scan'Op :: forall e. Elt e => (Z :. Int) -> CIO (Vector e, Scalar e)+ scan'Op !(Z :. numElements) = do+ vec@(Array _ ad_vec) <- allocateArray (Z :. numElements) :: CIO (Vector e)+ sum@(Array _ ad_sum) <- allocateArray Z :: CIO (Scalar e)+ d_vec <- devicePtrsOfArrayData ad_vec+ d_sum <- devicePtrsOfArrayData ad_sum+ --+ scanCore numElements vec d_vec d_sum+ return (vec, sum)++ scanCore+ :: forall e. Elt e+ => Int+ -> Vector e -- to fix Elt vs. EltRepr+ -> Prim.DevicePtrs (EltRepr e)+ -> Prim.DevicePtrs (EltRepr e)+ -> CIO ()+ scanCore !numElements (Array _ !adata) !body !sum+ | Cons _ !upsweep1 (Cons _ !upsweep2 _) <- more+ = let (_,!numIntervals,_) = configure kernel numElements+ !d_body = marshalDevicePtrs adata body+ !d_sum = marshalDevicePtrs adata sum+ in do+ blk <- allocateArray (Z :. numIntervals) :: CIO (Vector e)++ -- Phase 1: Split the array over multiple thread blocks and calculate+ -- the final scan result from each interval.+ --+ when (numIntervals > 1) $ do+ execute upsweep1 gamma aenv numElements blk+ execute upsweep2 gamma aenv numIntervals (blk, blk, d_sum)++ -- Phase 2: Re-scan the input using the carry-in value from each+ -- interval sum calculated in phase 1.+ --+ execute kernel gamma aenv numElements (Z :. numElements, d_body, blk, d_sum)++ | otherwise+ = INTERNAL_ERROR(error) "scanOp" "missing multi-block kernel module(s)"++ -- Forward permutation+ --+ permuteOp :: (Shape sh, Shape sh', Elt e) => sh -> Array sh' e -> CIO (Array sh' e)+ permuteOp !sh !dfs = do+ out <- allocateArray (shape dfs)+ copyArray dfs out+ execute kernel gamma aenv (size sh) out+ return out++ -- Stencil operations. NOTE: the arguments to 'namesOfArray' must be the+ -- same as those given in the function 'mkStencil[2]'.+ --+ stencilOp :: forall sh a b. (Shape sh, Elt a, Elt b) => Array sh a -> CIO (Array sh b)+ stencilOp !arr = do+ let sh = shape arr+ out <- allocateArray sh+ dev <- asks deviceProperties++ if computeCapability dev < Compute 2 0+ then marshalAccTex (namesOfArray "Stencil" (undefined :: a)) kernel arr >>+ execute kernel gamma aenv (size sh) (out, sh)+ else execute kernel gamma aenv (size sh) (out, arr)+ --+ return out++ stencil2Op :: forall sh a b c. (Shape sh, Elt a, Elt b, Elt c)+ => Array sh a -> Array sh b -> CIO (Array sh c)+ stencil2Op !arr1 !arr2 = do+ let sh1 = shape arr1+ sh2 = shape arr2+ sh = sh1 `intersect` sh2+ out <- allocateArray sh+ dev <- asks deviceProperties++ if computeCapability dev < Compute 2 0+ then marshalAccTex (namesOfArray "Stencil1" (undefined :: a)) kernel arr1 >>+ marshalAccTex (namesOfArray "Stencil2" (undefined :: b)) kernel arr2 >>+ execute kernel gamma aenv (size sh) (out, sh1, sh2)+ else execute kernel gamma aenv (size sh) (out, arr1, arr2)+ --+ return out+++-- Scalar expression evaluation+-- ----------------------------++executeExp :: ExecExp aenv t -> Val aenv -> CIO t+executeExp !exp !aenv = executeOpenExp exp Empty aenv++executeOpenExp :: forall env aenv exp. ExecOpenExp env aenv exp -> Val env -> Val aenv -> CIO exp+executeOpenExp !rootExp !env !aenv = travE rootExp+ where+ travE :: ExecOpenExp env aenv t -> CIO t+ travE exp = case exp of+ Var ix -> return (prj ix env)+ Let bnd body -> travE bnd >>= \x -> executeOpenExp body (env `Push` x) aenv+ Const c -> return (toElt c)+ PrimConst c -> return (evalPrimConst c)+ PrimApp f x -> evalPrim f <$> travE x+ Tuple t -> toTuple <$> travT t+ Prj ix e -> evalPrj ix . fromTuple <$> travE e+ Cond p t e -> travE p >>= \x -> if x then travE t else travE e+ Iterate n f x -> join $ iterate f <$> travE n <*> travE x+-- While p f x -> while p f =<< travE x+ IndexAny -> return Any+ IndexNil -> return Z+ IndexCons sh sz -> (:.) <$> travE sh <*> travE sz+ IndexHead sh -> (\(_ :. ix) -> ix) <$> travE sh+ IndexTail sh -> (\(ix :. _) -> ix) <$> travE sh+ IndexSlice ix slix sh -> indexSlice ix <$> travE slix <*> travE sh+ IndexFull ix slix sl -> indexFull ix <$> travE slix <*> travE sl+ ToIndex sh ix -> toIndex <$> travE sh <*> travE ix+ FromIndex sh ix -> fromIndex <$> travE sh <*> travE ix+ Intersect sh1 sh2 -> intersect <$> travE sh1 <*> travE sh2+ ShapeSize sh -> size <$> travE sh+ Shape acc -> shape <$> travA acc+ Index acc ix -> join $ index <$> travA acc <*> travE ix+ LinearIndex acc ix -> join $ indexArray <$> travA acc <*> travE ix+ Foreign _ f x -> travF1 f x++ -- Helpers+ -- -------++ travT :: Tuple (ExecOpenExp env aenv) t -> CIO t+ travT tup = case tup of+ NilTup -> return ()+ SnocTup !t !e -> (,) <$> travT t <*> travE e++ travA :: ExecOpenAcc aenv a -> CIO a+ travA !acc = executeOpenAcc acc aenv++ travF1 :: ExecFun () (a -> b) -> ExecOpenExp env aenv a -> CIO b+ travF1 (Lam (Body f)) x = travE x >>= \a -> executeOpenExp f (Empty `Push` a) Empty+ travF1 _ _ = error "I bless the rains down in Africa"++ iterate :: ExecOpenExp (env,a) aenv a -> Int -> a -> CIO a+ iterate !f !limit !x+ = let go !i !acc+ | i >= limit = return acc+ | otherwise = go (i+1) =<< executeOpenExp f (env `Push` acc) aenv+ in+ go 0 x++{--+ while :: ExecOpenExp (env,a) aenv Bool -> ExecOpenExp (env,a) aenv a -> a -> CIO a+ while !p !f !x+ = let go !acc = do+ done <- executeOpenExp p (env `Push` acc) aenv+ if done then return x+ else go =<< executeOpenExp f (env `Push` acc) aenv+ in+ go x+--}++ indexSlice :: (Elt slix, Elt sh, Elt sl)+ => SliceIndex (EltRepr slix) (EltRepr sl) co (EltRepr sh)+ -> slix+ -> sh+ -> sl+ indexSlice !ix !slix !sh = toElt $! restrict ix (fromElt slix) (fromElt sh)+ where+ restrict :: SliceIndex slix sl co sh -> slix -> sh -> sl+ restrict SliceNil () () = ()+ restrict (SliceAll sliceIdx) (slx, ()) (sl, sz) = (restrict sliceIdx slx sl, sz)+ restrict (SliceFixed sliceIdx) (slx, _) (sl, _) = restrict sliceIdx slx sl++ indexFull :: (Elt slix, Elt sh, Elt sl)+ => SliceIndex (EltRepr slix) (EltRepr sl) co (EltRepr sh)+ -> slix+ -> sl+ -> sh+ indexFull !ix !slix !sl = toElt $! extend ix (fromElt slix) (fromElt sl)+ where+ extend :: SliceIndex slix sl co sh -> slix -> sl -> sh+ extend SliceNil () () = ()+ extend (SliceAll sliceIdx) (slx, ()) (sh, sz) = (extend sliceIdx slx sh, sz)+ extend (SliceFixed sliceIdx) (slx, sz) sh = (extend sliceIdx slx sh, sz)++ index :: (Shape sh, Elt e) => Array sh e -> sh -> CIO e+ index !arr !ix = indexArray arr (toIndex (shape arr) ix)+++-- Marshalling data+-- ----------------++-- Data which can be marshalled as function arguments to a kernel invocation.+--+class Marshalable a where+ marshal :: a -> CIO [CUDA.FunParam]++instance Marshalable () where+ marshal () = return []++instance Marshalable CUDA.FunParam where+ marshal !x = return [x]++instance ArrayElt e => Marshalable (ArrayData e) where+ marshal !ad = marshalArrayData ad++instance Shape sh => Marshalable sh where+ marshal !sh = return [CUDA.VArg sh]++instance Marshalable a => Marshalable [a] where+ marshal = concatMapM marshal++instance (Marshalable sh, Elt e) => Marshalable (Array sh e) where+ marshal !(Array sh ad) = (++) <$> marshal (toElt sh :: sh) <*> marshal ad++instance (Marshalable a, Marshalable b) => Marshalable (a, b) where+ marshal (!a, !b) = (++) <$> marshal a <*> marshal b++instance (Marshalable a, Marshalable b, Marshalable c) => Marshalable (a, b, c) where+ marshal (!a, !b, !c)+ = concat <$> sequence [marshal a, marshal b, marshal c]++instance (Marshalable a, Marshalable b, Marshalable c, Marshalable d)+ => Marshalable (a, b, c, d) where+ marshal (!a, !b, !c, !d)+ = concat <$> sequence [marshal a, marshal b, marshal c, marshal d]+++#define primMarshalable(ty) \+instance Marshalable (ty) where { \+ marshal !x = return [CUDA.VArg x] }++primMarshalable(Int)+primMarshalable(Int8)+primMarshalable(Int16)+primMarshalable(Int32)+primMarshalable(Int64)+primMarshalable(Word)+primMarshalable(Word8)+primMarshalable(Word16)+primMarshalable(Word32)+primMarshalable(Word64)+primMarshalable(Float)+primMarshalable(Double)+primMarshalable(Ptr a)+primMarshalable(CUDA.DevicePtr a)++instance Shape sh => Storable sh where -- undecidable, incoherent+ sizeOf sh = sizeOf (undefined :: Int32) * (dim sh)+ alignment _ = alignment (undefined :: Int32)+ poke !p !sh = F.pokeArray (castPtr p) (convertShape (shapeToList sh))+++-- Convert shapes into 32-bit integers for marshalling onto the device+--+convertShape :: [Int] -> [Int32]+convertShape [] = [1]+convertShape sh = reverse (map convertIx sh)++convertIx :: Int -> Int32+convertIx !ix = INTERNAL_ASSERT "convertIx" (ix <= fromIntegral (maxBound :: Int32))+ $ fromIntegral ix+++-- Note [Array references in scalar code]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- All CUDA devices have between 6-8KB of read-only texture memory per+-- multiprocessor. Since all arrays in Accelerate are immutable, we can always+-- access input arrays through the texture cache to reduce global memory demand+-- when accesses do not follow the regular patterns required for coalescing.+--+-- This is great for older 1.x series devices, but newer devices have a+-- dedicated L2 cache (device dependent, 256KB-1.5MB), as well as a configurable+-- L1 cache combined with shared memory (16-48KB).+--+-- For older 1.x series devices, we pass free array variables as texture+-- references, but for new devices we pass them as standard array arguments so+-- as to use the larger available caches.+--++marshalAccEnvTex :: AccKernel a -> Val aenv -> Gamma aenv -> CIO [CUDA.FunParam]+marshalAccEnvTex !kernel !aenv (Gamma !gamma)+ = flip concatMapM (Map.toList gamma)+ $ \(Idx_ !(idx :: Idx aenv (Array sh e)), i) ->+ do let arr = prj idx aenv+ marshalAccTex (namesOfArray (groupOfInt i) (undefined :: e)) kernel arr+ marshal (shape arr)++marshalAccTex :: (Name,[Name]) -> AccKernel a -> Array sh e -> CIO ()+marshalAccTex (_, !arrIn) (AccKernel _ _ !mdl _ _ _ _) (Array !sh !adata)+ = marshalTextureData adata (R.size sh) =<< liftIO (sequence' $ map (CUDA.getTex mdl) (reverse arrIn))++marshalAccEnvArg :: Val aenv -> Gamma aenv -> CIO [CUDA.FunParam]+marshalAccEnvArg !aenv (Gamma !gamma)+ = concatMapM (\(Idx_ !idx) -> marshal (prj idx aenv)) (Map.keys gamma)+++-- A lazier version of 'Control.Monad.sequence'+--+sequence' :: [IO a] -> IO [a]+sequence' = foldr k (return [])+ where k m ms = do { x <- m; xs <- unsafeInterleaveIO ms; return (x:xs) }++-- Generalise concatMap for teh monadz+--+concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]+concatMapM f xs = concat `liftM` mapM f xs+++-- Kernel execution+-- ----------------++-- What launch parameters should we use to execute the kernel with a number of+-- array elements?+--+configure :: AccKernel a -> Int -> (Int, Int, Int)+configure (AccKernel _ _ _ _ !cta !smem !grid) !n = (cta, grid n, smem)+++-- Marshal the kernel arguments. For older 1.x devices this binds free arrays to+-- texture references, and for newer devices adds the parameters to the front of+-- the argument list+--+arguments :: Marshalable args+ => AccKernel a+ -> Val aenv+ -> Gamma aenv+ -> args+ -> CIO [CUDA.FunParam]+arguments !kernel !aenv !gamma !a = do+ dev <- asks deviceProperties+ let marshaller | computeCapability dev < Compute 2 0 = marshalAccEnvTex kernel+ | otherwise = marshalAccEnvArg+ --+ (++) <$> marshaller aenv gamma <*> marshal a+++-- Link the binary object implementing the computation, configure the kernel+-- launch parameters, and initiate the computation. This also handles lifting+-- and binding of array references from scalar expressions.+--+execute :: Marshalable args+ => AccKernel a -- The binary module implementing this kernel+ -> Gamma aenv -- variables of arrays embedded in scalar expressions+ -> Val aenv -- the environment+ -> Int -- a "size" parameter, typically number of elements in the output+ -> args -- arguments to marshal to the kernel function+ -> CIO ()+execute !kernel !gamma !aenv !n !a = do+ args <- arguments kernel aenv gamma a+ launch kernel (configure kernel n) args+++-- Execute a device function, with the given thread configuration and function+-- parameters. The tuple contains (threads per block, grid size, shared memory)+--+launch :: AccKernel a -> (Int,Int,Int) -> [CUDA.FunParam] -> CIO ()+launch (AccKernel _entry !fn _ _ _ _ _) !(cta, grid, smem) !args+#ifdef ACCELERATE_DEBUG+ | D.mode D.dump_exec+ = liftIO $ do+ gpuBegin <- Event.create []+ gpuEnd <- Event.create []+ cpuBegin <- getCPUTime+ Event.record gpuBegin Nothing+ CUDA.launchKernel fn (grid,1,1) (cta,1,1) smem Nothing args+ Event.record gpuEnd Nothing+ cpuEnd <- getCPUTime++ -- Wait for the GPU to finish executing then display the timing execution+ -- message. Do this in a separate thread so that the remaining kernels can+ -- be queued asynchronously.+ --+ void . forkIO $ do+ Event.block gpuEnd+ diff <- Event.elapsedTime gpuBegin gpuEnd+ let gpuTime = diff * 1E-3 -- milliseconds+ cpuTime = fromIntegral (cpuEnd - cpuBegin) * 1E-12 :: Double -- picoseconds++ Event.destroy gpuBegin+ Event.destroy gpuEnd+ --+ message $+ _entry ++ "<<< " ++ shows grid ", " ++ shows cta ", " ++ shows smem " >>> "+ ++ "gpu: " ++ D.showFFloatSIBase (Just 3) 1000 gpuTime "s, "+ ++ "cpu: " ++ D.showFFloatSIBase (Just 3) 1000 cpuTime "s"+#endif+ | otherwise+ = liftIO $ CUDA.launchKernel fn (grid,1,1) (cta,1,1) smem Nothing args+++-- Debugging+-- ---------++#ifdef ACCELERATE_DEBUG+{-# INLINE trace #-}+trace :: MonadIO m => String -> m a -> m a+trace msg next = D.message D.dump_exec ("exec: " ++ msg) >> next++{-# INLINE message #-}+message :: MonadIO m => String -> m ()+message s = s `trace` return ()+#endif
+ Data/Array/Accelerate/CUDA/Foreign.hs view
@@ -0,0 +1,158 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- |+-- Module : Data.Array.Accelerate.CUDA.Foreign+-- Copyright : [2013] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell, Robert Clifton-Everest+-- License : BSD3+--+-- Maintainer : Robert Clifton-Everest <robertce@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--+-- This module provides the CUDA backend's implementation of Accelerate's+-- foreign function interface. Also provided are a series of utility functions+-- for transferring arrays from the device to the host (and vice-versa),+-- allocating new arrays, getting the CUDA device pointers of a given array, and+-- executing IO actions within a CUDA context.+--+-- [/NOTE:/]+--+-- When arrays are passed to the foreign function there is no guarantee that the+-- host side data matches the device side data. If the data is needed host side+-- 'peekArray' or 'peekArrayAsync' must be called.+--+-- Arrays of tuples are represented as tuples of arrays so for example an array+-- of type @Array DIM1 (Float, Float)@ would have two device pointers associated+-- with it.+--++module Data.Array.Accelerate.CUDA.Foreign (++ -- * Backend representation+ cudaAcc, canExecute, CuForeignAcc, CuForeignExp, CIO,+ liftIO, canExecuteExp, cudaExp,++ -- * Manipulating arrays+ DevicePtrs,+ devicePtrsOfArray,+ indexArray, copyArray,+ useArray, useArrayAsync,+ peekArray, peekArrayAsync,+ pokeArray, pokeArrayAsync,+ allocateArray, newArray,++ -- * Running IO actions in a CUDA context+ inContext, inDefaultContext++) where++import Data.Array.Accelerate.CUDA.State+import Data.Array.Accelerate.CUDA.Context+import Data.Array.Accelerate.CUDA.Array.Sugar+import Data.Array.Accelerate.CUDA.Array.Data+import Data.Array.Accelerate.CUDA.Array.Prim ( DevicePtrs )++import qualified Foreign.CUDA.Driver as CUDA++import Data.Dynamic+import Control.Applicative+import Control.Exception ( bracket_ )+import Control.Monad.Trans ( liftIO )+import System.IO.Unsafe ( unsafePerformIO )+import System.Mem.StableName+++-- CUDA backend representation of foreign functions+-- ------------------------------------------------++-- CUDA foreign Acc functions are just CIO functions.+--+newtype CuForeignAcc args results = CuForeignAcc (args -> CIO results)+ deriving (Typeable)++instance Foreign CuForeignAcc where+ -- Using the hash of the StableName in order to uniquely identify the function+ -- when it is pretty printed.+ --+ strForeign ff =+ let sn = unsafePerformIO $ makeStableName ff+ in+ "cudaAcc<" ++ (show (hashStableName sn)) ++ ">"++-- |Gives the executable form of a foreign function if it can be executed by the+-- CUDA backend.+--+canExecute :: forall ff args results. (Foreign ff, Typeable args, Typeable results)+ => ff args results+ -> Maybe (args -> CIO results)+canExecute ff =+ let+ df = toDyn ff+ fd = fromDynamic :: Dynamic -> Maybe (CuForeignAcc args results)+ in (\(CuForeignAcc ff') -> ff') <$> fd df++-- CUDA foreign Exp functions are just strings with the header filename and the name of the+-- function separated by a space.+--+newtype CuForeignExp args results = CuForeignExp String+ deriving (Typeable)++instance Foreign CuForeignExp where+ strForeign (CuForeignExp n) = "cudaExp<" ++ n ++ ">"++-- |Gives the foreign function name as a string if it is a foreign Exp function+-- for the CUDA backend.+--+canExecuteExp :: forall ff args results. (Foreign ff, Typeable results, Typeable args)+ => ff args results+ -> Maybe String+canExecuteExp ff =+ let+ df = toDyn ff+ fd = fromDynamic :: Dynamic -> Maybe (CuForeignExp args results)+ in (\(CuForeignExp ff') -> ff') <$> fd df+++-- User facing utility functions+-- -----------------------------++-- |Create a CUDA foreign function+--+cudaAcc :: (Arrays args, Arrays results)+ => (args -> CIO results)+ -> CuForeignAcc args results+cudaAcc = CuForeignAcc++-- |Create a CUDA foreign scalar function. The string needs to be formatted in+-- the same way as for the Haskell FFI. That is, the header file name and the+-- name of the function separated by a space. i.e cudaExp "stdlib.h min".+--+cudaExp :: (Elt args, Elt results)+ => String+ -> CuForeignExp args results+cudaExp = CuForeignExp++-- |Get the raw CUDA device pointers associated with an array+--+devicePtrsOfArray :: Array sh e -> CIO (DevicePtrs (EltRepr e))+devicePtrsOfArray (Array _ adata) = devicePtrsOfArrayData adata++-- |Run an IO action within the given CUDA context+--+inContext :: Context -> IO a -> IO a+inContext ctx action =+ bracket_ (push ctx) CUDA.pop action++-- |Run an IO action in the default CUDA context+--+inDefaultContext :: IO a -> IO a+inDefaultContext = inContext defaultContext+
Data/Array/Accelerate/CUDA/FullList.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE PatternGuards #-} -- | -- Module : Data.Array.Accelerate.CUDA.FullList -- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee@@ -7,7 +8,7 @@ -- -- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au> -- Stability : experimental--- Portability : non-partable (GHC extensions)+-- Portability : non-portable (GHC extensions) -- -- Non-empty lists of key/value pairs. The lists are strict in the key and lazy -- in the values. We assume that keys only occur once.@@ -21,11 +22,13 @@ singleton, cons, size,- lookup+ mapM_,+ lookup,+ lookupDelete, ) where -import Prelude hiding ( lookup )+import Prelude hiding ( lookup, mapM_ ) data FullList k v = FL !k v !(List k v)@@ -67,7 +70,8 @@ lookup key (FL k v xs) | key == k = Just v | otherwise = lookupL key xs-{-# INLINABLE lookup #-}+{-# INLINABLE lookup #-}+{-# SPECIALISE lookup :: () -> FullList () v -> Maybe v #-} lookupL :: Eq k => k -> List k v -> Maybe v lookupL !key = go@@ -76,5 +80,39 @@ go (Cons k v xs) | key == k = Just v | otherwise = go xs-{-# INLINABLE lookupL #-}+{-# INLINABLE lookupL #-}+{-# SPECIALISE lookupL :: () -> List () v -> Maybe v #-}++lookupDelete :: Eq k => k -> FullList k v -> (Maybe v, Maybe (FullList k v))+lookupDelete key (FL k v xs)+ | key == k+ = case xs of+ Nil -> (Just v, Nothing)+ Cons k' v' xs' -> (Just v, Just $ FL k' v' xs')++ | (r, xs') <- lookupDeleteL k xs+ = (r, Just $ FL k v xs')+{-# INLINABLE lookupDelete #-}+{-# SPECIALISE lookupDelete :: () -> FullList () v -> (Maybe v, Maybe (FullList () v)) #-}++lookupDeleteL :: Eq k => k -> List k v -> (Maybe v, List k v)+lookupDeleteL !key = go+ where+ go Nil = (Nothing, Nil)+ go (Cons k v xs)+ | key == k = (Just v, xs)+ | (r, xs') <- go xs = (r, Cons k v xs')+{-# INLINABLE lookupDeleteL #-}+{-# SPECIALISE lookupDeleteL :: () -> List () v -> (Maybe v, List () v) #-}++mapM_ :: Monad m => (k -> v -> m a) -> FullList k v -> m ()+mapM_ !f (FL k v xs) = f k v >> mapML_ f xs+{-# INLINABLE mapM_ #-}++mapML_ :: Monad m => (k -> v -> m a) -> List k v -> m ()+mapML_ !f = go+ where+ go Nil = return ()+ go (Cons k v xs) = f k v >> go xs+{-# INLINABLE mapML_ #-}
Data/Array/Accelerate/CUDA/Persistent.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.CUDA.Persistent -- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee@@ -8,7 +9,7 @@ -- -- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au> -- Stability : experimental--- Portability : non-partable (GHC extensions)+-- Portability : non-portable (GHC extensions) -- module Data.Array.Accelerate.CUDA.Persistent (@@ -24,16 +25,20 @@ import qualified Data.Array.Accelerate.CUDA.FullList as FL -- libraries-import Prelude hiding ( lookup, catch )+import Prelude hiding ( lookup )+import Numeric import Data.Char import System.IO import System.FilePath import System.Directory-import System.Process ( ProcessHandle )-import Control.Exception+import System.IO.Error import Control.Applicative+import Control.Concurrent+import Control.Exception import Control.Monad.Trans+import Data.Version import Data.Binary+import Data.Hashable import Data.Binary.Get import Data.ByteString ( ByteString ) import Data.ByteString.Internal ( w2c )@@ -42,11 +47,19 @@ import qualified Data.HashTable.IO as HT import qualified Foreign.CUDA.Driver as CUDA-import qualified Foreign.CUDA.Analysis as CUDA import Paths_accelerate_cuda +instance Hashable CUDA.Compute where+ hashWithSalt salt (CUDA.Compute major minor)+ = salt `hashWithSalt` major `hashWithSalt` minor++instance Binary CUDA.Compute where+ put (CUDA.Compute major minor) = put major >> put minor+ get = CUDA.Compute <$> get <*> get++ -- Interface ------------------------------------------------------------------- -- --------- -- @@ -68,7 +81,7 @@ -- the persistent cache, it is loaded and linked into the current context. -- lookup :: KernelTable -> KernelKey -> IO (Maybe KernelEntry)-lookup (KT kt pt) key = do+lookup (KT kt pt) !key = do -- First check the local cache. If we get a hit, this could be: -- a) currently compiling -- b) compiled, but not linked into the current context@@ -107,7 +120,7 @@ -- entries are added, which the functions currently do not do. -- insert :: KernelTable -> KernelKey -> KernelEntry -> IO ()-insert (KT kt _) key val = HT.insert kt key val+insert (KT kt _) !key !val = HT.insert kt key val -- Local cache -----------------------------------------------------------------@@ -135,10 +148,11 @@ type KernelKey = (CUDA.Compute, ByteString) data KernelEntry- -- A currently compiling external process. We record the process ID and the- -- path of the .cu file being compiled+ -- A currently compiling external process. We record the path of the .cu file+ -- being compiled, and an MVar that will be filled upon completion. --- = CompileProcess !FilePath !ProcessHandle+ = CompileProcess !FilePath+ {-# UNPACK #-} !(MVar ()) -- The raw compiled data, and the list of contexts that the object has already -- been linked into. If we locate this entry in the ProgramCache, it may have@@ -164,28 +178,82 @@ -- The root directory of where the various persistent cache files live; the--- database and each individual binary object.+-- database and each individual binary object. This is inside a folder at the+-- root of the user's home directory. ----- TLM: Is this writeable, even at a 'cabal instal --global'? Maybe we should--- specifically choose something in the user's home directory.+-- Some platforms may have directories assigned to store cache files; Mac OS X+-- uses ~/Library/Caches, for example. This fact is ignored. -- cacheDirectory :: IO FilePath cacheDirectory = do- dir <- canonicalizePath =<< getDataDir- return $ dir </> "cache"+ home <- getAppUserDataDirectory "accelerate"+ return $ home </> "accelerate-cuda-" ++ showVersion version </> "cache" + -- A relative path to be appended to (presumably) 'cacheDirectory'. -- cacheFilePath :: KernelKey -> FilePath-cacheFilePath (cap, key) = show cap </> foldl (flip (mangle . w2c)) ".cubin" (B.unpack key)+cacheFilePath (cap, key) =+ show cap </> zEncodeString (B.foldl (flip (showLitChar . w2c)) [] key)++-- stolen from compiler/utils/Encoding.hs+--+type EncodedString = String++zEncodeString :: String -> EncodedString+zEncodeString [] = []+zEncodeString (h:rest) = encode_digit h ++ go rest where- -- TODO: complete z-encoding? see: compiler/utils/Encoding.hs- --- mangle '\\' = ("zr" ++)- mangle '/' = ("zs" ++)- mangle c = showLitChar c+ go [] = []+ go (c:cs) = encode_ch c ++ go cs +unencodedChar :: Char -> Bool+unencodedChar 'z' = False+unencodedChar 'Z' = False+unencodedChar c = isAlphaNum c +encode_digit :: Char -> EncodedString+encode_digit c | isDigit c = encode_as_unicode_char c+ | otherwise = encode_ch c++encode_ch :: Char -> EncodedString+encode_ch c | unencodedChar c = [c] -- Common case first+encode_ch '(' = "ZL"+encode_ch ')' = "ZR"+encode_ch '[' = "ZM"+encode_ch ']' = "ZN"+encode_ch ':' = "ZC"+encode_ch 'Z' = "ZZ"+encode_ch 'z' = "zz"+encode_ch '&' = "za"+encode_ch '|' = "zb"+encode_ch '^' = "zc"+encode_ch '$' = "zd"+encode_ch '=' = "ze"+encode_ch '>' = "zg"+encode_ch '#' = "zh"+encode_ch '.' = "zi"+encode_ch '<' = "zl"+encode_ch '-' = "zm"+encode_ch '!' = "zn"+encode_ch '+' = "zp"+encode_ch '\'' = "zq"+encode_ch '\\' = "zr"+encode_ch '/' = "zs"+encode_ch '*' = "zt"+encode_ch '_' = "zu"+encode_ch '%' = "zv"+encode_ch c = encode_as_unicode_char c++encode_as_unicode_char :: Char -> EncodedString+encode_as_unicode_char c+ = 'z'+ : if isDigit (head hex_str) then hex_str+ else '0':hex_str+ where+ hex_str = showHex (ord c) "U"++ -- The default Binary instance for lists is (necessarily) spine and value -- strict for efficiency. For us it is better if we just lazily consume elements -- and add them directly to the hash table so they can be collected as we go.@@ -206,7 +274,7 @@ restore :: FilePath -> IO PersistentCache restore db = do D.when D.flush_cache $ do- message $ "deleting persistent cache"+ message "deleting persistent cache" cacheDir <- cacheDirectory removeDirectoryRecursive cacheDir createDirectoryIfMissing True cacheDir@@ -224,7 +292,7 @@ -- message $ "persist/restore: " ++ shows n " entries" go (runGet (getMany n) rest)- pt `seq` return pt+ evaluate pt -- Append a single value to the persistent cache.@@ -233,7 +301,7 @@ -- location, and updates the database on disk. -- persist :: FilePath -> KernelKey -> IO ()-persist cubin key = do+persist !cubin !key = do cacheDir <- cacheDirectory let db = cacheDir </> "persistent.db" cacheFile = cacheDir </> cacheFilePath key@@ -244,7 +312,7 @@ -- If the temporary and cache directories are on different disks, we must -- copy the file instead. Unsupported operation: (Cross-device link) --- `catch` \(_ :: IOError) -> do+ `catchIOError` \_ -> do copyFile cubin cacheFile removeFile cubin --@@ -253,7 +321,7 @@ -- n <- runGet (get :: Get Int) `fmap` L.hGet h 8 hSeek h AbsoluteSeek 0- L.hPut h $ encode (n+1)+ L.hPut h (encode (n+1)) -- Append the new entry to the end of file --
Data/Array/Accelerate/CUDA/State.hs view
@@ -1,8 +1,5 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeOperators #-}-{-# OPTIONS_GHC -fno-warn-orphans #-} -- Eq CUDA.Context+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | -- Module : Data.Array.Accelerate.CUDA.State -- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee@@ -11,7 +8,7 @@ -- -- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au> -- Stability : experimental--- Portability : non-partable (GHC extensions)+-- Portability : non-portable (GHC extensions) -- -- This module defines a state monad token which keeps track of the code -- generator state, including memory transfers and external compilation@@ -21,64 +18,66 @@ module Data.Array.Accelerate.CUDA.State ( -- Evaluating computations- CIO, evalCUDA,+ CIO, Context, evalCUDA, -- Querying execution state- defaultContext, deviceProps, activeContext, kernelTable, memoryTable+ defaultContext, deviceProperties, activeContext, kernelTable, memoryTable ) where -- friends-import Data.Array.Accelerate.CUDA.Debug ( message, verbose, dump_gc, showFFloatSIBase )+import Data.Array.Accelerate.CUDA.Context+import Data.Array.Accelerate.CUDA.Debug ( message, dump_gc ) import Data.Array.Accelerate.CUDA.Persistent as KT import Data.Array.Accelerate.CUDA.Array.Table as MT import Data.Array.Accelerate.CUDA.Analysis.Device -- library-import Data.Label-import Control.Exception-import Control.Concurrent ( forkIO, threadDelay )-import Control.Monad.State.Strict ( StateT(..), evalStateT )+import Control.Applicative ( Applicative )+import Control.Exception ( bracket_ )+import Control.Monad.Trans ( MonadIO )+import Control.Monad.Reader ( MonadReader, ReaderT(..), runReaderT )+import Control.Monad.State.Strict ( MonadState, StateT(..), evalStateT ) import System.Mem ( performGC )-import System.Mem.Weak ( mkWeakPtr, addFinalizer ) import System.IO.Unsafe ( unsafePerformIO )-import Text.PrettyPrint-import qualified Foreign.CUDA.Driver as CUDA hiding ( device )-import qualified Foreign.CUDA.Driver.Context as CUDA+import qualified Foreign.CUDA.Driver as CUDA --- The state token for CUDA accelerated array operations+-- Execution State+-- ---------------++-- The state token for CUDA accelerated array operations. This is a stack of+-- (read only) device properties and context, and mutable state for tracking+-- device memory and kernel object code. ---type CIO = StateT CUDAState IO-data CUDAState = CUDAState- {- _deviceProps :: !CUDA.DeviceProperties,- _activeContext :: {-# UNPACK #-} !Context,- _kernelTable :: {-# UNPACK #-} !KernelTable,- _memoryTable :: {-# UNPACK #-} !MemoryTable+data State = State {+ memoryTable :: {-# UNPACK #-} !MemoryTable, -- host/device memory associations+ kernelTable :: {-# UNPACK #-} !KernelTable -- compiled kernel object code } -instance Eq CUDA.Context where- CUDA.Context p1 == CUDA.Context p2 = p1 == p2--$(mkLabels [''CUDAState])+newtype CIO a = CIO {+ runCIO :: ReaderT Context (StateT State IO) a+ }+ deriving ( Functor, Applicative, Monad, MonadIO+ , MonadReader Context, MonadState State ) --- Execution State--- ---------------+-- Extract the active context from the execution state+--+{-# INLINE activeContext #-}+activeContext :: Context -> Context+activeContext = id -- |Evaluate a CUDA array computation ---evalCUDA :: CUDA.Context -> CIO a -> IO a-evalCUDA ctx acc = bracket setup teardown $ evalStateT acc+{-# NOINLINE evalCUDA #-}+evalCUDA :: Context -> CIO a -> IO a+evalCUDA !ctx !acc+ = bracket_ setup teardown+ $ evalStateT (runReaderT (runCIO acc) ctx) theState where- teardown _ = CUDA.pop >> performGC- setup = do- CUDA.push ctx- dev <- CUDA.device- prp <- CUDA.props dev- weak_ctx <- mkWeakPtr ctx Nothing- return $! CUDAState prp (Context ctx weak_ctx) theKernelTable theMemoryTable+ teardown = CUDA.pop >> performGC+ setup = push ctx -- Top-level mutable state@@ -88,19 +87,14 @@ -- program, not just a single execution. These tokens use unsafePerformIO to -- ensure they are executed only once, and reused for subsequent invocations. ----{-# NOINLINE theMemoryTable #-}-theMemoryTable :: MemoryTable-theMemoryTable = unsafePerformIO $ do- message dump_gc "gc: initialise memory table"- keepAlive =<< MT.new---{-# NOINLINE theKernelTable #-}-theKernelTable :: KernelTable-theKernelTable = unsafePerformIO $ do- message dump_gc "gc: initialise kernel table"- keepAlive =<< KT.new+{-# NOINLINE theState #-}+theState :: State+theState+ = unsafePerformIO+ $ do message dump_gc "gc: initialise CUDA state"+ mtb <- keepAlive =<< MT.new+ ktb <- keepAlive =<< KT.new+ return $! State mtb ktb -- Select and initialise a default CUDA device, and create a new execution@@ -108,57 +102,10 @@ -- maximum throughput. -- {-# NOINLINE defaultContext #-}-defaultContext :: CUDA.Context+defaultContext :: Context defaultContext = unsafePerformIO $ do+ message dump_gc "gc: initialise default context" CUDA.initialise []- (dev,prp) <- selectBestDevice- ctx <- CUDA.create dev [CUDA.SchedAuto] >> CUDA.pop- --- message dump_gc $ "gc: initialise context"- message verbose $ deviceInfo dev prp- --- addFinalizer ctx $ do- message dump_gc $ "gc: finalise context" -- should never happen!- CUDA.destroy ctx- --- keepAlive ctx----- Make sure the GC knows that we want to keep this thing alive past the end of--- 'evalCUDA'.------ We may want to introduce some way to actually shut this down if, for example,--- the object has not been accessed in a while, and so let it be collected.----keepAlive :: a -> IO a-keepAlive x = forkIO (caffeine x) >> return x- where- caffeine hit = do threadDelay 5000000 -- microseconds = 5 seconds- caffeine hit----- Debugging--- ------------- Nicely format a summary of the selected CUDA device, example:------ Device 0: GeForce 9600M GT (compute capability 1.1)--- 4 multiprocessors @ 1.25GHz (32 cores), 512MB global memory----deviceInfo :: CUDA.Device -> CUDA.DeviceProperties -> String-deviceInfo dev prp = render $- devID <> colon <+> vcat [ name <+> parens compute- , processors <+> at <+> text clock <+> parens cores <> comma <+> memory- ]- where- name = text (CUDA.deviceName prp)- compute = text "compute capatability" <+> double (CUDA.computeCapability prp)- devID = text "Device" <+> int (fromIntegral $ CUDA.useDevice dev) -- hax- processors = int (CUDA.multiProcessorCount prp) <+> text "multiprocessors"- cores = int (CUDA.multiProcessorCount prp * coresPerMultiProcessor prp) <+> text "cores"- memory = text mem <+> text "global memory"- --- clock = showFFloatSIBase (Just 2) 1000 (fromIntegral $ CUDA.clockRate prp * 1000 :: Double) "Hz"- mem = showFFloatSIBase (Just 0) 1024 (fromIntegral $ CUDA.totalGlobalMem prp :: Double) "B"- at = char '@'+ (dev,_) <- selectBestDevice+ create dev [CUDA.SchedAuto]
Data/Array/Accelerate/Internal/Check.hs view
@@ -18,12 +18,13 @@ -- * Bounds checking and assertion infrastructure Checks(..), doChecks,- error, check, assert, checkIndex, checkLength, checkSlice+ error, check, warning, assert, checkIndex, checkLength, checkSlice ) where -import Prelude hiding( error )-import qualified Prelude as P+import Prelude hiding ( error )+import Debug.Trace+import qualified Prelude as P data Checks = Bounds | Unsafe | Internal deriving( Eq ) @@ -55,21 +56,33 @@ doChecks Unsafe = doUnsafeChecks doChecks Internal = doInternalChecks +message :: String -> Int -> Checks -> String -> String -> String+{-# INLINE message #-}+message file line kind loc msg+ = unlines+ $ (if kind == Internal+ then ([""+ ,"*** Internal error in package accelerate ***"+ ,"*** Please submit a bug report at https://github.com/AccelerateHS/accelerate/issues"]++)+ else id)+ [ file ++ ":" ++ show line ++ " (" ++ loc ++ "): " ++ msg ]+ error :: String -> Int -> Checks -> String -> String -> a+{-# INLINE error #-} error file line kind loc msg- = P.error . unlines $- (if kind == Internal- then ([""- ,"*** Internal error in package accelerate-cuda ***"- ,"*** Please submit a bug report at https://github.com/AccelerateHS/accelerate/issues"]++)- else id)- [ file ++ ":" ++ show line ++ " (" ++ loc ++ "): " ++ msg ]+ = P.error (message file line kind loc msg) check :: String -> Int -> Checks -> String -> String -> Bool -> a -> a {-# INLINE check #-} check file line kind loc msg cond x | not (doChecks kind) || cond = x | otherwise = error file line kind loc msg++warning :: String -> Int -> Checks -> String -> String -> Bool -> a -> a+{-# INLINE warning #-}+warning file line kind loc msg cond x+ | not (doChecks kind) || cond = x+ | otherwise = trace (message file line kind loc msg) x assert_msg :: String assert_msg = "assertion failure"
Setup.hs view
@@ -1,4 +1,20 @@ #! /usr/bin/env runhaskell +import Control.Monad import Distribution.Simple-main = defaultMainWithHooks autoconfUserHooks+import Distribution.Simple.Setup+import Distribution.Simple.Utils+import System.Directory++main :: IO ()+main = defaultMainWithHooks autoconfUserHooks { preConf = preConfHook }+ where+ preConfHook args flags = do+ let verbosity = fromFlag (configVerbosity flags)++ confExists <- doesFileExist "configure"+ unless confExists $+ rawSystemExit verbosity "autoconf" []++ preConf autoconfUserHooks args flags+
accelerate-cuda.cabal view
@@ -1,29 +1,41 @@ Name: accelerate-cuda-Version: 0.12.1.2+Version: 0.13.0.0 Cabal-version: >= 1.6 Tested-with: GHC >= 7.4-Build-type: Configure+Build-type: Custom Synopsis: Accelerate backend for NVIDIA GPUs Description:- This library implements a backend for the Accelerate language instrumented for- parallel execution on CUDA-capable NVIDIA GPUs.+ This library implements a backend for the /Accelerate/ language instrumented+ for parallel execution on CUDA-capable NVIDIA GPUs. For further information,+ refer to the main /Accelerate/ package:+ <http://hackage.haskell.org/package/accelerate> .- To use this backend you need CUDA version 3.x or later installed, which you- can find at the NVIDIA Developer Zone.+ To use this backend you will need: .- <http://developer.nvidia.com/cuda-downloads>+ 1. A CUDA-enabled NVIDIA GPU with, for full functionality, compute+ capability 1.2 or greater. See the table on Wikipedia for supported GPUs:+ <http://en.wikipedia.org/wiki/CUDA#Supported_GPUs> .+ 2. The CUDA SDK, available from the NVIDIA Developer Zone:+ <http://developer.nvidia.com/cuda-downloads>+ .+ See the Haddock documentation for additional information related to using this+ backend.+ .+ Compile modules that use the CUDA backend with the @-threaded@ flag.+ . License: BSD3 License-file: LICENSE Author: Manuel M T Chakravarty,+ Robert Clifton-Everest, Gabriele Keller, Sean Lee, Trevor L. McDonell Maintainer: Trevor L. McDonell <tmcdonell@cse.unsw.edu.au> Bug-reports: https://github.com/AccelerateHS/accelerate/issues-Homepage: http://www.cse.unsw.edu.au/~chak/project/accelerate/+Homepage: https://github.com/AccelerateHS/accelerate-cuda/ Category: Compilers/Interpreters, Concurrency, Data, Parallelism Stability: Experimental@@ -84,55 +96,62 @@ Default: False Library- Include-Dirs: include+ include-dirs: include - Build-depends: accelerate >= 0.12.1 && < 0.13,- array >= 0.3 && < 0.5,+ build-depends: accelerate == 0.13.*, base == 4.*,- binary >= 0.5,- bytestring >= 0.9,- containers >= 0.4,- cryptohash >= 0.7,- cuda >= 0.4.1 && < 0.5,- directory >= 1.0,- fclabels >= 1.0,- filepath >= 1.0,- hashable >= 1.1,- hashtables >= 1.0.1,- language-c-quote >= 0.4,- mainland-pretty >= 0.2,- mtl >= 2.0,- pretty >= 1.0,- process >= 1.0,- srcloc >= 0.2,- text >= 0.11,- transformers >= 0.2,- unordered-containers >= 0.1.4+ array >= 0.3 && < 0.5,+ binary >= 0.5 && < 0.7,+ bytestring >= 0.9 && < 0.11,+ cryptohash >= 0.7 && < 0.10,+ cuda >= 0.5.0.2 && < 0.6,+ directory >= 1.0 && < 1.3,+ fclabels >= 1.0 && < 1.2,+ filepath >= 1.0 && < 1.4,+ hashable >= 1.1 && < 1.3,+ hashtables >= 1.0 && < 1.2,+ language-c-quote >= 0.4.4 && < 0.8,+ mainland-pretty >= 0.2 && < 0.3,+ mtl >= 2.0 && < 2.2,+ old-time >= 1.0 && < 1.2,+ pretty >= 1.0 && < 1.2,+ process >= 1.0 && < 1.2,+ SafeSemaphore >= 0.9 && < 0.10,+ srcloc >= 0.2 && < 0.5,+ text >= 0.11 && < 0.12,+ transformers >= 0.2 && < 0.4,+ unordered-containers >= 0.1.4 && < 0.3 if os(windows)+ cpp-options: -DWIN32 build-depends: Win32 >= 2.2.1 else+ cpp-options: -DUNIX build-depends: unix >= 2.4 Exposed-modules: Data.Array.Accelerate.CUDA+ Data.Array.Accelerate.CUDA.Foreign - Other-modules: Data.Array.Accelerate.CUDA.Analysis.Device+ Other-modules: Data.Array.Accelerate.CUDA.AST+ Data.Array.Accelerate.CUDA.Analysis.Device Data.Array.Accelerate.CUDA.Analysis.Launch Data.Array.Accelerate.CUDA.Array.Data+ Data.Array.Accelerate.CUDA.Array.Nursery Data.Array.Accelerate.CUDA.Array.Prim Data.Array.Accelerate.CUDA.Array.Sugar Data.Array.Accelerate.CUDA.Array.Table+ Data.Array.Accelerate.CUDA.Async Data.Array.Accelerate.CUDA.CodeGen Data.Array.Accelerate.CUDA.CodeGen.Base- Data.Array.Accelerate.CUDA.CodeGen.Monad- Data.Array.Accelerate.CUDA.CodeGen.Mapping Data.Array.Accelerate.CUDA.CodeGen.IndexSpace+ Data.Array.Accelerate.CUDA.CodeGen.Mapping+ Data.Array.Accelerate.CUDA.CodeGen.Monad Data.Array.Accelerate.CUDA.CodeGen.PrefixSum Data.Array.Accelerate.CUDA.CodeGen.Reduction Data.Array.Accelerate.CUDA.CodeGen.Stencil Data.Array.Accelerate.CUDA.CodeGen.Type- Data.Array.Accelerate.CUDA.AST Data.Array.Accelerate.CUDA.Compile+ Data.Array.Accelerate.CUDA.Context Data.Array.Accelerate.CUDA.Debug Data.Array.Accelerate.CUDA.Execute Data.Array.Accelerate.CUDA.FullList@@ -157,21 +176,11 @@ -Wall -fwarn-tabs - Extensions: BangPatterns,- CPP,- ExistentialQuantification,- FlexibleContexts,- FlexibleInstances,- GADTs,- PatternGuards,- QuasiQuotes,- RankNTypes,- ScopedTypeVariables,- TemplateHaskell,- TupleSections,- TypeFamilies,- TypeOperators,- TypeSynonymInstances+ -- Don't add the extensions list here. Instead, place individual LANGUAGE+ -- pragmas in the files that require a specific extension. This means the+ -- project loads in GHCi, and avoids extension clashes.+ --+ -- Extensions: source-repository head type: git
cubits/accelerate_cuda_function.h view
@@ -48,6 +48,31 @@ return x > 0 && y < 0 ? (x - y - 1) / y : (x < 0 && y > 0 ? (x - y + 1) / y : x / y); } +template <>+static __inline__ __device__ Word8 idiv(const Word8 x, const Word8 y)+{+ return x / y;+}++template <>+static __inline__ __device__ Word16 idiv(const Word16 x, const Word16 y)+{+ return x / y;+}++template <>+static __inline__ __device__ Word32 idiv(const Word32 x, const Word32 y)+{+ return x / y;+}++template <>+static __inline__ __device__ Word64 idiv(const Word64 x, const Word64 y)+{+ return x / y;+}++ /* * Integer modulus, Haskell style */@@ -58,7 +83,32 @@ return x > 0 && y < 0 || x < 0 && y > 0 ? (r != 0 ? r + y : 0) : r; } +template <>+static __inline__ __device__ Word8 mod(const Word8 x, const Word8 y)+{+ return x % y;+} +template <>+static __inline__ __device__ Word16 mod(const Word16 x, const Word16 y)+{+ return x % y;+}++template <>+static __inline__ __device__ Word32 mod(const Word32 x, const Word32 y)+{+ return x % y;+}++template <>+static __inline__ __device__ Word64 mod(const Word64 x, const Word64 y)+{+ return x % y;+}+++ /* * Type coercion */@@ -72,6 +122,12 @@ } template <>+static __inline__ __device__ Word32 reinterpret32(const Word32 x)+{+ return x;+}++template <> static __inline__ __device__ Word32 reinterpret32(const float x) { return __float_as_int(x);@@ -86,6 +142,12 @@ return u.b; } +template <>+static __inline__ __device__ Word64 reinterpret64(const Word64 x)+{+ return x;+}+ #if !defined(__CUDA_ARCH__) || __CUDA_ARCH__ >= 130 template <> static __inline__ __device__ Word64 reinterpret64(const double x)@@ -137,6 +199,86 @@ return atomicCAS(address, compare, val); } #endif+++#if !defined(__CUDA_ARCH__) || __CUDA_ARCH__ >= 300+/*+ * Warp shuffle functions+ */+template <typename T>+static __inline__ __device__ T shfl_up32(T var, unsigned int delta, int width=warpSize)+{+ union { T a; Int32 b; } u, v;++ v.a = var;+ u.b = __shfl_up(v.b, delta, warpSize);++ return u.a;+}++template <>+static __inline__ __device__ int shfl_up32(int var, unsigned int delta, int width)+{+ return __shfl_up(var, delta, width);+}++template <>+static __inline__ __device__ float shfl_up32(float var, unsigned int delta, int width)+{+ return __shfl_up(var, delta, width);+}+++template <typename T>+static __inline__ __device__ T shfl_up64(T var, unsigned int delta, int width=warpSize)+{+ union { T a; struct { Int32 lo; Int32 hi; }; } u, v;++ v.a = var;+ u.lo = __shfl_up(v.lo, delta, warpSize);+ u.hi = __shfl_up(v.hi, delta, warpSize);++ return u.a;+}+++template <typename T>+static __inline__ __device__ T shfl_xor32(T var, int laneMask, int width=warpSize)+{+ union { T a; Int32 b; } u, v;++ v.a = var;+ u.b = __shfl_xor(v.b, laneMask, warpSize);++ return u.a;+}++template <>+static __inline__ __device__ int shfl_xor32(int var, int laneMask, int width)+{+ return __shfl_xor(var, laneMask, width);+}++template <>+static __inline__ __device__ float shfl_xor32(float var, int laneMask, int width)+{+ return __shfl_xor(var, laneMask, width);+}+++template <typename T>+static __inline__ __device__ T shfl_xor64(T var, int laneMask, int width=warpSize)+{+ union { T a; struct { Int32 lo; Int32 hi; }; } u, v;++ v.a = var;+ u.lo = __shfl_xor(v.lo, laneMask, warpSize);+ u.hi = __shfl_xor(v.hi, laneMask, warpSize);++ return u.a;+}+#endif+ #if 0 /* -----------------------------------------------------------------------------
cubits/accelerate_cuda_shape.h view
@@ -23,7 +23,7 @@ * future hardware gains better 64-bit support and/or we need to access very * large arrays. *- * typedef Int32 Ix;+ * typedef Int64 Ix; */ typedef Int32 Ix; typedef void* DIM0;