diff --git a/Data/Array/Accelerate/CUDA.hs b/Data/Array/Accelerate/CUDA.hs --- a/Data/Array/Accelerate/CUDA.hs +++ b/Data/Array/Accelerate/CUDA.hs @@ -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 @@ -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: . -- 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 diff --git a/Data/Array/Accelerate/CUDA/AST.hs b/Data/Array/Accelerate/CUDA/AST.hs --- a/Data/Array/Accelerate/CUDA/AST.hs +++ b/Data/Array/Accelerate/CUDA/AST.hs @@ -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 -- 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 diff --git a/Data/Array/Accelerate/CUDA/Analysis/Device.hs b/Data/Array/Accelerate/CUDA/Analysis/Device.hs --- a/Data/Array/Accelerate/CUDA/Analysis/Device.hs +++ b/Data/Array/Accelerate/CUDA/Analysis/Device.hs @@ -6,7 +6,7 @@ -- -- Maintainer : Trevor L. McDonell -- 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 diff --git a/Data/Array/Accelerate/CUDA/Analysis/Launch.hs b/Data/Array/Accelerate/CUDA/Analysis/Launch.hs --- a/Data/Array/Accelerate/CUDA/Analysis/Launch.hs +++ b/Data/Array/Accelerate/CUDA/Analysis/Launch.hs @@ -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 -- 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) diff --git a/Data/Array/Accelerate/CUDA/Array/Data.hs b/Data/Array/Accelerate/CUDA/Array/Data.hs --- a/Data/Array/Accelerate/CUDA/Array/Data.hs +++ b/Data/Array/Accelerate/CUDA/Array/Data.hs @@ -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 @@ -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) - diff --git a/Data/Array/Accelerate/CUDA/Array/Nursery.hs b/Data/Array/Accelerate/CUDA/Array/Nursery.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/CUDA/Array/Nursery.hs @@ -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 +-- 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 () + diff --git a/Data/Array/Accelerate/CUDA/Array/Prim.hs b/Data/Array/Accelerate/CUDA/Array/Prim.hs --- a/Data/Array/Accelerate/CUDA/Array/Prim.hs +++ b/Data/Array/Accelerate/CUDA/Array/Prim.hs @@ -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 @@ -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 diff --git a/Data/Array/Accelerate/CUDA/Array/Table.hs b/Data/Array/Accelerate/CUDA/Array/Table.hs --- a/Data/Array/Accelerate/CUDA/Array/Table.hs +++ b/Data/Array/Accelerate/CUDA/Array/Table.hs @@ -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 diff --git a/Data/Array/Accelerate/CUDA/Async.hs b/Data/Array/Accelerate/CUDA/Async.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/CUDA/Async.hs @@ -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 +-- 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 + diff --git a/Data/Array/Accelerate/CUDA/CodeGen.hs b/Data/Array/Accelerate/CUDA/CodeGen.hs --- a/Data/Array/Accelerate/CUDA/CodeGen.hs +++ b/Data/Array/Accelerate/CUDA/CodeGen.hs @@ -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 ") |] - 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 diff --git a/Data/Array/Accelerate/CUDA/CodeGen/Base.hs b/Data/Array/Accelerate/CUDA/CodeGen/Base.hs --- a/Data/Array/Accelerate/CUDA/CodeGen/Base.hs +++ b/Data/Array/Accelerate/CUDA/CodeGen/Base.hs @@ -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 -- 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 diff --git a/Data/Array/Accelerate/CUDA/CodeGen/IndexSpace.hs b/Data/Array/Accelerate/CUDA/CodeGen/IndexSpace.hs --- a/Data/Array/Accelerate/CUDA/CodeGen/IndexSpace.hs +++ b/Data/Array/Accelerate/CUDA/CodeGen/IndexSpace.hs @@ -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 ") + $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 ") + $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 ") $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 diff --git a/Data/Array/Accelerate/CUDA/CodeGen/Mapping.hs b/Data/Array/Accelerate/CUDA/CodeGen/Mapping.hs --- a/Data/Array/Accelerate/CUDA/CodeGen/Mapping.hs +++ b/Data/Array/Accelerate/CUDA/CodeGen/Mapping.hs @@ -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 ") + $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"] diff --git a/Data/Array/Accelerate/CUDA/CodeGen/Monad.hs b/Data/Array/Accelerate/CUDA/CodeGen/Monad.hs --- a/Data/Array/Accelerate/CUDA/CodeGen/Monad.hs +++ b/Data/Array/Accelerate/CUDA/CodeGen/Monad.hs @@ -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 diff --git a/Data/Array/Accelerate/CUDA/CodeGen/PrefixSum.hs b/Data/Array/Accelerate/CUDA/CodeGen/PrefixSum.hs --- a/Data/Array/Accelerate/CUDA/CodeGen/PrefixSum.hs +++ b/Data/Array/Accelerate/CUDA/CodeGen/PrefixSum.hs @@ -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 ") + $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 ") + $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" +--} diff --git a/Data/Array/Accelerate/CUDA/CodeGen/Reduction.hs b/Data/Array/Accelerate/CUDA/CodeGen/Reduction.hs --- a/Data/Array/Accelerate/CUDA/CodeGen/Reduction.hs +++ b/Data/Array/Accelerate/CUDA/CodeGen/Reduction.hs @@ -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 ") + $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 ") + $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 ") + $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")) + } |] + : [] diff --git a/Data/Array/Accelerate/CUDA/CodeGen/Stencil.hs b/Data/Array/Accelerate/CUDA/CodeGen/Stencil.hs --- a/Data/Array/Accelerate/CUDA/CodeGen/Stencil.hs +++ b/Data/Array/Accelerate/CUDA/CodeGen/Stencil.hs @@ -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 ") $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 ") $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 diff --git a/Data/Array/Accelerate/CUDA/CodeGen/Type.hs b/Data/Array/Accelerate/CUDA/CodeGen/Type.hs --- a/Data/Array/Accelerate/CUDA/CodeGen/Type.hs +++ b/Data/Array/Accelerate/CUDA/CodeGen/Type.hs @@ -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" diff --git a/Data/Array/Accelerate/CUDA/Compile.hs b/Data/Array/Accelerate/CUDA/Compile.hs --- a/Data/Array/Accelerate/CUDA/Compile.hs +++ b/Data/Array/Accelerate/CUDA/Compile.hs @@ -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 -- 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 () diff --git a/Data/Array/Accelerate/CUDA/Context.hs b/Data/Array/Accelerate/CUDA/Context.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/CUDA/Context.hs @@ -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 +-- 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" + diff --git a/Data/Array/Accelerate/CUDA/Debug.hs b/Data/Array/Accelerate/CUDA/Debug.hs --- a/Data/Array/Accelerate/CUDA/Debug.hs +++ b/Data/Array/Accelerate/CUDA/Debug.hs @@ -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 -- 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 diff --git a/Data/Array/Accelerate/CUDA/Execute.hs b/Data/Array/Accelerate/CUDA/Execute.hs --- a/Data/Array/Accelerate/CUDA/Execute.hs +++ b/Data/Array/Accelerate/CUDA/Execute.hs @@ -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 --- 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 +-- 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 diff --git a/Data/Array/Accelerate/CUDA/Foreign.hs b/Data/Array/Accelerate/CUDA/Foreign.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/CUDA/Foreign.hs @@ -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 +-- 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 + diff --git a/Data/Array/Accelerate/CUDA/FullList.hs b/Data/Array/Accelerate/CUDA/FullList.hs --- a/Data/Array/Accelerate/CUDA/FullList.hs +++ b/Data/Array/Accelerate/CUDA/FullList.hs @@ -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 -- 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_ #-} diff --git a/Data/Array/Accelerate/CUDA/Persistent.hs b/Data/Array/Accelerate/CUDA/Persistent.hs --- a/Data/Array/Accelerate/CUDA/Persistent.hs +++ b/Data/Array/Accelerate/CUDA/Persistent.hs @@ -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 -- 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 -- diff --git a/Data/Array/Accelerate/CUDA/State.hs b/Data/Array/Accelerate/CUDA/State.hs --- a/Data/Array/Accelerate/CUDA/State.hs +++ b/Data/Array/Accelerate/CUDA/State.hs @@ -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 -- 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] diff --git a/Data/Array/Accelerate/Internal/Check.hs b/Data/Array/Accelerate/Internal/Check.hs --- a/Data/Array/Accelerate/Internal/Check.hs +++ b/Data/Array/Accelerate/Internal/Check.hs @@ -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" diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -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 + diff --git a/accelerate-cuda.cabal b/accelerate-cuda.cabal --- a/accelerate-cuda.cabal +++ b/accelerate-cuda.cabal @@ -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: + . - 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: . - + 1. A CUDA-enabled NVIDIA GPU with, for full functionality, compute + capability 1.2 or greater. See the table on Wikipedia for supported GPUs: + . + 2. The CUDA SDK, available from the NVIDIA Developer Zone: + + . + 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 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 diff --git a/cubits/accelerate_cuda_function.h b/cubits/accelerate_cuda_function.h --- a/cubits/accelerate_cuda_function.h +++ b/cubits/accelerate_cuda_function.h @@ -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 +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 +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 +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 +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 /* ----------------------------------------------------------------------------- diff --git a/cubits/accelerate_cuda_shape.h b/cubits/accelerate_cuda_shape.h --- a/cubits/accelerate_cuda_shape.h +++ b/cubits/accelerate_cuda_shape.h @@ -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;