diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -7,37 +7,113 @@ Policy (PVP)](https://pvp.haskell.org) +## [1.4.0.0] - ? +### Changed + * Support for LLVM-16 to 22. + * Use shuffle instructions for faster warp-level folds and scans. + * Support new compute capabilities. + +### Fixed + * Device memory was deallocated too early or overwritten [accelerate-llvm#111] + * CUDA Context double free [accelerate-llvm#113] + * Execution of stencil boundaries were not properly synchronised + * Scans sometimes gave incorrect results + * Various other small correctness issues + +### Contributors + +Special thanks to those who contributed patches as part of this release: + + * Trevor L. McDonell (@tmcdonell) + * Tom Smeding (@tomsmeding) + * David van Balen (@dpvanbalen) + * Ivo Gabe de Wolff (@ivogabe) + * Michael Swam (@michael-swan) + * Travis Whitaker (@TravisWhitaker) + * Noah Williams (@noahmartinwilliams) + * Robbert van der Helm (@robbert-vdh) + * Jann Müller (@j-mueller) + +## [1.3.0.0] - 2018-08-27 +### Changed + * Code generation improvements for stencil operations + +### Fixed + * Segmented folds crash or give inconsistent results ([accelerate#423]) + * Synchronisation problems on SM7+ [#436] + +### Contributors + +Special thanks to those who contributed patches as part of this release: + + * Trevor L. McDonell (@tmcdonell) + * Josh Meredith (@JoshMeredith) + * Ivo Gabe de Wolff (@ivogabe) + * Lars van den Haak (@sakehl) + * Joshua Meredith (@JoshMeredith) + + +## [1.2.0.0] - 2018-04-03 +### Changed + * `run` variants which do not take an explicit execution context now execute on + the first available device in an exclusive fashion. Multi-GPU systems can + specify the default set of GPUs to use with environment variable + `ACCELERATE_LLVM_PTX_DEVICES` as a list of device ordinals. + +### Added + * support for half-precision floats + * support for struct-of-array-of-struct representations + * support 64-bit atomic-add instruction in forward permutations ([#363]) + * support for LLVM-6.0 + * support for GHC-8.4 + +### Contributors + +Special thanks to those who contributed patches as part of this release: + + * Trevor L. McDonell (@tmcdonell) + * Moritz Kiefer (@cocreature) + + ## [1.1.0.1] - 2018-01-08 ### Fixed - * add support for building with CUDA-9.x + * add support for building with CUDA-9.x + ## [1.1.0.0] - 2017-09-21 ### Added - * support for GHC-8.2 - * caching of compilation results ([accelerate-llvm#17]) - * support for ahead-of-time compilation (`runQ` and `runQAsync`) + * support for GHC-8.2 + * caching of compilation results ([accelerate-llvm#17]) + * support for ahead-of-time compilation (`runQ` and `runQAsync`) ### Changed - * generalise `run1*` to polyvariadic `runN*` + * generalise `run1*` to polyvariadic `runN*` ### Fixed - * Fixed synchronisation bug in multidimensional reduction - + * Fixed synchronisation bug in multidimensional reduction + ## [1.0.0.1] - 2017-05-25 ### Fixed - * [#386] (partial fix) + * device kernel image is invalid ([#386]) + ## [1.0.0.0] - 2017-03-31 * initial release +[1.3.0.0]: https://github.com/AccelerateHS/accelerate-llvm/compare/1.2.0.0...v1.3.0.0 +[1.2.0.0]: https://github.com/AccelerateHS/accelerate-llvm/compare/1.1.0.1-ptx...1.2.0.0 [1.1.0.1]: https://github.com/AccelerateHS/accelerate-llvm/compare/1.1.0.0...1.1.0.1-ptx [1.1.0.0]: https://github.com/AccelerateHS/accelerate-llvm/compare/1.0.0.0...1.1.0.0 [1.0.0.1]: https://github.com/AccelerateHS/accelerate-llvm/compare/1.0.0.0...1.0.0.1 [1.0.0.0]: https://github.com/AccelerateHS/accelerate-llvm/compare/be7f91295f77434b2103c70aa1cabb6a4f2b09a8...1.0.0.0 [#386]: https://github.com/AccelerateHS/accelerate/issues/386 +[#363]: https://github.com/AccelerateHS/accelerate/issues/363 +[#436]: https://github.com/AccelerateHS/accelerate/issues/436 [accelerate-llvm#17]: https://github.com/AccelerateHS/accelerate-llvm/issues/17 - +[accelerate#423]: https://github.com/AccelerateHS/accelerate/issues/423 +[accelerate-llvm#111]: https://github.com/AccelerateHS/accelerate-llvm/pull/111 +[accelerate-llvm#113]: https://github.com/AccelerateHS/accelerate-llvm/pull/113 diff --git a/Data/Array/Accelerate/LLVM/PTX.hs b/Data/Array/Accelerate/LLVM/PTX.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/PTX.hs +++ /dev/null @@ -1,458 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeSynonymInstances #-} --- | --- Module : Data.Array.Accelerate.LLVM.PTX --- Copyright : [2014..2017] Trevor L. McDonell --- [2014..2014] Vinod Grover (NVIDIA Corporation) --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- --- This module implements a backend for the /Accelerate/ language targeting --- NVPTX for execution on NVIDIA GPUs. Expressions are on-line translated into --- LLVM code, which is just-in-time executed in parallel on the GPU. --- - -module Data.Array.Accelerate.LLVM.PTX ( - - Acc, Arrays, - - -- * Synchronous execution - run, runWith, - run1, run1With, - runN, runNWith, - stream, streamWith, - - -- * Asynchronous execution - Async, - wait, poll, cancel, - - runAsync, runAsyncWith, - run1Async, run1AsyncWith, - runNAsync, runNAsyncWith, - - -- * Ahead-of-time compilation - runQ, runQWith, - runQAsync, runQAsyncWith, - - -- * Execution targets - PTX, createTargetForDevice, createTargetFromContext, - - -- * Controlling host-side allocation - registerPinnedAllocator, registerPinnedAllocatorWith, - -) where - --- accelerate -import Data.Array.Accelerate.AST ( PreOpenAfun(..) ) -import Data.Array.Accelerate.Array.Sugar ( Arrays ) -import Data.Array.Accelerate.Async -import Data.Array.Accelerate.Debug as Debug -import Data.Array.Accelerate.Error -import Data.Array.Accelerate.Smart ( Acc ) -import Data.Array.Accelerate.Trafo - -import Data.Array.Accelerate.LLVM.Execute.Async ( AsyncR(..) ) -import Data.Array.Accelerate.LLVM.Execute.Environment ( AvalR(..) ) -import Data.Array.Accelerate.LLVM.PTX.Compile -import Data.Array.Accelerate.LLVM.PTX.Embed ( embedOpenAcc ) -import Data.Array.Accelerate.LLVM.PTX.Execute -import Data.Array.Accelerate.LLVM.PTX.Execute.Environment ( Aval ) -import Data.Array.Accelerate.LLVM.PTX.Link -import Data.Array.Accelerate.LLVM.PTX.State -import Data.Array.Accelerate.LLVM.PTX.Target -import Data.Array.Accelerate.LLVM.State -import qualified Data.Array.Accelerate.LLVM.PTX.Array.Data as AD -import qualified Data.Array.Accelerate.LLVM.PTX.Context as CT -import qualified Data.Array.Accelerate.LLVM.PTX.Execute.Async as E - -import Foreign.CUDA.Driver as CUDA ( CUDAException, mallocHostForeignPtr ) - --- standard library -import Data.Typeable -import Control.Exception -import Control.Monad.Trans -import System.IO.Unsafe -import Text.Printf -import qualified Language.Haskell.TH as TH -import qualified Language.Haskell.TH.Syntax as TH - - --- Accelerate: LLVM backend for NVIDIA GPUs --- ---------------------------------------- - --- | Compile and run a complete embedded array program. --- --- The result is copied back to the host only once the arrays are demanded (or --- the result is forced to normal form). For results consisting of multiple --- components (a tuple of arrays or array of tuples) this applies per primitive --- array. Evaluating the result of 'run' to WHNF will initiate the computation, --- but does not copy the results back from the device. --- --- /NOTE:/ it is recommended to use 'runN' or 'runQ' whenever possible. --- -run :: Arrays a => Acc a -> a -run = runWith defaultTarget - --- | As 'run', but execute using the specified target rather than using the --- default, automatically selected device. --- --- Contexts passed to this function may all target to the same device, or to --- separate devices of differing compute capabilities. --- -runWith :: Arrays a => PTX -> Acc a -> a -runWith target a - = unsafePerformIO - $ wait =<< runAsyncWith target a - - --- | As 'run', but run the computation asynchronously and 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 be active on only one host thread at a time. If --- you want to execute multiple computations in parallel, on the same or --- different devices, use 'runAsyncWith'. --- -runAsync :: Arrays a => Acc a -> IO (Async a) -runAsync = runAsyncWith defaultTarget - --- | As 'runWith', but execute asynchronously. Be sure not to destroy the context, --- or attempt to attach it to a different host thread, before all outstanding --- operations have completed. --- -runAsyncWith :: Arrays a => PTX -> Acc a -> IO (Async a) -runAsyncWith target a = asyncBound execute - where - !acc = convertAccWith config a - execute = do - dumpGraph acc - evalPTX target $ do - acc `seq` dumpSimplStats - build <- phase "compile" (compileAcc acc) - exec <- phase "link" (linkAcc build) - res <- phase "execute" (executeAcc exec >>= AD.copyToHostLazy) - return res - - --- | This is 'runN', specialised to an array program of one argument. --- -run1 :: (Arrays a, Arrays b) => (Acc a -> Acc b) -> a -> b -run1 = run1With defaultTarget - --- | As 'run1', but execute using the specified target rather than using the --- default, automatically selected device. --- -run1With :: (Arrays a, Arrays b) => PTX -> (Acc a -> Acc b) -> a -> b -run1With = runNWith - - --- | Prepare and execute an embedded array program. --- --- This function can be used to improve performance in cases where the array --- program is constant between invocations, because it enables us to bypass --- front-end conversion stages and move directly to the execution phase. If you --- have a computation applied repeatedly to different input data, use this, --- specifying any changing aspects of the computation via the input parameters. --- If the function is only evaluated once, this is equivalent to 'run'. --- --- In order to use 'runN' you must express your Accelerate program as a function --- of array terms: --- --- > f :: (Arrays a, Arrays b, ... Arrays c) => Acc a -> Acc b -> ... -> Acc c --- --- This function then returns the compiled version of 'f': --- --- > runN f :: (Arrays a, Arrays b, ... Arrays c) => a -> b -> ... -> c --- --- At an example, rather than: --- --- > step :: Acc (Vector a) -> Acc (Vector b) --- > step = ... --- > --- > simulate :: Vector a -> Vector b --- > simulate xs = run $ step (use xs) --- --- Instead write: --- --- > simulate = runN step --- --- You can use the debugging options to check whether this is working --- successfully. For example, running with the @-ddump-phases@ flag should show --- that the compilation steps only happen once, not on the second and subsequent --- invocations of 'simulate'. Note that this typically relies on GHC knowing --- that it can lift out the function returned by 'runN' and reuse it. --- --- As with 'run', the resulting array(s) are only copied back to the host once --- they are actually demanded (forced to normal form). Thus, splitting a program --- into multiple 'runN' steps does not imply transferring intermediate --- computations back and forth between host and device. However note that --- Accelerate is not able to optimise (fuse) across separate 'runN' invocations. --- --- See the programs in the 'accelerate-examples' package for examples. --- --- See also 'runQ', which compiles the Accelerate program at _Haskell_ compile --- time, thus eliminating the runtime overhead altogether. --- -runN :: Afunction f => f -> AfunctionR f -runN = runNWith defaultTarget - --- | As 'runN', but execute using the specified target device. --- -runNWith :: Afunction f => PTX -> f -> AfunctionR f -runNWith target f = exec - where - !acc = convertAfunWith config f - !afun = unsafePerformIO $ do - dumpGraph acc - evalPTX target $ do - build <- phase "compile" (compileAfun acc) >>= dumpStats - link <- phase "link" (linkAfun build) - return link - !exec = go afun (return Aempty) - - go :: ExecOpenAfun PTX aenv t -> LLVM PTX (Aval aenv) -> t - go (Alam l) k = \arrs -> - let k' = do aenv <- k - AsyncR _ a <- E.async (AD.useRemoteAsync arrs) - return (aenv `Apush` a) - in go l k' - go (Abody b) k = unsafePerformIO . phase "execute" . evalPTX target $ do - aenv <- k - r <- E.async (executeOpenAcc b aenv) - AD.copyToHostLazy =<< E.get r - - --- | As 'run1', but the computation is executed asynchronously. --- -run1Async :: (Arrays a, Arrays b) => (Acc a -> Acc b) -> a -> IO (Async b) -run1Async = run1AsyncWith defaultTarget - --- | As 'run1With', but execute asynchronously. --- -run1AsyncWith :: (Arrays a, Arrays b) => PTX -> (Acc a -> Acc b) -> a -> IO (Async b) -run1AsyncWith = runNAsyncWith - - --- | As 'runN', but execute asynchronously. --- -runNAsync :: (Afunction f, RunAsync r, AfunctionR f ~ RunAsyncR r) => f -> r -runNAsync = runNAsyncWith defaultTarget - --- | As 'runNWith', but execute asynchronously. --- -runNAsyncWith :: (Afunction f, RunAsync r, AfunctionR f ~ RunAsyncR r) => PTX -> f -> r -runNAsyncWith target f = runAsync' target afun (return Aempty) - where - !acc = convertAfunWith config f - !afun = unsafePerformIO $ do - dumpGraph acc - evalPTX target $ do - build <- phase "compile" (compileAfun acc) >>= dumpStats - exec <- phase "link" (linkAfun build) - return exec - -class RunAsync f where - type RunAsyncR f - runAsync' :: PTX -> ExecOpenAfun PTX aenv (RunAsyncR f) -> LLVM PTX (Aval aenv) -> f - -instance RunAsync b => RunAsync (a -> b) where - type RunAsyncR (a -> b) = a -> RunAsyncR b - runAsync' _ Abody{} _ _ = error "runAsync: function oversaturated" - runAsync' target (Alam l) k arrs = - let k' = do aenv <- k - AsyncR _ a <- E.async (AD.useRemoteAsync arrs) - return (aenv `Apush` a) - in runAsync' target l k' - -instance RunAsync (IO (Async b)) where - type RunAsyncR (IO (Async b)) = b - runAsync' _ Alam{} _ = error "runAsync: function not fully applied" - runAsync' target (Abody b) k = asyncBound . phase "execute" . evalPTX target $ do - aenv <- k - r <- E.async (executeOpenAcc b aenv) - AD.copyToHostLazy =<< E.get r - - --- | Stream a lazily read list of input arrays through the given program, --- collecting results as we go. --- -stream :: (Arrays a, Arrays b) => (Acc a -> Acc b) -> [a] -> [b] -stream = streamWith defaultTarget - --- | As 'stream', but execute using the specified target. --- -streamWith :: (Arrays a, Arrays b) => PTX -> (Acc a -> Acc b) -> [a] -> [b] -streamWith target f arrs = map go arrs - where - !go = run1With target f - - --- | Ahead-of-time compilation for an embedded array program. --- --- This function will generate, compile, and link into the final executable, --- code to execute the given Accelerate computation /at Haskell compile time/. --- This eliminates any runtime overhead associated with the other @run*@ --- operations. The generated code will be compiled for the current (default) GPU --- architecture. --- --- Since the Accelerate program will be generated at Haskell compile time, --- construction of the Accelerate program, in particular via meta-programming, --- will be limited to operations available to that phase. Also note that any --- arrays which are embedded into the program via 'Data.Array.Accelerate.use' --- will be stored as part of the final executable. --- --- Usage of this function in your program is similar to that of 'runN'. First, --- express your Accelerate program as a function of array terms: --- --- > f :: (Arrays a, Arrays b, ... Arrays c) => Acc a -> Acc b -> ... -> Acc c --- --- This function then returns a compiled version of @f@ as a Template Haskell --- splice, to be added into your program at Haskell compile time: --- --- > {-# LANGUAGE TemplateHaskell #-} --- > --- > f' :: a -> b -> ... -> c --- > f' = $( runQ f ) --- --- Note that at the splice point the usage of @f@ must monomorphic; i.e. the --- types @a@, @b@ and @c@ must be at some known concrete type. --- --- See the --- project for an example. --- --- [/Note:/] --- --- Due to , this --- currently must be as an /untyped/ splice. --- --- The correct type of this function is similar to that of 'runN': --- --- > runQ :: Afunction f => f -> Q (TExp (AfunctionR f)) --- --- @since 1.1.0.0 --- -runQ :: Afunction f => f -> TH.ExpQ -runQ = runQ' [| unsafePerformIO |] [| defaultTarget |] - --- | Ahead-of-time analogue of 'runNWith'. See 'runQ' for more information. --- --- /NOTE:/ The supplied (at runtime) target must be compatible with the --- architecture that this function was compiled for (the 'defaultTarget' of the --- compiling machine). Running on a device with the same compute capability is --- best, but this should also be forward compatible to newer architectures. --- --- The correct type of this function is: --- --- > runQWith :: Afunction f => f -> Q (TExp (PTX -> AfunctionR f)) --- --- @since 1.1.0.0 --- -runQWith :: Afunction f => f -> TH.ExpQ -runQWith f = do - target <- TH.newName "target" - TH.lamE [TH.varP target] (runQ' [| unsafePerformIO |] (TH.varE target) f) - - --- | Ahead-of-time analogue of 'runNAsync'. See 'runQ' for more information. --- --- The correct type of this function is: --- --- > runQAsync :: (Afunction f, RunAsync r, AfunctionR f ~ RunAsyncR r) => f -> Q (TExp r) --- --- @since 1.1.0.0 --- -runQAsync :: Afunction f => f -> TH.ExpQ -runQAsync = runQ' [| async |] [| defaultTarget |] - --- | Ahead-of-time analogue of 'runNAsyncWith'. See 'runQWith' for more information. --- --- The correct type of this function is: --- --- > runQAsyncWith :: (Afunction f, RunAsync r, AfunctionR f ~ RunAsyncR r) => f -> Q (TExp (PTX -> r)) --- --- @since 1.1.0.0 --- -runQAsyncWith :: Afunction f => f -> TH.ExpQ -runQAsyncWith f = do - target <- TH.newName "target" - TH.lamE [TH.varP target] (runQ' [| async |] (TH.varE target) f) - - -runQ' :: Afunction f => TH.ExpQ -> TH.ExpQ -> f -> TH.ExpQ -runQ' using target f = do - afun <- let acc = convertAfunWith config f - in TH.runIO $ do - dumpGraph acc - evalPTX defaultTarget $ - phase "compile" (compileAfun acc) >>= dumpStats - let - go :: Typeable aenv => CompiledOpenAfun PTX aenv t -> [TH.PatQ] -> [TH.ExpQ] -> [TH.StmtQ] -> TH.ExpQ - go (Alam lam) xs as stmts = do - x <- TH.newName "x" -- lambda bound variable - a <- TH.newName "a" -- local array name - s <- TH.bindS (TH.conP 'AsyncR [TH.wildP, TH.varP a]) [| E.async (AD.useRemoteAsync $(TH.varE x)) |] - go lam (TH.varP x : xs) (TH.varE a : as) (return s : stmts) - - go (Abody body) xs as stmts = - let aenv = foldr (\a gamma -> [| $gamma `Apush` $a |] ) [| Aempty |] as - eval = TH.noBindS [| AD.copyToHostLazy =<< E.get =<< E.async (executeOpenAcc $(TH.unTypeQ (embedOpenAcc defaultTarget body)) $aenv) |] - in - TH.lamE (reverse xs) [| $using . phase "execute" . evalPTX $target $ - $(TH.doE (reverse (eval : stmts))) |] - -- - go afun [] [] [] - - --- How the Accelerate program should be evaluated. --- --- TODO: make sharing/fusion runtime configurable via debug flags or otherwise. --- -config :: Phase -config = phases - { convertOffsetOfSegment = True - } - - --- Controlling host-side allocation --- -------------------------------- - --- | Configure the default execution target to allocate all future host-side --- arrays using (CUDA) pinned memory. Any newly allocated arrays will be --- page-locked and directly accessible from the device, enabling high-speed --- (asynchronous) DMA. --- --- Note that since the amount of available pageable memory will be reduced, --- overall system performance can suffer. --- -registerPinnedAllocator :: IO () -registerPinnedAllocator = registerPinnedAllocatorWith defaultTarget - - --- | As with 'registerPinnedAllocator', but configure the given execution --- context. --- -registerPinnedAllocatorWith :: PTX -> IO () -registerPinnedAllocatorWith target = - AD.registerForeignPtrAllocator $ \bytes -> - CT.withContext (ptxContext target) (CUDA.mallocHostForeignPtr [] bytes) - `catch` - \e -> $internalError "registerPinnedAlocator" (show (e :: CUDAException)) - - --- Debugging --- ========= - -dumpStats :: MonadIO m => a -> m a -dumpStats x = dumpSimplStats >> return x - -phase :: MonadIO m => String -> m a -> m a -phase n go = timed dump_phases (\wall cpu -> printf "phase %s: %s" n (elapsed wall cpu)) go - diff --git a/Data/Array/Accelerate/LLVM/PTX/Analysis/Device.hs b/Data/Array/Accelerate/LLVM/PTX/Analysis/Device.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/PTX/Analysis/Device.hs +++ /dev/null @@ -1,50 +0,0 @@ --- | --- Module : Data.Array.Accelerate.LLVM.PTX.Analysis.Device --- Copyright : [2008..2017] Manuel M T Chakravarty, Gabriele Keller --- [2009..2017] Trevor L. McDonell --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -module Data.Array.Accelerate.LLVM.PTX.Analysis.Device - where - -import Data.Ord -import Data.List -import Data.Function -import Foreign.CUDA.Driver.Device -import Foreign.CUDA.Analysis.Device -import qualified Foreign.CUDA.Driver as CUDA - - --- Select the best of the available CUDA capable devices. This prefers devices --- with higher compute capability, followed by maximum throughput. This does not --- take into account any other factors, such as whether the device is currently --- in use by another process. --- --- Ignore the possibility of emulation-mode devices, as this has been deprecated --- as of CUDA v3.0 (compute-capability == 9999.9999) --- -selectBestDevice :: IO (Device, DeviceProperties) -selectBestDevice = do - dev <- mapM CUDA.device . enumFromTo 0 . subtract 1 =<< CUDA.count - prop <- mapM CUDA.props dev - return . minimumBy (flip cmp `on` snd) $ zip dev prop - where - compute = computeCapability - flops d = multiProcessorCount d * coresPerMultiProcessor d * clockRate d - cmp x y - | compute x == compute y = comparing flops x y - | otherwise = comparing compute x y - - --- Number of CUDA cores per streaming multiprocessor for a given architecture --- revision. This is the number of SIMD arithmetic units per multiprocessor, --- executing in lockstep in half-warp groupings (16 ALUs). --- -coresPerMultiProcessor :: DeviceProperties -> Int -coresPerMultiProcessor = coresPerMP . deviceResources - diff --git a/Data/Array/Accelerate/LLVM/PTX/Analysis/Launch.hs b/Data/Array/Accelerate/LLVM/PTX/Analysis/Launch.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/PTX/Analysis/Launch.hs +++ /dev/null @@ -1,75 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} --- | --- Module : Data.Array.Accelerate.LLVM.PTX.Analysis.Launch --- Copyright : [2008..2017] Manuel M T Chakravarty, Gabriele Keller --- [2009..2017] Trevor L. McDonell --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -module Data.Array.Accelerate.LLVM.PTX.Analysis.Launch ( - - DeviceProperties, Occupancy, LaunchConfig, - simpleLaunchConfig, launchConfig, - multipleOf, multipleOfQ, - -) where - -import Foreign.CUDA.Analysis as CUDA -import Language.Haskell.TH - - --- | Given information about the resource usage of the compiled kernel, --- determine the optimum launch parameters. --- -type LaunchConfig - = Int -- maximum #threads per block - -> Int -- #registers per thread - -> Int -- #bytes of static shared memory - -> ( Occupancy - , Int -- thread block size - , Int -> Int -- grid size required to process the given input size - , Int -- #bytes dynamic shared memory - , Q (TExp (Int -> Int)) - ) - --- | Analytics for a simple kernel which requires no additional shared memory or --- have other constraints on launch configuration. The smallest thread block --- size, in increments of a single warp, with the highest occupancy is used. --- -simpleLaunchConfig :: DeviceProperties -> LaunchConfig -simpleLaunchConfig dev = launchConfig dev (decWarp dev) (const 0) multipleOf multipleOfQ - - --- | Determine the optimal kernel launch configuration for a kernel. --- -launchConfig - :: DeviceProperties -- ^ Device architecture to optimise for - -> [Int] -- ^ Thread block sizes to consider - -> (Int -> Int) -- ^ Shared memory (#bytes) as a function of thread block size - -> (Int -> Int -> Int) -- ^ Determine grid size for input size 'n' (first arg) over thread blocks of size 'm' (second arg) - -> Q (TExp (Int -> Int -> Int)) - -> LaunchConfig -launchConfig dev candidates dynamic_smem grid_size grid_sizeQ maxThreads registers static_smem = - let - (cta, occ) = optimalBlockSizeOf dev (filter (<= maxThreads) candidates) (const registers) smem - maxGrid = multiProcessorCount dev * activeThreadBlocks occ - grid n = maxGrid `min` grid_size n cta - smem n = static_smem + dynamic_smem n - gridQ = [|| \n -> (maxGrid::Int) `min` $$grid_sizeQ (n::Int) (cta::Int) ||] - in - ( occ, cta, grid, dynamic_smem cta, gridQ ) - - --- | The next highest multiple of 'y' from 'x'. --- -multipleOf :: Int -> Int -> Int -multipleOf x y = ((x + y - 1) `quot` y) - -multipleOfQ :: Q (TExp (Int -> Int -> Int)) -multipleOfQ = [|| multipleOf ||] - diff --git a/Data/Array/Accelerate/LLVM/PTX/Array/Data.hs b/Data/Array/Accelerate/LLVM/PTX/Array/Data.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/PTX/Array/Data.hs +++ /dev/null @@ -1,213 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RecordWildCards #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} --- | --- Module : Data.Array.Accelerate.LLVM.PTX.Array.Data --- Copyright : [2014..2017] Trevor L. McDonell --- [2014..2014] Vinod Grover (NVIDIA Corporation) --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -module Data.Array.Accelerate.LLVM.PTX.Array.Data ( - - module Data.Array.Accelerate.LLVM.Array.Data, - module Data.Array.Accelerate.LLVM.PTX.Array.Data, - -) where - --- accelerate -import Data.Array.Accelerate.Array.Sugar -import Data.Array.Accelerate.Array.Unique ( UniqueArray(..) ) -import Data.Array.Accelerate.Lifetime ( Lifetime(..) ) -import qualified Data.Array.Accelerate.Array.Representation as R - -import Data.Array.Accelerate.LLVM.Array.Data -import Data.Array.Accelerate.LLVM.State - -import Data.Array.Accelerate.LLVM.PTX.State -import Data.Array.Accelerate.LLVM.PTX.Target -import Data.Array.Accelerate.LLVM.PTX.Execute.Async -import qualified Data.Array.Accelerate.LLVM.PTX.Array.Prim as Prim - --- standard library -import Control.Applicative -import Control.Monad.State ( liftIO, gets ) -import Data.Typeable -import Foreign.Ptr -import Foreign.Storable -import System.IO.Unsafe -import Prelude - - --- Instance of remote array memory management for the PTX target --- -instance Remote PTX where - - {-# INLINEABLE allocateRemote #-} - allocateRemote !sh = do - arr <- liftIO $ allocateArray sh - runArray arr (\ad -> Prim.mallocArray (size sh) ad >> return ad) - - {-# INLINEABLE useRemoteR #-} - useRemoteR !n !mst !ad = do - case mst of - Nothing -> Prim.useArray n ad - Just st -> Prim.useArrayAsync st n ad - - {-# INLINEABLE copyToRemoteR #-} - copyToRemoteR !from !to !mst !ad = do - case mst of - Nothing -> Prim.pokeArrayR from to ad - Just st -> Prim.pokeArrayAsyncR st from to ad - - {-# INLINEABLE copyToHostR #-} - copyToHostR !from !to !mst !ad = do - case mst of - Nothing -> Prim.peekArrayR from to ad - Just st -> Prim.peekArrayAsyncR st from to ad - - {-# INLINEABLE copyToPeerR #-} - copyToPeerR !from !to !dst !mst !ad = do - case mst of - Nothing -> Prim.copyArrayPeerR (ptxContext dst) (ptxMemoryTable dst) from to ad - Just st -> Prim.copyArrayPeerAsyncR (ptxContext dst) (ptxMemoryTable dst) st from to ad - - {-# INLINEABLE indexRemote #-} - indexRemote arr i = - runIndexArray Prim.indexArray arr i - - --- | Copy an array from the remote device to the host. Although the Accelerate --- program is hyper-strict and will evaluate the computation as soon as any part --- of it is demanded, the individual array payloads are copied back to the host --- _only_ as they are demanded by the Haskell program. This has several --- consequences: --- --- 1. If the device has multiple memcpy engines, only one will be used. The --- transfers are however associated with a non-default stream. --- --- 2. Using 'seq' to force an Array to head-normal form will initiate the --- computation, but not transfer the results back to the host. Requesting --- an array element or using 'deepseq' to force to normal form is required --- to actually transfer the data. --- -copyToHostLazy - :: Arrays arrs - => arrs - -> LLVM PTX arrs -copyToHostLazy arrs = do - ptx <- gets llvmTarget - liftIO $ runArrays arrs $ \(Array sh adata) -> - let - n :: Int - n = R.size sh - - peekR :: (ArrayElt e, ArrayPtrs e ~ Ptr a, Storable a, Typeable a, Typeable e) - => ArrayData e - -> UniqueArray a - -> IO (UniqueArray a) - peekR ad (UniqueArray uid (Lifetime ref weak fp)) = do - fp' <- unsafeInterleaveIO $ - evalPTX ptx $ do - s <- fork - copyToHostR 0 n (Just s) ad - e <- checkpoint s - block e - join s - return fp - return $ UniqueArray uid (Lifetime ref weak fp') - - runR :: ArrayEltR e -> ArrayData e -> IO (ArrayData e) - runR ArrayEltRunit AD_Unit = return AD_Unit - runR (ArrayEltRpair aeR2 aeR1) (AD_Pair ad2 ad1) = AD_Pair <$> runR aeR2 ad2 <*> runR aeR1 ad1 - runR ArrayEltRint ad@(AD_Int ua) = AD_Int <$> peekR ad ua - runR ArrayEltRint8 ad@(AD_Int8 ua) = AD_Int8 <$> peekR ad ua - runR ArrayEltRint16 ad@(AD_Int16 ua) = AD_Int16 <$> peekR ad ua - runR ArrayEltRint32 ad@(AD_Int32 ua) = AD_Int32 <$> peekR ad ua - runR ArrayEltRint64 ad@(AD_Int64 ua) = AD_Int64 <$> peekR ad ua - runR ArrayEltRword ad@(AD_Word ua) = AD_Word <$> peekR ad ua - runR ArrayEltRword8 ad@(AD_Word8 ua) = AD_Word8 <$> peekR ad ua - runR ArrayEltRword16 ad@(AD_Word16 ua) = AD_Word16 <$> peekR ad ua - runR ArrayEltRword32 ad@(AD_Word32 ua) = AD_Word32 <$> peekR ad ua - runR ArrayEltRword64 ad@(AD_Word64 ua) = AD_Word64 <$> peekR ad ua - runR ArrayEltRcshort ad@(AD_CShort ua) = AD_CShort <$> peekR ad ua - runR ArrayEltRcushort ad@(AD_CUShort ua) = AD_CUShort <$> peekR ad ua - runR ArrayEltRcint ad@(AD_CInt ua) = AD_CInt <$> peekR ad ua - runR ArrayEltRcuint ad@(AD_CUInt ua) = AD_CUInt <$> peekR ad ua - runR ArrayEltRclong ad@(AD_CLong ua) = AD_CLong <$> peekR ad ua - runR ArrayEltRculong ad@(AD_CULong ua) = AD_CULong <$> peekR ad ua - runR ArrayEltRcllong ad@(AD_CLLong ua) = AD_CLLong <$> peekR ad ua - runR ArrayEltRcullong ad@(AD_CULLong ua) = AD_CULLong <$> peekR ad ua - runR ArrayEltRfloat ad@(AD_Float ua) = AD_Float <$> peekR ad ua - runR ArrayEltRdouble ad@(AD_Double ua) = AD_Double <$> peekR ad ua - runR ArrayEltRcfloat ad@(AD_CFloat ua) = AD_CFloat <$> peekR ad ua - runR ArrayEltRcdouble ad@(AD_CDouble ua) = AD_CDouble <$> peekR ad ua - runR ArrayEltRbool ad@(AD_Bool ua) = AD_Bool <$> peekR ad ua - runR ArrayEltRchar ad@(AD_Char ua) = AD_Char <$> peekR ad ua - runR ArrayEltRcchar ad@(AD_CChar ua) = AD_CChar <$> peekR ad ua - runR ArrayEltRcschar ad@(AD_CSChar ua) = AD_CSChar <$> peekR ad ua - runR ArrayEltRcuchar ad@(AD_CUChar ua) = AD_CUChar <$> peekR ad ua - in - Array sh <$> runR arrayElt adata - - --- | Clone an array into a newly allocated array on the device. --- -cloneArrayAsync - :: (Shape sh, Elt e) - => Stream - -> Array sh e - -> LLVM PTX (Array sh e) -cloneArrayAsync stream arr@(Array _ src) = do - out@(Array _ dst) <- allocateRemote sh - copyR arrayElt src dst - return out - where - sh = shape arr - n = size sh - - copyR :: ArrayEltR e -> ArrayData e -> ArrayData e -> LLVM PTX () - copyR ArrayEltRunit _ _ = return () - copyR (ArrayEltRpair aeR1 aeR2) ad1 ad2 = copyR aeR1 (fstArrayData ad1) (fstArrayData ad2) >> - copyR aeR2 (sndArrayData ad1) (sndArrayData ad2) - -- - copyR ArrayEltRint ad1 ad2 = copyPrim ad1 ad2 - copyR ArrayEltRint8 ad1 ad2 = copyPrim ad1 ad2 - copyR ArrayEltRint16 ad1 ad2 = copyPrim ad1 ad2 - copyR ArrayEltRint32 ad1 ad2 = copyPrim ad1 ad2 - copyR ArrayEltRint64 ad1 ad2 = copyPrim ad1 ad2 - copyR ArrayEltRword ad1 ad2 = copyPrim ad1 ad2 - copyR ArrayEltRword8 ad1 ad2 = copyPrim ad1 ad2 - copyR ArrayEltRword16 ad1 ad2 = copyPrim ad1 ad2 - copyR ArrayEltRword32 ad1 ad2 = copyPrim ad1 ad2 - copyR ArrayEltRword64 ad1 ad2 = copyPrim ad1 ad2 - copyR ArrayEltRfloat ad1 ad2 = copyPrim ad1 ad2 - copyR ArrayEltRdouble ad1 ad2 = copyPrim ad1 ad2 - copyR ArrayEltRbool ad1 ad2 = copyPrim ad1 ad2 - copyR ArrayEltRchar ad1 ad2 = copyPrim ad1 ad2 - copyR ArrayEltRcshort ad1 ad2 = copyPrim ad1 ad2 - copyR ArrayEltRcushort ad1 ad2 = copyPrim ad1 ad2 - copyR ArrayEltRcint ad1 ad2 = copyPrim ad1 ad2 - copyR ArrayEltRcuint ad1 ad2 = copyPrim ad1 ad2 - copyR ArrayEltRclong ad1 ad2 = copyPrim ad1 ad2 - copyR ArrayEltRculong ad1 ad2 = copyPrim ad1 ad2 - copyR ArrayEltRcllong ad1 ad2 = copyPrim ad1 ad2 - copyR ArrayEltRcullong ad1 ad2 = copyPrim ad1 ad2 - copyR ArrayEltRcfloat ad1 ad2 = copyPrim ad1 ad2 - copyR ArrayEltRcdouble ad1 ad2 = copyPrim ad1 ad2 - copyR ArrayEltRcchar ad1 ad2 = copyPrim ad1 ad2 - copyR ArrayEltRcschar ad1 ad2 = copyPrim ad1 ad2 - copyR ArrayEltRcuchar ad1 ad2 = copyPrim ad1 ad2 - - copyPrim - :: (ArrayElt e, ArrayPtrs e ~ Ptr a, Typeable e, Storable a, Typeable a) - => ArrayData e - -> ArrayData e - -> LLVM PTX () - copyPrim a1 a2 = Prim.copyArrayAsync stream n a1 a2 - diff --git a/Data/Array/Accelerate/LLVM/PTX/Array/Prim.hs b/Data/Array/Accelerate/LLVM/PTX/Array/Prim.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/PTX/Array/Prim.hs +++ /dev/null @@ -1,508 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeOperators #-} --- | --- Module : Data.Array.Accelerate.LLVM.PTX.Array.Prim --- Copyright : [2014..2017] Trevor L. McDonell --- [2014..2014] Vinod Grover (NVIDIA Corporation) --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -module Data.Array.Accelerate.LLVM.PTX.Array.Prim ( - - mallocArray, - memsetArray, memsetArrayAsync, - useArray, useArrayAsync, - indexArray, - peekArray, peekArrayR, peekArrayAsync, peekArrayAsyncR, - pokeArray, pokeArrayR, pokeArrayAsync, pokeArrayAsyncR, - copyArray, copyArrayR, copyArrayAsync, copyArrayAsyncR, - copyArrayPeer, copyArrayPeerR, copyArrayPeerAsync, copyArrayPeerAsyncR, - withDevicePtr, - -) where - --- accelerate -import Data.Array.Accelerate.Array.Data -import Data.Array.Accelerate.Error -import Data.Array.Accelerate.Lifetime -import Data.Array.Accelerate.Type - -import Data.Array.Accelerate.LLVM.State - -import Data.Array.Accelerate.LLVM.PTX.Context -import Data.Array.Accelerate.LLVM.PTX.Target -import Data.Array.Accelerate.LLVM.PTX.Execute.Event -import Data.Array.Accelerate.LLVM.PTX.Execute.Stream -import Data.Array.Accelerate.LLVM.PTX.Array.Table -import Data.Array.Accelerate.LLVM.PTX.Array.Remote as Remote -import qualified Data.Array.Accelerate.LLVM.PTX.Debug as Debug - --- CUDA -import qualified Foreign.CUDA.Driver as CUDA -import qualified Foreign.CUDA.Driver.Stream as CUDA - --- standard library -import Control.Exception -import Control.Monad -import Control.Monad.State -import Data.Typeable -import Foreign.Ptr -import Foreign.Storable -import GHC.TypeLits -import Text.Printf -import Prelude hiding ( lookup ) - - --- | Allocate a device-side array associated with the given host array. If the --- allocation fails due to a memory error, we attempt some last-ditch memory --- cleanup before trying again. --- -{-# INLINEABLE mallocArray #-} -mallocArray - :: forall e a. (ArrayElt e, ArrayPtrs e ~ Ptr a, Storable a, Typeable a, Typeable e) - => Int - -> ArrayData e - -> LLVM PTX () -mallocArray !n !ad = do - message ("mallocArray: " ++ showBytes (n * sizeOf (undefined::a))) - void $ malloc ad n False - - --- | A combination of 'mallocArray' and 'pokeArray', that allocates remotes --- memory and uploads an existing array. This is specialised because we tell the --- allocator that the host-side array is frozen, and thus it is safe to evict --- the remote memory and re-upload the data at any time. --- -{-# INLINEABLE useArray #-} -useArray - :: forall e a. (ArrayElt e, ArrayPtrs e ~ Ptr a, Storable a, Typeable a, Typeable e) - => Int - -> ArrayData e - -> LLVM PTX () -useArray !n !ad = - blocking $ \st -> useArrayAsync st n ad - -{-# INLINEABLE useArrayAsync #-} -useArrayAsync - :: forall e a. (ArrayElt e, ArrayPtrs e ~ Ptr a, Storable a, Typeable a, Typeable e) - => Stream - -> Int - -> ArrayData e - -> LLVM PTX () -useArrayAsync !st !n !ad = do - alloc <- malloc ad n True - when alloc $ pokeArrayAsync st n ad - - --- | Copy data from the host to an existing array on the device --- -{-# INLINEABLE pokeArray #-} -pokeArray - :: forall e a. (ArrayElt e, ArrayPtrs e ~ Ptr a, Typeable e, Storable a, Typeable a) - => Int - -> ArrayData e - -> LLVM PTX () -pokeArray !n !ad = - blocking $ \st -> pokeArrayAsync st n ad - -{-# INLINEABLE pokeArrayAsync #-} -pokeArrayAsync - :: forall e a. (ArrayElt e, ArrayPtrs e ~ Ptr a, Typeable e, Storable a, Typeable a) - => Stream - -> Int - -> ArrayData e - -> LLVM PTX () -pokeArrayAsync !stream !n !ad = do - let !src = CUDA.HostPtr (ptrsOfArrayData ad) - !bytes = n * sizeOf (undefined :: a) - !st = unsafeGetValue stream - -- - withDevicePtr ad $ \dst -> - nonblocking stream $ - transfer "pokeArray" bytes (Just st) $ CUDA.pokeArrayAsync n src dst (Just st) - liftIO (touchLifetime stream) - liftIO (Debug.didCopyBytesToRemote (fromIntegral bytes)) - - -{-# INLINEABLE pokeArrayR #-} -pokeArrayR - :: forall e a. (ArrayElt e, ArrayPtrs e ~ Ptr a, Typeable e, Typeable a, Storable a) - => Int - -> Int - -> ArrayData e - -> LLVM PTX () -pokeArrayR !from !to !ad = - blocking $ \st -> pokeArrayAsyncR st from to ad - -{-# INLINEABLE pokeArrayAsyncR #-} -pokeArrayAsyncR - :: forall e a. (ArrayElt e, ArrayPtrs e ~ Ptr a, Typeable e, Typeable a, Storable a) - => Stream - -> Int - -> Int - -> ArrayData e - -> LLVM PTX () -pokeArrayAsyncR !stream !from !to !ad = do - let !n = to - from - !bytes = n * sizeOf (undefined :: a) - !offset = from * sizeOf (undefined :: a) - !src = CUDA.HostPtr (ptrsOfArrayData ad) - !st = unsafeGetValue stream - -- - withDevicePtr ad $ \dst -> - nonblocking stream $ - transfer "pokeArray" bytes (Just st) $ - CUDA.pokeArrayAsync n (src `CUDA.plusHostPtr` offset) (dst `CUDA.plusDevPtr` offset) (Just st) - liftIO (touchLifetime stream) - liftIO (Debug.didCopyBytesToRemote (fromIntegral bytes)) - - --- | Read a single element from an array at a given row-major index --- -{-# INLINEABLE indexArray #-} -indexArray - :: forall e a. (ArrayElt e, ArrayPtrs e ~ Ptr a, Typeable e, Typeable a, Storable a) - => ArrayData e - -> Int - -> LLVM PTX a -indexArray !ad !i = - blocking $ \stream -> - withDevicePtr ad $ \src -> liftIO $ - bracket (CUDA.mallocHostArray [] 1) CUDA.freeHost $ \dst -> do - let !st = unsafeGetValue stream - message $ "indexArray: " ++ showBytes (sizeOf (undefined::a)) - Debug.didCopyBytesFromRemote (fromIntegral (sizeOf (undefined::a))) - CUDA.peekArrayAsync 1 (src `CUDA.advanceDevPtr` i) dst (Just st) - CUDA.block st - touchLifetime stream - r <- peek (CUDA.useHostPtr dst) - return (Nothing, r) - - --- | Copy data from the device into the associated host-side Accelerate array --- -{-# INLINEABLE peekArray #-} -peekArray - :: forall e a. (ArrayElt e, ArrayPtrs e ~ Ptr a, Typeable e, Typeable a, Storable a) - => Int - -> ArrayData e - -> LLVM PTX () -peekArray !n !ad = - blocking $ \st -> peekArrayAsync st n ad - -{-# INLINEABLE peekArrayAsync #-} -peekArrayAsync - :: forall e a. (ArrayElt e, ArrayPtrs e ~ Ptr a, Typeable e, Typeable a, Storable a) - => Stream - -> Int - -> ArrayData e - -> LLVM PTX () -peekArrayAsync !stream !n !ad = do - let !bytes = n * sizeOf (undefined :: a) - !dst = CUDA.HostPtr (ptrsOfArrayData ad) - !st = unsafeGetValue stream - -- - withDevicePtr ad $ \src -> - nonblocking stream $ - transfer "peekArray" bytes (Just st) $ CUDA.peekArrayAsync n src dst (Just st) - liftIO (touchLifetime stream) - liftIO (Debug.didCopyBytesFromRemote (fromIntegral bytes)) - -{-# INLINEABLE peekArrayR #-} -peekArrayR - :: forall e a. (ArrayElt e, ArrayPtrs e ~ Ptr a, Typeable a, Typeable e, Storable a) - => Int - -> Int - -> ArrayData e - -> LLVM PTX () -peekArrayR !from !to !ad = - blocking $ \st -> peekArrayAsyncR st from to ad - -{-# INLINEABLE peekArrayAsyncR #-} -peekArrayAsyncR - :: forall e a. (ArrayElt e, ArrayPtrs e ~ Ptr a, Typeable e, Typeable a, Storable a) - => Stream - -> Int - -> Int - -> ArrayData e - -> LLVM PTX () -peekArrayAsyncR !stream !from !to !ad = do - let !n = to - from - !bytes = n * sizeOf (undefined :: a) - !offset = from * sizeOf (undefined :: a) - !dst = CUDA.HostPtr (ptrsOfArrayData ad) - !st = unsafeGetValue stream - -- - withDevicePtr ad $ \src -> - nonblocking stream $ - transfer "peekArray" bytes (Just st) $ - CUDA.peekArrayAsync n (src `CUDA.plusDevPtr` offset) (dst `CUDA.plusHostPtr` offset) (Just st) - liftIO (touchLifetime stream) - liftIO (Debug.didCopyBytesFromRemote (fromIntegral bytes)) - - --- | Copy data between arrays in the same context --- -{-# INLINEABLE copyArray #-} -copyArray - :: forall e a. (ArrayElt e, ArrayPtrs e ~ Ptr a, Typeable e, Storable a, Typeable a) - => Int - -> ArrayData e - -> ArrayData e - -> LLVM PTX () -copyArray !n !src !dst = - blocking $ \st -> copyArrayAsync st n src dst - -{-# INLINEABLE copyArrayAsync #-} -copyArrayAsync - :: forall e a. (ArrayElt e, ArrayPtrs e ~ Ptr a, Typeable e, Storable a, Typeable a) - => Stream - -> Int - -> ArrayData e - -> ArrayData e - -> LLVM PTX () -copyArrayAsync !stream !n !ad_src !ad_dst = do - let !bytes = n * sizeOf (undefined :: a) - !st = unsafeGetValue stream - -- - withDevicePtr ad_src $ \src -> do - e <- withDevicePtr ad_dst $ \dst -> do - (e,()) <- nonblocking stream - $ transfer "copyArray" bytes (Just st) $ CUDA.copyArrayAsync n src dst (Just st) - return (e,e) - return (e,()) - liftIO (touchLifetime stream) - -{-# INLINEABLE copyArrayR #-} -copyArrayR - :: forall e a. (ArrayElt e, ArrayPtrs e ~ Ptr a, Typeable e, Storable a, Typeable a) - => Int - -> Int - -> ArrayData e - -> ArrayData e - -> LLVM PTX () -copyArrayR !from !to !src !dst = - blocking $ \st -> copyArrayAsyncR st from to src dst - -{-# INLINEABLE copyArrayAsyncR #-} -copyArrayAsyncR - :: forall e a. (ArrayElt e, ArrayPtrs e ~ Ptr a, Typeable e, Storable a, Typeable a) - => Stream - -> Int - -> Int - -> ArrayData e - -> ArrayData e - -> LLVM PTX () -copyArrayAsyncR !stream !from !to !ad_src !ad_dst = do - let !n = to - from - !bytes = n * sizeOf (undefined :: a) - !offset = from * sizeOf (undefined :: a) - !st = unsafeGetValue stream - -- - withDevicePtr ad_src $ \src -> do - e <- withDevicePtr ad_dst $ \dst -> do - (e,()) <- nonblocking stream - $ transfer "copyArray" bytes (Just st) - $ CUDA.copyArrayAsync n (src `CUDA.plusDevPtr` offset) (dst `CUDA.plusDevPtr` offset) (Just st) - return (e,e) - return (e,()) - liftIO (touchLifetime stream) - - --- | Copy data from one device context into a _new_ array on the second context. --- It is an error if the destination array already exists. --- -{-# INLINEABLE copyArrayPeer #-} -copyArrayPeer - :: forall e a. (ArrayElt e, ArrayPtrs e ~ Ptr a, Storable a, Typeable a) - => Context -- destination context - -> MemoryTable -- destination memory table - -> Int - -> ArrayData e - -> LLVM PTX () -copyArrayPeer !ctx2 !mt2 !n !ad = - blocking $ \st -> copyArrayPeerAsync ctx2 mt2 st n ad - -{-# INLINEABLE copyArrayPeerAsync #-} -copyArrayPeerAsync - :: forall e a. (ArrayElt e, ArrayPtrs e ~ Ptr a, Storable a, Typeable a) - => Context -- destination context - -> MemoryTable -- destination memory table - -> Stream - -> Int - -> ArrayData e - -> LLVM PTX () -copyArrayPeerAsync = error "copyArrayPeerAsync" -{-- -copyArrayPeerAsync !ctx2 !mt2 !st !n !ad = do - let !bytes = n * sizeOf (undefined :: a) - src <- devicePtr mt1 ad - dst <- mallocArray ctx2 mt2 n ad - transfer "copyArrayPeer" bytes (Just st) $ - CUDA.copyArrayPeerAsync n src (deviceContext ctx1) dst (deviceContext ctx2) (Just st) ---} - --- | Copy part of an array from one device context to another. Both source and --- destination arrays must exist. --- -{-# INLINEABLE copyArrayPeerR #-} -copyArrayPeerR - :: forall e a. (ArrayElt e, ArrayPtrs e ~ Ptr a, Storable a, Typeable a) - => Context -- destination context - -> MemoryTable -- destination memory table - -> Int - -> Int - -> ArrayData e - -> LLVM PTX () -copyArrayPeerR !ctx2 !mt2 !from !to !ad = - blocking $ \st -> copyArrayPeerAsyncR ctx2 mt2 st from to ad - -{-# INLINEABLE copyArrayPeerAsyncR #-} -copyArrayPeerAsyncR - :: forall e a. (ArrayElt e, ArrayPtrs e ~ Ptr a, Storable a, Typeable a) - => Context -- destination context - -> MemoryTable -- destination memory table - -> Stream - -> Int - -> Int - -> ArrayData e - -> LLVM PTX () -copyArrayPeerAsyncR = error "copyArrayPeerAsyncR" -{-- -copyArrayPeerAsyncR !ctx2 !mt2 !st !from !to !ad = do - let !n = to - from - !bytes = n * sizeOf (undefined :: a) - !offset = from * sizeOf (undefined :: a) - src <- devicePtr mt1 ad :: IO (CUDA.DevicePtr a) - dst <- devicePtr mt2 ad :: IO (CUDA.DevicePtr a) - transfer "copyArrayPeer" bytes (Just st) $ - CUDA.copyArrayPeerAsync n (src `CUDA.plusDevPtr` offset) (deviceContext ctx1) - (dst `CUDA.plusDevPtr` offset) (deviceContext ctx2) (Just st) ---} - - --- | Set elements of the array to the specified value. Only 8-, 16-, and 32-bit --- values are supported. --- -{-# INLINEABLE memsetArray #-} -memsetArray - :: forall e a. (ArrayElt e, ArrayPtrs e ~ Ptr a, Typeable e, Typeable a, Storable a, BitSize a <= 32) - => Int - -> a - -> ArrayData e - -> LLVM PTX () -memsetArray !n !v !ad = - blocking $ \st -> memsetArrayAsync st n v ad - -{-# INLINEABLE memsetArrayAsync #-} -memsetArrayAsync - :: forall e a. (ArrayElt e, ArrayPtrs e ~ Ptr a, Typeable e, Typeable a, Storable a, BitSize a <= 32) - => Stream - -> Int - -> a - -> ArrayData e - -> LLVM PTX () -memsetArrayAsync !stream !n !v !ad = do - let !bytes = n * sizeOf (undefined :: a) - !st = unsafeGetValue stream - -- - withDevicePtr ad $ \ptr -> - nonblocking stream $ - transfer "memset" bytes (Just st) $ CUDA.memsetAsync ptr n v (Just st) - liftIO (touchLifetime stream) - - -{-- --- | Lookup the device memory associated with a given host array --- -{-# INLINEABLE devicePtr #-} -devicePtr - :: (ArrayElt e, ArrayPtrs e ~ Ptr a, Typeable a, Typeable b) - => ArrayData e - -> LLVM PTX (CUDA.DevicePtr b) -devicePtr !ad = do - undefined - {-- - mv <- Table.lookup mt ad - case mv of - Just v -> return v - Nothing -> $internalError "devicePtr" "lost device memory" - --} ---} - --- Auxiliary --- --------- - --- | Lookup the device memory associated with a given host array and do --- something with it. --- -{-# INLINEABLE withDevicePtr #-} -withDevicePtr - :: (ArrayElt e, ArrayPtrs e ~ Ptr a, Typeable e, Typeable a, Storable a) - => ArrayData e - -> (CUDA.DevicePtr a -> LLVM PTX (Maybe Event, r)) - -> LLVM PTX r -withDevicePtr !ad !f = do - mr <- withRemote ad f - case mr of - Nothing -> $internalError "withDevicePtr" "array does not exist on the device" - Just r -> return r - --- | Execute the given operation in a new stream, and wait for the operation to --- complete before returning. --- -{-# INLINE blocking #-} -blocking :: (Stream -> LLVM PTX a) -> LLVM PTX a -blocking !f = - streaming f $ \e r -> do - liftIO $ block e - return r - --- | Execute a (presumable asynchronous) operation and return the result --- together with an event recorded immediately afterwards in the given stream. --- -{-# INLINE nonblocking #-} -nonblocking :: Stream -> LLVM PTX a -> LLVM PTX (Maybe Event, a) -nonblocking !stream !f = do - r <- f - e <- waypoint stream - return (Just e, r) - - --- Debug --- ----- - -{-# INLINE showBytes #-} -showBytes :: Int -> String -showBytes x = Debug.showFFloatSIBase (Just 0) 1024 (fromIntegral x :: Double) "B" - -{-# INLINE trace #-} -trace :: MonadIO m => String -> m a -> m a -trace msg next = liftIO (Debug.traceIO Debug.dump_gc ("gc: " ++ msg)) >> next - -{-# INLINE message #-} -message :: MonadIO m => String -> m () -message s = s `trace` return () - -{-# INLINE transfer #-} -transfer :: MonadIO m => String -> Int -> Maybe CUDA.Stream -> IO () -> m () -transfer name bytes stream action - = let showRate x t = Debug.showFFloatSIBase (Just 3) 1024 (fromIntegral x / t) "B/s" - msg wall cpu gpu = printf "gc: %s: %s bytes @ %s, %s" - name - (showBytes bytes) - (showRate bytes wall) - (Debug.elapsed wall cpu gpu) - in - liftIO (Debug.timed Debug.dump_gc msg stream action) - diff --git a/Data/Array/Accelerate/LLVM/PTX/Array/Remote.hs b/Data/Array/Accelerate/LLVM/PTX/Array/Remote.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/PTX/Array/Remote.hs +++ /dev/null @@ -1,163 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} --- | --- Module : Data.Array.Accelerate.LLVM.PTX.Array.Remote --- Copyright : [2014..2017] Trevor L. McDonell --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -module Data.Array.Accelerate.LLVM.PTX.Array.Remote ( - - withRemote, malloc, - -) where - -import Data.Array.Accelerate.LLVM.State -import Data.Array.Accelerate.LLVM.PTX.Target -import {-# SOURCE #-} Data.Array.Accelerate.LLVM.PTX.Execute.Event -import {-# SOURCE #-} Data.Array.Accelerate.LLVM.PTX.Execute.Stream - -import Data.Array.Accelerate.Lifetime -import Data.Array.Accelerate.Array.Data -import qualified Data.Array.Accelerate.Array.Remote as Remote -import qualified Data.Array.Accelerate.LLVM.PTX.Debug as Debug - -import Foreign.CUDA.Driver.Error -import qualified Foreign.CUDA.Ptr as CUDA -import qualified Foreign.CUDA.Driver as CUDA -import qualified Foreign.CUDA.Driver.Stream as CUDA - -import Control.Exception -import Control.Monad.State -import Data.Typeable -import Foreign.Ptr -import Foreign.Storable -import Text.Printf - - --- Events signal once a computation has completed --- -instance Remote.Task (Maybe Event) where - completed Nothing = return True - completed (Just e) = query e - -instance Remote.RemoteMemory (LLVM PTX) where - type RemotePtr (LLVM PTX) = CUDA.DevicePtr - -- - mallocRemote n - | n <= 0 = return (Just CUDA.nullDevPtr) - | otherwise = liftIO $ do - ep <- try (CUDA.mallocArray n) - case ep of - Right p -> do liftIO (Debug.didAllocateBytesRemote (fromIntegral n)) - return (Just p) - Left (ExitCode OutOfMemory) -> do return Nothing - Left e -> do message ("malloc failed with error: " ++ show e) - throwIO e - - peekRemote n src ad = - let bytes = n * sizeOfPtr src - dst = CUDA.HostPtr (ptrsOfArrayData ad) - in - blocking $ \stream -> - withLifetime stream $ \st -> do - Debug.didCopyBytesFromRemote (fromIntegral bytes) - transfer "peekRemote" bytes (Just st) $ CUDA.peekArrayAsync n src dst (Just st) - - pokeRemote n dst ad = - let bytes = n * sizeOfPtr dst - src = CUDA.HostPtr (ptrsOfArrayData ad) - in - blocking $ \stream -> - withLifetime stream $ \st -> do - Debug.didCopyBytesToRemote (fromIntegral bytes) - transfer "pokeRemote" bytes (Just st) $ CUDA.pokeArrayAsync n src dst (Just st) - - castRemotePtr _ = CUDA.castDevPtr - availableRemoteMem = liftIO $ fst `fmap` CUDA.getMemInfo - totalRemoteMem = liftIO $ snd `fmap` CUDA.getMemInfo - remoteAllocationSize = return 4096 - - - --- | Allocate an array in the remote memory space sufficient to hold the given --- number of elements, and associated with the given host side array. Space will --- be freed from the remote device if necessary. --- -{-# INLINEABLE malloc #-} -malloc - :: (ArrayElt e, ArrayPtrs e ~ Ptr a, Typeable e, Typeable a, Storable a) - => ArrayData e - -> Int - -> Bool - -> LLVM PTX Bool -malloc !ad !n !frozen = do - PTX{..} <- gets llvmTarget - Remote.malloc ptxMemoryTable ad frozen n - - --- | Lookup up the remote array pointer for the given host-side array --- -{-# INLINEABLE withRemote #-} -withRemote - :: (ArrayElt e, ArrayPtrs e ~ Ptr a, Typeable e, Typeable a, Storable a) - => ArrayData e - -> (CUDA.DevicePtr a -> LLVM PTX (Maybe Event, r)) - -> LLVM PTX (Maybe r) -withRemote !ad !f = do - PTX{..} <- gets llvmTarget - Remote.withRemote ptxMemoryTable ad f - - --- Auxiliary --- --------- - --- | Execute the given operation in a new stream, and wait for the operation to --- complete before returning. --- -{-# INLINE blocking #-} -blocking :: (Stream -> IO a) -> LLVM PTX a -blocking !fun = - streaming (liftIO . fun) $ \e r -> do - liftIO $ block e - return r - -{-# INLINE sizeOfPtr #-} -sizeOfPtr :: forall a. Storable a => CUDA.DevicePtr a -> Int -sizeOfPtr _ = sizeOf (undefined :: a) - --- Debugging --- --------- - -{-# INLINE showBytes #-} -showBytes :: Int -> String -showBytes x = Debug.showFFloatSIBase (Just 0) 1024 (fromIntegral x :: Double) "B" - -{-# INLINE trace #-} -trace :: String -> IO a -> IO a -trace msg next = Debug.traceIO Debug.dump_gc ("gc: " ++ msg) >> next - -{-# INLINE message #-} -message :: String -> IO () -message s = s `trace` return () - -{-# INLINE transfer #-} -transfer :: String -> Int -> Maybe CUDA.Stream -> IO () -> IO () -transfer name bytes stream action - = let showRate x t = Debug.showFFloatSIBase (Just 3) 1024 (fromIntegral x / t) "B/s" - msg wall cpu gpu = printf "gc: %s: %s bytes @ %s, %s" - name - (showBytes bytes) - (showRate bytes wall) - (Debug.elapsed wall cpu gpu) - in - Debug.timed Debug.dump_gc msg stream action - diff --git a/Data/Array/Accelerate/LLVM/PTX/Array/Table.hs b/Data/Array/Accelerate/LLVM/PTX/Array/Table.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/PTX/Array/Table.hs +++ /dev/null @@ -1,60 +0,0 @@ -{-# LANGUAGE BangPatterns #-} --- | --- Module : Data.Array.Accelerate.LLVM.PTX.Array.Table --- Copyright : [2014..2017] Trevor L. McDonell --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -module Data.Array.Accelerate.LLVM.PTX.Array.Table ( - - MemoryTable, - new, - -) where - -import Data.Array.Accelerate.LLVM.PTX.Context ( Context, withContext ) -import qualified Data.Array.Accelerate.Array.Remote as Remote -import qualified Data.Array.Accelerate.LLVM.PTX.Debug as Debug -import {-# SOURCE #-} Data.Array.Accelerate.LLVM.PTX.Execute.Event - -import qualified Foreign.CUDA.Ptr as CUDA -import qualified Foreign.CUDA.Driver as CUDA - -import Text.Printf - - --- Remote memory tables. This builds upon the LRU-cached memory tables provided --- by the base Accelerate package. --- -type MemoryTable = Remote.MemoryTable CUDA.DevicePtr (Maybe Event) - - --- | Create a new PTX memory table. This is specific to a given PTX target, as --- devices arrays are unique to a CUDA context. --- -{-# INLINEABLE new #-} -new :: Context -> IO MemoryTable -new !ctx = Remote.new freeRemote - where - freeRemote :: CUDA.DevicePtr a -> IO () - freeRemote !ptr = do - message (printf "freeRemote %s" (show ptr)) - withContext ctx (CUDA.free ptr) - - --- Debugging --- --------- - -{-# INLINE trace #-} -trace :: String -> IO a -> IO a -trace msg next = Debug.traceIO Debug.dump_gc ("gc: " ++ msg) >> next - -{-# INLINE message #-} -message :: String -> IO () -message s = s `trace` return () - - diff --git a/Data/Array/Accelerate/LLVM/PTX/CodeGen.hs b/Data/Array/Accelerate/LLVM/PTX/CodeGen.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/PTX/CodeGen.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} --- | --- Module : Data.Array.Accelerate.LLVM.PTX.CodeGen --- Copyright : [2014..2017] Trevor L. McDonell --- [2014..2014] Vinod Grover (NVIDIA Corporation) --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -module Data.Array.Accelerate.LLVM.PTX.CodeGen ( - - KernelMetadata(..), - -) where - --- accelerate -import Data.Array.Accelerate.LLVM.CodeGen - -import Data.Array.Accelerate.LLVM.PTX.CodeGen.Base -import Data.Array.Accelerate.LLVM.PTX.CodeGen.Fold -import Data.Array.Accelerate.LLVM.PTX.CodeGen.FoldSeg -import Data.Array.Accelerate.LLVM.PTX.CodeGen.Generate -import Data.Array.Accelerate.LLVM.PTX.CodeGen.Intrinsic () -import Data.Array.Accelerate.LLVM.PTX.CodeGen.Map -import Data.Array.Accelerate.LLVM.PTX.CodeGen.Permute -import Data.Array.Accelerate.LLVM.PTX.CodeGen.Scan -import Data.Array.Accelerate.LLVM.PTX.Target - - -instance Skeleton PTX where - map ptx _ = mkMap ptx - generate ptx _ = mkGenerate ptx - fold ptx _ = mkFold ptx - fold1 ptx _ = mkFold1 ptx - foldSeg ptx _ = mkFoldSeg ptx - fold1Seg ptx _ = mkFold1Seg ptx - scanl ptx _ = mkScanl ptx - scanl1 ptx _ = mkScanl1 ptx - scanl' ptx _ = mkScanl' ptx - scanr ptx _ = mkScanr ptx - scanr1 ptx _ = mkScanr1 ptx - scanr' ptx _ = mkScanr' ptx - permute ptx _ = mkPermute ptx - diff --git a/Data/Array/Accelerate/LLVM/PTX/CodeGen/Base.hs b/Data/Array/Accelerate/LLVM/PTX/CodeGen/Base.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/PTX/CodeGen/Base.hs +++ /dev/null @@ -1,408 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} --- | --- Module : Data.Array.Accelerate.LLVM.PTX.CodeGen.Base --- Copyright : [2014..2017] Trevor L. McDonell --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -module Data.Array.Accelerate.LLVM.PTX.CodeGen.Base ( - - -- Types - DeviceProperties, KernelMetadata(..), - - -- Thread identifiers - blockDim, gridDim, threadIdx, blockIdx, warpSize, - gridSize, globalThreadIdx, - gangParam, - - -- Other intrinsics - laneId, warpId, - laneMask_eq, laneMask_lt, laneMask_le, laneMask_gt, laneMask_ge, - atomicAdd_f, - - -- Barriers and synchronisation - __syncthreads, - __threadfence_block, __threadfence_grid, - - -- Shared memory - staticSharedMem, - dynamicSharedMem, - sharedMemAddrSpace, - - -- Kernel definitions - (+++), - makeOpenAcc, makeOpenAccWith, - -) where - --- llvm -import LLVM.AST.Type.AddrSpace -import LLVM.AST.Type.Constant -import LLVM.AST.Type.Global -import LLVM.AST.Type.Instruction -import LLVM.AST.Type.Instruction.Volatile -import LLVM.AST.Type.Metadata -import LLVM.AST.Type.Name -import LLVM.AST.Type.Operand -import LLVM.AST.Type.Representation -import qualified LLVM.AST.Global as LLVM -import qualified LLVM.AST.Constant as LLVM hiding ( type' ) -import qualified LLVM.AST.Linkage as LLVM -import qualified LLVM.AST.Name as LLVM -import qualified LLVM.AST.Type as LLVM - --- accelerate -import Data.Array.Accelerate.Analysis.Type -import Data.Array.Accelerate.Array.Sugar ( Elt, Vector, eltType ) -import Data.Array.Accelerate.Error - -import Data.Array.Accelerate.LLVM.CodeGen.Arithmetic as A -import Data.Array.Accelerate.LLVM.CodeGen.Base -import Data.Array.Accelerate.LLVM.CodeGen.Constant -import Data.Array.Accelerate.LLVM.CodeGen.Downcast -import Data.Array.Accelerate.LLVM.CodeGen.IR -import Data.Array.Accelerate.LLVM.CodeGen.Module -import Data.Array.Accelerate.LLVM.CodeGen.Monad -import Data.Array.Accelerate.LLVM.CodeGen.Ptr -import Data.Array.Accelerate.LLVM.CodeGen.Sugar -import Data.Array.Accelerate.LLVM.CodeGen.Type - -import Data.Array.Accelerate.LLVM.PTX.Analysis.Launch -import Data.Array.Accelerate.LLVM.PTX.Context -import Data.Array.Accelerate.LLVM.PTX.Target - --- standard library -import Control.Applicative -import Control.Monad ( void ) -import Data.String -import Text.Printf -import Prelude as P - - --- Thread identifiers --- ------------------ - --- | Read the builtin registers that store CUDA thread and grid identifiers --- --- --- -specialPTXReg :: Label -> CodeGen (IR Int32) -specialPTXReg f = - call (Body type' f) [NoUnwind, ReadNone] - -blockDim, gridDim, threadIdx, blockIdx, warpSize :: CodeGen (IR Int32) -blockDim = specialPTXReg "llvm.nvvm.read.ptx.sreg.ntid.x" -gridDim = specialPTXReg "llvm.nvvm.read.ptx.sreg.nctaid.x" -threadIdx = specialPTXReg "llvm.nvvm.read.ptx.sreg.tid.x" -blockIdx = specialPTXReg "llvm.nvvm.read.ptx.sreg.ctaid.x" -warpSize = specialPTXReg "llvm.nvvm.read.ptx.sreg.warpsize" - -laneId :: CodeGen (IR Int32) -laneId = specialPTXReg "llvm.nvvm.read.ptx.sreg.laneid" - -laneMask_eq, laneMask_lt, laneMask_le, laneMask_gt, laneMask_ge :: CodeGen (IR Int32) -laneMask_eq = specialPTXReg "llvm.nvvm.read.ptx.sreg.lanemask.eq" -laneMask_lt = specialPTXReg "llvm.nvvm.read.ptx.sreg.lanemask.lt" -laneMask_le = specialPTXReg "llvm.nvvm.read.ptx.sreg.lanemask.le" -laneMask_gt = specialPTXReg "llvm.nvvm.read.ptx.sreg.lanemask.gt" -laneMask_ge = specialPTXReg "llvm.nvvm.read.ptx.sreg.lanemask.ge" - - --- | NOTE: The special register %warpid as volatile value and is not guaranteed --- to be constant over the lifetime of a thread or thread block. --- --- http://docs.nvidia.com/cuda/cuda-c-programming-guide/index.html#sm-id-and-warp-id --- --- http://docs.nvidia.com/cuda/parallel-thread-execution/index.html#special-registers-warpid --- --- We might consider passing in the (constant) warp size from device properties, --- so that the division can be optimised to a shift. --- -warpId :: CodeGen (IR Int32) -warpId = do - tid <- threadIdx - ws <- warpSize - A.quot integralType tid ws - -_warpId :: CodeGen (IR Int32) -_warpId = specialPTXReg "llvm.ptx.read.warpid" - - --- | The size of the thread grid --- --- > gridDim.x * blockDim.x --- -gridSize :: CodeGen (IR Int32) -gridSize = do - ncta <- gridDim - nt <- blockDim - mul numType ncta nt - - --- | The global thread index --- --- > blockDim.x * blockIdx.x + threadIdx.x --- -globalThreadIdx :: CodeGen (IR Int32) -globalThreadIdx = do - ntid <- blockDim - ctaid <- blockIdx - tid <- threadIdx - -- - u <- mul numType ntid ctaid - v <- add numType tid u - return v - - --- | Generate function parameters that will specify the first and last (linear) --- index of the array this kernel should evaluate. --- -gangParam :: (IR Int32, IR Int32, [LLVM.Parameter]) -gangParam = - let t = scalarType - start = "ix.start" - end = "ix.end" - in - (local t start, local t end, [ scalarParameter t start, scalarParameter t end ] ) - - --- Barriers and synchronisation --- ---------------------------- - --- | Call a builtin CUDA synchronisation intrinsic --- -barrier :: Label -> CodeGen () -barrier f = void $ call (Body VoidType f) [NoUnwind, NoDuplicate, Convergent] - - --- | Wait until all threads in the thread block have reached this point and all --- global and shared memory accesses made by these threads prior to --- __syncthreads() are visible to all threads in the block. --- --- --- -__syncthreads :: CodeGen () -__syncthreads = barrier "llvm.nvvm.barrier0" - - --- | Ensure that all writes to shared and global memory before the call to --- __threadfence_block() are observed by all threads in the *block* of the --- calling thread as occurring before all writes to shared and global memory --- made by the calling thread after the call. --- --- --- -__threadfence_block :: CodeGen () -__threadfence_block = barrier "llvm.nvvm.membar.cta" - - --- | As __threadfence_block(), but the synchronisation is for *all* thread blocks. --- In CUDA this is known simply as __threadfence(). --- -__threadfence_grid :: CodeGen () -__threadfence_grid = barrier "llvm.nvvm.membar.gl" - - --- Atomic functions --- ---------------- - --- LLVM provides atomic instructions for integer arguments only. CUDA provides --- additional support for atomic add on floating point types, which can be --- accessed through the following intrinsics. --- --- Double precision is only supported on Compute 6.0 devices and later. LLVM-4.0 --- currently lacks support for this intrinsic, however it may be possible to use --- inline assembly. --- --- --- -atomicAdd_f :: FloatingType a -> Operand (Ptr a) -> Operand a -> CodeGen () -atomicAdd_f t addr val = - let - width :: Int - width = - case t of - TypeFloat{} -> 32 - TypeDouble{} -> 64 - TypeCFloat{} -> 32 - TypeCDouble{} -> 64 - - addrspace :: Word32 - (t_addr, t_val, addrspace) = - case typeOf addr of - PrimType ta@(PtrPrimType (ScalarPrimType tv) (AddrSpace as)) - -> (ta, tv, as) - _ -> $internalError "atomicAdd" "unexpected operand type" - - t_ret = PrimType (ScalarPrimType t_val) - fun = fromString $ printf "llvm.nvvm.atomic.load.add.f%d.p%df%d" width addrspace width - in - void $ call (Lam t_addr addr (Lam (ScalarPrimType t_val) val (Body t_ret fun))) [NoUnwind] - - --- Shared memory --- ------------- - -sharedMemAddrSpace :: AddrSpace -sharedMemAddrSpace = AddrSpace 3 - -sharedMemVolatility :: Volatility -sharedMemVolatility = Volatile - - --- Declare a new statically allocated array in the __shared__ memory address --- space, with enough storage to contain the given number of elements. --- -staticSharedMem - :: forall e. Elt e - => Word64 - -> CodeGen (IRArray (Vector e)) -staticSharedMem n = do - ad <- go (eltType (undefined::e)) - return $ IRArray { irArrayShape = IR (OP_Pair OP_Unit (OP_Int (integral integralType (P.fromIntegral n)))) - , irArrayData = IR ad - , irArrayAddrSpace = sharedMemAddrSpace - , irArrayVolatility = sharedMemVolatility - } - where - go :: TupleType s -> CodeGen (Operands s) - go UnitTuple = return OP_Unit - go (PairTuple t1 t2) = OP_Pair <$> go t1 <*> go t2 - go tt@(SingleTuple t) = do - -- Declare a new global reference for the statically allocated array - -- located in the __shared__ memory space. - nm <- freshName - sm <- return $ ConstantOperand $ GlobalReference (PrimType (PtrPrimType (ArrayType n t) sharedMemAddrSpace)) nm - declare $ LLVM.globalVariableDefaults - { LLVM.addrSpace = sharedMemAddrSpace - , LLVM.type' = LLVM.ArrayType n (downcast t) - , LLVM.linkage = LLVM.External - , LLVM.name = downcast nm - , LLVM.alignment = 4 `P.max` P.fromIntegral (sizeOf tt) - } - - -- Return a pointer to the first element of the __shared__ memory array. - -- We do this rather than just returning the global reference directly due - -- to how __shared__ memory needs to be indexed with the GEP instruction. - p <- instr' $ GetElementPtr sm [num numType 0, num numType 0 :: Operand Int32] - q <- instr' $ PtrCast (PtrPrimType (ScalarPrimType t) sharedMemAddrSpace) p - - return $ ir' t (unPtr q) - - --- External declaration in shared memory address space. This must be declared in --- order to access memory allocated dynamically by the CUDA driver. This results --- in the following global declaration: --- --- > @__shared__ = external addrspace(3) global [0 x i8] --- -initialiseDynamicSharedMemory :: CodeGen (Operand (Ptr Word8)) -initialiseDynamicSharedMemory = do - declare $ LLVM.globalVariableDefaults - { LLVM.addrSpace = sharedMemAddrSpace - , LLVM.type' = LLVM.ArrayType 0 (LLVM.IntegerType 8) - , LLVM.linkage = LLVM.External - , LLVM.name = LLVM.Name "__shared__" - , LLVM.alignment = 4 - } - return $ ConstantOperand $ GlobalReference (PrimType (PtrPrimType (ArrayType 0 scalarType) sharedMemAddrSpace)) "__shared__" - - --- Declared a new dynamically allocated array in the __shared__ memory space --- with enough space to contain the given number of elements. --- -dynamicSharedMem - :: forall e int. (Elt e, IsIntegral int) - => IR int -- number of array elements - -> IR int -- #bytes of shared memory the have already been allocated - -> CodeGen (IRArray (Vector e)) -dynamicSharedMem n@(op integralType -> m) (op integralType -> offset) = do - smem <- initialiseDynamicSharedMemory - let - go :: TupleType s -> Operand int -> CodeGen (Operand int, Operands s) - go UnitTuple i = return (i, OP_Unit) - go (PairTuple t2 t1) i0 = do - (i1, p1) <- go t1 i0 - (i2, p2) <- go t2 i1 - return $ (i2, OP_Pair p2 p1) - go (SingleTuple t) i = do - p <- instr' $ GetElementPtr smem [num numType 0, i] -- TLM: note initial zero index!! - q <- instr' $ PtrCast (PtrPrimType (ScalarPrimType t) sharedMemAddrSpace) p - a <- instr' $ Mul numType m (integral integralType (P.fromIntegral (sizeOf (SingleTuple t)))) - b <- instr' $ Add numType i a - return (b, ir' t (unPtr q)) - -- - (_, ad) <- go (eltType (undefined::e)) offset - IR sz <- A.fromIntegral integralType (numType :: NumType Int) n - return $ IRArray { irArrayShape = IR $ OP_Pair OP_Unit sz - , irArrayData = IR ad - , irArrayAddrSpace = sharedMemAddrSpace - , irArrayVolatility = sharedMemVolatility - } - - --- Global kernel definitions --- ------------------------- - -data instance KernelMetadata PTX = KM_PTX LaunchConfig - --- | Combine kernels into a single program --- -(+++) :: IROpenAcc PTX aenv a -> IROpenAcc PTX aenv a -> IROpenAcc PTX aenv a -IROpenAcc k1 +++ IROpenAcc k2 = IROpenAcc (k1 ++ k2) - - --- | Create a single kernel program with the default launch configuration. --- -makeOpenAcc - :: PTX - -> Label - -> [LLVM.Parameter] - -> CodeGen () - -> CodeGen (IROpenAcc PTX aenv a) -makeOpenAcc (deviceProperties . ptxContext -> dev) = - makeOpenAccWith (simpleLaunchConfig dev) - --- | Create a single kernel program with the given launch analysis information. --- -makeOpenAccWith - :: LaunchConfig - -> Label - -> [LLVM.Parameter] - -> CodeGen () - -> CodeGen (IROpenAcc PTX aenv a) -makeOpenAccWith config name param kernel = do - body <- makeKernel config name param kernel - return $ IROpenAcc [body] - --- | Create a complete kernel function by running the code generation process --- specified in the final parameter. --- -makeKernel :: LaunchConfig -> Label -> [LLVM.Parameter] -> CodeGen () -> CodeGen (Kernel PTX aenv a) -makeKernel config name@(Label l) param kernel = do - _ <- kernel - code <- createBlocks - addMetadata "nvvm.annotations" - [ Just . MetadataConstantOperand $ LLVM.GlobalReference (LLVM.PointerType (LLVM.FunctionType LLVM.VoidType [ t | LLVM.Parameter t _ _ <- param ] False) (AddrSpace 0)) (LLVM.Name l) - , Just . MetadataStringOperand $ "kernel" - , Just . MetadataConstantOperand $ LLVM.Int 32 1 - ] - return $ Kernel - { kernelMetadata = KM_PTX config - , unKernel = LLVM.functionDefaults - { LLVM.returnType = LLVM.VoidType - , LLVM.name = downcast name - , LLVM.parameters = (param, False) - , LLVM.basicBlocks = code - } - } - diff --git a/Data/Array/Accelerate/LLVM/PTX/CodeGen/Fold.hs b/Data/Array/Accelerate/LLVM/PTX/CodeGen/Fold.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/PTX/CodeGen/Fold.hs +++ /dev/null @@ -1,628 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RebindableSyntax #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ViewPatterns #-} --- | --- Module : Data.Array.Accelerate.LLVM.PTX.CodeGen.Fold --- Copyright : [2016..2017] Trevor L. McDonell --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -module Data.Array.Accelerate.LLVM.PTX.CodeGen.Fold - where - --- accelerate -import Data.Array.Accelerate.Analysis.Match -import Data.Array.Accelerate.Analysis.Type -import Data.Array.Accelerate.Array.Sugar ( Array, Scalar, Vector, Shape, Z, (:.), Elt(..) ) - --- accelerate-llvm-* -import Data.Array.Accelerate.LLVM.Analysis.Match -import Data.Array.Accelerate.LLVM.CodeGen.Arithmetic as A -import Data.Array.Accelerate.LLVM.CodeGen.Array -import Data.Array.Accelerate.LLVM.CodeGen.Base -import Data.Array.Accelerate.LLVM.CodeGen.Environment -import Data.Array.Accelerate.LLVM.CodeGen.Exp -import Data.Array.Accelerate.LLVM.CodeGen.IR -import Data.Array.Accelerate.LLVM.CodeGen.Loop as Loop -import Data.Array.Accelerate.LLVM.CodeGen.Monad -import Data.Array.Accelerate.LLVM.CodeGen.Sugar - -import Data.Array.Accelerate.LLVM.PTX.Analysis.Launch -import Data.Array.Accelerate.LLVM.PTX.CodeGen.Base -import Data.Array.Accelerate.LLVM.PTX.CodeGen.Generate -import Data.Array.Accelerate.LLVM.PTX.Context -import Data.Array.Accelerate.LLVM.PTX.Target - -import LLVM.AST.Type.Representation - --- cuda -import qualified Foreign.CUDA.Analysis as CUDA - -import Control.Applicative ( (<$>), (<*>) ) -import Control.Monad ( (>=>), (<=<) ) -import Data.String ( fromString ) -import Data.Bits as P -import Prelude as P - - --- Reduce an array along the innermost dimension. The reduction function must be --- associative to allow for an efficient parallel implementation, but the --- initial element does /not/ need to be a neutral element of operator. --- --- TODO: Specialise for commutative operations (such as (+)) and those with --- a neutral element {(+), 0} --- -mkFold - :: forall aenv sh e. (Shape sh, Elt e) - => PTX - -> Gamma aenv - -> IRFun2 PTX aenv (e -> e -> e) - -> IRExp PTX aenv e - -> IRDelayed PTX aenv (Array (sh :. Int) e) - -> CodeGen (IROpenAcc PTX aenv (Array sh e)) -mkFold ptx@(deviceProperties . ptxContext -> dev) aenv f z acc - | Just Refl <- matchShapeType (undefined::sh) (undefined::Z) - = (+++) <$> mkFoldAll dev aenv f (Just z) acc - <*> mkFoldFill ptx aenv z - - | otherwise - = (+++) <$> mkFoldDim dev aenv f (Just z) acc - <*> mkFoldFill ptx aenv z - - --- Reduce a non-empty array along the innermost dimension. The reduction --- function must be associative to allow for an efficient parallel --- implementation. --- --- TODO: Specialise for commutative operations (such as (+)) and those with --- a neutral element {(+), 0} --- -mkFold1 - :: forall aenv sh e. (Shape sh, Elt e) - => PTX - -> Gamma aenv - -> IRFun2 PTX aenv (e -> e -> e) - -> IRDelayed PTX aenv (Array (sh :. Int) e) - -> CodeGen (IROpenAcc PTX aenv (Array sh e)) -mkFold1 (deviceProperties . ptxContext -> dev) aenv f acc - | Just Refl <- matchShapeType (undefined::sh) (undefined::Z) - = mkFoldAll dev aenv f Nothing acc - - | otherwise - = mkFoldDim dev aenv f Nothing acc - - --- Reduce an array to a single element. --- --- Since reductions consume arrays that have been fused into them, parallel --- reduction requires two separate kernels. At an example, take vector dot --- product: --- --- > dotp xs ys = fold (+) 0 (zipWith (*) xs ys) --- --- 1. The first pass reads in the fused array data, in this case corresponding --- to the function (\i -> (xs!i) * (ys!i)). --- --- 2. The second pass reads in the manifest array data from the first step and --- directly reduces the array. This can be done recursively in-place until --- only a single element remains. --- --- In both phases, thread blocks cooperatively reduce a stripe of the input (one --- element per thread) to a single element, which is stored to the output array. --- -mkFoldAll - :: forall aenv e. Elt e - => DeviceProperties -- ^ properties of the target GPU - -> Gamma aenv -- ^ array environment - -> IRFun2 PTX aenv (e -> e -> e) -- ^ combination function - -> Maybe (IRExp PTX aenv e) -- ^ seed element, if this is an exclusive reduction - -> IRDelayed PTX aenv (Vector e) -- ^ input data - -> CodeGen (IROpenAcc PTX aenv (Scalar e)) -mkFoldAll dev aenv combine mseed acc = - foldr1 (+++) <$> sequence [ mkFoldAllS dev aenv combine mseed acc - , mkFoldAllM1 dev aenv combine acc - , mkFoldAllM2 dev aenv combine mseed - ] - - --- Reduction to an array to a single element, for small arrays which can be --- processed by a single thread block. --- -mkFoldAllS - :: forall aenv e. Elt e - => DeviceProperties -- ^ properties of the target GPU - -> Gamma aenv -- ^ array environment - -> IRFun2 PTX aenv (e -> e -> e) -- ^ combination function - -> Maybe (IRExp PTX aenv e) - -> IRDelayed PTX aenv (Vector e) -- ^ input data - -> CodeGen (IROpenAcc PTX aenv (Scalar e)) -mkFoldAllS dev aenv combine mseed IRDelayed{..} = - let - (start, end, paramGang) = gangParam - (arrOut, paramOut) = mutableArray ("out" :: Name (Scalar e)) - paramEnv = envParam aenv - -- - config = launchConfig dev (CUDA.incWarp dev) smem multipleOf multipleOfQ - smem n = warps * (1 + per_warp) * bytes - where - ws = CUDA.warpSize dev - warps = n `P.quot` ws - per_warp = ws + ws `P.quot` 2 - bytes = sizeOf (eltType (undefined :: e)) - in - makeOpenAccWith config "foldAllS" (paramGang ++ paramOut ++ paramEnv) $ do - - tid <- threadIdx - bd <- blockDim - - -- We can assume that there is only a single thread block - i0 <- A.add numType start tid - sz <- A.sub numType end start - when (A.lt scalarType i0 sz) $ do - - -- Thread reads initial element and then participates in block-wide - -- reduction. - x0 <- app1 delayedLinearIndex =<< A.fromIntegral integralType numType i0 - r0 <- if A.eq scalarType sz bd - then reduceBlockSMem dev combine Nothing x0 - else reduceBlockSMem dev combine (Just sz) x0 - - when (A.eq scalarType tid (lift 0)) $ - writeArray arrOut tid =<< - case mseed of - Nothing -> return r0 - Just z -> flip (app2 combine) r0 =<< z -- Note: initial element on the left - - return_ - - --- Reduction of an entire array to a single element. This kernel implements step --- one for reducing large arrays which must be processed by multiple thread --- blocks. --- -mkFoldAllM1 - :: forall aenv e. Elt e - => DeviceProperties -- ^ properties of the target GPU - -> Gamma aenv -- ^ array environment - -> IRFun2 PTX aenv (e -> e -> e) -- ^ combination function - -> IRDelayed PTX aenv (Vector e) -- ^ input data - -> CodeGen (IROpenAcc PTX aenv (Scalar e)) -mkFoldAllM1 dev aenv combine IRDelayed{..} = - let - (start, end, paramGang) = gangParam - (arrTmp, paramTmp) = mutableArray ("tmp" :: Name (Vector e)) - paramEnv = envParam aenv - -- - config = launchConfig dev (CUDA.incWarp dev) smem const [|| const ||] - smem n = warps * (1 + per_warp) * bytes - where - ws = CUDA.warpSize dev - warps = n `P.quot` ws - per_warp = ws + ws `P.quot` 2 - bytes = sizeOf (eltType (undefined :: e)) - in - makeOpenAccWith config "foldAllM1" (paramGang ++ paramTmp ++ paramEnv) $ do - - -- Each thread block cooperatively reduces a stripe of the input and stores - -- that value into a temporary array at a corresponding index. Since the - -- order of operations remains fixed, this method supports non-commutative - -- reductions. - -- - tid <- threadIdx - bd <- blockDim - sz <- i32 . indexHead =<< delayedExtent - - imapFromTo start end $ \seg -> do - - -- Wait for all threads to catch up before beginning the stripe - __syncthreads - - -- Bounds of the input array we will reduce between - from <- A.mul numType seg bd - step <- A.add numType from bd - to <- A.min scalarType sz step - - -- Threads cooperatively reduce this stripe - reduceFromTo dev from to combine - (app1 delayedLinearIndex <=< A.fromIntegral integralType numType) - (when (A.eq scalarType tid (lift 0)) . writeArray arrTmp seg) - - return_ - - --- Reduction of an array to a single element, (recursive) step 2 of multi-block --- reduction algorithm. --- -mkFoldAllM2 - :: forall aenv e. Elt e - => DeviceProperties - -> Gamma aenv - -> IRFun2 PTX aenv (e -> e -> e) - -> Maybe (IRExp PTX aenv e) - -> CodeGen (IROpenAcc PTX aenv (Scalar e)) -mkFoldAllM2 dev aenv combine mseed = - let - (start, end, paramGang) = gangParam - (arrTmp, paramTmp) = mutableArray ("tmp" :: Name (Vector e)) - (arrOut, paramOut) = mutableArray ("out" :: Name (Vector e)) - paramEnv = envParam aenv - -- - config = launchConfig dev (CUDA.incWarp dev) smem const [|| const ||] - smem n = warps * (1 + per_warp) * bytes - where - ws = CUDA.warpSize dev - warps = n `P.quot` ws - per_warp = ws + ws `P.quot` 2 - bytes = sizeOf (eltType (undefined :: e)) - in - makeOpenAccWith config "foldAllM2" (paramGang ++ paramTmp ++ paramOut ++ paramEnv) $ do - - -- Threads cooperatively reduce a stripe of the input (temporary) array - -- output from the first phase, storing the results into another temporary. - -- When only a single thread block remains, we have reached the final - -- reduction step and add the initial element (for exclusive reductions). - -- - tid <- threadIdx - bd <- blockDim - gd <- gridDim - sz <- i32 . indexHead $ irArrayShape arrTmp - - imapFromTo start end $ \seg -> do - - -- Wait for all threads to catch up before beginning the stripe - __syncthreads - - -- Bounds of the input we will reduce between - from <- A.mul numType seg bd - step <- A.add numType from bd - to <- A.min scalarType sz step - - -- Threads cooperatively reduce this stripe - reduceFromTo dev from to combine (readArray arrTmp) $ \r -> - when (A.eq scalarType tid (lift 0)) $ - writeArray arrOut seg =<< - case mseed of - Nothing -> return r - Just z -> if A.eq scalarType gd (lift 1) - then flip (app2 combine) r =<< z -- Note: initial element on the left - else return r - - return_ - - --- Reduce an array of arbitrary rank along the innermost dimension only. --- --- For simplicity, each element of the output (reduction along an --- innermost-dimension index) is computed by a single thread block, meaning we --- don't have to worry about inter-block synchronisation. A more balanced method --- would be a segmented reduction (specialised, since the length of each segment --- is known a priori). --- -mkFoldDim - :: forall aenv sh e. (Shape sh, Elt e) - => DeviceProperties -- ^ properties of the target GPU - -> Gamma aenv -- ^ array environment - -> IRFun2 PTX aenv (e -> e -> e) -- ^ combination function - -> Maybe (IRExp PTX aenv e) -- ^ seed element, if this is an exclusive reduction - -> IRDelayed PTX aenv (Array (sh :. Int) e) -- ^ input data - -> CodeGen (IROpenAcc PTX aenv (Array sh e)) -mkFoldDim dev aenv combine mseed IRDelayed{..} = - let - (start, end, paramGang) = gangParam - (arrOut, paramOut) = mutableArray ("out" :: Name (Array sh e)) - paramEnv = envParam aenv - -- - config = launchConfig dev (CUDA.incWarp dev) smem const [|| const ||] - smem n = warps * (1 + per_warp) * bytes - where - ws = CUDA.warpSize dev - warps = n `P.quot` ws - per_warp = ws + ws `P.quot` 2 - bytes = sizeOf (eltType (undefined :: e)) - in - makeOpenAccWith config "fold" (paramGang ++ paramOut ++ paramEnv) $ do - - -- If the innermost dimension is smaller than the number of threads in the - -- block, those threads will never contribute to the output. - tid <- threadIdx - sz <- i32 . indexHead =<< delayedExtent - when (A.lt scalarType tid sz) $ do - - -- Thread blocks iterate over the outer dimensions, each thread block - -- cooperatively reducing along each outermost index to a single value. - -- - imapFromTo start end $ \seg -> do - - -- Wait for threads to catch up before starting this segment. We could - -- also place this at the bottom of the loop, but here allows threads to - -- exit quickly on the last iteration. - __syncthreads - - -- Step 1: initialise local sums - from <- A.mul numType seg sz -- first linear index this block will reduce - to <- A.add numType from sz -- last linear index this block will reduce (exclusive) - - i0 <- A.add numType from tid - x0 <- app1 delayedLinearIndex =<< A.fromIntegral integralType numType i0 - bd <- blockDim - r0 <- if A.gte scalarType sz bd - then reduceBlockSMem dev combine Nothing x0 - else reduceBlockSMem dev combine (Just sz) x0 - - -- Step 2: keep walking over the input - next <- A.add numType from bd - r <- iterFromStepTo next bd to r0 $ \offset r -> do - - -- Wait for all threads to catch up before starting the next stripe - __syncthreads - - -- Threads cooperatively reduce this stripe of the input - i <- A.add numType offset tid - v' <- A.sub numType to offset - r' <- if A.gte scalarType v' bd - -- All threads of the block are valid, so we can avoid - -- bounds checks. - then do - x <- app1 delayedLinearIndex =<< A.fromIntegral integralType numType i - y <- reduceBlockSMem dev combine Nothing x - return y - - -- Otherwise, we require bounds checks when reading the input - -- and during the reduction. Note that even though only the - -- valid threads will contribute useful work in the - -- reduction, we must still have all threads enter the - -- reduction procedure to avoid synchronisation divergence. - else do - x <- if A.lt scalarType i to - then app1 delayedLinearIndex =<< A.fromIntegral integralType numType i - else return r - y <- reduceBlockSMem dev combine (Just v') x - return y - - if A.eq scalarType tid (lift 0) - then app2 combine r r' - else return r' - - -- Step 3: Thread 0 writes the aggregate reduction of this dimension to - -- memory. If this is an exclusive fold, combine with the initial element. - -- - when (A.eq scalarType tid (lift 0)) $ - writeArray arrOut seg =<< - case mseed of - Nothing -> return r - Just z -> flip (app2 combine) r =<< z -- Note: initial element on the left - - return_ - - --- Exclusive reductions over empty arrays (of any dimension) fill the lower --- dimensions with the initial element. --- -mkFoldFill - :: (Shape sh, Elt e) - => PTX - -> Gamma aenv - -> IRExp PTX aenv e - -> CodeGen (IROpenAcc PTX aenv (Array sh e)) -mkFoldFill ptx aenv seed = - mkGenerate ptx aenv (IRFun1 (const seed)) - - --- Efficient threadblock-wide reduction using the specified operator. The --- aggregate reduction value is stored in thread zero. Supports non-commutative --- operators. --- --- Requires dynamically allocated memory: (#warps * (1 + 1.5 * warp size)). --- --- Example: https://github.com/NVlabs/cub/blob/1.5.2/cub/block/specializations/block_reduce_warp_reductions.cuh --- -reduceBlockSMem - :: forall aenv e. Elt e - => DeviceProperties -- ^ properties of the target device - -> IRFun2 PTX aenv (e -> e -> e) -- ^ combination function - -> Maybe (IR Int32) -- ^ number of valid elements (may be less than block size) - -> IR e -- ^ calling thread's input element - -> CodeGen (IR e) -- ^ thread-block-wide reduction using the specified operator (lane 0 only) -reduceBlockSMem dev combine size = warpReduce >=> warpAggregate - where - int32 :: Integral a => a -> IR Int32 - int32 = lift . P.fromIntegral - - -- Temporary storage required for each warp - bytes = sizeOf (eltType (undefined::e)) - warp_smem_elems = CUDA.warpSize dev + (CUDA.warpSize dev `P.quot` 2) - - -- Step 1: Reduction in every warp - -- - warpReduce :: IR e -> CodeGen (IR e) - warpReduce input = do - -- Allocate (1.5 * warpSize) elements of shared memory for each warp - wid <- warpId - skip <- A.mul numType wid (int32 (warp_smem_elems * bytes)) - smem <- dynamicSharedMem (int32 warp_smem_elems) skip - - -- Are we doing bounds checking for this warp? - -- - case size of - -- The entire thread block is valid, so skip bounds checks. - Nothing -> - reduceWarpSMem dev combine smem Nothing input - - -- Otherwise check how many elements are valid for this warp. If it is - -- full then we can still skip bounds checks for it. - Just n -> do - offset <- A.mul numType wid (int32 (CUDA.warpSize dev)) - valid <- A.sub numType n offset - if A.gte scalarType valid (int32 (CUDA.warpSize dev)) - then reduceWarpSMem dev combine smem Nothing input - else reduceWarpSMem dev combine smem (Just valid) input - - -- Step 2: Aggregate per-warp reductions - -- - warpAggregate :: IR e -> CodeGen (IR e) - warpAggregate input = do - -- Allocate #warps elements of shared memory - bd <- blockDim - warps <- A.quot integralType bd (int32 (CUDA.warpSize dev)) - skip <- A.mul numType warps (int32 (warp_smem_elems * bytes)) - smem <- dynamicSharedMem warps skip - - -- Share the per-lane aggregates - wid <- warpId - lane <- laneId - when (A.eq scalarType lane (lift 0)) $ do - writeArray smem wid input - - -- Wait for each warp to finish its local reduction - __syncthreads - - -- Update the total aggregate. Thread 0 just does this sequentially (as is - -- done in CUB), but we could also do this cooperatively (better for - -- larger thread blocks?) - tid <- threadIdx - if A.eq scalarType tid (lift 0) - then do - steps <- case size of - Nothing -> return warps - Just n -> do - a <- A.add numType n (int32 (CUDA.warpSize dev - 1)) - b <- A.quot integralType a (int32 (CUDA.warpSize dev)) - return b - iterFromStepTo (lift 1) (lift 1) steps input $ \step x -> - app2 combine x =<< readArray smem step - else - return input - - --- Efficient warp-wide reduction using shared memory. The aggregate reduction --- value for the warp is stored in thread lane zero. --- --- Each warp requires 48 (1.5 x warp size) elements of shared memory. The --- routine assumes that is is allocated individually per-warp (i.e. can be --- indexed in the range [0,warp size)). --- --- Example: https://github.com/NVlabs/cub/blob/1.5.2/cub/warp/specializations/warp_reduce_smem.cuh#L128 --- -reduceWarpSMem - :: forall aenv e. Elt e - => DeviceProperties -- ^ properties of the target device - -> IRFun2 PTX aenv (e -> e -> e) -- ^ combination function - -> IRArray (Vector e) -- ^ temporary storage array in shared memory (1.5 warp size elements) - -> Maybe (IR Int32) -- ^ number of items that will be reduced by this warp, otherwise all lanes are valid - -> IR e -- ^ calling thread's input element - -> CodeGen (IR e) -- ^ warp-wide reduction using the specified operator (lane 0 only) -reduceWarpSMem dev combine smem size = reduce 0 - where - log2 :: Double -> Double - log2 = P.logBase 2 - - -- Number steps required to reduce warp - steps = P.floor . log2 . P.fromIntegral . CUDA.warpSize $ dev - - -- Return whether the index is valid. Assume that constant branches are - -- optimised away. - valid i = - case size of - Nothing -> return (lift True) - Just n -> A.lt scalarType i n - - -- Unfold the reduction as a recursive code generation function. - reduce :: Int -> IR e -> CodeGen (IR e) - reduce step x - | step >= steps = return x - | offset <- 1 `P.shiftL` step = do - -- share input through buffer - lane <- laneId - writeArray smem lane x - - -- update input if in range - i <- A.add numType lane (lift offset) - x' <- if valid i - then app2 combine x =<< readArray smem i - else return x - - reduce (step+1) x' - - --- Efficient warp reduction using __shfl_up instruction (compute >= 3.0) --- --- Example: https://github.com/NVlabs/cub/blob/1.5.2/cub/warp/specializations/warp_reduce_shfl.cuh#L310 --- --- reduceWarpShfl --- :: IRFun2 PTX aenv (e -> e -> e) -- ^ combination function --- -> IR e -- ^ this thread's input value --- -> CodeGen (IR e) -- ^ final result --- reduceWarpShfl combine input = --- error "TODO: PTX.reduceWarpShfl" - - --- Reduction loops --- --------------- - -reduceFromTo - :: Elt a - => DeviceProperties - -> IR Int32 -- ^ starting index - -> IR Int32 -- ^ final index (exclusive) - -> (IRFun2 PTX aenv (a -> a -> a)) -- ^ combination function - -> (IR Int32 -> CodeGen (IR a)) -- ^ function to retrieve element at index - -> (IR a -> CodeGen ()) -- ^ what to do with the value - -> CodeGen () -reduceFromTo dev from to combine get set = do - - tid <- threadIdx - bd <- blockDim - - valid <- A.sub numType to from - i <- A.add numType from tid - - _ <- if A.gte scalarType valid bd - then do - -- All threads in the block will participate in the reduction, so - -- we can avoid bounds checks - x <- get i - r <- reduceBlockSMem dev combine Nothing x - set r - - return (IR OP_Unit :: IR ()) -- unsightly, but free - else do - -- Only in-bounds threads can read their input and participate in - -- the reduction - when (A.lt scalarType i to) $ do - x <- get i - r <- reduceBlockSMem dev combine (Just valid) x - set r - - return (IR OP_Unit :: IR ()) - - return () - - - --- Utilities --- --------- - -i32 :: IR Int -> CodeGen (IR Int32) -i32 = A.fromIntegral integralType numType - - -imapFromTo - :: IR Int32 - -> IR Int32 - -> (IR Int32 -> CodeGen ()) - -> CodeGen () -imapFromTo start end body = do - bid <- blockIdx - gd <- gridDim - i0 <- A.add numType start bid - imapFromStepTo i0 gd end body - diff --git a/Data/Array/Accelerate/LLVM/PTX/CodeGen/FoldSeg.hs b/Data/Array/Accelerate/LLVM/PTX/CodeGen/FoldSeg.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/PTX/CodeGen/FoldSeg.hs +++ /dev/null @@ -1,464 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RebindableSyntax #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ViewPatterns #-} --- | --- Module : Data.Array.Accelerate.LLVM.PTX.CodeGen.FoldSeg --- Copyright : [2016..2017] Trevor L. McDonell --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -module Data.Array.Accelerate.LLVM.PTX.CodeGen.FoldSeg - where - --- accelerate -import Data.Array.Accelerate.Analysis.Type -import Data.Array.Accelerate.Array.Sugar ( Array, Segments, Shape(rank), (:.), Elt(..) ) - --- accelerate-llvm-* -import LLVM.AST.Type.Representation - -import Data.Array.Accelerate.LLVM.CodeGen.Arithmetic as A -import Data.Array.Accelerate.LLVM.CodeGen.Array -import Data.Array.Accelerate.LLVM.CodeGen.Base -import Data.Array.Accelerate.LLVM.CodeGen.Constant -import Data.Array.Accelerate.LLVM.CodeGen.Environment -import Data.Array.Accelerate.LLVM.CodeGen.Exp -import Data.Array.Accelerate.LLVM.CodeGen.IR -import Data.Array.Accelerate.LLVM.CodeGen.Loop as Loop -import Data.Array.Accelerate.LLVM.CodeGen.Monad -import Data.Array.Accelerate.LLVM.CodeGen.Sugar - -import Data.Array.Accelerate.LLVM.PTX.Analysis.Launch -import Data.Array.Accelerate.LLVM.PTX.CodeGen.Base -import Data.Array.Accelerate.LLVM.PTX.CodeGen.Fold ( reduceBlockSMem, reduceWarpSMem, imapFromTo ) --- import Data.Array.Accelerate.LLVM.PTX.CodeGen.Queue -import Data.Array.Accelerate.LLVM.PTX.Context -import Data.Array.Accelerate.LLVM.PTX.Target - --- cuda -import qualified Foreign.CUDA.Analysis as CUDA - -import Control.Applicative ( (<$>), (<*>) ) -import Control.Monad ( void ) -import Data.String ( fromString ) -import Prelude as P - - --- Segmented reduction along the innermost dimension of an array. Performs one --- reduction per segment of the source array. --- -mkFoldSeg - :: forall aenv sh i e. (Shape sh, IsIntegral i, Elt i, Elt e) - => PTX - -> Gamma aenv - -> IRFun2 PTX aenv (e -> e -> e) - -> IRExp PTX aenv e - -> IRDelayed PTX aenv (Array (sh :. Int) e) - -> IRDelayed PTX aenv (Segments i) - -> CodeGen (IROpenAcc PTX aenv (Array (sh :. Int) e)) -mkFoldSeg (deviceProperties . ptxContext -> dev) aenv combine seed arr seg = - (+++) <$> mkFoldSegP_block dev aenv combine (Just seed) arr seg - <*> mkFoldSegP_warp dev aenv combine (Just seed) arr seg - - --- Segmented reduction along the innermost dimension of an array, where /all/ --- segments are non-empty. --- -mkFold1Seg - :: forall aenv sh i e. (Shape sh, IsIntegral i, Elt i, Elt e) - => PTX - -> Gamma aenv - -> IRFun2 PTX aenv (e -> e -> e) - -> IRDelayed PTX aenv (Array (sh :. Int) e) - -> IRDelayed PTX aenv (Segments i) - -> CodeGen (IROpenAcc PTX aenv (Array (sh :. Int) e)) -mkFold1Seg (deviceProperties . ptxContext -> dev) aenv combine arr seg = - (+++) <$> mkFoldSegP_block dev aenv combine Nothing arr seg - <*> mkFoldSegP_warp dev aenv combine Nothing arr seg - - --- This implementation assumes that the segments array represents the offset --- indices to the source array, rather than the lengths of each segment. The --- segment-offset approach is required for parallel implementations. --- --- Each segment is computed by a single thread block, meaning we don't have to --- worry about inter-block synchronisation. --- -mkFoldSegP_block - :: forall aenv sh i e. (Shape sh, IsIntegral i, Elt i, Elt e) - => DeviceProperties - -> Gamma aenv - -> IRFun2 PTX aenv (e -> e -> e) - -> Maybe (IRExp PTX aenv e) - -> IRDelayed PTX aenv (Array (sh :. Int) e) - -> IRDelayed PTX aenv (Segments i) - -> CodeGen (IROpenAcc PTX aenv (Array (sh :. Int) e)) -mkFoldSegP_block dev aenv combine mseed arr seg = - let - (start, end, paramGang) = gangParam - (arrOut, paramOut) = mutableArray ("out" :: Name (Array (sh :. Int) e)) - paramEnv = envParam aenv - -- - config = launchConfig dev (CUDA.decWarp dev) dsmem const [|| const ||] - dsmem n = warps * (1 + per_warp) * bytes - where - ws = CUDA.warpSize dev - warps = n `P.quot` ws - per_warp = ws + ws `P.quot` 2 - bytes = sizeOf (eltType (undefined :: e)) - in - makeOpenAccWith config "foldSeg_block" (paramGang ++ paramOut ++ paramEnv) $ do - - -- We use a dynamically scheduled work queue in order to evenly distribute - -- the uneven workload, due to the variable length of each segment, over the - -- available thread blocks. - -- queue <- globalWorkQueue - - -- All threads in the block need to know what the start and end indices of - -- this segment are in order to participate in the reduction. We use - -- variables in __shared__ memory to communicate these values between - -- threads in the block. Furthermore, by using a 2-element array, we can - -- have the first two threads of the block read the start and end indices as - -- a single coalesced read, since they will be sequential in the - -- segment-offset array. - -- - smem <- staticSharedMem 2 - - -- Compute the number of segments and size of the innermost dimension. These - -- are required if we are reducing a rank-2 or higher array, to properly - -- compute the start and end indices of the portion of the array this thread - -- block reduces. Note that this is a segment-offset array computed by - -- 'scanl (+) 0' of the segment length array, so its size has increased by - -- one. - -- - sz <- i32 . indexHead =<< delayedExtent arr - ss <- do n <- i32 . indexHead =<< delayedExtent seg - A.sub numType n (lift 1) - - -- Each thread block cooperatively reduces a segment. - -- s0 <- dequeue queue (lift 1) - -- for s0 (\s -> A.lt scalarType s end) (\_ -> dequeue queue (lift 1)) $ \s -> do - imapFromTo start end $ \s -> do - - -- The first two threads of the block determine the indices of the - -- segments array that we will reduce between and distribute those values - -- to the other threads in the block. - tid <- threadIdx - when (A.lt scalarType tid (lift 2)) $ do - i <- case rank (undefined::sh) of - 0 -> return s - _ -> A.rem integralType s ss - j <- A.add numType i tid - v <- app1 (delayedLinearIndex seg) =<< A.fromIntegral integralType numType j - writeArray smem tid =<< i32 v - - -- Once all threads have caught up, begin work on the new segment. - __syncthreads - - u <- readArray smem (lift 0 :: IR Int32) - v <- readArray smem (lift 1 :: IR Int32) - - -- Determine the index range of the input array we will reduce over. - -- Necessary for multidimensional segmented reduction. - (inf,sup) <- A.unpair <$> case rank (undefined::sh) of - 0 -> return (A.pair u v) - _ -> do q <- A.quot integralType s ss - a <- A.mul numType q sz - A.pair <$> A.add numType u a - <*> A.add numType v a - - void $ - if A.eq scalarType inf sup - -- This segment is empty. If this is an exclusive reduction the - -- first thread writes out the initial element for this segment. - then do - case mseed of - Nothing -> return (IR OP_Unit :: IR ()) - Just z -> do - when (A.eq scalarType tid (lift 0)) $ writeArray arrOut s =<< z - return (IR OP_Unit) - - -- This is a non-empty segment. - else do - -- Step 1: initialise local sums - -- - -- NOTE: We require all threads to enter this branch and execute the - -- first step, even if they do not have a valid element and must - -- return 'undef'. If we attempt to skip this entire section for - -- non-participating threads (i.e. 'when (i0 < sup)'), it seems that - -- those threads die and will not participate in the computation of - -- _any_ further segment. I'm not sure if this is a CUDA oddity - -- (e.g. we must have all threads convergent on __syncthreads) or - -- a bug in NVPTX / ptxas. - -- - bd <- blockDim - i0 <- A.add numType inf tid - x0 <- if A.lt scalarType i0 sup - then app1 (delayedLinearIndex arr) =<< A.fromIntegral integralType numType i0 - else let - go :: TupleType a -> Operands a - go UnitTuple = OP_Unit - go (PairTuple a b) = OP_Pair (go a) (go b) - go (SingleTuple t) = ir' t (undef t) - in - return . IR $ go (eltType (undefined::e)) - - v0 <- A.sub numType sup inf - r0 <- if A.gte scalarType v0 bd - then reduceBlockSMem dev combine Nothing x0 - else reduceBlockSMem dev combine (Just v0) x0 - - -- Step 2: keep walking over the input - nxt <- A.add numType inf bd - r <- iterFromStepTo nxt bd sup r0 $ \offset r -> do - - -- Wait for threads to catch up before starting the next stripe - __syncthreads - - i' <- A.add numType offset tid - v' <- A.sub numType sup offset - r' <- if A.gte scalarType v' bd - -- All threads in the block are in bounds, so we - -- can avoid bounds checks. - then do - x <- app1 (delayedLinearIndex arr) =<< A.fromIntegral integralType numType i' - y <- reduceBlockSMem dev combine Nothing x - return y - - -- Not all threads are valid. Note that we still - -- have all threads enter the reduction procedure - -- to avoid thread divergence on synchronisation - -- points, similar to the above NOTE. - else do - x <- if A.lt scalarType i' sup - then app1 (delayedLinearIndex arr) =<< A.fromIntegral integralType numType i' - else return r - y <- reduceBlockSMem dev combine (Just v') x - return y - - -- first thread incorporates the result from the previous - -- iteration - if A.eq scalarType tid (lift 0) - then app2 combine r r' - else return r' - - -- Step 3: Thread zero writes the aggregate reduction for this - -- segment to memory. If this is an exclusive fold combine with the - -- initial element as well. - when (A.eq scalarType tid (lift 0)) $ - writeArray arrOut s =<< - case mseed of - Nothing -> return r - Just z -> flip (app2 combine) r =<< z -- Note: initial element on the left - - return (IR OP_Unit) - - return_ - - --- This implementation assumes that the segments array represents the offset --- indices to the source array, rather than the lengths of each segment. The --- segment-offset approach is required for parallel implementations. --- --- Each segment is computed by a single warp, meaning we don't have to worry --- about inter- or intra-block synchronisation. --- -mkFoldSegP_warp - :: forall aenv sh i e. (Shape sh, IsIntegral i, Elt i, Elt e) - => DeviceProperties - -> Gamma aenv - -> IRFun2 PTX aenv (e -> e -> e) - -> Maybe (IRExp PTX aenv e) - -> IRDelayed PTX aenv (Array (sh :. Int) e) - -> IRDelayed PTX aenv (Segments i) - -> CodeGen (IROpenAcc PTX aenv (Array (sh :. Int) e)) -mkFoldSegP_warp dev aenv combine mseed arr seg = - let - (start, end, paramGang) = gangParam - (arrOut, paramOut) = mutableArray ("out" :: Name (Array (sh :. Int) e)) - paramEnv = envParam aenv - -- - config = launchConfig dev (CUDA.decWarp dev) dsmem grid gridQ - dsmem n = warps * (2 + per_warp_elems) * bytes - where - warps = n `P.quot` ws - -- - grid n m = multipleOf n (m `P.quot` ws) - gridQ = [|| \n m -> $$multipleOfQ n (m `P.quot` ws) ||] - -- - per_warp_bytes = per_warp_elems * bytes - per_warp_elems = ws + (ws `P.quot` 2) - ws = CUDA.warpSize dev - bytes = sizeOf (eltType (undefined :: e)) - - int32 :: Integral a => a -> IR Int32 - int32 = lift . P.fromIntegral - in - makeOpenAccWith config "foldSeg_warp" (paramGang ++ paramOut ++ paramEnv) $ do - - -- Each warp works independently. - -- Determine the ID of this warp within the thread block. - tid <- threadIdx - wid <- A.quot integralType tid (int32 ws) - - -- Number of warps per thread block - bd <- blockDim - wpb <- A.quot integralType bd (int32 ws) - - -- ID of this warp within the grid - bid <- blockIdx - gwid <- do a <- A.mul numType bid wpb - b <- A.add numType wid a - return b - - -- All threads in the warp need to know what the start and end indices of - -- this segment are in order to participate in the reduction. We use - -- variables in __shared__ memory to communicate these values between - -- threads. Furthermore, by using a 2-element array, we can have the first - -- two threads of the warp read the start and end indices as a single - -- coalesced read, as these elements will be adjacent in the segment-offset - -- array. - -- - lim <- do - a <- A.mul numType wid (int32 (2 * bytes)) - b <- dynamicSharedMem (lift 2) a - return b - - -- Allocate (1.5 * warpSize) elements of share memory for each warp - smem <- do - a <- A.mul numType wpb (int32 (2 * bytes)) - b <- A.mul numType wid (int32 per_warp_bytes) - c <- A.add numType a b - d <- dynamicSharedMem (int32 per_warp_elems) c - return d - - -- Compute the number of segments and size of the innermost dimension. These - -- are required if we are reducing a rank-2 or higher array, to properly - -- compute the start and end indices of the portion of the array this warp - -- reduces. Note that this is a segment-offset array computed by 'scanl (+) 0' - -- of the segment length array, so its size has increased by one. - -- - sz <- i32 . indexHead =<< delayedExtent arr - ss <- do a <- i32 . indexHead =<< delayedExtent seg - b <- A.sub numType a (lift 1) - return b - - -- Each thread reduces a segment independently - s0 <- A.add numType start gwid - gd <- gridDim - step <- A.mul numType wpb gd - imapFromStepTo s0 step end $ \s -> do - - -- The first two threads of the warp determine the indices of the segments - -- array that we will reduce between and distribute those values to the - -- other threads in the warp - lane <- laneId - when (A.lt scalarType lane (lift 2)) $ do - a <- case rank (undefined::sh) of - 0 -> return s - _ -> A.rem integralType s ss - b <- A.add numType a lane - c <- app1 (delayedLinearIndex seg) =<< A.fromIntegral integralType numType b - writeArray lim lane =<< i32 c - - -- Determine the index range of the input array we will reduce over. - -- Necessary for multidimensional segmented reduction. - (inf,sup) <- do - u <- readArray lim (lift 0 :: IR Int32) - v <- readArray lim (lift 1 :: IR Int32) - A.unpair <$> case rank (undefined::sh) of - 0 -> return (A.pair u v) - _ -> do q <- A.quot integralType s ss - a <- A.mul numType q sz - A.pair <$> A.add numType u a <*> A.add numType v a - - -- TLM: I don't think this should be necessary... - __syncthreads - - void $ - if A.eq scalarType inf sup - -- This segment is empty. If this is an exclusive reduction the first - -- lane writes out the initial element for this segment. - then do - case mseed of - Nothing -> return (IR OP_Unit :: IR ()) - Just z -> do - when (A.eq scalarType lane (lift 0)) $ writeArray arrOut s =<< z - return (IR OP_Unit) - - -- This is a non-empty segment. - else do - -- Step 1: initialise local sums - -- - -- See comment above why we initialise the loop in this way - -- - i0 <- A.add numType inf lane - x0 <- if A.lt scalarType i0 sup - then app1 (delayedLinearIndex arr) =<< A.fromIntegral integralType numType i0 - else let - go :: TupleType a -> Operands a - go UnitTuple = OP_Unit - go (PairTuple a b) = OP_Pair (go a) (go b) - go (SingleTuple t) = ir' t (undef t) - in - return . IR $ go (eltType (undefined::e)) - - v0 <- A.sub numType sup inf - r0 <- if A.gte scalarType v0 (int32 ws) - then reduceWarpSMem dev combine smem Nothing x0 - else reduceWarpSMem dev combine smem (Just v0) x0 - - -- Step 2: Keep walking over the rest of the segment - nx <- A.add numType inf (int32 ws) - r <- iterFromStepTo nx (int32 ws) sup r0 $ \offset r -> do - - -- TLM: Similarly, I think this is unnecessary... - __syncthreads - - i' <- A.add numType offset lane - v' <- A.sub numType sup offset - r' <- if A.gte scalarType v' (int32 ws) - then do - -- All lanes are in bounds, so avoid bounds checks - x <- app1 (delayedLinearIndex arr) =<< A.fromIntegral integralType numType i' - y <- reduceWarpSMem dev combine smem Nothing x - return y - - else do - x <- if A.lt scalarType i' sup - then app1 (delayedLinearIndex arr) =<< A.fromIntegral integralType numType i' - else return r - y <- reduceWarpSMem dev combine smem (Just v') x - return y - - -- The first lane incorporates the result from the previous - -- iteration - if A.eq scalarType lane (lift 0) - then app2 combine r r' - else return r' - - -- Step 3: Lane zero writes the aggregate reduction for this - -- segment to memory. If this is an exclusive reduction, also - -- combine with the initial element - when (A.eq scalarType lane (lift 0)) $ - writeArray arrOut s =<< - case mseed of - Nothing -> return r - Just z -> flip (app2 combine) r =<< z -- Note: initial element on the left - - return (IR OP_Unit) - - return_ - - -i32 :: IsIntegral a => IR a -> CodeGen (IR Int32) -i32 = A.fromIntegral integralType numType - diff --git a/Data/Array/Accelerate/LLVM/PTX/CodeGen/Generate.hs b/Data/Array/Accelerate/LLVM/PTX/CodeGen/Generate.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/PTX/CodeGen/Generate.hs +++ /dev/null @@ -1,60 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} --- | --- Module : Data.Array.Accelerate.LLVM.PTX.CodeGen.Generate --- Copyright : [2014..2017] Trevor L. McDonell --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -module Data.Array.Accelerate.LLVM.PTX.CodeGen.Generate - where - -import Prelude hiding ( fromIntegral ) - --- accelerate -import Data.Array.Accelerate.Array.Sugar ( Array, Shape, Elt ) -import Data.Array.Accelerate.Type - -import Data.Array.Accelerate.LLVM.CodeGen.Arithmetic -import Data.Array.Accelerate.LLVM.CodeGen.Array -import Data.Array.Accelerate.LLVM.CodeGen.Base -import Data.Array.Accelerate.LLVM.CodeGen.Environment -import Data.Array.Accelerate.LLVM.CodeGen.Exp -import Data.Array.Accelerate.LLVM.CodeGen.Monad -import Data.Array.Accelerate.LLVM.CodeGen.Sugar - -import Data.Array.Accelerate.LLVM.PTX.CodeGen.Base -import Data.Array.Accelerate.LLVM.PTX.CodeGen.Loop -import Data.Array.Accelerate.LLVM.PTX.Target ( PTX ) - - --- Construct a new array by applying a function to each index. Each thread --- processes multiple adjacent elements. --- -mkGenerate - :: forall aenv sh e. (Shape sh, Elt e) - => PTX - -> Gamma aenv - -> IRFun1 PTX aenv (sh -> e) - -> CodeGen (IROpenAcc PTX aenv (Array sh e)) -mkGenerate ptx aenv apply = - let - (start, end, paramGang) = gangParam - (arrOut, paramOut) = mutableArray ("out" :: Name (Array sh e)) - paramEnv = envParam aenv - in - makeOpenAcc ptx "generate" (paramGang ++ paramOut ++ paramEnv) $ do - - imapFromTo start end $ \i -> do - i' <- fromIntegral integralType numType i -- loop counter is Int32 - ix <- indexOfInt (irArrayShape arrOut) i' -- convert to multidimensional index - r <- app1 apply ix -- apply generator function - writeArray arrOut i' r -- store result - - return_ - - diff --git a/Data/Array/Accelerate/LLVM/PTX/CodeGen/Intrinsic.hs b/Data/Array/Accelerate/LLVM/PTX/CodeGen/Intrinsic.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/PTX/CodeGen/Intrinsic.hs +++ /dev/null @@ -1,359 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} --- | --- Module : Data.Array.Accelerate.LLVM.PTX.CodeGen.Intrinsic --- Copyright : [2017] Trevor L. McDonell --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -module Data.Array.Accelerate.LLVM.PTX.CodeGen.Intrinsic ( ) - where - -import LLVM.AST.Type.Name ( Label(..) ) - -import Data.Array.Accelerate.LLVM.CodeGen.Intrinsic -import Data.Array.Accelerate.LLVM.PTX.Target - -import Data.ByteString.Short ( ShortByteString ) -import Data.HashMap.Strict ( HashMap ) -import Data.Monoid -import qualified Data.HashMap.Strict as HashMap - - -instance Intrinsic PTX where - intrinsicForTarget _ = libdeviceIndex - --- The list of functions implemented by libdevice. These are all more-or-less --- named consistently based on the standard mathematical functions they --- implement, with the "__nv_" prefix stripped. --- -libdeviceIndex :: HashMap ShortByteString Label -libdeviceIndex = - let nv base = (base, Label $ "__nv_" <> base) - in - HashMap.fromList $ map nv - [ "abs" - , "acos" - , "acosf" - , "acosh" - , "acoshf" - , "asin" - , "asinf" - , "asinh" - , "asinhf" - , "atan" - , "atan2" - , "atan2f" - , "atanf" - , "atanh" - , "atanhf" - , "brev" - , "brevll" - , "byte_perm" - , "cbrt" - , "cbrtf" - , "ceil" - , "ceilf" - , "clz" - , "clzll" - , "copysign" - , "copysignf" - , "cos" - , "cosf" - , "cosh" - , "coshf" - , "cospi" - , "cospif" - , "dadd_rd" - , "dadd_rn" - , "dadd_ru" - , "dadd_rz" - , "ddiv_rd" - , "ddiv_rn" - , "ddiv_ru" - , "ddiv_rz" - , "dmul_rd" - , "dmul_rn" - , "dmul_ru" - , "dmul_rz" - , "double2float_rd" - , "double2float_rn" - , "double2float_ru" - , "double2float_rz" - , "double2hiint" - , "double2int_rd" - , "double2int_rn" - , "double2int_ru" - , "double2int_rz" - , "double2ll_rd" - , "double2ll_rn" - , "double2ll_ru" - , "double2ll_rz" - , "double2loint" - , "double2uint_rd" - , "double2uint_rn" - , "double2uint_ru" - , "double2uint_rz" - , "double2ull_rd" - , "double2ull_rn" - , "double2ull_ru" - , "double2ull_rz" - , "double_as_longlong" - , "drcp_rd" - , "drcp_rn" - , "drcp_ru" - , "drcp_rz" - , "dsqrt_rd" - , "dsqrt_rn" - , "dsqrt_ru" - , "dsqrt_rz" - , "erf" - , "erfc" - , "erfcf" - , "erfcinv" - , "erfcinvf" - , "erfcx" - , "erfcxf" - , "erff" - , "erfinv" - , "erfinvf" - , "exp" - , "exp10" - , "exp10f" - , "exp2" - , "exp2f" - , "expf" - , "expm1" - , "expm1f" - , "fabs" - , "fabsf" - , "fadd_rd" - , "fadd_rn" - , "fadd_ru" - , "fadd_rz" - , "fast_cosf" - , "fast_exp10f" - , "fast_expf" - , "fast_fdividef" - , "fast_log10f" - , "fast_log2f" - , "fast_logf" - , "fast_powf" - , "fast_sincosf" - , "fast_sinf" - , "fast_tanf" - , "fdim" - , "fdimf" - , "fdiv_rd" - , "fdiv_rn" - , "fdiv_ru" - , "fdiv_rz" - , "ffs" - , "ffsll" - , "finitef" - , "float2half_rn" - , "float2int_rd" - , "float2int_rn" - , "float2int_ru" - , "float2int_rz" - , "float2ll_rd" - , "float2ll_rn" - , "float2ll_ru" - , "float2ll_rz" - , "float2uint_rd" - , "float2uint_rn" - , "float2uint_ru" - , "float2uint_rz" - , "float2ull_rd" - , "float2ull_rn" - , "float2ull_ru" - , "float2ull_rz" - , "float_as_int" - , "floor" - , "floorf" - , "fma" - , "fma_rd" - , "fma_rn" - , "fma_ru" - , "fma_rz" - , "fmaf" - , "fmaf_rd" - , "fmaf_rn" - , "fmaf_ru" - , "fmaf_rz" - , "fmax" - , "fmaxf" - , "fmin" - , "fminf" - , "fmod" - , "fmodf" - , "fmul_rd" - , "fmul_rn" - , "fmul_ru" - , "fmul_rz" - , "frcp_rd" - , "frcp_rn" - , "frcp_ru" - , "frcp_rz" - , "frexp" - , "frexpf" - , "frsqrt_rn" - , "fsqrt_rd" - , "fsqrt_rn" - , "fsqrt_ru" - , "fsqrt_rz" - , "fsub_rd" - , "fsub_rn" - , "fsub_ru" - , "fsub_rz" - , "hadd" - , "half2float" - , "hiloint2double" - , "hypot" - , "hypotf" - , "ilogb" - , "ilogbf" - , "int2double_rn" - , "int2float_rd" - , "int2float_rn" - , "int2float_ru" - , "int2float_rz" - , "int_as_float" - , "isfinited" - , "isinfd" - , "isinff" - , "isnand" - , "isnanf" - , "j0" - , "j0f" - , "j1" - , "j1f" - , "jn" - , "jnf" - , "ldexp" - , "ldexpf" - , "lgamma" - , "lgammaf" - , "ll2double_rd" - , "ll2double_rn" - , "ll2double_ru" - , "ll2double_rz" - , "ll2float_rd" - , "ll2float_rn" - , "ll2float_ru" - , "ll2float_rz" - , "llabs" - , "llmax" - , "llmin" - , "llrint" - , "llrintf" - , "llround" - , "llroundf" - , "log" - , "log10" - , "log10f" - , "log1p" - , "log1pf" - , "log2" - , "log2f" - , "logb" - , "logbf" - , "logf" - , "longlong_as_double" - , "max" - , "min" - , "modf" - , "modff" - , "mul24" - , "mul64hi" - , "mulhi" - , "nan" - , "nanf" - , "nearbyint" - , "nearbyintf" - , "nextafter" - , "nextafterf" - , "normcdf" - , "normcdff" - , "normcdfinv" - , "normcdfinvf" - , "popc" - , "popcll" - , "pow" - , "powf" - , "powi" - , "powif" - , "rcbrt" - , "rcbrtf" - , "remainder" - , "remainderf" - , "remquo" - , "remquof" - , "rhadd" - , "rint" - , "rintf" - , "round" - , "roundf" - , "rsqrt" - , "rsqrtf" - , "sad" - , "saturatef" - , "scalbn" - , "scalbnf" - , "signbitd" - , "signbitf" - , "sin" - , "sincos" - , "sincosf" - , "sincospi" - , "sincospif" - , "sinf" - , "sinh" - , "sinhf" - , "sinpi" - , "sinpif" - , "sqrt" - , "sqrtf" - , "tan" - , "tanf" - , "tanh" - , "tanhf" - , "tgamma" - , "tgammaf" - , "trunc" - , "truncf" - , "uhadd" - , "uint2double_rn" - , "uint2float_rd" - , "uint2float_rn" - , "uint2float_ru" - , "uint2float_rz" - , "ull2double_rd" - , "ull2double_rn" - , "ull2double_ru" - , "ull2double_rz" - , "ull2float_rd" - , "ull2float_rn" - , "ull2float_ru" - , "ull2float_rz" - , "ullmax" - , "ullmin" - , "umax" - , "umin" - , "umul24" - , "umul64hi" - , "umulhi" - , "urhadd" - , "usad" - , "y0" - , "y0f" - , "y1" - , "y1f" - , "yn" - , "ynf" - ] - diff --git a/Data/Array/Accelerate/LLVM/PTX/CodeGen/Loop.hs b/Data/Array/Accelerate/LLVM/PTX/CodeGen/Loop.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/PTX/CodeGen/Loop.hs +++ /dev/null @@ -1,47 +0,0 @@ --- | --- Module : Data.Array.Accelerate.LLVM.PTX.CodeGen.Loop --- Copyright : [2015..2017] Trevor L. McDonell --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -module Data.Array.Accelerate.LLVM.PTX.CodeGen.Loop - where - --- accelerate -import Data.Array.Accelerate.Type - -import Data.Array.Accelerate.LLVM.CodeGen.Arithmetic -import Data.Array.Accelerate.LLVM.CodeGen.IR -import Data.Array.Accelerate.LLVM.CodeGen.Monad -import qualified Data.Array.Accelerate.LLVM.CodeGen.Loop as Loop - -import Data.Array.Accelerate.LLVM.PTX.CodeGen.Base - - --- | A standard loop where the CUDA threads cooperatively step over an index --- space from the start to end indices. The threads stride the array in a way --- that maintains memory coalescing. --- --- The start and end array indices are given as natural array indexes, and the --- thread specific indices are calculated by the loop. --- --- > for ( int32 i = blockDim.x * blockIdx.x + threadIdx.x + start --- > ; i < end --- > ; i += blockDim.x * gridDim.x ) --- --- TODO: This assumes that the starting offset retains alignment to the warp --- boundary. This might not always be the case, so provide a version that --- explicitly aligns reads to the warp boundary. --- -imapFromTo :: IR Int32 -> IR Int32 -> (IR Int32 -> CodeGen ()) -> CodeGen () -imapFromTo start end body = do - step <- gridSize - tid <- globalThreadIdx - i0 <- add numType tid start - -- - Loop.imapFromStepTo i0 step end body - diff --git a/Data/Array/Accelerate/LLVM/PTX/CodeGen/Map.hs b/Data/Array/Accelerate/LLVM/PTX/CodeGen/Map.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/PTX/CodeGen/Map.hs +++ /dev/null @@ -1,60 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} --- | --- Module : Data.Array.Accelerate.LLVM.PTX.CodeGen.Map --- Copyright : [2014..2017] Trevor L. McDonell --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -module Data.Array.Accelerate.LLVM.PTX.CodeGen.Map - where - -import Prelude hiding ( fromIntegral ) - --- accelerate -import Data.Array.Accelerate.Array.Sugar ( Array, Elt ) -import Data.Array.Accelerate.Type - -import Data.Array.Accelerate.LLVM.CodeGen.Arithmetic -import Data.Array.Accelerate.LLVM.CodeGen.Array -import Data.Array.Accelerate.LLVM.CodeGen.Base -import Data.Array.Accelerate.LLVM.CodeGen.Environment -import Data.Array.Accelerate.LLVM.CodeGen.Monad -import Data.Array.Accelerate.LLVM.CodeGen.Sugar - -import Data.Array.Accelerate.LLVM.PTX.CodeGen.Base -import Data.Array.Accelerate.LLVM.PTX.CodeGen.Loop -import Data.Array.Accelerate.LLVM.PTX.Target ( PTX ) - - --- Apply a unary function to each element of an array. Each thread processes --- multiple elements, striding the array by the grid size. --- -mkMap :: forall aenv sh a b. Elt b - => PTX - -> Gamma aenv - -> IRFun1 PTX aenv (a -> b) - -> IRDelayed PTX aenv (Array sh a) - -> CodeGen (IROpenAcc PTX aenv (Array sh b)) -mkMap ptx aenv apply IRDelayed{..} = - let - (start, end, paramGang) = gangParam - (arrOut, paramOut) = mutableArray ("out" :: Name (Array sh b)) - paramEnv = envParam aenv - in - makeOpenAcc ptx "map" (paramGang ++ paramOut ++ paramEnv) $ do - - imapFromTo start end $ \i -> do - i' <- fromIntegral integralType numType i - xs <- app1 delayedLinearIndex i' - ys <- app1 apply xs - writeArray arrOut i' ys - - return_ - diff --git a/Data/Array/Accelerate/LLVM/PTX/CodeGen/Permute.hs b/Data/Array/Accelerate/LLVM/PTX/CodeGen/Permute.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/PTX/CodeGen/Permute.hs +++ /dev/null @@ -1,366 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ViewPatterns #-} --- | --- Module : Data.Array.Accelerate.LLVM.PTX.CodeGen.Permute --- Copyright : [2016..2017] Trevor L. McDonell --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -module Data.Array.Accelerate.LLVM.PTX.CodeGen.Permute ( - - mkPermute, - -) where - --- accelerate -import Data.Array.Accelerate.Analysis.Type -import Data.Array.Accelerate.Array.Sugar ( Array, Vector, Shape, Elt, eltType ) -import Data.Array.Accelerate.Error -import qualified Data.Array.Accelerate.Array.Sugar as S - -import Data.Array.Accelerate.LLVM.CodeGen.Arithmetic as A -import Data.Array.Accelerate.LLVM.CodeGen.Array -import Data.Array.Accelerate.LLVM.CodeGen.Base -import Data.Array.Accelerate.LLVM.CodeGen.Constant -import Data.Array.Accelerate.LLVM.CodeGen.Environment -import Data.Array.Accelerate.LLVM.CodeGen.Exp -import Data.Array.Accelerate.LLVM.CodeGen.IR -import Data.Array.Accelerate.LLVM.CodeGen.Monad -import Data.Array.Accelerate.LLVM.CodeGen.Permute -import Data.Array.Accelerate.LLVM.CodeGen.Ptr -import Data.Array.Accelerate.LLVM.CodeGen.Sugar - -import Data.Array.Accelerate.LLVM.PTX.CodeGen.Base -import Data.Array.Accelerate.LLVM.PTX.CodeGen.Loop -import Data.Array.Accelerate.LLVM.PTX.Context -import Data.Array.Accelerate.LLVM.PTX.Target - -import LLVM.AST.Type.AddrSpace -import LLVM.AST.Type.Instruction -import LLVM.AST.Type.Instruction.Atomic -import LLVM.AST.Type.Instruction.RMW as RMW -import LLVM.AST.Type.Instruction.Volatile -import LLVM.AST.Type.Operand -import LLVM.AST.Type.Representation - -import Foreign.CUDA.Analysis - -import Data.Typeable -import Control.Monad ( void ) -import Prelude - - --- Forward permutation specified by an indexing mapping. The resulting array is --- initialised with the given defaults, and any further values that are permuted --- into the result array are added to the current value using the combination --- function. --- --- The combination function must be /associative/ and /commutative/. Elements --- that are mapped to the magic index 'ignore' are dropped. --- --- Parallel forward permutation has to take special care because different --- threads could concurrently try to update the same memory location. Where --- available we make use of special atomic instructions and other optimisations, --- but in the general case each element of the output array has a lock which --- must be obtained by the thread before it can update that memory location. --- --- TODO: After too many failures to acquire the lock on an element, the thread --- should back off and try a different element, adding this failed element to --- a queue or some such. --- -mkPermute - :: forall aenv sh sh' e. (Shape sh, Shape sh', Elt e) - => PTX - -> Gamma aenv - -> IRPermuteFun PTX aenv (e -> e -> e) - -> IRFun1 PTX aenv (sh -> sh') - -> IRDelayed PTX aenv (Array sh e) - -> CodeGen (IROpenAcc PTX aenv (Array sh' e)) -mkPermute ptx aenv IRPermuteFun{..} project arr = - let - bytes = sizeOf (eltType (undefined :: e)) - sizeOk = bytes == 4 || bytes == 8 - in - case atomicRMW of - Just (rmw, f) | sizeOk -> mkPermute_rmw ptx aenv rmw f project arr - _ -> mkPermute_mutex ptx aenv combine project arr - - --- Parallel forward permutation function which uses atomic instructions to --- implement lock-free array updates. --- --- Atomic instruction support on CUDA devices is a bit patchy, so depending on --- the element type and compute capability of the target hardware we may need to --- emulate the operation using atomic compare-and-swap. --- --- Int32 Int64 Float32 Float64 --- +---------------------------------------- --- (+) | 2.0 2.0 2.0 6.0 --- (-) | 2.0 2.0 x x --- (.&.) | 2.0 3.2 --- (.|.) | 2.0 3.2 --- xor | 2.0 3.2 --- min | 2.0 3.2 x x --- max | 2.0 3.2 x x --- CAS | 2.0 2.0 --- --- Note that NVPTX requires at least compute 2.0, so we can always implement the --- lockfree update operations in terms of compare-and-swap. --- -mkPermute_rmw - :: forall aenv sh sh' e. (Shape sh, Shape sh', Elt e) - => PTX - -> Gamma aenv - -> RMWOperation - -> IRFun1 PTX aenv (e -> e) - -> IRFun1 PTX aenv (sh -> sh') - -> IRDelayed PTX aenv (Array sh e) - -> CodeGen (IROpenAcc PTX aenv (Array sh' e)) -mkPermute_rmw ptx@(deviceProperties . ptxContext -> dev) aenv rmw update project IRDelayed{..} = - let - (start, end, paramGang) = gangParam - (arrOut, paramOut) = mutableArray ("out" :: Name (Array sh' e)) - paramEnv = envParam aenv - -- - bytes = sizeOf (eltType (undefined :: e)) - compute = computeCapability dev - compute32 = Compute 3 2 - -- compute60 = Compute 6 0 - in - makeOpenAcc ptx "permute_rmw" (paramGang ++ paramOut ++ paramEnv) $ do - - sh <- delayedExtent - - imapFromTo start end $ \i -> do - - i' <- A.fromIntegral integralType numType i - ix <- indexOfInt sh i' - ix' <- app1 project ix - - unless (ignore ix') $ do - j <- intOfIndex (irArrayShape arrOut) ix' - x <- app1 delayedLinearIndex i' - r <- app1 update x - - case rmw of - Exchange - -> writeArray arrOut j r - -- - _ | SingleTuple s <- eltType (undefined::e) - , Just adata <- gcast (irArrayData arrOut) - , Just r' <- gcast r - -> do - addr <- instr' $ GetElementPtr (asPtr defaultAddrSpace (op s adata)) [op integralType j] - -- - let - rmw_integral :: IntegralType t -> Operand (Ptr t) -> Operand t -> CodeGen () - rmw_integral t ptr val - | primOk = void . instr' $ AtomicRMW t NonVolatile rmw ptr val (CrossThread, AcquireRelease) - | otherwise = - case rmw of - RMW.And -> atomicCAS_rmw s' (A.band t (ir t val)) ptr - RMW.Or -> atomicCAS_rmw s' (A.bor t (ir t val)) ptr - RMW.Xor -> atomicCAS_rmw s' (A.xor t (ir t val)) ptr - RMW.Min -> atomicCAS_cmp s' A.lt ptr val - RMW.Max -> atomicCAS_cmp s' A.gt ptr val - _ -> $internalError "mkPermute_rmw.integral" "unexpected transition" - where - s' = NumScalarType (IntegralNumType t) - primOk = compute >= compute32 - || bytes == 4 - || case rmw of - RMW.Add -> True - RMW.Sub -> True - _ -> False - - rmw_floating :: FloatingType t -> Operand (Ptr t) -> Operand t -> CodeGen () - rmw_floating t ptr val = - case rmw of - RMW.Min -> atomicCAS_cmp s' A.lt ptr val - RMW.Max -> atomicCAS_cmp s' A.gt ptr val - RMW.Sub -> atomicCAS_rmw s' (A.sub n (ir t val)) ptr - RMW.Add - | primAdd -> atomicAdd_f t ptr val - | otherwise -> atomicCAS_rmw s' (A.add n (ir t val)) ptr - _ -> $internalError "mkPermute_rmw.floating" "unexpected transition" - where - n = FloatingNumType t - s' = NumScalarType n - primAdd = bytes == 4 - -- Disabling due to missing support from llvm-4.0. - -- - -- compute >= compute60 - - rmw_nonnum :: NonNumType t -> Operand (Ptr t) -> Operand t -> CodeGen () - rmw_nonnum TypeChar{} ptr val = do - ptr32 <- instr' $ PtrCast (primType :: PrimType (Ptr Word32)) ptr - val32 <- instr' $ BitCast (scalarType :: ScalarType Word32) val - void $ instr' $ AtomicRMW (integralType :: IntegralType Word32) NonVolatile rmw ptr32 val32 (CrossThread, AcquireRelease) - rmw_nonnum _ _ _ = -- C character types are 8-bit, and thus not supported - $internalError "mkPermute_rmw.nonnum" "unexpected transition" - case s of - NumScalarType (IntegralNumType t) -> rmw_integral t addr (op t r') - NumScalarType (FloatingNumType t) -> rmw_floating t addr (op t r') - NonNumScalarType t -> rmw_nonnum t addr (op t r') - -- - _ -> $internalError "mkPermute_rmw" "unexpected transition" - - return_ - - --- Parallel forward permutation function which uses a spinlock to acquire --- a mutex before updating the value at that location. --- -mkPermute_mutex - :: forall aenv sh sh' e. (Shape sh, Shape sh', Elt e) - => PTX - -> Gamma aenv - -> IRFun2 PTX aenv (e -> e -> e) - -> IRFun1 PTX aenv (sh -> sh') - -> IRDelayed PTX aenv (Array sh e) - -> CodeGen (IROpenAcc PTX aenv (Array sh' e)) -mkPermute_mutex ptx aenv combine project IRDelayed{..} = - let - (start, end, paramGang) = gangParam - (arrOut, paramOut) = mutableArray ("out" :: Name (Array sh' e)) - (arrLock, paramLock) = mutableArray ("lock" :: Name (Vector Word32)) - paramEnv = envParam aenv - in - makeOpenAcc ptx "permute_mutex" (paramGang ++ paramOut ++ paramLock ++ paramEnv) $ do - - sh <- delayedExtent - - imapFromTo start end $ \i -> do - - i' <- A.fromIntegral integralType numType i - ix <- indexOfInt sh i' - ix' <- app1 project ix - - -- project element onto the destination array and (atomically) update - unless (ignore ix') $ do - j <- intOfIndex (irArrayShape arrOut) ix' - x <- app1 delayedLinearIndex i' - - atomically arrLock j $ do - y <- readArray arrOut j - r <- app2 combine x y - writeArray arrOut j r - - return_ - - --- Atomically execute the critical section only when the lock at the given array --- index is obtained. The thread spins waiting for the lock to be released and --- there is no backoff strategy in case the lock is contended. --- --- The canonical implementation of a spin-lock looks like this: --- --- > do { --- > old = atomic_exchange(&lock[i], 1); --- > } while (old == 1); --- > --- > /* critical section */ --- > --- > atomic_exchange(&lock[i], 0); --- --- The initial loop repeatedly attempts to take the lock by writing a 1 (locked) --- into the lock slot. Once the 'old' state of the lock returns 0 (unlocked), --- then we just acquired the lock and the atomic section can be computed. --- Finally, the lock is released by writing 0 back to the lock slot. --- --- However, there is a complication with CUDA devices because all threads in --- a warp must execute in lockstep (with predicated execution). In the above --- setup, once a thread acquires a lock, then it will be disabled and stop --- participating in the loop, waiting for all other threads (to acquire their --- locks) before continuing program execution. If two threads in the same warp --- attempt to acquire the same lock, then once the lock is acquired by one --- thread then it will sit idle waiting while the second thread spins attempting --- to grab a lock that will never be released because the first thread (which --- holds the lock) can not make progress. DEADLOCK. --- --- To prevent this situation we must invert the algorithm so that threads can --- always make progress, until each warp in the thread has committed their --- result. --- --- > done = 0; --- > do { --- > if ( atomic_exchange(&lock[i], 1) == 0 ) { --- > --- > /* critical section */ --- > --- > done = 1; --- > atomic_exchange(&lock[i], 0); --- > } --- > } while ( done == 0 ); --- -atomically - :: IRArray (Vector Word32) - -> IR Int - -> CodeGen a - -> CodeGen a -atomically barriers i action = do - let - lock = integral integralType 1 - unlock = integral integralType 0 - unlock' = lift 0 - -- - spin <- newBlock "spinlock.entry" - crit <- newBlock "spinlock.critical-start" - skip <- newBlock "spinlock.critical-end" - exit <- newBlock "spinlock.exit" - - addr <- instr' $ GetElementPtr (asPtr defaultAddrSpace (op integralType (irArrayData barriers))) [op integralType i] - _ <- br spin - - -- Loop until this thread has completed its critical section. If the slot was - -- unlocked then we just acquired the lock and the thread can perform the - -- critical section, otherwise skip to the bottom of the critical section. - setBlock spin - old <- instr $ AtomicRMW integralType NonVolatile Exchange addr lock (CrossThread, Acquire) - ok <- A.eq scalarType old unlock' - no <- cbr ok crit skip - - -- If we just acquired the lock, execute the critical section - setBlock crit - r <- action - _ <- instr $ AtomicRMW integralType NonVolatile Exchange addr unlock (CrossThread, Release) - yes <- br skip - - -- At the base of the critical section, threads participate in a memory fence - -- to ensure the lock state is committed to memory. Depending on which - -- incoming edge the thread arrived at this block from determines whether they - -- have completed their critical section. - setBlock skip - done <- phi [(lift True, yes), (lift False, no)] - - __syncthreads - _ <- cbr done exit spin - - setBlock exit - return r - - --- Helper functions --- ---------------- - --- Test whether the given index is the magic value 'ignore'. This operates --- strictly rather than performing short-circuit (&&). --- -ignore :: forall ix. Shape ix => IR ix -> CodeGen (IR Bool) -ignore (IR ix) = go (S.eltType (undefined::ix)) (S.fromElt (S.ignore::ix)) ix - where - go :: TupleType t -> t -> Operands t -> CodeGen (IR Bool) - go UnitTuple () OP_Unit = return (lift True) - go (PairTuple tsh tsz) (ish, isz) (OP_Pair sh sz) = do x <- go tsh ish sh - y <- go tsz isz sz - land' x y - go (SingleTuple t) ig sz = A.eq t (ir t (scalar t ig)) (ir t (op' t sz)) - diff --git a/Data/Array/Accelerate/LLVM/PTX/CodeGen/Queue.hs b/Data/Array/Accelerate/LLVM/PTX/CodeGen/Queue.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/PTX/CodeGen/Queue.hs +++ /dev/null @@ -1,118 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} --- | --- Module : Data.Array.Accelerate.LLVM.PTX.CodeGen.Queue --- Copyright : [2014..2017] Trevor L. McDonell --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- --- Abstractions for creating simply dynamically scheduled work queues. This --- works by atomically incrementing a global counter (in global memory) and --- distributing this result to each thread in the block (via shared memory). --- Thus there is an additional ~1000 cycle overhead for a thread block to --- determine their next work item. This also implies all thread blocks are --- contending for the same global counter. --- --- In practice this extra overhead is not always worth paying. We use it for --- segmented reductions, because the length of each segment is unknown apriori --- and the entire thread block participates in the reduction of a segment. On --- the other hand, the arithmetically unbalanced mandelbrot fractal program was --- (generally) slower with this addition, so for now at least keep (morally) --- balanced operations (map, generate) with a static schedule. (Admittidely this --- test was on my very old 650M, so newer/more powerful GPUs with faster atomic --- instructions or more inflight thread blocks could benefit more.) --- - -module Data.Array.Accelerate.LLVM.PTX.CodeGen.Queue - where - -import Data.Array.Accelerate.LLVM.CodeGen.Arithmetic as A -import Data.Array.Accelerate.LLVM.CodeGen.Downcast -import Data.Array.Accelerate.LLVM.CodeGen.IR -import Data.Array.Accelerate.LLVM.CodeGen.Monad -import Data.Array.Accelerate.LLVM.CodeGen.Sugar - -import Data.Array.Accelerate.LLVM.PTX.Analysis.Launch -import Data.Array.Accelerate.LLVM.PTX.CodeGen.Base -import Data.Array.Accelerate.LLVM.PTX.Target - -import LLVM.AST.Type.Constant -import LLVM.AST.Type.Instruction -import LLVM.AST.Type.Instruction.Atomic -import LLVM.AST.Type.Instruction.Volatile -import LLVM.AST.Type.Operand -import LLVM.AST.Type.Representation -import qualified LLVM.AST.Global as LLVM -import qualified LLVM.AST.Linkage as LLVM -import qualified LLVM.AST.Name as LLVM -import qualified LLVM.AST.Type as LLVM -import qualified LLVM.AST.Type.Instruction.RMW as RMW - - --- Interface --- --------- - -type WorkQueue = (Operand (Ptr Int32), Operand (Ptr Int32)) - --- Declare a new dynamically scheduled global work queue. Don't forget to --- initialise the queue with the kernel generated by 'mkQueueInit'. --- -globalWorkQueue :: CodeGen WorkQueue -globalWorkQueue = do - sn <- freshName - declare $ LLVM.globalVariableDefaults - { LLVM.name = LLVM.Name "__queue__" - , LLVM.type' = LLVM.IntegerType 32 - , LLVM.alignment = 4 - } - declare $ LLVM.globalVariableDefaults - { LLVM.name = downcast sn - , LLVM.addrSpace = sharedMemAddrSpace - , LLVM.type' = LLVM.IntegerType 32 - , LLVM.linkage = LLVM.Internal - , LLVM.alignment = 4 - } - return ( ConstantOperand (GlobalReference type' "__queue__") - , ConstantOperand (GlobalReference type' sn) ) - - --- Dequeue the next 'n' items from the work queue for evaluation by the calling --- thread block. Each thread in the thread block receives the index of the start --- of the newly acquired range. --- -dequeue :: WorkQueue -> IR Int32 -> CodeGen (IR Int32) -dequeue (queue, smem) n = do - tid <- threadIdx - when (A.eq scalarType tid (lift 0)) $ do - v <- instr' $ AtomicRMW integralType NonVolatile RMW.Add queue (op integralType n) (CrossThread, AcquireRelease) - _ <- instr' $ Store Volatile smem v - return () - -- - __syncthreads - v <- instr' $ Load scalarType Volatile smem - return (ir integralType v) - - --- Initialisation kernel --- --------------------- - --- This kernel is used to initialise the dynamically scheduled work queue. It --- must be called before the main kernel, which uses the work queue, is invoked. --- -mkQueueInit - :: DeviceProperties - -> CodeGen (IROpenAcc PTX aenv a) -mkQueueInit dev = - let - (start, _end, paramGang) = gangParam - config = launchConfig dev [1] (\_ -> 0) (\_ _ -> 1) [|| \_ _ -> 1 ||] - in - makeOpenAccWith config "qinit" paramGang $ do - (queue,_) <- globalWorkQueue - _ <- instr' $ Store Volatile queue (op integralType start) - return_ - diff --git a/Data/Array/Accelerate/LLVM/PTX/CodeGen/Scan.hs b/Data/Array/Accelerate/LLVM/PTX/CodeGen/Scan.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/PTX/CodeGen/Scan.hs +++ /dev/null @@ -1,1335 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE RebindableSyntax #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ViewPatterns #-} --- | --- Module : Data.Array.Accelerate.LLVM.PTX.CodeGen.Scan --- Copyright : [2016..2017] Trevor L. McDonell --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -module Data.Array.Accelerate.LLVM.PTX.CodeGen.Scan ( - - mkScanl, mkScanl1, mkScanl', - mkScanr, mkScanr1, mkScanr', - -) where - --- accelerate -import Data.Array.Accelerate.Analysis.Type -import Data.Array.Accelerate.Array.Sugar - -import Data.Array.Accelerate.LLVM.Analysis.Match -import Data.Array.Accelerate.LLVM.CodeGen.Arithmetic as A -import Data.Array.Accelerate.LLVM.CodeGen.Array -import Data.Array.Accelerate.LLVM.CodeGen.Base -import Data.Array.Accelerate.LLVM.CodeGen.Constant -import Data.Array.Accelerate.LLVM.CodeGen.Environment -import Data.Array.Accelerate.LLVM.CodeGen.Exp -import Data.Array.Accelerate.LLVM.CodeGen.IR -import Data.Array.Accelerate.LLVM.CodeGen.Loop -import Data.Array.Accelerate.LLVM.CodeGen.Monad -import Data.Array.Accelerate.LLVM.CodeGen.Sugar -import Data.Array.Accelerate.LLVM.PTX.Analysis.Launch -import Data.Array.Accelerate.LLVM.PTX.CodeGen.Base -import Data.Array.Accelerate.LLVM.PTX.CodeGen.Generate -import Data.Array.Accelerate.LLVM.PTX.Context -import Data.Array.Accelerate.LLVM.PTX.Target - -import LLVM.AST.Type.Representation - -import qualified Foreign.CUDA.Analysis as CUDA - -import Control.Applicative -import Control.Monad ( (>=>), void ) -import Data.String ( fromString ) -import Data.Coerce as Safe -import Data.Bits as P -import Prelude as P hiding ( last ) - - -data Direction = L | R - --- 'Data.List.scanl' style left-to-right exclusive scan, but with the --- restriction that the combination function must be associative to enable --- efficient parallel implementation. --- --- > scanl (+) 10 (use $ fromList (Z :. 10) [0..]) --- > --- > ==> Array (Z :. 11) [10,10,11,13,16,20,25,31,38,46,55] --- -mkScanl - :: forall aenv sh e. (Shape sh, Elt e) - => PTX - -> Gamma aenv - -> IRFun2 PTX aenv (e -> e -> e) - -> IRExp PTX aenv e - -> IRDelayed PTX aenv (Array (sh:.Int) e) - -> CodeGen (IROpenAcc PTX aenv (Array (sh:.Int) e)) -mkScanl ptx@(deviceProperties . ptxContext -> dev) aenv combine seed arr - | Just Refl <- matchShapeType (undefined::sh) (undefined::Z) - = foldr1 (+++) <$> sequence [ mkScanAllP1 L dev aenv combine (Just seed) arr - , mkScanAllP2 L dev aenv combine - , mkScanAllP3 L dev aenv combine (Just seed) - , mkScanFill ptx aenv seed - ] - -- - | otherwise - = (+++) <$> mkScanDim L dev aenv combine (Just seed) arr - <*> mkScanFill ptx aenv seed - - --- 'Data.List.scanl1' style left-to-right inclusive scan, but with the --- restriction that the combination function must be associative to enable --- efficient parallel implementation. The array must not be empty. --- --- > scanl1 (+) (use $ fromList (Z :. 10) [0..]) --- > --- > ==> Array (Z :. 10) [0,1,3,6,10,15,21,28,36,45] --- -mkScanl1 - :: forall aenv sh e. (Shape sh, Elt e) - => PTX - -> Gamma aenv - -> IRFun2 PTX aenv (e -> e -> e) - -> IRDelayed PTX aenv (Array (sh:.Int) e) - -> CodeGen (IROpenAcc PTX aenv (Array (sh:.Int) e)) -mkScanl1 (deviceProperties . ptxContext -> dev) aenv combine arr - | Just Refl <- matchShapeType (undefined::sh) (undefined::Z) - = foldr1 (+++) <$> sequence [ mkScanAllP1 L dev aenv combine Nothing arr - , mkScanAllP2 L dev aenv combine - , mkScanAllP3 L dev aenv combine Nothing - ] - -- - | otherwise - = mkScanDim L dev aenv combine Nothing arr - - --- Variant of 'scanl' where the final result is returned in a separate array. --- --- > scanr' (+) 10 (use $ fromList (Z :. 10) [0..]) --- > --- > ==> ( Array (Z :. 10) [10,10,11,13,16,20,25,31,38,46] --- , Array Z [55] --- ) --- -mkScanl' - :: forall aenv sh e. (Shape sh, Elt e) - => PTX - -> Gamma aenv - -> IRFun2 PTX aenv (e -> e -> e) - -> IRExp PTX aenv e - -> IRDelayed PTX aenv (Array (sh:.Int) e) - -> CodeGen (IROpenAcc PTX aenv (Array (sh:.Int) e, Array sh e)) -mkScanl' ptx@(deviceProperties . ptxContext -> dev) aenv combine seed arr - | Just Refl <- matchShapeType (undefined::sh) (undefined::Z) - = foldr1 (+++) <$> sequence [ mkScan'AllP1 L dev aenv combine seed arr - , mkScan'AllP2 L dev aenv combine - , mkScan'AllP3 L dev aenv combine - , mkScan'Fill ptx aenv seed - ] - -- - | otherwise - = (+++) <$> mkScan'Dim L dev aenv combine seed arr - <*> mkScan'Fill ptx aenv seed - - --- 'Data.List.scanr' style right-to-left exclusive scan, but with the --- restriction that the combination function must be associative to enable --- efficient parallel implementation. --- --- > scanr (+) 10 (use $ fromList (Z :. 10) [0..]) --- > --- > ==> Array (Z :. 11) [55,55,54,52,49,45,40,34,27,19,10] --- -mkScanr - :: forall aenv sh e. (Shape sh, Elt e) - => PTX - -> Gamma aenv - -> IRFun2 PTX aenv (e -> e -> e) - -> IRExp PTX aenv e - -> IRDelayed PTX aenv (Array (sh:.Int) e) - -> CodeGen (IROpenAcc PTX aenv (Array (sh:.Int) e)) -mkScanr ptx@(deviceProperties . ptxContext -> dev) aenv combine seed arr - | Just Refl <- matchShapeType (undefined::sh) (undefined::Z) - = foldr1 (+++) <$> sequence [ mkScanAllP1 R dev aenv combine (Just seed) arr - , mkScanAllP2 R dev aenv combine - , mkScanAllP3 R dev aenv combine (Just seed) - , mkScanFill ptx aenv seed - ] - -- - | otherwise - = (+++) <$> mkScanDim R dev aenv combine (Just seed) arr - <*> mkScanFill ptx aenv seed - - --- 'Data.List.scanr1' style right-to-left inclusive scan, but with the --- restriction that the combination function must be associative to enable --- efficient parallel implementation. The array must not be empty. --- --- > scanr (+) 10 (use $ fromList (Z :. 10) [0..]) --- > --- > ==> Array (Z :. 10) [45,45,44,42,39,35,30,24,17,9] --- -mkScanr1 - :: forall aenv sh e. (Shape sh, Elt e) - => PTX - -> Gamma aenv - -> IRFun2 PTX aenv (e -> e -> e) - -> IRDelayed PTX aenv (Array (sh:.Int) e) - -> CodeGen (IROpenAcc PTX aenv (Array (sh:.Int) e)) -mkScanr1 (deviceProperties . ptxContext -> dev) aenv combine arr - | Just Refl <- matchShapeType (undefined::sh) (undefined::Z) - = foldr1 (+++) <$> sequence [ mkScanAllP1 R dev aenv combine Nothing arr - , mkScanAllP2 R dev aenv combine - , mkScanAllP3 R dev aenv combine Nothing - ] - -- - | otherwise - = mkScanDim R dev aenv combine Nothing arr - - --- Variant of 'scanr' where the final result is returned in a separate array. --- --- > scanr' (+) 10 (use $ fromList (Z :. 10) [0..]) --- > --- > ==> ( Array (Z :. 10) [55,54,52,49,45,40,34,27,19,10] --- , Array Z [55] --- ) --- -mkScanr' - :: forall aenv sh e. (Shape sh, Elt e) - => PTX - -> Gamma aenv - -> IRFun2 PTX aenv (e -> e -> e) - -> IRExp PTX aenv e - -> IRDelayed PTX aenv (Array (sh:.Int) e) - -> CodeGen (IROpenAcc PTX aenv (Array (sh:.Int) e, Array sh e)) -mkScanr' ptx@(deviceProperties . ptxContext -> dev) aenv combine seed arr - | Just Refl <- matchShapeType (undefined::sh) (undefined::Z) - = foldr1 (+++) <$> sequence [ mkScan'AllP1 R dev aenv combine seed arr - , mkScan'AllP2 R dev aenv combine - , mkScan'AllP3 R dev aenv combine - , mkScan'Fill ptx aenv seed - ] - -- - | otherwise - = (+++) <$> mkScan'Dim R dev aenv combine seed arr - <*> mkScan'Fill ptx aenv seed - - --- Device wide scans --- ----------------- --- --- This is a classic two-pass algorithm which proceeds in two phases and --- requires ~4n data movement to global memory. In future we would like to --- replace this with a single pass algorithm. --- - --- Parallel scan, step 1. --- --- Threads scan a stripe of the input into a temporary array, incorporating the --- initial element and any fused functions on the way. The final reduction --- result of this chunk is written to a separate array. --- -mkScanAllP1 - :: forall aenv e. Elt e - => Direction - -> DeviceProperties -- ^ properties of the target GPU - -> Gamma aenv -- ^ array environment - -> IRFun2 PTX aenv (e -> e -> e) -- ^ combination function - -> Maybe (IRExp PTX aenv e) -- ^ seed element, if this is an exclusive scan - -> IRDelayed PTX aenv (Vector e) -- ^ input data - -> CodeGen (IROpenAcc PTX aenv (Vector e)) -mkScanAllP1 dir dev aenv combine mseed IRDelayed{..} = - let - (start, end, paramGang) = gangParam - (arrOut, paramOut) = mutableArray ("out" :: Name (Vector e)) - (arrTmp, paramTmp) = mutableArray ("tmp" :: Name (Vector e)) - paramEnv = envParam aenv - -- - config = launchConfig dev (CUDA.incWarp dev) smem const [|| const ||] - smem n = warps * (1 + per_warp) * bytes - where - ws = CUDA.warpSize dev - warps = n `P.quot` ws - per_warp = ws + ws `P.quot` 2 - bytes = sizeOf (eltType (undefined :: e)) - in - makeOpenAccWith config "scanP1" (paramGang ++ paramTmp ++ paramOut ++ paramEnv) $ do - - -- Size of the input array - sz <- A.fromIntegral integralType numType . indexHead =<< delayedExtent - - -- A thread block scans a non-empty stripe of the input, storing the final - -- block-wide aggregate into a separate array - -- - -- For exclusive scans, thread 0 of segment 0 must incorporate the initial - -- element into the input and output. Threads shuffle their indices - -- appropriately. - -- - bid <- blockIdx - gd <- gridDim - s0 <- A.add numType start bid - - -- iterating over thread-block-wide segments - imapFromStepTo s0 gd end $ \chunk -> do - - bd <- blockDim - inf <- A.mul numType chunk bd - - -- index i* is the index that this thread will read data from. Recall that - -- the supremum index is exclusive - tid <- threadIdx - i0 <- case dir of - L -> A.add numType inf tid - R -> do x <- A.sub numType sz inf - y <- A.sub numType x tid - z <- A.sub numType y (lift 1) - return z - - -- index j* is the index that we write to. Recall that for exclusive scans - -- the output array is one larger than the input; the initial element will - -- be written into this spot by thread 0 of the first thread block. - j0 <- case mseed of - Nothing -> return i0 - Just _ -> case dir of - L -> A.add numType i0 (lift 1) - R -> return i0 - - -- If this thread has input, read data and participate in thread-block scan - let valid i = case dir of - L -> A.lt scalarType i sz - R -> A.gte scalarType i (lift 0) - - when (valid i0) $ do - x0 <- app1 delayedLinearIndex =<< A.fromIntegral integralType numType i0 - x1 <- case mseed of - Nothing -> return x0 - Just seed -> - if A.eq scalarType tid (lift 0) `A.land` A.eq scalarType chunk (lift 0) - then do - z <- seed - case dir of - L -> writeArray arrOut (lift 0 :: IR Int32) z >> app2 combine z x0 - R -> writeArray arrOut sz z >> app2 combine x0 z - else - return x0 - - n <- A.sub numType sz inf - x2 <- if A.gte scalarType n bd - then scanBlockSMem dir dev combine Nothing x1 - else scanBlockSMem dir dev combine (Just n) x1 - - -- Write this thread's scan result to memory - writeArray arrOut j0 x2 - - -- The last thread also writes its result---the aggregate for this - -- thread block---to the temporary partial sums array. This is only - -- necessary for full blocks in a multi-block scan; the final - -- partially-full tile does not have a successor block. - last <- A.sub numType bd (lift 1) - when (A.gt scalarType gd (lift 1) `land` A.eq scalarType tid last) $ - case dir of - L -> writeArray arrTmp chunk x2 - R -> do u <- A.sub numType end chunk - v <- A.sub numType u (lift 1) - writeArray arrTmp v x2 - - return_ - - --- Parallel scan, step 2 --- --- A single thread block performs a scan of the per-block aggregates computed in --- step 1. This gives the per-block prefix which must be added to each element --- in step 3. --- -mkScanAllP2 - :: forall aenv e. Elt e - => Direction - -> DeviceProperties -- ^ properties of the target GPU - -> Gamma aenv -- ^ array environment - -> IRFun2 PTX aenv (e -> e -> e) -- ^ combination function - -> CodeGen (IROpenAcc PTX aenv (Vector e)) -mkScanAllP2 dir dev aenv combine = - let - (start, end, paramGang) = gangParam - (arrTmp, paramTmp) = mutableArray ("tmp" :: Name (Vector e)) - paramEnv = envParam aenv - -- - config = launchConfig dev (CUDA.incWarp dev) smem grid gridQ - grid _ _ = 1 - gridQ = [|| \_ _ -> 1 ||] - smem n = warps * (1 + per_warp) * bytes - where - ws = CUDA.warpSize dev - warps = n `P.quot` ws - per_warp = ws + ws `P.quot` 2 - bytes = sizeOf (eltType (undefined :: e)) - in - makeOpenAccWith config "scanP2" (paramGang ++ paramTmp ++ paramEnv) $ do - - -- The first and last threads of the block need to communicate the - -- block-wide aggregate as a carry-in value across iterations. - -- - -- TODO: We could optimise this a bit if we can get access to the shared - -- memory area used by 'scanBlockSMem', and from there directly read the - -- value computed by the last thread. - carry <- staticSharedMem 1 - - bd <- blockDim - imapFromStepTo start bd end $ \offset -> do - - -- Index of the partial sums array that this thread will process. - tid <- threadIdx - i0 <- case dir of - L -> A.add numType offset tid - R -> do x <- A.sub numType end offset - y <- A.sub numType x tid - z <- A.sub numType y (lift 1) - return z - - let valid i = case dir of - L -> A.lt scalarType i end - R -> A.gte scalarType i start - - when (valid i0) $ do - - __syncthreads - - x0 <- readArray arrTmp i0 - x1 <- if A.gt scalarType offset (lift 0) `land` A.eq scalarType tid (lift 0) - then do - c <- readArray carry (lift 0 :: IR Int32) - case dir of - L -> app2 combine c x0 - R -> app2 combine x0 c - else do - return x0 - - n <- A.sub numType end offset - x2 <- if A.gte scalarType n bd - then scanBlockSMem dir dev combine Nothing x1 - else scanBlockSMem dir dev combine (Just n) x1 - - -- Update the temporary array with this thread's result - writeArray arrTmp i0 x2 - - -- The last thread writes the carry-out value. If the last thread is not - -- active, then this must be the last stripe anyway. - last <- A.sub numType bd (lift 1) - when (A.eq scalarType tid last) $ - writeArray carry (lift 0 :: IR Int32) x2 - - return_ - - --- Parallel scan, step 3. --- --- Threads combine every element of the partial block results with the carry-in --- value computed in step 2. --- -mkScanAllP3 - :: forall aenv e. Elt e - => Direction - -> DeviceProperties -- ^ properties of the target GPU - -> Gamma aenv -- ^ array environment - -> IRFun2 PTX aenv (e -> e -> e) -- ^ combination function - -> Maybe (IRExp PTX aenv e) -- ^ seed element, if this is an exclusive scan - -> CodeGen (IROpenAcc PTX aenv (Vector e)) -mkScanAllP3 dir dev aenv combine mseed = - let - (start, end, paramGang) = gangParam - (arrOut, paramOut) = mutableArray ("out" :: Name (Vector e)) - (arrTmp, paramTmp) = mutableArray ("tmp" :: Name (Vector e)) - paramEnv = envParam aenv - -- - stride = local scalarType ("ix.stride" :: Name Int32) - paramStride = scalarParameter scalarType ("ix.stride" :: Name Int32) - -- - config = launchConfig dev (CUDA.incWarp dev) (const 0) const [|| const ||] - in - makeOpenAccWith config "scanP3" (paramGang ++ paramTmp ++ paramOut ++ paramStride : paramEnv) $ do - - sz <- A.fromIntegral integralType numType (indexHead (irArrayShape arrOut)) - tid <- threadIdx - - -- Threads that will never contribute can just exit immediately. The size of - -- each chunk is set by the block dimension of the step 1 kernel, which may - -- be different from the block size of this kernel. - when (A.lt scalarType tid stride) $ do - - -- Iterate over the segments computed in phase 1. Note that we have one - -- fewer chunk to process because the first has no carry-in. - bid <- blockIdx - gd <- gridDim - c0 <- A.add numType start bid - imapFromStepTo c0 gd end $ \chunk -> do - - -- Determine the start and end indicies of this chunk to which we will - -- carry-in the value. Returned for left-to-right traversal. - (inf,sup) <- case dir of - L -> do - a <- A.add numType chunk (lift 1) - b <- A.mul numType stride a - case mseed of - Just{} -> do - c <- A.add numType b (lift 1) - d <- A.add numType c stride - e <- A.min scalarType d sz - return (c,e) - Nothing -> do - c <- A.add numType b stride - d <- A.min scalarType c sz - return (b,d) - R -> do - a <- A.sub numType end chunk - b <- A.mul numType stride a - c <- A.sub numType sz b - case mseed of - Just{} -> do - d <- A.sub numType c (lift 1) - e <- A.sub numType d stride - f <- A.max scalarType e (lift 0) - return (f,d) - Nothing -> do - d <- A.sub numType c stride - e <- A.max scalarType d (lift 0) - return (e,c) - - -- Read the carry-in value - carry <- case dir of - L -> readArray arrTmp chunk - R -> do - a <- A.add numType chunk (lift 1) - b <- readArray arrTmp a - return b - - -- Apply the carry-in value to each element in the chunk - bd <- blockDim - i0 <- A.add numType inf tid - imapFromStepTo i0 bd sup $ \i -> do - v <- readArray arrOut i - u <- case dir of - L -> app2 combine carry v - R -> app2 combine v carry - writeArray arrOut i u - - return_ - - --- Parallel scan', step 1. --- --- Similar to mkScanAllP1. Threads scan a stripe of the input into a temporary --- array, incorporating the initial element and any fused functions on the way. --- The final reduction result of this chunk is written to a separate array. --- -mkScan'AllP1 - :: forall aenv e. Elt e - => Direction - -> DeviceProperties - -> Gamma aenv - -> IRFun2 PTX aenv (e -> e -> e) - -> IRExp PTX aenv e - -> IRDelayed PTX aenv (Vector e) - -> CodeGen (IROpenAcc PTX aenv (Vector e, Scalar e)) -mkScan'AllP1 dir dev aenv combine seed IRDelayed{..} = - let - (start, end, paramGang) = gangParam - (arrOut, paramOut) = mutableArray ("out" :: Name (Vector e)) - (arrTmp, paramTmp) = mutableArray ("tmp" :: Name (Vector e)) - paramEnv = envParam aenv - -- - config = launchConfig dev (CUDA.incWarp dev) smem const [|| const ||] - smem n = warps * (1 + per_warp) * bytes - where - ws = CUDA.warpSize dev - warps = n `P.quot` ws - per_warp = ws + ws `P.quot` 2 - bytes = sizeOf (eltType (undefined :: e)) - in - makeOpenAccWith config "scanP1" (paramGang ++ paramTmp ++ paramOut ++ paramEnv) $ do - - -- Size of the input array - sz <- A.fromIntegral integralType numType . indexHead =<< delayedExtent - - -- A thread block scans a non-empty stripe of the input, storing the partial - -- result and the final block-wide aggregate - bid <- blockIdx - gd <- gridDim - s0 <- A.add numType start bid - - -- iterate over thread-block wide segments - imapFromStepTo s0 gd end $ \seg -> do - - bd <- blockDim - inf <- A.mul numType seg bd - - -- i* is the index that this thread will read data from - tid <- threadIdx - i0 <- case dir of - L -> A.add numType inf tid - R -> do x <- A.sub numType sz inf - y <- A.sub numType x tid - z <- A.sub numType y (lift 1) - return z - - -- j* is the index this thread will write to. This is just shifted by one - -- to make room for the initial element - j0 <- case dir of - L -> A.add numType i0 (lift 1) - R -> A.sub numType i0 (lift 1) - - -- If this thread has input it participates in the scan - let valid i = case dir of - L -> A.lt scalarType i sz - R -> A.gte scalarType i (lift 0) - - when (valid i0) $ do - x0 <- app1 delayedLinearIndex =<< A.fromIntegral integralType numType i0 - - -- Thread 0 of the first segment must also evaluate and store the - -- initial element - x1 <- if A.eq scalarType tid (lift 0) `A.land` A.eq scalarType seg (lift 0) - then do - z <- seed - writeArray arrOut i0 z - case dir of - L -> app2 combine z x0 - R -> app2 combine x0 z - else - return x0 - - -- Block-wide scan - n <- A.sub numType sz inf - x2 <- if A.gte scalarType n bd - then scanBlockSMem dir dev combine Nothing x1 - else scanBlockSMem dir dev combine (Just n) x1 - - -- Write this thread's scan result to memory. Recall that we had to make - -- space for the initial element, so the very last thread does not store - -- its result here. - case dir of - L -> when (A.lt scalarType j0 sz) $ writeArray arrOut j0 x2 - R -> when (A.gte scalarType j0 (lift 0)) $ writeArray arrOut j0 x2 - - -- Last active thread writes its result to the partial sums array. These - -- will be used to compute the carry-in value in step 2. - m <- do x <- A.min scalarType n bd - y <- A.sub numType x (lift 1) - return y - when (A.eq scalarType tid m) $ - case dir of - L -> writeArray arrTmp seg x2 - R -> do x <- A.sub numType end seg - y <- A.sub numType x (lift 1) - writeArray arrTmp y x2 - - return_ - - --- Parallel scan', step 2 --- --- A single thread block performs an inclusive scan of the partial sums array to --- compute the per-block carry-in values, as well as the final reduction result. --- -mkScan'AllP2 - :: forall aenv e. Elt e - => Direction - -> DeviceProperties - -> Gamma aenv - -> IRFun2 PTX aenv (e -> e -> e) - -> CodeGen (IROpenAcc PTX aenv (Vector e, Scalar e)) -mkScan'AllP2 dir dev aenv combine = - let - (start, end, paramGang) = gangParam - (arrTmp, paramTmp) = mutableArray ("tmp" :: Name (Vector e)) - (arrSum, paramSum) = mutableArray ("sum" :: Name (Scalar e)) - paramEnv = envParam aenv - -- - config = launchConfig dev (CUDA.incWarp dev) smem grid gridQ - grid _ _ = 1 - gridQ = [|| \_ _ -> 1 ||] - smem n = warps * (1 + per_warp) * bytes - where - ws = CUDA.warpSize dev - warps = n `P.quot` ws - per_warp = ws + ws `P.quot` 2 - bytes = sizeOf (eltType (undefined :: e)) - in - makeOpenAccWith config "scanP2" (paramGang ++ paramTmp ++ paramSum ++ paramEnv) $ do - - -- The first and last threads of the block need to communicate the - -- block-wide aggregate as a carry-in value across iterations. - carry <- staticSharedMem 1 - - -- A single thread block iterates over the per-block partial results from - -- step 1 - tid <- threadIdx - bd <- blockDim - imapFromStepTo start bd end $ \offset -> do - - i0 <- case dir of - L -> A.add numType offset tid - R -> do x <- A.sub numType end offset - y <- A.sub numType x tid - z <- A.sub numType y (lift 1) - return z - - let valid i = case dir of - L -> A.lt scalarType i end - R -> A.gte scalarType i start - - when (valid i0) $ do - - -- wait for the carry-in value to be updated - __syncthreads - - x0 <- readArray arrTmp i0 - x1 <- if A.gt scalarType offset (lift 0) `A.land` A.eq scalarType tid (lift 0) - then do - c <- readArray carry (lift 0 :: IR Int32) - case dir of - L -> app2 combine c x0 - R -> app2 combine x0 c - else - return x0 - - n <- A.sub numType end offset - x2 <- if A.gte scalarType n bd - then scanBlockSMem dir dev combine Nothing x1 - else scanBlockSMem dir dev combine (Just n) x1 - - -- Update the partial results array - writeArray arrTmp i0 x2 - - -- The last active thread saves its result as the carry-out value. - m <- do x <- A.min scalarType bd n - y <- A.sub numType x (lift 1) - return y - when (A.eq scalarType tid m) $ - writeArray carry (lift 0 :: IR Int32) x2 - - -- First thread stores the final carry-out values at the final reduction - -- result for the entire array - __syncthreads - - when (A.eq scalarType tid (lift 0)) $ - writeArray arrSum (lift 0 :: IR Int32) =<< readArray carry (lift 0 :: IR Int32) - - return_ - - --- Parallel scan', step 3. --- --- Threads combine every element of the partial block results with the carry-in --- value computed in step 2. --- -mkScan'AllP3 - :: forall aenv e. Elt e - => Direction - -> DeviceProperties -- ^ properties of the target GPU - -> Gamma aenv -- ^ array environment - -> IRFun2 PTX aenv (e -> e -> e) -- ^ combination function - -> CodeGen (IROpenAcc PTX aenv (Vector e, Scalar e)) -mkScan'AllP3 dir dev aenv combine = - let - (start, end, paramGang) = gangParam - (arrOut, paramOut) = mutableArray ("out" :: Name (Vector e)) - (arrTmp, paramTmp) = mutableArray ("tmp" :: Name (Vector e)) - paramEnv = envParam aenv - -- - stride = local scalarType ("ix.stride" :: Name Int32) - paramStride = scalarParameter scalarType ("ix.stride" :: Name Int32) - -- - config = launchConfig dev (CUDA.incWarp dev) (const 0) const [|| const ||] - in - makeOpenAccWith config "scanP3" (paramGang ++ paramTmp ++ paramOut ++ paramStride : paramEnv) $ do - - sz <- A.fromIntegral integralType numType (indexHead (irArrayShape arrOut)) - tid <- threadIdx - - when (A.lt scalarType tid stride) $ do - - bid <- blockIdx - gd <- gridDim - c0 <- A.add numType start bid - imapFromStepTo c0 gd end $ \chunk -> do - - (inf,sup) <- case dir of - L -> do - a <- A.add numType chunk (lift 1) - b <- A.mul numType stride a - c <- A.add numType b (lift 1) - d <- A.add numType c stride - e <- A.min scalarType d sz - return (c,e) - R -> do - a <- A.sub numType end chunk - b <- A.mul numType stride a - c <- A.sub numType sz b - d <- A.sub numType c (lift 1) - e <- A.sub numType d stride - f <- A.max scalarType e (lift 0) - return (f,d) - - carry <- case dir of - L -> readArray arrTmp chunk - R -> do - a <- A.add numType chunk (lift 1) - b <- readArray arrTmp a - return b - - -- Apply the carry-in value to each element in the chunk - bd <- blockDim - i0 <- A.add numType inf tid - imapFromStepTo i0 bd sup $ \i -> do - v <- readArray arrOut i - u <- case dir of - L -> app2 combine carry v - R -> app2 combine v carry - writeArray arrOut i u - - return_ - - --- Multidimensional scans --- ---------------------- - --- Multidimensional scan along the innermost dimension --- --- A thread block individually computes along each innermost dimension. This is --- a single-pass operation. --- --- * We can assume that the array is non-empty; exclusive scans with empty --- innermost dimension will be instead filled with the seed element via --- 'mkScanFill'. --- --- * Small but non-empty innermost dimension arrays (size << thread --- block size) will have many threads which do no work. --- -mkScanDim - :: forall aenv sh e. (Shape sh, Elt e) - => Direction - -> DeviceProperties -- ^ properties of the target GPU - -> Gamma aenv -- ^ array environment - -> IRFun2 PTX aenv (e -> e -> e) -- ^ combination function - -> Maybe (IRExp PTX aenv e) -- ^ seed element, if this is an exclusive scan - -> IRDelayed PTX aenv (Array (sh:.Int) e) -- ^ input data - -> CodeGen (IROpenAcc PTX aenv (Array (sh:.Int) e)) -mkScanDim dir dev aenv combine mseed IRDelayed{..} = - let - (start, end, paramGang) = gangParam - (arrOut, paramOut) = mutableArray ("out" :: Name (Array (sh:.Int) e)) - paramEnv = envParam aenv - -- - config = launchConfig dev (CUDA.incWarp dev) smem const [|| const ||] - smem n = warps * (1 + per_warp) * bytes - where - ws = CUDA.warpSize dev - warps = n `P.quot` ws - per_warp = ws + ws `P.quot` 2 - bytes = sizeOf (eltType (undefined :: e)) - in - makeOpenAccWith config "scan" (paramGang ++ paramOut ++ paramEnv) $ do - - -- The first and last threads of the block need to communicate the - -- block-wide aggregate as a carry-in value across iterations. - -- - -- TODO: we could optimise this a bit if we can get access to the shared - -- memory area used by 'scanBlockSMem', and from there directly read the - -- value computed by the last thread. - carry <- staticSharedMem 1 - - -- Size of the input array - sz <- A.fromIntegral integralType numType . indexHead =<< delayedExtent - - -- Thread blocks iterate over the outer dimensions. Threads in a block - -- cooperatively scan along one dimension, but thread blocks do not - -- communicate with each other. - -- - bid <- blockIdx - gd <- gridDim - s0 <- A.add numType start bid - imapFromStepTo s0 gd end $ \seg -> do - - -- Index this thread reads from - tid <- threadIdx - i0 <- case dir of - L -> do x <- A.mul numType seg sz - y <- A.add numType x tid - return y - - R -> do x <- A.add numType seg (lift 1) - y <- A.mul numType x sz - z <- A.sub numType y tid - w <- A.sub numType z (lift 1) - return w - - -- Index this thread writes to - j0 <- case mseed of - Nothing -> return i0 - Just{} -> do szp1 <- A.fromIntegral integralType numType (indexHead (irArrayShape arrOut)) - case dir of - L -> do x <- A.mul numType seg szp1 - y <- A.add numType x tid - return y - - R -> do x <- A.add numType seg (lift 1) - y <- A.mul numType x szp1 - z <- A.sub numType y tid - w <- A.sub numType z (lift 1) - return w - - -- Stride indices by block dimension - bd <- blockDim - let next ix = case dir of - L -> A.add numType ix bd - R -> A.sub numType ix bd - - -- Initialise this scan segment - -- - -- If this is an exclusive scan then the first thread just evaluates the - -- seed element and stores this value into the carry-in slot. All threads - -- shift their write-to index (j) by one, to make space for this element. - -- - -- If this is an inclusive scan then do a block-wide scan. The last thread - -- in the block writes the carry-in value. - -- - r <- - case mseed of - Just seed -> do - when (A.eq scalarType tid (lift 0)) $ do - z <- seed - writeArray arrOut j0 z - writeArray carry (lift 0 :: IR Int32) z - j1 <- case dir of - L -> A.add numType j0 (lift 1) - R -> A.sub numType j0 (lift 1) - return $ A.trip sz i0 j1 - - Nothing -> do - when (A.lt scalarType tid sz) $ do - x0 <- app1 delayedLinearIndex =<< A.fromIntegral integralType numType i0 - r0 <- if A.gte scalarType sz bd - then scanBlockSMem dir dev combine Nothing x0 - else scanBlockSMem dir dev combine (Just sz) x0 - writeArray arrOut j0 r0 - - ll <- A.sub numType bd (lift 1) - when (A.eq scalarType tid ll) $ - writeArray carry (lift 0 :: IR Int32) r0 - - n1 <- A.sub numType sz bd - i1 <- next i0 - j1 <- next j0 - return $ A.trip n1 i1 j1 - - -- Iterate over the remaining elements in this segment - void $ while - (\(A.fst3 -> n) -> A.gt scalarType n (lift 0)) - (\(A.untrip -> (n,i,j)) -> do - - -- Wait for the carry-in value from the previous iteration to be updated - __syncthreads - - -- Compute and store the next element of the scan - -- - -- NOTE: As with 'foldSeg' we require all threads to participate in - -- every iteration of the loop otherwise they will die prematurely. - -- Out-of-bounds threads return 'undef' at this point, which is really - -- unfortunate ): - -- - x <- if A.lt scalarType tid n - then app1 delayedLinearIndex =<< A.fromIntegral integralType numType i - else let - go :: TupleType a -> Operands a - go UnitTuple = OP_Unit - go (PairTuple a b) = OP_Pair (go a) (go b) - go (SingleTuple t) = ir' t (undef t) - in - return . IR $ go (eltType (undefined::e)) - - -- Thread zero incorporates the carry-in element - y <- if A.eq scalarType tid (lift 0) - then do - c <- readArray carry (lift 0 :: IR Int32) - case dir of - L -> app2 combine c x - R -> app2 combine x c - else - return x - - -- Perform the scan and write the result to memory - z <- if A.gte scalarType n bd - then scanBlockSMem dir dev combine Nothing y - else scanBlockSMem dir dev combine (Just n) y - - when (A.lt scalarType tid n) $ do - writeArray arrOut j z - - -- The last thread of the block writes its result as the carry-out - -- value. If this thread is not active then we are on the last - -- iteration of the loop and it will not be needed. - w <- A.sub numType bd (lift 1) - when (A.eq scalarType tid w) $ - writeArray carry (lift 0 :: IR Int32) z - - -- Update indices for the next iteration - n' <- A.sub numType n bd - i' <- next i - j' <- next j - return $ A.trip n' i' j') - r - - return_ - - --- Multidimensional scan' along the innermost dimension --- --- A thread block individually computes along each innermost dimension. This is --- a single-pass operation. --- --- * We can assume that the array is non-empty; exclusive scans with empty --- innermost dimension will be instead filled with the seed element via --- 'mkScan'Fill'. --- --- * Small but non-empty innermost dimension arrays (size << thread --- block size) will have many threads which do no work. --- -mkScan'Dim - :: forall aenv sh e. (Shape sh, Elt e) - => Direction - -> DeviceProperties -- ^ properties of the target GPU - -> Gamma aenv -- ^ array environment - -> IRFun2 PTX aenv (e -> e -> e) -- ^ combination function - -> IRExp PTX aenv e -- ^ seed element - -> IRDelayed PTX aenv (Array (sh:.Int) e) -- ^ input data - -> CodeGen (IROpenAcc PTX aenv (Array (sh:.Int) e, Array sh e)) -mkScan'Dim dir dev aenv combine seed IRDelayed{..} = - let - (start, end, paramGang) = gangParam - (arrOut, paramOut) = mutableArray ("out" :: Name (Array (sh:.Int) e)) - (arrSum, paramSum) = mutableArray ("sum" :: Name (Array sh e)) - paramEnv = envParam aenv - -- - config = launchConfig dev (CUDA.incWarp dev) smem const [|| const ||] - smem n = warps * (1 + per_warp) * bytes - where - ws = CUDA.warpSize dev - warps = n `P.quot` ws - per_warp = ws + ws `P.quot` 2 - bytes = sizeOf (eltType (undefined :: e)) - in - makeOpenAccWith config "scan" (paramGang ++ paramOut ++ paramSum ++ paramEnv) $ do - - -- The first and last threads of the block need to communicate the - -- block-wide aggregate as a carry-in value across iterations. - -- - -- TODO: we could optimise this a bit if we can get access to the shared - -- memory area used by 'scanBlockSMem', and from there directly read the - -- value computed by the last thread. - carry <- staticSharedMem 1 - - -- Size of the input array - sz <- A.fromIntegral integralType numType . indexHead =<< delayedExtent - - -- If the innermost dimension is smaller than the number of threads in the - -- block, those threads will never contribute to the output. - tid <- threadIdx - when (A.lte scalarType tid sz) $ do - - -- Thread blocks iterate over the outer dimensions, each thread block - -- cooperatively scanning along each outermost index. - bid <- blockIdx - gd <- gridDim - s0 <- A.add numType start bid - imapFromStepTo s0 gd end $ \seg -> do - - -- Not necessary to wait for threads to catch up before starting this segment - -- __syncthreads - - -- Linear index bounds for this segment - inf <- A.mul numType seg sz - sup <- A.add numType inf sz - - -- Index that this thread will read from. Recall that the supremum index - -- is exclusive. - i0 <- case dir of - L -> A.add numType inf tid - R -> do x <- A.sub numType sup tid - y <- A.sub numType x (lift 1) - return y - - -- The index that this thread will write to. This is just shifted along - -- by one to make room for the initial element. - j0 <- case dir of - L -> A.add numType i0 (lift 1) - R -> A.sub numType i0 (lift 1) - - -- Evaluate the initial element. Store it into the carry-in slot as well - -- as to the array as the first element. This is always valid because if - -- the input array is empty then we will be evaluating via mkScan'Fill. - when (A.eq scalarType tid (lift 0)) $ do - z <- seed - writeArray arrOut i0 z - writeArray carry (lift 0 :: IR Int32) z - - bd <- blockDim - let next ix = case dir of - L -> A.add numType ix bd - R -> A.sub numType ix bd - - -- Now, threads iterate over the elements along the innermost dimension. - -- At each iteration the first thread incorporates the carry-in value - -- from the previous step. - -- - -- The index tracks how many elements remain for the thread block, since - -- indices i* and j* are local to each thread - n0 <- A.sub numType sup inf - void $ while - (\(A.fst3 -> n) -> A.gt scalarType n (lift 0)) - (\(A.untrip -> (n,i,j)) -> do - - -- Wait for threads to catch up to ensure the carry-in value from - -- the last iteration has been updated - __syncthreads - - -- If all threads in the block will participate this round we can - -- avoid (almost) all bounds checks. - _ <- if A.gte scalarType n bd - -- All threads participate. No bounds checks required but - -- the last thread needs to update the carry-in value. - then do - x <- app1 delayedLinearIndex =<< A.fromIntegral integralType numType i - y <- if A.eq scalarType tid (lift 0) - then do - c <- readArray carry (lift 0 :: IR Int32) - case dir of - L -> app2 combine c x - R -> app2 combine x c - else - return x - z <- scanBlockSMem dir dev combine Nothing y - - -- Write results to the output array. Note that if we - -- align directly on the boundary of the array this is not - -- valid for the last thread. - case dir of - L -> when (A.lt scalarType j sup) $ writeArray arrOut j z - R -> when (A.gte scalarType j inf) $ writeArray arrOut j z - - -- Last thread of the block also saves its result as the - -- carry-in value - bd1 <- A.sub numType bd (lift 1) - when (A.eq scalarType tid bd1) $ - writeArray carry (lift 0 :: IR Int32) z - - return (IR OP_Unit :: IR ()) - - -- Only threads that are in bounds can participate. This is - -- the last iteration of the loop. The last active thread - -- still needs to store its value into the carry-in slot. - else do - when (A.lt scalarType tid n) $ do - x <- app1 delayedLinearIndex =<< A.fromIntegral integralType numType i - y <- if A.eq scalarType tid (lift 0) - then do - c <- readArray carry (lift 0 :: IR Int32) - case dir of - L -> app2 combine c x - R -> app2 combine x c - else - return x - z <- scanBlockSMem dir dev combine (Just n) y - - m <- A.sub numType n (lift 1) - _ <- if A.lt scalarType tid m - then writeArray arrOut j z >> return (IR OP_Unit :: IR ()) - else writeArray carry (lift 0 :: IR Int32) z >> return (IR OP_Unit :: IR ()) - - return () - return (IR OP_Unit :: IR ()) - - A.trip <$> A.sub numType n bd <*> next i <*> next j) - (A.trip n0 i0 j0) - - -- Wait for the carry-in value to be updated - __syncthreads - - -- Store the carry-in value to the separate final results array - when (A.eq scalarType tid (lift 0)) $ - writeArray arrSum seg =<< readArray carry (lift 0 :: IR Int32) - - return_ - - - --- Parallel scan, auxiliary --- --- If this is an exclusive scan of an empty array, we just fill the result with --- the seed element. --- -mkScanFill - :: (Shape sh, Elt e) - => PTX - -> Gamma aenv - -> IRExp PTX aenv e - -> CodeGen (IROpenAcc PTX aenv (Array sh e)) -mkScanFill ptx aenv seed = - mkGenerate ptx aenv (IRFun1 (const seed)) - -mkScan'Fill - :: forall aenv sh e. (Shape sh, Elt e) - => PTX - -> Gamma aenv - -> IRExp PTX aenv e - -> CodeGen (IROpenAcc PTX aenv (Array (sh:.Int) e, Array sh e)) -mkScan'Fill ptx aenv seed = - Safe.coerce <$> (mkGenerate ptx aenv (IRFun1 (const seed)) :: CodeGen (IROpenAcc PTX aenv (Array sh e))) - - --- Block wide scan --- --------------- - --- Efficient block-wide (inclusive) scan using the specified operator. --- --- Each block requires (#warps * (1 + 1.5*warp size)) elements of dynamically --- allocated shared memory. --- --- Example: https://github.com/NVlabs/cub/blob/1.5.4/cub/block/specializations/block_scan_warp_scans.cuh --- -scanBlockSMem - :: forall aenv e. Elt e - => Direction - -> DeviceProperties -- ^ properties of the target device - -> IRFun2 PTX aenv (e -> e -> e) -- ^ combination function - -> Maybe (IR Int32) -- ^ number of valid elements (may be less than block size) - -> IR e -- ^ calling thread's input element - -> CodeGen (IR e) -scanBlockSMem dir dev combine nelem = warpScan >=> warpPrefix - where - int32 :: Integral a => a -> IR Int32 - int32 = lift . P.fromIntegral - - -- Temporary storage required for each warp - warp_smem_elems = CUDA.warpSize dev + (CUDA.warpSize dev `P.quot` 2) - warp_smem_bytes = warp_smem_elems * sizeOf (eltType (undefined::e)) - - -- Step 1: Scan in every warp - warpScan :: IR e -> CodeGen (IR e) - warpScan input = do - -- Allocate (1.5 * warpSize) elements of shared memory for each warp - -- (individually addressable by each warp) - wid <- warpId - skip <- A.mul numType wid (int32 warp_smem_bytes) - smem <- dynamicSharedMem (int32 warp_smem_elems) skip - scanWarpSMem dir dev combine smem input - - -- Step 2: Collect the aggregate results of each warp to compute the prefix - -- values for each warp and combine with the partial result to compute each - -- thread's final value. - warpPrefix :: IR e -> CodeGen (IR e) - warpPrefix input = do - -- Allocate #warps elements of shared memory - bd <- blockDim - warps <- A.quot integralType bd (int32 (CUDA.warpSize dev)) - skip <- A.mul numType warps (int32 warp_smem_bytes) - smem <- dynamicSharedMem warps skip - - -- Share warp aggregates - wid <- warpId - lane <- laneId - when (A.eq scalarType lane (int32 (CUDA.warpSize dev - 1))) $ do - writeArray smem wid input - - -- Wait for each warp to finish its local scan and share the aggregate - __syncthreads - - -- Compute the prefix value for this warp and add to the partial result. - -- This step is not required for the first warp, which has no carry-in. - if A.eq scalarType wid (lift 0) - then return input - else do - -- Every thread sequentially scans the warp aggregates to compute - -- their prefix value. We do this sequentially, but could also have - -- warp 0 do it cooperatively if we limit thread block sizes to - -- (warp size ^ 2). - steps <- case nelem of - Nothing -> return wid - Just n -> A.min scalarType wid =<< A.quot integralType n (int32 (CUDA.warpSize dev)) - - p0 <- readArray smem (lift 0 :: IR Int32) - prefix <- iterFromStepTo (lift 1) (lift 1) steps p0 $ \step x -> do - y <- readArray smem step - case dir of - L -> app2 combine x y - R -> app2 combine y x - - case dir of - L -> app2 combine prefix input - R -> app2 combine input prefix - - --- Warp-wide scan --- -------------- - --- Efficient warp-wide (inclusive) scan using the specified operator. --- --- Each warp requires 48 (1.5 x warp size) elements of shared memory. The --- routine assumes that it is allocated individually per-warp (i.e. can be --- indexed in the range [0, warp size)). --- --- Example: https://github.com/NVlabs/cub/blob/1.5.4/cub/warp/specializations/warp_scan_smem.cuh --- -scanWarpSMem - :: forall aenv e. Elt e - => Direction - -> DeviceProperties -- ^ properties of the target device - -> IRFun2 PTX aenv (e -> e -> e) -- ^ combination function - -> IRArray (Vector e) -- ^ temporary storage array in shared memory (1.5 x warp size elements) - -> IR e -- ^ calling thread's input element - -> CodeGen (IR e) -scanWarpSMem dir dev combine smem = scan 0 - where - log2 :: Double -> Double - log2 = P.logBase 2 - - -- Number of steps required to scan warp - steps = P.floor (log2 (P.fromIntegral (CUDA.warpSize dev))) - halfWarp = P.fromIntegral (CUDA.warpSize dev `P.quot` 2) - - -- Unfold the scan as a recursive code generation function - scan :: Int -> IR e -> CodeGen (IR e) - scan step x - | step >= steps = return x - | offset <- 1 `P.shiftL` step = do - -- share partial result through shared memory buffer - lane <- laneId - i <- A.add numType lane (lift halfWarp) - writeArray smem i x - - -- update partial result if in range - x' <- if A.gte scalarType lane (lift offset) - then do - i' <- A.sub numType i (lift offset) -- lane + HALF_WARP - offset - x' <- readArray smem i' - case dir of - L -> app2 combine x' x - R -> app2 combine x x' - - else - return x - - scan (step+1) x' - diff --git a/Data/Array/Accelerate/LLVM/PTX/Compile.hs b/Data/Array/Accelerate/LLVM/PTX/Compile.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/PTX/Compile.hs +++ /dev/null @@ -1,322 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} --- | --- Module : Data.Array.Accelerate.LLVM.PTX.Compile --- Copyright : [2014..2017] Trevor L. McDonell --- [2014..2014] Vinod Grover (NVIDIA Corporation) --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -module Data.Array.Accelerate.LLVM.PTX.Compile ( - - module Data.Array.Accelerate.LLVM.Compile, - ObjectR(..), - -) where - --- llvm-hs -import qualified LLVM.AST as AST -import qualified LLVM.AST.Name as LLVM -import qualified LLVM.Context as LLVM -import qualified LLVM.Module as LLVM -import qualified LLVM.PassManager as LLVM -import qualified LLVM.Target as LLVM -import qualified LLVM.Internal.Module as LLVM.Internal -import qualified LLVM.Internal.FFI.LLVMCTypes as LLVM.Internal.FFI -#ifdef ACCELERATE_INTERNAL_CHECKS -import qualified LLVM.Analysis as LLVM -#endif - --- accelerate -import Data.Array.Accelerate.Error ( internalError ) -import Data.Array.Accelerate.Trafo ( DelayedOpenAcc ) - -import Data.Array.Accelerate.LLVM.CodeGen -import Data.Array.Accelerate.LLVM.CodeGen.Environment ( Gamma ) -import Data.Array.Accelerate.LLVM.CodeGen.Module ( Module(..) ) -import Data.Array.Accelerate.LLVM.Compile -import Data.Array.Accelerate.LLVM.State -import Data.Array.Accelerate.LLVM.Util - -import Data.Array.Accelerate.LLVM.PTX.Analysis.Launch -import Data.Array.Accelerate.LLVM.PTX.CodeGen -import Data.Array.Accelerate.LLVM.PTX.Compile.Cache -import Data.Array.Accelerate.LLVM.PTX.Compile.Libdevice -import Data.Array.Accelerate.LLVM.PTX.Foreign ( ) -import Data.Array.Accelerate.LLVM.PTX.Target - -import qualified Data.Array.Accelerate.LLVM.PTX.Debug as Debug - --- cuda -import Foreign.CUDA.Path -import qualified Foreign.CUDA.Analysis as CUDA -import qualified Foreign.NVVM as NVVM - --- standard library -import Control.Concurrent -import Control.DeepSeq -import Control.Exception -import Control.Monad.Except -import Control.Monad.State -import Data.ByteString ( ByteString ) -import Data.ByteString.Short ( ShortByteString ) -import Data.Maybe -import Data.Word -import Foreign.C -import Foreign.ForeignPtr -import Foreign.Ptr -import Foreign.Storable -import GHC.IO.Exception ( IOErrorType(..), IOException(..) ) -import System.Directory -import System.Exit -import System.FilePath -import System.IO -import System.IO.Unsafe -import System.Process -import Text.Printf ( printf ) -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as B8 -import qualified Data.ByteString.Internal as B -import qualified Data.Map as Map -import Prelude as P - - -instance Compile PTX where - data ObjectR PTX = ObjectR { objId :: {-# UNPACK #-} !UID - , ptxConfig :: ![(ShortByteString, LaunchConfig)] - , objData :: {- LAZY -} ByteString - } - compileForTarget = compile - - --- | Compile an Accelerate expression to object code. --- --- This generates the target code together with a list of each kernel function --- defined in the module paired with its occupancy information. --- -compile :: DelayedOpenAcc aenv a -> Gamma aenv -> LLVM PTX (ObjectR PTX) -compile acc aenv = do - target <- gets llvmTarget - (uid, cacheFile) <- cacheOfOpenAcc acc - - -- Generate code for this Acc operation - -- - let Module ast md = llvmOfOpenAcc target uid acc aenv - dev = ptxDeviceProperties target - config = [ (f,x) | (LLVM.Name f, KM_PTX x) <- Map.toList md ] - - -- Lower the generated LLVM into a CUBIN object code. - -- - -- The 'objData' field is lazily evaluated since the object code might have - -- already been loaded into the current context from a different function, in - -- which case it will be found by the linker cache. - -- - cubin <- liftIO . unsafeInterleaveIO $ do - exists <- doesFileExist cacheFile - recomp <- Debug.queryFlag Debug.force_recomp - if exists && not (fromMaybe False recomp) - then do - Debug.traceIO Debug.dump_cc (printf "cc: found cached object code %016x" uid) - B.readFile cacheFile - - else - LLVM.withContext $ \ctx -> do - ptx <- compilePTX dev ctx ast - cubin <- compileCUBIN dev cacheFile ptx - return cubin - - return $! ObjectR uid config cubin - - --- | Compile the LLVM module to PTX assembly. This is done either by the --- closed-source libNVVM library, or via the standard NVPTX backend (which is --- the default). --- -compilePTX :: CUDA.DeviceProperties -> LLVM.Context -> AST.Module -> IO ByteString -compilePTX dev ctx ast = do -#ifdef ACCELERATE_USE_NVVM - ptx <- withLibdeviceNVVM dev ctx ast (compileModuleNVVM dev (AST.moduleName ast)) -#else - ptx <- withLibdeviceNVPTX dev ctx ast (compileModuleNVPTX dev) -#endif - Debug.when Debug.dump_asm $ Debug.traceIO Debug.verbose (B8.unpack ptx) - return ptx - - --- | Compile the given PTX assembly to a CUBIN file (SASS object code). The --- compiled code will be stored at the given FilePath. --- -compileCUBIN :: CUDA.DeviceProperties -> FilePath -> ByteString -> IO ByteString -compileCUBIN dev sass ptx = do - _verbose <- Debug.queryFlag Debug.verbose - _debug <- Debug.queryFlag Debug.debug_cc - -- - let verboseFlag = if _verbose then [ "-v" ] else [] - debugFlag = if _debug then [ "-g", "-lineinfo" ] else [] - arch = printf "-arch=sm_%d%d" m n - CUDA.Compute m n = CUDA.computeCapability dev - flags = "-" : "-o" : sass : arch : verboseFlag ++ debugFlag - -- - cp = (proc (cudaBinPath "ptxas") flags) - { std_in = CreatePipe - , std_out = NoStream - , std_err = CreatePipe - } - - -- Invoke the 'ptxas' executable (which must be on the PATH) to compile the - -- PTX into SASS. The output is written directly to the final cache location. - -- - withCreateProcess cp $ \(Just inh) Nothing (Just errh) ph -> do - - -- fork off a thread to start consuming stderr - info <- hGetContents errh - withForkWait (evaluate (rnf info)) $ \waitErr -> do - - -- write the PTX to the input handle - -- closing the handle performs an implicit flush, thus may trigger SIGPIPE - ignoreSIGPIPE $ B.hPut inh ptx - ignoreSIGPIPE $ hClose inh - - -- wait on the output - waitErr - hClose errh - - -- wait on the process - ex <- waitForProcess ph - case ex of - ExitFailure r -> $internalError "compile" (printf "ptxas %s (exit %d)\n%s" (unwords flags) r info) - ExitSuccess -> return () - - when _verbose $ - unless (null info) $ - Debug.traceIO Debug.dump_cc (printf "ptx: compiled entry function(s)\n%s" info) - - -- Read back the results - B.readFile sass - - --- | Fork a thread while doing something else, but kill it if there's an --- exception. --- --- This is important because we want to kill the thread that is holding the --- Handle lock, because when we clean up the process we try to close that --- handle, which could otherwise deadlock. --- --- Stolen from the 'process' package. --- -withForkWait :: IO () -> (IO () -> IO a) -> IO a -withForkWait async body = do - waitVar <- newEmptyMVar :: IO (MVar (Either SomeException ())) - mask $ \restore -> do - tid <- forkIO $ try (restore async) >>= putMVar waitVar - let wait = takeMVar waitVar >>= either throwIO return - restore (body wait) `onException` killThread tid - -ignoreSIGPIPE :: IO () -> IO () -ignoreSIGPIPE = - handle $ \e -> - case e of - IOError{..} | ResourceVanished <- ioe_type - , Just ioe <- ioe_errno - , Errno ioe == ePIPE - -> return () - _ -> throwIO e - - --- Compile and optimise the module to PTX using the (closed source) NVVM --- library. This _may_ produce faster object code than the LLVM NVPTX compiler. --- -compileModuleNVVM :: CUDA.DeviceProperties -> String -> [(String, ByteString)] -> LLVM.Module -> IO ByteString -compileModuleNVVM dev name libdevice mdl = do - _debug <- Debug.queryFlag Debug.debug_cc - -- - let arch = CUDA.computeCapability dev - verbose = if _debug then [ NVVM.GenerateDebugInfo ] else [] - flags = NVVM.Target arch : verbose - - -- Note: [NVVM and target datalayout] - -- - -- The NVVM library does not correctly parse the target datalayout field, - -- instead doing a (very dodgy) string compare against exactly two - -- expected values. This means that it is sensitive to, e.g. the ordering - -- of the fields, and changes to the representation in each LLVM release. - -- - -- We get around this by only specifying the data layout in a separate - -- (otherwise empty) module that we additionally link against. - -- - header = case bitSize (undefined::Int) of - 32 -> "target triple = \"nvptx-nvidia-cuda\"\ntarget datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v16:16:16-v32:32:32-v64:64:64-v128:128:128-n16:32:64\"" - 64 -> "target triple = \"nvptx64-nvidia-cuda\"\ntarget datalayout = \"e-p:64:64:64-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v16:16:16-v32:32:32-v64:64:64-v128:128:128-n16:32:64\"" - _ -> $internalError "compileModuleNVVM" "I don't know what architecture I am" - - Debug.when Debug.dump_cc $ do - Debug.when Debug.verbose $ do - ll <- LLVM.moduleLLVMAssembly mdl -- TLM: unfortunate to do the lowering twice in debug mode - Debug.traceIO Debug.verbose (B8.unpack ll) - - -- Lower the generated module to bitcode, then compile and link together with - -- the shim header and libdevice library (if necessary) - bc <- LLVM.moduleBitcode mdl - ptx <- NVVM.compileModules (("",header) : (name,bc) : libdevice) flags - - unless (B.null (NVVM.compileLog ptx)) $ do - Debug.traceIO Debug.dump_cc $ "llvm: " ++ B8.unpack (NVVM.compileLog ptx) - - -- Return the generated binary code - return (NVVM.compileResult ptx) - - --- Compiling with the NVPTX backend uses LLVM-3.3 and above --- -compileModuleNVPTX :: CUDA.DeviceProperties -> LLVM.Module -> IO ByteString -compileModuleNVPTX dev mdl = - withPTXTargetMachine dev $ \nvptx -> do - - -- Run the standard optimisation pass - -- - let pss = LLVM.defaultCuratedPassSetSpec { LLVM.optLevel = Just 3 } - LLVM.withPassManager pss $ \pm -> do -#ifdef ACCELERATE_INTERNAL_CHECKS - LLVM.verify mdl -#endif - b1 <- LLVM.runPassManager pm mdl - - -- debug printout - Debug.when Debug.dump_cc $ do - Debug.traceIO Debug.dump_cc $ printf "llvm: optimisation did work? %s" (show b1) - Debug.traceIO Debug.verbose . B8.unpack =<< LLVM.moduleLLVMAssembly mdl - - -- Lower the LLVM module into target assembly (PTX) - moduleTargetAssembly nvptx mdl - - --- | Produce target specific assembly as a 'ByteString'. --- -moduleTargetAssembly :: LLVM.TargetMachine -> LLVM.Module -> IO ByteString -moduleTargetAssembly tm m = unsafe0 =<< LLVM.Internal.emitToByteString LLVM.Internal.FFI.codeGenFileTypeAssembly tm m - where - -- Ensure that the ByteString is NULL-terminated, so that it can be passed - -- directly to C. This will unsafely mutate the underlying ForeignPtr if the - -- string is not NULL-terminated but the last character is a whitespace - -- character (there are usually a few blank lines at the end). - -- - unsafe0 :: ByteString -> IO ByteString - unsafe0 bs@(B.PS fp s l) = - liftIO . withForeignPtr fp $ \p -> do - let p' :: Ptr Word8 - p' = p `plusPtr` (s+l-1) - -- - x <- peek p' - case x of - 0 -> return bs - _ | B.isSpaceWord8 x -> poke p' 0 >> return bs - _ -> return (B.snoc bs 0) - diff --git a/Data/Array/Accelerate/LLVM/PTX/Compile/Cache.hs b/Data/Array/Accelerate/LLVM/PTX/Compile/Cache.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/PTX/Compile/Cache.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} --- | --- Module : Data.Array.Accelerate.LLVM.PTX.Compile.Cache --- Copyright : [2017] Trevor L. McDonell --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -module Data.Array.Accelerate.LLVM.PTX.Compile.Cache ( - - module Data.Array.Accelerate.LLVM.Compile.Cache - -) where - -import Data.Array.Accelerate.LLVM.Compile.Cache -import Data.Array.Accelerate.LLVM.PTX.Target - -import Control.Monad.State -import Data.Version -import Foreign.CUDA.Analysis -import System.FilePath -import qualified Data.ByteString.Char8 as B8 -import qualified Data.ByteString.Short.Char8 as S8 - -import Paths_accelerate_llvm_ptx - - -instance Persistent PTX where - targetCacheTemplate = do - dev <- gets ptxDeviceProperties - let Compute m n = computeCapability dev - -- - return $ "accelerate-llvm-ptx-" ++ showVersion version - S8.unpack ptxTargetTriple - B8.unpack (ptxISAVersion m n) - "morp.sass" - diff --git a/Data/Array/Accelerate/LLVM/PTX/Compile/Libdevice.hs b/Data/Array/Accelerate/LLVM/PTX/Compile/Libdevice.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/PTX/Compile/Libdevice.hs +++ /dev/null @@ -1,177 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ViewPatterns #-} --- | --- Module : Data.Array.Accelerate.LLVM.PTX.Compile.Libdevice --- Copyright : [2014..2017] Trevor L. McDonell --- [2014..2014] Vinod Grover (NVIDIA Corporation) --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -module Data.Array.Accelerate.LLVM.PTX.Compile.Libdevice ( - - withLibdeviceNVVM, - withLibdeviceNVPTX, - -) where - --- llvm-hs -import LLVM.Context -import qualified LLVM.Module as LLVM - -import LLVM.AST as AST -import LLVM.AST.Global as G -import LLVM.AST.Linkage - --- accelerate -import Data.Array.Accelerate.LLVM.PTX.Compile.Libdevice.Load -import qualified Data.Array.Accelerate.LLVM.PTX.Debug as Debug - --- cuda -import Foreign.CUDA.Analysis - --- standard library -import Control.Monad -import Data.ByteString ( ByteString ) -import Data.ByteString.Short.Char8 ( ShortByteString ) -import Data.HashSet ( HashSet ) -import Data.List -import Data.Maybe -import Text.Printf -import qualified Data.ByteString.Short.Char8 as S8 -import qualified Data.ByteString.Short.Extra as BS -import qualified Data.HashSet as Set - - --- | Lower an LLVM AST to C++ objects and link it against the libdevice module, --- iff any libdevice functions are referenced from the base module. --- --- Note: [Linking with libdevice] --- --- The CUDA toolkit comes with an LLVM bitcode library called 'libdevice' that --- implements many common mathematical functions. The library can be used as a --- high performance math library for targets of the LLVM NVPTX backend, such as --- this one. To link a module 'foo' with libdevice, the following compilation --- pipeline is recommended: --- --- 1. Save all external functions in module 'foo' --- --- 2. Link module 'foo' with the appropriate 'libdevice_compute_XX.YY.bc' --- --- 3. Internalise all functions not in the list from (1) --- --- 4. Eliminate all unused internal functions --- --- 5. Run the NVVMReflect pass (see note: [NVVM Reflect Pass]) --- --- 6. Run the standard optimisation pipeline --- -withLibdeviceNVPTX - :: DeviceProperties - -> Context - -> Module - -> (LLVM.Module -> IO a) - -> IO a -withLibdeviceNVPTX dev ctx ast next = - case Set.null externs of - True -> LLVM.withModuleFromAST ctx ast next - False -> - LLVM.withModuleFromAST ctx ast $ \mdl -> - LLVM.withModuleFromAST ctx nvvmReflect $ \refl -> - LLVM.withModuleFromAST ctx (internalise externs libdev) $ \libd -> do - LLVM.linkModules mdl refl - LLVM.linkModules mdl libd - Debug.traceIO Debug.dump_cc msg - next mdl - where - -- Replace the target triple and datalayout from the libdevice.bc module - -- with those of the generated code. This avoids warnings such as "linking - -- two modules of different target triples..." - libdev = (libdevice arch) { moduleTargetTriple = moduleTargetTriple ast - , moduleDataLayout = moduleDataLayout ast - } - externs = analyse ast - arch = computeCapability dev - - msg = printf "cc: linking with libdevice: %s" - $ intercalate ", " - $ map S8.unpack - $ Set.toList externs - - --- | Lower an LLVM AST to C++ objects and prepare it for linking against --- libdevice using the nvvm bindings, iff any libdevice functions are referenced --- from the base module. --- --- Rather than internalise and strip any unused functions ourselves, allow the --- nvvm library to do so when linking the two modules together. --- --- TLM: This really should work with the above method, however for some reason --- we get a "CUDA Exception: function named symbol not found" error, even though --- the function is clearly visible in the generated code. hmm... --- -withLibdeviceNVVM - :: DeviceProperties - -> Context - -> Module - -> ([(String, ByteString)] -> LLVM.Module -> IO a) - -> IO a -withLibdeviceNVVM dev ctx ast next = - LLVM.withModuleFromAST ctx ast $ \mdl -> do - when withlib $ Debug.traceIO Debug.dump_cc msg - next lib mdl - where - externs = analyse ast - withlib = not (Set.null externs) - lib | withlib = [ nvvmReflect, libdevice arch ] - | otherwise = [] - - arch = computeCapability dev - - msg = printf "cc: linking with libdevice: %s" - $ intercalate ", " - $ map S8.unpack - $ Set.toList externs - - --- | Analyse the LLVM AST module and determine if any of the external --- declarations are intrinsics implemented by libdevice. The set of such --- functions is returned, and will be used when determining which functions from --- libdevice to internalise. --- -analyse :: Module -> HashSet ShortByteString -analyse Module{..} = - let intrinsic (GlobalDefinition Function{..}) - | null basicBlocks - , Name n <- name - , "__nv_" <- BS.take 5 n - = Just n - - intrinsic _ - = Nothing - in - Set.fromList (mapMaybe intrinsic moduleDefinitions) - - --- | Mark all definitions in the module as internal linkage. This means that --- unused definitions can be removed as dead code. Be careful to leave any --- declarations as external. --- -internalise :: HashSet ShortByteString -> Module -> Module -internalise externals Module{..} = - let internal (GlobalDefinition Function{..}) - | Name n <- name - , not (Set.member n externals) -- we don't call this function directly; and - , not (null basicBlocks) -- it is not an external declaration - = GlobalDefinition Function { linkage=Internal, .. } - - internal x - = x - in - Module { moduleDefinitions = map internal moduleDefinitions, .. } - diff --git a/Data/Array/Accelerate/LLVM/PTX/Compile/Libdevice/Load.hs b/Data/Array/Accelerate/LLVM/PTX/Compile/Libdevice/Load.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/PTX/Compile/Libdevice/Load.hs +++ /dev/null @@ -1,143 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} --- | --- Module : Data.Array.Accelerate.LLVM.PTX.Compile.Libdevice.Load --- Copyright : [2014..2017] Trevor L. McDonell --- [2014..2014] Vinod Grover (NVIDIA Corporation) --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -module Data.Array.Accelerate.LLVM.PTX.Compile.Libdevice.Load ( - - nvvmReflect, libdevice, - -) where - --- llvm-hs -import LLVM.Context -import LLVM.Module as LLVM -import LLVM.AST as AST ( Module(..) ) - --- accelerate -import Data.Array.Accelerate.Error -import Data.Array.Accelerate.LLVM.PTX.Compile.Libdevice.TH -import Data.Array.Accelerate.LLVM.PTX.Execute.Event ( ) -- GHC#1012 -import Data.Array.Accelerate.LLVM.PTX.Execute.Stream ( ) -- GHC#1012 - --- cuda -import Foreign.CUDA.Analysis -import qualified Foreign.CUDA.Driver as CUDA - --- standard library -import Data.ByteString ( ByteString ) -import System.IO.Unsafe - - --- NVVM Reflect --- ------------ - -class NVVMReflect a where - nvvmReflect :: a - -instance NVVMReflect AST.Module where - nvvmReflect = nvvmReflectModule - -instance NVVMReflect (String, ByteString) where - nvvmReflect = $$( nvvmReflectBitcode nvvmReflectModule ) - - --- libdevice --- --------- - --- Compatible version of libdevice for a given compute capability should be --- listed here: --- --- https://github.com/llvm-mirror/llvm/blob/master/lib/Target/NVPTX/NVPTX.td#L72 --- -class Libdevice a where - libdevice :: Compute -> a - -instance Libdevice AST.Module where - libdevice _ - | CUDA.libraryVersion >= 9000 - = libdevice_50_mdl - -- - libdevice (Compute n m) = - case (n,m) of - (2,_) -> libdevice_20_mdl -- 2.0, 2.1 - (3,x) | x < 5 -> libdevice_30_mdl -- 3.0, 3.2 - | otherwise -> libdevice_35_mdl -- 3.5, 3.7 - (5,_) -> libdevice_50_mdl -- 5.x - (6,_) -> libdevice_50_mdl -- 6.x - _ -> $internalError "libdevice" "no binary for this architecture" - -instance Libdevice (String, ByteString) where - libdevice _ - | CUDA.libraryVersion >= 9000 - = libdevice_50_bc - -- - libdevice (Compute n m) = - case (n,m) of - (2,_) -> libdevice_20_bc -- 2.0, 2.1 - (3,x) | x < 5 -> libdevice_30_bc -- 3.0, 3.2 - | otherwise -> libdevice_35_bc -- 3.5, 3.7 - (5,_) -> libdevice_50_bc -- 5.x - (6,_) -> libdevice_50_bc -- 6.x - _ -> $internalError "libdevice" "no binary for this architecture" - - --- Load the libdevice bitcode files as an LLVM AST module. The top-level --- unsafePerformIO ensures that the data is only read from disk once per program --- execution. --- --- TLM: As of CUDA-9.0, libdevice is no longer split into multiple files --- depending on the target compute architecture. The function 'libdeviceBitcode' --- knows this and ignores the architecture parameter, and in the above instances --- we only refer to the 5.0 module below. Although the TH splices will be run --- 4 times (and read in the same file 4 times) hopefully GHC is smart enough to --- remove the unused bindings as dead code... --- -{-# NOINLINE libdevice_20_mdl #-} -{-# NOINLINE libdevice_30_mdl #-} -{-# NOINLINE libdevice_35_mdl #-} -{-# NOINLINE libdevice_50_mdl #-} -libdevice_20_mdl, libdevice_30_mdl, libdevice_35_mdl, libdevice_50_mdl :: AST.Module -libdevice_20_mdl = unsafePerformIO $ libdeviceModule (Compute 2 0) -libdevice_30_mdl = unsafePerformIO $ libdeviceModule (Compute 3 0) -libdevice_35_mdl = unsafePerformIO $ libdeviceModule (Compute 3 5) -libdevice_50_mdl = unsafePerformIO $ libdeviceModule (Compute 5 0) - --- Load the libdevice bitcode files as raw binary data. --- -libdevice_20_bc, libdevice_30_bc, libdevice_35_bc, libdevice_50_bc :: (String,ByteString) -libdevice_20_bc = $$( libdeviceBitcode (Compute 2 0) ) -libdevice_30_bc = $$( libdeviceBitcode (Compute 3 0) ) -libdevice_35_bc = $$( libdeviceBitcode (Compute 3 5) ) -libdevice_50_bc = $$( libdeviceBitcode (Compute 5 0) ) - - --- Load the libdevice bitcode file for the given compute architecture, and raise --- it to a Haskell AST that can be kept for future use. The name of the bitcode --- files follows: --- --- libdevice.compute_XX.YY.bc --- --- Where XX represents the compute capability, and YY represents a version(?) We --- search the libdevice PATH for all files of the appropriate compute capability --- and load the most recent. --- -libdeviceModule :: Compute -> IO AST.Module -libdeviceModule arch = do - let bc :: (String, ByteString) - bc = libdevice arch - -- - withContext $ \ctx -> - withModuleFromBitcode ctx bc moduleAST - diff --git a/Data/Array/Accelerate/LLVM/PTX/Compile/Libdevice/TH.hs b/Data/Array/Accelerate/LLVM/PTX/Compile/Libdevice/TH.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/PTX/Compile/Libdevice/TH.hs +++ /dev/null @@ -1,188 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} --- | --- Module : Data.Array.Accelerate.LLVM.PTX.Compile.Libdevice.TH --- Copyright : [2017] Trevor L. McDonell --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -module Data.Array.Accelerate.LLVM.PTX.Compile.Libdevice.TH ( - - nvvmReflectModule, nvvmReflectBitcode, - libdeviceBitcode, - -) where - -import qualified LLVM.AST as AST -import qualified LLVM.AST.Attribute as AST -import qualified LLVM.AST.Global as AST.G -import qualified LLVM.Context as LLVM -import qualified LLVM.Module as LLVM - -import LLVM.AST.Type.Representation - -import Data.Array.Accelerate.Error -import Data.Array.Accelerate.LLVM.CodeGen.Base -import Data.Array.Accelerate.LLVM.CodeGen.Downcast -import Data.Array.Accelerate.LLVM.PTX.Target - -import Foreign.CUDA.Path -import Foreign.CUDA.Analysis -import qualified Foreign.CUDA.Driver as CUDA - -import Data.ByteString ( ByteString ) -import Data.FileEmbed -import Data.List -import Data.Maybe -import Language.Haskell.TH.Syntax hiding ( Name ) -import System.Directory -import System.FilePath -import Text.Printf -import qualified Data.ByteString.Short as BS - - --- This is a hacky module that can be linked against in order to provide the --- same functionality as running the NVVMReflect pass. --- --- Note: [NVVM Reflect Pass] --- --- To accommodate various math-related compiler flags that can affect code --- generation of libdevice code, the library code depends on a special LLVM IR --- pass (NVVMReflect) to handle conditional compilation within LLVM IR. This --- pass looks for calls to the @__nvvm_reflect function and replaces them with --- constants based on the defined reflection parameters. --- --- libdevice currently uses the following reflection parameters to control code --- generation: --- --- * __CUDA_FTZ={0,1} fast math that flushes denormals to zero --- --- Since this is currently the only reflection parameter supported, and that we --- prefer correct results over pure speed, we do not flush denormals to zero. If --- the list of supported parameters ever changes, we may need to re-evaluate --- this implementation. --- -nvvmReflectModule :: AST.Module -nvvmReflectModule = - AST.Module - { AST.moduleName = "nvvm-reflect" - , AST.moduleSourceFileName = BS.empty - , AST.moduleDataLayout = targetDataLayout (undefined::PTX) - , AST.moduleTargetTriple = targetTriple (undefined::PTX) - , AST.moduleDefinitions = [AST.GlobalDefinition $ AST.G.functionDefaults - { AST.G.name = AST.Name "__nvvm_reflect" - , AST.G.returnType = downcast (integralType :: IntegralType Int32) - , AST.G.parameters = ( [ptrParameter scalarType (UnName 0 :: Name (Ptr Int8))], False ) - , AST.G.functionAttributes = map Right [AST.NoUnwind, AST.ReadNone, AST.AlwaysInline] - , AST.G.basicBlocks = [] - }] - } - - --- Lower the given NVVM Reflect module into bitcode. --- -nvvmReflectBitcode :: AST.Module -> Q (TExp (String, ByteString)) -nvvmReflectBitcode mdl = do - let name = "__nvvm_reflect" - -- - bs <- runIO $ LLVM.withContext $ \ctx -> do - LLVM.withModuleFromAST ctx mdl LLVM.moduleLLVMAssembly - be <- bsToExp bs - return . TExp $ TupE [ LitE (StringL name), be ] - - --- Load the libdevice bitcode file for the given compute architecture. The name --- of the bitcode files follows the format: --- --- libdevice.compute_XX.YY.bc --- --- Where XX represents the compute capability, and YY represents a version(?) We --- search the libdevice PATH for all files of the appropriate compute capability --- and load the "most recent" (by sort order). --- -libdeviceBitcode :: Compute -> Q (TExp (String, ByteString)) -libdeviceBitcode (Compute m n) = do - let basename - | CUDA.libraryVersion < 9000 = printf "libdevice.compute_%d%d" m n - | otherwise = "libdevice" - -- - err = $internalError "libdevice" (printf "not found: %s.YY.bc" basename) - best f = basename `isPrefixOf` f && takeExtension f == ".bc" - base = cudaInstallPath "nvvm" "libdevice" - -- - files <- runIO $ getDirectoryContents base - -- - let name = fromMaybe err . listToMaybe . sortBy (flip compare) $ filter best files - path = base name - -- - bc <- embedFile path - return . TExp $ TupE [ LitE (StringL name), bc ] - - --- Determine the location of the libdevice bitcode libraries. We search for the --- location of the 'nvcc' executable in the PATH. From that, we assume the --- location of the libdevice bitcode files. --- --- libdevicePath :: IO FilePath --- libdevicepath = do --- nvcc <- fromMaybe (error "could not find 'nvcc' in PATH") `fmap` findExecutable "nvcc" --- -- --- let ccvn = reverse (splitPath nvcc) --- dir = "libdevice" : "nvvm" : drop 2 ccvn --- -- --- return (joinPath (reverse dir)) - - --- With these instances it is possible to also write TH function to raise the --- libNVVM modules to an AST. However, generating those large ASTs results in --- awful compile times. --- --- $( deriveLift ''AST.AddrSpace ) --- $( deriveLift ''AST.AlignType ) --- $( deriveLift ''AST.AlignmentInfo ) --- $( deriveLift ''AST.BasicBlock ) --- $( deriveLift ''AST.CallingConvention ) --- $( deriveLift ''AST.Constant ) --- $( deriveLift ''AST.DataLayout ) --- $( deriveLift ''AST.Definition ) --- $( deriveLift ''AST.Dialect ) --- $( deriveLift ''AST.Endianness ) --- $( deriveLift ''AST.FastMathFlags ) --- $( deriveLift ''AST.FloatingPointFormat ) --- $( deriveLift ''AST.FloatingPointPredicate ) --- $( deriveLift ''AST.FunctionAttribute ) --- $( deriveLift ''AST.Global ) --- $( deriveLift ''AST.GroupID ) --- $( deriveLift ''AST.InlineAssembly ) --- $( deriveLift ''AST.Instruction ) --- $( deriveLift ''AST.IntegerPredicate ) --- $( deriveLift ''AST.LandingPadClause ) --- $( deriveLift ''AST.Linkage ) --- $( deriveLift ''AST.Mangling ) --- $( deriveLift ''AST.MemoryOrdering ) --- $( deriveLift ''AST.Metadata ) --- $( deriveLift ''AST.MetadataNode ) --- $( deriveLift ''AST.MetadataNodeID ) --- $( deriveLift ''AST.Model ) --- $( deriveLift ''AST.Module ) --- $( deriveLift ''AST.Name ) --- $( deriveLift ''AST.Named ) --- $( deriveLift ''AST.Operand ) --- $( deriveLift ''AST.Parameter ) --- $( deriveLift ''AST.ParameterAttribute ) --- $( deriveLift ''AST.RMWOperation ) --- $( deriveLift ''AST.SelectionKind ) --- $( deriveLift ''AST.SomeFloat ) --- $( deriveLift ''AST.StorageClass ) --- $( deriveLift ''AST.SynchronizationScope ) --- $( deriveLift ''AST.TailCallKind ) --- $( deriveLift ''AST.Terminator ) --- $( deriveLift ''AST.Type ) --- $( deriveLift ''AST.UnnamedAddr ) --- $( deriveLift ''AST.Visibility ) --- $( deriveLift ''NonEmpty ) - diff --git a/Data/Array/Accelerate/LLVM/PTX/Context.hs b/Data/Array/Accelerate/LLVM/PTX/Context.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/PTX/Context.hs +++ /dev/null @@ -1,147 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} --- | --- Module : Data.Array.Accelerate.LLVM.PTX.Context --- Copyright : [2014..2017] Trevor L. McDonell --- [2014..2014] Vinod Grover (NVIDIA Corporation) --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -module Data.Array.Accelerate.LLVM.PTX.Context ( - - Context(..), - new, raw, withContext, - -) where - -import Data.Array.Accelerate.Lifetime -import Data.Array.Accelerate.LLVM.PTX.Analysis.Device -import qualified Data.Array.Accelerate.LLVM.PTX.Debug as Debug - -import qualified Foreign.CUDA.Analysis as CUDA -import qualified Foreign.CUDA.Driver as CUDA -import qualified Foreign.CUDA.Driver.Device as CUDA - -import Control.Exception -import Control.Monad -import Text.PrettyPrint - - --- | An execution context, which is tied to a specific device and CUDA execution --- context. --- -data Context = Context { - deviceProperties :: {-# UNPACK #-} !CUDA.DeviceProperties -- information on hardware resources - , deviceContext :: {-# UNPACK #-} !(Lifetime CUDA.Context) -- device execution context - } - -instance Eq Context where - c1 == c2 = deviceContext c1 == deviceContext c2 - - --- | Create a new CUDA execution context --- -new :: CUDA.Device - -> CUDA.DeviceProperties - -> [CUDA.ContextFlag] - -> IO Context -new dev prp flags = do - ctx <- raw dev prp =<< CUDA.create dev flags - _ <- CUDA.pop - return ctx - --- | Wrap a raw CUDA execution context --- -raw :: CUDA.Device - -> CUDA.DeviceProperties - -> CUDA.Context - -> IO Context -raw dev prp ctx = do - lft <- newLifetime ctx - addFinalizer lft $ do - message $ "finalise context " ++ showContext ctx - CUDA.destroy ctx - - -- The kernels don't use much shared memory, so for devices that support it - -- prefer using those memory banks as an L1 cache. - -- - -- TLM: Is this a good idea? For example, external libraries such as cuBLAS - -- rely heavily on shared memory and thus this could adversely affect - -- performance. Perhaps we should use 'setCacheConfigFun' for individual - -- functions which might benefit from this. - -- - when (CUDA.computeCapability prp >= CUDA.Compute 2 0) - (CUDA.setCache CUDA.PreferL1) - - -- Display information about the selected device - Debug.traceIO Debug.verbose (deviceInfo dev prp) - - return $! Context prp lft - - --- | Push the context onto the CPUs thread stack of current contexts and execute --- some operation. --- -{-# INLINE withContext #-} -withContext :: Context -> IO a -> IO a -withContext Context{..} action = - withLifetime deviceContext $ \ctx -> - bracket_ (push ctx) pop action - -{-# INLINE push #-} -push :: CUDA.Context -> IO () -push ctx = do - message $ "push context: " ++ showContext ctx - CUDA.push ctx - -{-# INLINE pop #-} -pop :: IO () -pop = do - ctx <- CUDA.pop - message $ "pop context: " ++ showContext ctx - - --- 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 = Debug.showFFloatSIBase (Just 2) 1000 (fromIntegral $ CUDA.clockRate prp * 1000 :: Double) "Hz" - mem = Debug.showFFloatSIBase (Just 0) 1024 (fromIntegral $ CUDA.totalGlobalMem prp :: Double) "B" - at = char '@' - reset = zeroWidthText "\r" - - -{-# INLINE trace #-} -trace :: String -> IO a -> IO a -trace msg next = do - Debug.traceIO Debug.dump_gc ("gc: " ++ msg) - next - -{-# INLINE message #-} -message :: String -> IO () -message s = s `trace` return () - -{-# INLINE showContext #-} -showContext :: CUDA.Context -> String -showContext (CUDA.Context c) = show c - diff --git a/Data/Array/Accelerate/LLVM/PTX/Debug.hs b/Data/Array/Accelerate/LLVM/PTX/Debug.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/PTX/Debug.hs +++ /dev/null @@ -1,101 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeOperators #-} --- | --- Module : Data.Array.Accelerate.LLVM.PTX.Debug --- Copyright : [2014..2017] Trevor L. McDonell --- [2014..2014] Vinod Grover (NVIDIA Corporation) --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -module Data.Array.Accelerate.LLVM.PTX.Debug ( - - module Data.Array.Accelerate.Debug, - module Data.Array.Accelerate.LLVM.PTX.Debug, - -) where - -import Data.Array.Accelerate.Debug hiding ( timed, elapsed ) - -import Foreign.CUDA.Driver.Stream ( Stream ) -import qualified Foreign.CUDA.Driver.Event as Event - -import Control.Concurrent -import Data.Label -import Data.Time.Clock -import System.CPUTime -import Text.Printf - -import GHC.Float - - --- | Execute an action and time the results. The second argument specifies how --- to format the output string given elapsed GPU and CPU time respectively --- -timed - :: (Flags :-> Bool) - -> (Double -> Double -> Double -> String) - -> Maybe Stream - -> IO () - -> IO () -{-# INLINE timed #-} -timed f msg = - monitorProcTime (queryFlag f) (\t1 t2 t3 -> traceIO f (msg t1 t2 t3)) - -monitorProcTime - :: IO Bool - -> (Double -> Double -> Double -> IO ()) - -> Maybe Stream - -> IO () - -> IO () -{-# INLINE monitorProcTime #-} -#if ACCELERATE_DEBUG -monitorProcTime enabled display stream action = do - yes <- enabled - if yes - then do - gpuBegin <- Event.create [] - gpuEnd <- Event.create [] - wallBegin <- getCurrentTime - cpuBegin <- getCPUTime - Event.record gpuBegin stream - action - Event.record gpuEnd stream - cpuEnd <- getCPUTime - wallEnd <- getCurrentTime - - -- 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. - -- - _ <- forkIO $ do - Event.block gpuEnd - diff <- Event.elapsedTime gpuBegin gpuEnd - let gpuTime = float2Double $ diff * 1E-3 -- milliseconds - cpuTime = fromIntegral (cpuEnd - cpuBegin) * 1E-12 -- picoseconds - wallTime = realToFrac (diffUTCTime wallEnd wallBegin) - - Event.destroy gpuBegin - Event.destroy gpuEnd - -- - display wallTime cpuTime gpuTime - -- - return () - - else - action -#else -monitorProcTime _ _ _ action = action -#endif - -{-# INLINE elapsed #-} -elapsed :: Double -> Double -> Double -> String -elapsed wallTime cpuTime gpuTime = - printf "%s (wall), %s (cpu), %s (gpu)" - (showFFloatSIBase (Just 3) 1000 wallTime "s") - (showFFloatSIBase (Just 3) 1000 cpuTime "s") - (showFFloatSIBase (Just 3) 1000 gpuTime "s") - diff --git a/Data/Array/Accelerate/LLVM/PTX/Embed.hs b/Data/Array/Accelerate/LLVM/PTX/Embed.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/PTX/Embed.hs +++ /dev/null @@ -1,86 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} --- | --- Module : Data.Array.Accelerate.LLVM.PTX.Embed --- Copyright : [2017] Trevor L. McDonell --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -module Data.Array.Accelerate.LLVM.PTX.Embed ( - - module Data.Array.Accelerate.LLVM.Embed, - -) where - -import Data.ByteString.Short.Char8 as S8 -import Data.ByteString.Short.Internal as BS - -import Data.Array.Accelerate.Lifetime - -import Data.Array.Accelerate.LLVM.Compile -import Data.Array.Accelerate.LLVM.Embed - -import Data.Array.Accelerate.LLVM.PTX.Compile -import Data.Array.Accelerate.LLVM.PTX.Link -import Data.Array.Accelerate.LLVM.PTX.Target -import Data.Array.Accelerate.LLVM.PTX.Context - --- import qualified Foreign.CUDA.Analysis as CUDA -import qualified Foreign.CUDA.Driver as CUDA - -import Foreign.Ptr -import GHC.Ptr ( Ptr(..) ) -import Language.Haskell.TH ( Q, TExp ) -import System.IO.Unsafe -import qualified Data.ByteString as B -import qualified Data.ByteString.Unsafe as B -import qualified Language.Haskell.TH as TH -import qualified Language.Haskell.TH.Syntax as TH - - -instance Embed PTX where - embedForTarget = embed - --- Embed the given object code and set up to be reloaded at execution time. --- -embed :: PTX -> ObjectR PTX -> Q (TExp (ExecutableR PTX)) -embed target (ObjectR _ cfg obj) = do - -- Load the module to recover information such as number of registers and - -- bytes of shared memory. It may be possible to do this without requiring an - -- active CUDA context. - kmd <- TH.runIO $ withContext (ptxContext target) $ do - jit <- B.unsafeUseAsCString obj $ \p -> CUDA.loadDataFromPtrEx (castPtr p) [] - ks <- mapM (uncurry (linkFunctionQ (CUDA.jitModule jit))) cfg - CUDA.unload (CUDA.jitModule jit) - return ks - - -- Generate the embedded kernel executable. This will load the embedded object - -- code into the current (at execution time) context. - [|| unsafePerformIO $ do - jit <- CUDA.loadDataFromPtrEx $$( TH.unsafeTExpCoerce [| Ptr $(TH.litE (TH.StringPrimL (B.unpack obj))) |] ) [] - fun <- newLifetime (FunctionTable $$(listE (map (linkQ 'jit) kmd))) - return $ PTXR fun - ||] - where - linkQ :: TH.Name -> (Kernel, Q (TExp (Int -> Int))) -> Q (TExp Kernel) - linkQ jit (Kernel name _ dsmem cta _, grid) = - [|| unsafePerformIO $ do - f <- CUDA.getFun (CUDA.jitModule $$(TH.unsafeTExpCoerce (TH.varE jit))) $$(TH.unsafeTExpCoerce (TH.lift (S8.unpack name))) - return $ Kernel $$(liftSBS name) f dsmem cta $$grid - ||] - - listE :: [Q (TExp a)] -> Q (TExp [a]) - listE xs = TH.unsafeTExpCoerce (TH.listE (map TH.unTypeQ xs)) - - liftSBS :: ShortByteString -> Q (TExp ShortByteString) - liftSBS bs = - let bytes = BS.unpack bs - len = BS.length bs - in - [|| unsafePerformIO $ BS.createFromPtr $$( TH.unsafeTExpCoerce [| Ptr $(TH.litE (TH.StringPrimL bytes)) |]) len ||] - diff --git a/Data/Array/Accelerate/LLVM/PTX/Execute.hs b/Data/Array/Accelerate/LLVM/PTX/Execute.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/PTX/Execute.hs +++ /dev/null @@ -1,595 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeOperators #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} --- | --- Module : Data.Array.Accelerate.LLVM.PTX.Execute --- Copyright : [2014..2017] Trevor L. McDonell --- [2014..2014] Vinod Grover (NVIDIA Corporation) --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -module Data.Array.Accelerate.LLVM.PTX.Execute ( - - executeAcc, executeAfun, - executeOpenAcc, - -) where - --- accelerate -import Data.Array.Accelerate.Analysis.Match -import Data.Array.Accelerate.Array.Sugar -import Data.Array.Accelerate.Error -import Data.Array.Accelerate.Lifetime - -import Data.Array.Accelerate.LLVM.Analysis.Match -import Data.Array.Accelerate.LLVM.Execute -import Data.Array.Accelerate.LLVM.State - -import Data.Array.Accelerate.LLVM.PTX.Analysis.Launch ( multipleOf ) -import Data.Array.Accelerate.LLVM.PTX.Array.Data -import Data.Array.Accelerate.LLVM.PTX.Array.Prim ( memsetArrayAsync ) -import Data.Array.Accelerate.LLVM.PTX.Execute.Async -import Data.Array.Accelerate.LLVM.PTX.Execute.Environment -import Data.Array.Accelerate.LLVM.PTX.Execute.Marshal -import Data.Array.Accelerate.LLVM.PTX.Link -import Data.Array.Accelerate.LLVM.PTX.Target -import qualified Data.Array.Accelerate.LLVM.PTX.Debug as Debug - -import Data.Range.Range ( Range(..) ) -import Control.Parallel.Meta ( runExecutable ) - --- cuda -import qualified Foreign.CUDA.Driver as CUDA - --- library -import Control.Monad ( when ) -import Control.Monad.State ( gets, liftIO ) -import Data.ByteString.Short.Char8 ( ShortByteString, unpack ) -import Data.Int ( Int32 ) -import Data.List ( find ) -import Data.Maybe ( fromMaybe ) -import Data.Word ( Word32 ) -import Text.Printf ( printf ) -import Prelude hiding ( exp, map, sum, scanl, scanr ) -import qualified Prelude as P - - --- 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, we return a reference to the array data. The data --- will already have been copied to the device during compilation of the --- kernels. --- --- 2. If it is a non-skeleton node, such as a let binding or shape conversion, --- then execute directly by updating the environment or similar. --- --- 3. If it is a skeleton node, then we need to execute the generated LLVM --- code. --- -instance Execute PTX where - map = simpleOp - generate = simpleOp - transform = simpleOp - backpermute = simpleOp - fold = foldOp - fold1 = fold1Op - foldSeg = foldSegOp - fold1Seg = foldSegOp - scanl = scanOp - scanl1 = scan1Op - scanl' = scan'Op - scanr = scanOp - scanr1 = scan1Op - scanr' = scan'Op - permute = permuteOp - stencil1 = stencil1Op - stencil2 = stencil2Op - - --- Skeleton implementation --- ----------------------- - --- Simple kernels just need to know the shape of the output array --- -simpleOp - :: (Shape sh, Elt e) - => ExecutableR PTX - -> Gamma aenv - -> Aval aenv - -> Stream - -> sh - -> LLVM PTX (Array sh e) -simpleOp exe gamma aenv stream sh = withExecutable exe $ \ptxExecutable -> do - let kernel = case functionTable ptxExecutable of - k:_ -> k - _ -> $internalError "simpleOp" "no kernels found" - -- - out <- allocateRemote sh - ptx <- gets llvmTarget - liftIO $ executeOp ptx kernel gamma aenv stream (IE 0 (size sh)) out - return out - -simpleNamed - :: (Shape sh, Elt e) - => ShortByteString - -> ExecutableR PTX - -> Gamma aenv - -> Aval aenv - -> Stream - -> sh - -> LLVM PTX (Array sh e) -simpleNamed fun exe gamma aenv stream sh = withExecutable exe $ \ptxExecutable -> do - out <- allocateRemote sh - ptx <- gets llvmTarget - liftIO $ executeOp ptx (ptxExecutable !# fun) gamma aenv stream (IE 0 (size sh)) out - return out - - --- There are two flavours of fold operation: --- --- 1. If we are collapsing to a single value, then multiple thread blocks are --- working together. Since thread blocks synchronise with each other via --- kernel launches, each block computes a partial sum and the kernel is --- launched recursively until the final value is reached. --- --- 2. If this is a multidimensional reduction, then each inner dimension is --- handled by a single thread block, so no global communication is --- necessary. Furthermore are two kernel flavours: each innermost dimension --- can be cooperatively reduced by (a) a thread warp; or (b) a thread --- block. Currently we always use the first, but require benchmarking to --- determine when to select each. --- -fold1Op - :: (Shape sh, Elt e) - => ExecutableR PTX - -> Gamma aenv - -> Aval aenv - -> Stream - -> (sh :. Int) - -> LLVM PTX (Array sh e) -fold1Op exe gamma aenv stream sh@(sx :. sz) - = $boundsCheck "fold1" "empty array" (sz > 0) - $ case size sh of - 0 -> allocateRemote sx -- empty, but possibly with one or more non-zero dimensions - _ -> foldCore exe gamma aenv stream sh - -foldOp - :: (Shape sh, Elt e) - => ExecutableR PTX - -> Gamma aenv - -> Aval aenv - -> Stream - -> (sh :. Int) - -> LLVM PTX (Array sh e) -foldOp exe gamma aenv stream sh@(sx :. _) - = case size sh of - 0 -> simpleNamed "generate" exe gamma aenv stream (listToShape (P.map (max 1) (shapeToList sx))) - _ -> foldCore exe gamma aenv stream sh - -foldCore - :: forall aenv sh e. (Shape sh, Elt e) - => ExecutableR PTX - -> Gamma aenv - -> Aval aenv - -> Stream - -> (sh :. Int) - -> LLVM PTX (Array sh e) -foldCore exe gamma aenv stream sh - | Just Refl <- matchShapeType (undefined::sh) (undefined::Z) - = foldAllOp exe gamma aenv stream sh - -- - | otherwise - = foldDimOp exe gamma aenv stream sh - - -foldAllOp - :: forall aenv e. Elt e - => ExecutableR PTX - -> Gamma aenv - -> Aval aenv - -> Stream - -> DIM1 - -> LLVM PTX (Scalar e) -foldAllOp exe gamma aenv stream (Z :. n) = withExecutable exe $ \ptxExecutable -> do - ptx <- gets llvmTarget - let - ks = ptxExecutable !# "foldAllS" - km1 = ptxExecutable !# "foldAllM1" - km2 = ptxExecutable !# "foldAllM2" - -- - if kernelThreadBlocks ks n == 1 - then do - -- The array is small enough that we can compute it in a single step - out <- allocateRemote Z - liftIO $ executeOp ptx ks gamma aenv stream (IE 0 n) out - return out - - else do - -- Multi-kernel reduction to a single element. The first kernel integrates - -- any delayed elements, and the second is called recursively until - -- reaching a single element. - let - rec :: Vector e -> LLVM PTX (Scalar e) - rec tmp@(Array ((),m) adata) - | m <= 1 = return $ Array () adata - | otherwise = do - let s = m `multipleOf` kernelThreadBlockSize km2 - out <- allocateRemote (Z :. s) - liftIO $ executeOp ptx km2 gamma aenv stream (IE 0 s) (tmp, out) - rec out - -- - let s = n `multipleOf` kernelThreadBlockSize km1 - tmp <- allocateRemote (Z :. s) - liftIO $ executeOp ptx km1 gamma aenv stream (IE 0 s) tmp - rec tmp - - -foldDimOp - :: forall aenv sh e. (Shape sh, Elt e) - => ExecutableR PTX - -> Gamma aenv - -> Aval aenv - -> Stream - -> (sh :. Int) - -> LLVM PTX (Array sh e) -foldDimOp exe gamma aenv stream (sh :. sz) = withExecutable exe $ \ptxExecutable -> do - let - kernel = if sz > 0 - then ptxExecutable !# "fold" - else ptxExecutable !# "generate" - -- - out <- allocateRemote sh - ptx <- gets llvmTarget - liftIO $ executeOp ptx kernel gamma aenv stream (IE 0 (size sh)) out - return out - - -foldSegOp - :: (Shape sh, Elt e) - => ExecutableR PTX - -> Gamma aenv - -> Aval aenv - -> Stream - -> (sh :. Int) - -> (Z :. Int) - -> LLVM PTX (Array (sh :. Int) e) -foldSegOp exe gamma aenv stream (sh :. sz) (Z :. ss) = withExecutable exe $ \ptxExecutable -> do - let - n = ss - 1 -- segments array has been 'scanl (+) 0'`ed - m = size sh * n - foldseg = if (sz`quot`ss) < (2 * kernelThreadBlockSize foldseg_cta) - then foldseg_warp - else foldseg_cta - -- - foldseg_cta = ptxExecutable !# "foldSeg_block" - foldseg_warp = ptxExecutable !# "foldSeg_warp" - -- qinit = ptxExecutable !# "qinit" - -- - out <- allocateRemote (sh :. n) - ptx <- gets llvmTarget - liftIO $ executeOp ptx foldseg gamma aenv stream (IE 0 m) out - return out - - -scanOp - :: (Shape sh, Elt e) - => ExecutableR PTX - -> Gamma aenv - -> Aval aenv - -> Stream - -> sh :. Int - -> LLVM PTX (Array (sh:.Int) e) -scanOp exe gamma aenv stream (sz :. n) = - case n of - 0 -> simpleNamed "generate" exe gamma aenv stream (sz :. 1) - _ -> scanCore exe gamma aenv stream sz n (n+1) - -scan1Op - :: (Shape sh, Elt e) - => ExecutableR PTX - -> Gamma aenv - -> Aval aenv - -> Stream - -> sh :. Int - -> LLVM PTX (Array (sh:.Int) e) -scan1Op exe gamma aenv stream (sz :. n) - = $boundsCheck "scan1" "empty array" (n > 0) - $ scanCore exe gamma aenv stream sz n n - -scanCore - :: forall aenv sh e. (Shape sh, Elt e) - => ExecutableR PTX - -> Gamma aenv - -> Aval aenv - -> Stream - -> sh - -> Int -- input size - -> Int -- output size - -> LLVM PTX (Array (sh:.Int) e) -scanCore exe gamma aenv stream sz n m - | Just Refl <- matchShapeType (undefined::sh) (undefined::Z) - = scanAllOp exe gamma aenv stream n m - -- - | otherwise - = scanDimOp exe gamma aenv stream sz m - - -scanAllOp - :: forall aenv e. Elt e - => ExecutableR PTX - -> Gamma aenv - -> Aval aenv - -> Stream - -> Int -- input size - -> Int -- output size - -> LLVM PTX (Vector e) -scanAllOp exe gamma aenv stream n m = withExecutable exe $ \ptxExecutable -> do - let - k1 = ptxExecutable !# "scanP1" - k2 = ptxExecutable !# "scanP2" - k3 = ptxExecutable !# "scanP3" - -- - c = kernelThreadBlockSize k1 - s = n `multipleOf` c - -- - ptx <- gets llvmTarget - out <- allocateRemote (Z :. m) - - -- Step 1: Independent thread-block-wide scans of the input. Small arrays - -- which can be computed by a single thread block will require no - -- additional work. - tmp <- allocateRemote (Z :. s) :: LLVM PTX (Vector e) - liftIO $ executeOp ptx k1 gamma aenv stream (IE 0 s) (tmp, out) - - -- Step 2: Multi-block reductions need to compute the per-block prefix, - -- then apply those values to the partial results. - when (s > 1) $ do - liftIO $ executeOp ptx k2 gamma aenv stream (IE 0 s) tmp - liftIO $ executeOp ptx k3 gamma aenv stream (IE 0 (s-1)) (tmp, out, i32 c) - - return out - - -scanDimOp - :: forall aenv sh e. (Shape sh, Elt e) - => ExecutableR PTX - -> Gamma aenv - -> Aval aenv - -> Stream - -> sh - -> Int - -> LLVM PTX (Array (sh:.Int) e) -scanDimOp exe gamma aenv stream sz m = withExecutable exe $ \ptxExecutable -> do - ptx <- gets llvmTarget - out <- allocateRemote (sz :. m) - liftIO $ executeOp ptx (ptxExecutable !# "scan") gamma aenv stream (IE 0 (size sz)) out - return out - - -scan'Op - :: forall aenv sh e. (Shape sh, Elt e) - => ExecutableR PTX - -> Gamma aenv - -> Aval aenv - -> Stream - -> sh :. Int - -> LLVM PTX (Array (sh:.Int) e, Array sh e) -scan'Op exe gamma aenv stream sh@(sz :. n) = - case n of - 0 -> do out <- allocateRemote (sz :. 0) - sum <- simpleNamed "generate" exe gamma aenv stream sz - return (out, sum) - _ -> scan'Core exe gamma aenv stream sh - -scan'Core - :: forall aenv sh e. (Shape sh, Elt e) - => ExecutableR PTX - -> Gamma aenv - -> Aval aenv - -> Stream - -> sh :. Int - -> LLVM PTX (Array (sh:.Int) e, Array sh e) -scan'Core exe gamma aenv stream sh - | Just Refl <- matchShapeType (undefined::sh) (undefined::Z) - = scan'AllOp exe gamma aenv stream sh - -- - | otherwise - = scan'DimOp exe gamma aenv stream sh - -scan'AllOp - :: forall aenv e. Elt e - => ExecutableR PTX - -> Gamma aenv - -> Aval aenv - -> Stream - -> DIM1 - -> LLVM PTX (Vector e, Scalar e) -scan'AllOp exe gamma aenv stream (Z :. n) = withExecutable exe $ \ptxExecutable -> do - let - k1 = ptxExecutable !# "scanP1" - k2 = ptxExecutable !# "scanP2" - k3 = ptxExecutable !# "scanP3" - -- - c = kernelThreadBlockSize k1 - s = n `multipleOf` c - -- - ptx <- gets llvmTarget - out <- allocateRemote (Z :. n) - tmp <- allocateRemote (Z :. s) :: LLVM PTX (Vector e) - - -- Step 1: independent thread-block-wide scans. Each block stores its partial - -- sum to a temporary array. - liftIO $ executeOp ptx k1 gamma aenv stream (IE 0 s) (tmp, out) - - -- If this was a small array that was processed by a single thread block then - -- we are done, otherwise compute the per-block prefix and apply those values - -- to the partial results. - if s == 1 - then case tmp of - Array _ ad -> return (out, Array () ad) - else do - sum <- allocateRemote Z - liftIO $ executeOp ptx k2 gamma aenv stream (IE 0 s) (tmp, sum) - liftIO $ executeOp ptx k3 gamma aenv stream (IE 0 (s-1)) (tmp, out, i32 c) - return (out, sum) - - -scan'DimOp - :: forall aenv sh e. (Shape sh, Elt e) - => ExecutableR PTX - -> Gamma aenv - -> Aval aenv - -> Stream - -> sh :. Int - -> LLVM PTX (Array (sh:.Int) e, Array sh e) -scan'DimOp exe gamma aenv stream sh@(sz :. _) = withExecutable exe $ \ptxExecutable -> do - ptx <- gets llvmTarget - out <- allocateRemote sh - sum <- allocateRemote sz - liftIO $ executeOp ptx (ptxExecutable !# "scan") gamma aenv stream (IE 0 (size sz)) (out,sum) - return (out,sum) - - -permuteOp - :: (Shape sh, Shape sh', Elt e) - => ExecutableR PTX - -> Gamma aenv - -> Aval aenv - -> Stream - -> Bool - -> sh - -> Array sh' e - -> LLVM PTX (Array sh' e) -permuteOp exe gamma aenv stream inplace shIn dfs = withExecutable exe $ \ptxExecutable -> do - let - n = size shIn - m = size (shape dfs) - kernel = case functionTable ptxExecutable of - k:_ -> k - _ -> $internalError "permute" "no kernels found" - -- - ptx <- gets llvmTarget - out <- if inplace - then return dfs - else cloneArrayAsync stream dfs - -- - case kernelName kernel of - "permute_rmw" -> liftIO $ executeOp ptx kernel gamma aenv stream (IE 0 n) out - "permute_mutex" -> do - barrier@(Array _ ad) <- allocateRemote (Z :. m) :: LLVM PTX (Vector Word32) - memsetArrayAsync stream m 0 ad - liftIO $ executeOp ptx kernel gamma aenv stream (IE 0 n) (out, barrier) - _ -> $internalError "permute" "unexpected kernel image" - -- - return out - - --- Using the defaulting instances for stencil operations (for now). --- -stencil1Op - :: (Shape sh, Elt b) - => ExecutableR PTX - -> Gamma aenv - -> Aval aenv - -> Stream - -> Array sh a - -> LLVM PTX (Array sh b) -stencil1Op exe gamma aenv stream arr = - simpleOp exe gamma aenv stream (shape arr) - -stencil2Op - :: (Shape sh, Elt c) - => ExecutableR PTX - -> Gamma aenv - -> Aval aenv - -> Stream - -> Array sh a - -> Array sh b - -> LLVM PTX (Array sh c) -stencil2Op exe gamma aenv stream arr brr = - simpleOp exe gamma aenv stream (shape arr `intersect` shape brr) - - --- Skeleton execution --- ------------------ - --- TODO: Calculate this from the device properties, say [a multiple of] the --- maximum number of in-flight threads that the device supports. --- -defaultPPT :: Int -defaultPPT = 32768 - -{-# INLINE i32 #-} -i32 :: Int -> Int32 -i32 = fromIntegral - --- | Retrieve the named kernel --- -(!#) :: FunctionTable -> ShortByteString -> Kernel -(!#) exe name - = fromMaybe ($internalError "lookupFunction" ("function not found: " ++ unpack name)) - $ lookupKernel name exe - -lookupKernel :: ShortByteString -> FunctionTable -> Maybe Kernel -lookupKernel name ptxExecutable = - find (\k -> kernelName k == name) (functionTable ptxExecutable) - - --- Execute the function implementing this kernel. --- -executeOp - :: Marshalable args - => PTX - -> Kernel - -> Gamma aenv - -> Aval aenv - -> Stream - -> Range - -> args - -> IO () -executeOp ptx@PTX{..} kernel@Kernel{..} gamma aenv stream r args = - runExecutable fillP kernelName defaultPPT r $ \start end _ -> do - argv <- marshal ptx stream (i32 start, i32 end, args, (gamma,aenv)) - launch kernel stream (end-start) argv - - --- Execute a device function with the given thread configuration and function --- parameters. --- -launch :: Kernel -> Stream -> Int -> [CUDA.FunParam] -> IO () -launch Kernel{..} stream n args = - when (n > 0) $ - withLifetime stream $ \st -> - Debug.monitorProcTime query msg (Just st) $ - CUDA.launchKernel kernelFun grid cta smem (Just st) args - where - cta = (kernelThreadBlockSize, 1, 1) - grid = (kernelThreadBlocks n, 1, 1) - smem = kernelSharedMemBytes - - -- Debugging/monitoring support - query = if Debug.monitoringIsEnabled - then return True - else Debug.queryFlag Debug.dump_exec - - fst3 (x,_,_) = x - msg wall cpu gpu = do - Debug.addProcessorTime Debug.PTX gpu - Debug.traceIO Debug.dump_exec $ - printf "exec: %s <<< %d, %d, %d >>> %s" - (unpack kernelName) (fst3 grid) (fst3 cta) smem (Debug.elapsed wall cpu gpu) - diff --git a/Data/Array/Accelerate/LLVM/PTX/Execute/Async.hs b/Data/Array/Accelerate/LLVM/PTX/Execute/Async.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/PTX/Execute/Async.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} --- | --- Module : Data.Array.Accelerate.LLVM.PTX.Execute.Async --- Copyright : [2014..2017] Trevor L. McDonell --- [2014..2014] Vinod Grover (NVIDIA Corporation) --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -module Data.Array.Accelerate.LLVM.PTX.Execute.Async ( - - Async, Stream, Event, - module Data.Array.Accelerate.LLVM.Execute.Async, - -) where - --- accelerate -import Data.Array.Accelerate.LLVM.Execute.Async hiding ( Async ) -import qualified Data.Array.Accelerate.LLVM.Execute.Async as A - -import Data.Array.Accelerate.LLVM.PTX.Target -import Data.Array.Accelerate.LLVM.PTX.Execute.Event ( Event ) -import Data.Array.Accelerate.LLVM.PTX.Execute.Stream ( Stream ) -import qualified Data.Array.Accelerate.LLVM.PTX.Execute.Event as Event -import qualified Data.Array.Accelerate.LLVM.PTX.Execute.Stream as Stream - --- standard library -import Control.Monad.State - - --- Asynchronous arrays in the CUDA backend are tagged with an Event that will be --- filled once the kernel implementing that array has completed. --- -type Async a = AsyncR PTX a - -instance A.Async PTX where - type StreamR PTX = Stream - type EventR PTX = Event - - {-# INLINEABLE fork #-} - fork = - Stream.create - - {-# INLINEABLE join #-} - join stream = - liftIO $! Stream.destroy stream - - {-# INLINEABLE checkpoint #-} - checkpoint stream = - Event.waypoint stream - - {-# INLINEABLE after #-} - after stream event = - liftIO $! Event.after event stream - - {-# INLINEABLE block #-} - block event = - liftIO $! Event.block event - diff --git a/Data/Array/Accelerate/LLVM/PTX/Execute/Environment.hs b/Data/Array/Accelerate/LLVM/PTX/Execute/Environment.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/PTX/Execute/Environment.hs +++ /dev/null @@ -1,22 +0,0 @@ --- | --- Module : Data.Array.Accelerate.LLVM.PTX.Execute.Environment --- Copyright : [2014..2017] Trevor L. McDonell --- [2014..2014] Vinod Grover (NVIDIA Corporation) --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -module Data.Array.Accelerate.LLVM.PTX.Execute.Environment ( - - Aval, aprj - -) where - -import Data.Array.Accelerate.LLVM.PTX.Target -import Data.Array.Accelerate.LLVM.Execute.Environment - -type Aval = AvalR PTX - diff --git a/Data/Array/Accelerate/LLVM/PTX/Execute/Event.hs b/Data/Array/Accelerate/LLVM/PTX/Execute/Event.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/PTX/Execute/Event.hs +++ /dev/null @@ -1,162 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} --- | --- Module : Data.Array.Accelerate.LLVM.PTX.Execute.Event --- Copyright : [2014..2017] Trevor L. McDonell --- [2014..2014] Vinod Grover (NVIDIA Corporation) --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -module Data.Array.Accelerate.LLVM.PTX.Execute.Event ( - - Event, - create, destroy, query, waypoint, after, block, - -) where - --- accelerate -import Data.Array.Accelerate.Lifetime -import qualified Data.Array.Accelerate.Array.Remote.LRU as Remote - -import Data.Array.Accelerate.LLVM.PTX.Array.Remote ( ) -import Data.Array.Accelerate.LLVM.PTX.Target ( PTX(..) ) -import Data.Array.Accelerate.LLVM.State -import qualified Data.Array.Accelerate.LLVM.PTX.Debug as Debug -import {-# SOURCE #-} Data.Array.Accelerate.LLVM.PTX.Execute.Stream - --- cuda -import Foreign.CUDA.Driver.Error -import qualified Foreign.CUDA.Driver.Event as Event -import qualified Foreign.CUDA.Driver.Stream as Stream - -import Control.Exception -import Control.Monad.State - - --- | Events can be used for efficient device-side synchronisation between --- execution streams and between the host. --- -type Event = Lifetime Event.Event - - --- | Create a new event. It will not be automatically garbage collected, and is --- not suitable for timing purposes. --- -{-# INLINEABLE create #-} -create :: LLVM PTX Event -create = do - e <- create' - event <- liftIO $ newLifetime e - liftIO $ addFinalizer event $ do message $ "destroy " ++ showEvent e - Event.destroy e - return event - -create' :: LLVM PTX Event.Event -create' = do - PTX{ptxMemoryTable} <- gets llvmTarget - me <- attempt "create/new" (liftIO . catchOOM $ Event.create [Event.DisableTiming]) - `orElse` do - Remote.reclaim ptxMemoryTable - liftIO $ do - message "create/new: failed (purging)" - catchOOM $ Event.create [Event.DisableTiming] - case me of - Just e -> return e - Nothing -> liftIO $ do - message "create/new: failed (non-recoverable)" - throwIO (ExitCode OutOfMemory) - - where - catchOOM :: IO a -> IO (Maybe a) - catchOOM it = - liftM Just it `catch` \e -> case e of - ExitCode OutOfMemory -> return Nothing - _ -> throwIO e - - attempt :: MonadIO m => String -> m (Maybe a) -> m (Maybe a) - attempt msg ea = do - ma <- ea - case ma of - Nothing -> return Nothing - Just a -> do liftIO (message msg) - return (Just a) - - orElse :: MonadIO m => m (Maybe a) -> m (Maybe a) -> m (Maybe a) - orElse ea eb = do - ma <- ea - case ma of - Just a -> return (Just a) - Nothing -> eb - - --- | Delete an event --- -{-# INLINEABLE destroy #-} -destroy :: Event -> IO () -destroy = finalize - --- | Create a new event marker that will be filled once execution in the --- specified stream has completed all previously submitted work. --- -{-# INLINEABLE waypoint #-} -waypoint :: Stream -> LLVM PTX Event -waypoint stream = do - event <- create - liftIO $ - withLifetime stream $ \s -> do - withLifetime event $ \e -> do - message $ "add waypoint " ++ showEvent e ++ " in stream " ++ showStream s - Event.record e (Just s) - return event - --- | Make all future work submitted to the given stream wait until the event --- reports completion before beginning execution. --- -{-# INLINEABLE after #-} -after :: Event -> Stream -> IO () -after event stream = - withLifetime stream $ \s -> - withLifetime event $ \e -> do - message $ "after " ++ showEvent e ++ " in stream " ++ showStream s - Event.wait e (Just s) [] - --- | Block the calling thread until the event is recorded --- -{-# INLINEABLE block #-} -block :: Event -> IO () -block event = - withLifetime event $ \e -> do - message $ "blocked on event " ++ showEvent e - Event.block e - --- | Test whether an event has completed --- -{-# INLINEABLE query #-} -query :: Event -> IO Bool -query event = withLifetime event Event.query - - --- Debug --- ----- - -{-# INLINE trace #-} -trace :: String -> IO a -> IO a -trace msg next = do - Debug.traceIO Debug.dump_sched ("event: " ++ msg) - next - -{-# INLINE message #-} -message :: String -> IO () -message s = s `trace` return () - -{-# INLINE showEvent #-} -showEvent :: Event.Event -> String -showEvent (Event.Event e) = show e - -{-# INLINE showStream #-} -showStream :: Stream.Stream -> String -showStream (Stream.Stream s) = show s - diff --git a/Data/Array/Accelerate/LLVM/PTX/Execute/Event.hs-boot b/Data/Array/Accelerate/LLVM/PTX/Execute/Event.hs-boot deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/PTX/Execute/Event.hs-boot +++ /dev/null @@ -1,26 +0,0 @@ --- | --- Module : Data.Array.Accelerate.LLVM.PTX.Execute.Event-boot --- Copyright : [2016..2017] Trevor L. McDonell --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -module Data.Array.Accelerate.LLVM.PTX.Execute.Event ( - - Event, - query, block - -) where - -import Data.Array.Accelerate.Lifetime -import qualified Foreign.CUDA.Driver.Event as Event - - -type Event = Lifetime Event.Event - -query :: Event -> IO Bool -block :: Event -> IO () - diff --git a/Data/Array/Accelerate/LLVM/PTX/Execute/Marshal.hs b/Data/Array/Accelerate/LLVM/PTX/Execute/Marshal.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/PTX/Execute/Marshal.hs +++ /dev/null @@ -1,147 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -#if __GLASGOW_HASKELL__ <= 708 -{-# LANGUAGE OverlappingInstances #-} -{-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-} -#endif --- | --- Module : Data.Array.Accelerate.LLVM.PTX.Execute.Marshal --- Copyright : [2014..2017] Trevor L. McDonell --- [2014..2014] Vinod Grover (NVIDIA Corporation) --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -module Data.Array.Accelerate.LLVM.PTX.Execute.Marshal ( - - Marshalable, M.marshal - -) where - --- accelerate -import Data.Array.Accelerate.LLVM.CodeGen.Environment ( Gamma, Idx'(..) ) -import qualified Data.Array.Accelerate.LLVM.Execute.Marshal as M - -import Data.Array.Accelerate.LLVM.PTX.State -import Data.Array.Accelerate.LLVM.PTX.Target -import Data.Array.Accelerate.LLVM.PTX.Array.Data -import Data.Array.Accelerate.LLVM.PTX.Execute.Async ( Async, AsyncR(..) ) -import Data.Array.Accelerate.LLVM.PTX.Execute.Event ( after ) -import Data.Array.Accelerate.LLVM.PTX.Execute.Environment -import qualified Data.Array.Accelerate.LLVM.PTX.Array.Prim as Prim - --- cuda -import qualified Foreign.CUDA.Driver as CUDA - --- libraries -import Control.Monad -import Data.Int -import Data.DList ( DList ) -import Data.Typeable -import Foreign.Ptr -import Foreign.Storable ( Storable ) -import qualified Data.DList as DL -import qualified Data.IntMap as IM - - --- Instances for the PTX backend --- -type Marshalable args = M.Marshalable PTX args -type instance M.ArgR PTX = CUDA.FunParam - - --- Instances for handling concrete types in this backend, namely shapes and --- array data. --- -instance M.Marshalable PTX Int where - marshal' _ _ x = return $ DL.singleton (CUDA.VArg x) - -instance M.Marshalable PTX Int32 where - marshal' _ _ x = return $ DL.singleton (CUDA.VArg x) - -instance {-# OVERLAPS #-} M.Marshalable PTX (Gamma aenv, Aval aenv) where - marshal' ptx stream (gamma, aenv) - = fmap DL.concat - $ mapM (\(_, Idx' idx) -> M.marshal' ptx stream =<< sync (aprj idx aenv)) (IM.elems gamma) - where - -- HAXORZ~ D: - -- - -- The 'Async' class functions need to run in the LLVM monad, but the - -- marshalling functions must run in IO because they will be executed in - -- the lower-level scheduling code. - -- - -- We hack around this impedance mismatch by calling the 'after' - -- implementation directly. - -- - sync :: Async a -> IO a - sync (AsyncR event arr) = after event stream >> return arr - -instance ArrayElt e => M.Marshalable PTX (ArrayData e) where - marshal' ptx _ adata = do - let marshalP :: forall e' a. (ArrayElt e', ArrayPtrs e' ~ Ptr a, Typeable e', Typeable a, Storable a) - => ArrayData e' - -> IO (DList CUDA.FunParam) - marshalP ad = - fmap (DL.singleton . CUDA.VArg) - (unsafeGetDevicePtr ptx ad :: IO (CUDA.DevicePtr a)) - - marshalR :: ArrayEltR e' -> ArrayData e' -> IO (DList CUDA.FunParam) - marshalR ArrayEltRunit _ = return DL.empty - marshalR (ArrayEltRpair aeR1 aeR2) ad = - return DL.append `ap` marshalR aeR1 (fstArrayData ad) - `ap` marshalR aeR2 (sndArrayData ad) - marshalR ArrayEltRint ad = marshalP ad - marshalR ArrayEltRint8 ad = marshalP ad - marshalR ArrayEltRint16 ad = marshalP ad - marshalR ArrayEltRint32 ad = marshalP ad - marshalR ArrayEltRint64 ad = marshalP ad - marshalR ArrayEltRword ad = marshalP ad - marshalR ArrayEltRword8 ad = marshalP ad - marshalR ArrayEltRword16 ad = marshalP ad - marshalR ArrayEltRword32 ad = marshalP ad - marshalR ArrayEltRword64 ad = marshalP ad - marshalR ArrayEltRfloat ad = marshalP ad - marshalR ArrayEltRdouble ad = marshalP ad - marshalR ArrayEltRchar ad = marshalP ad - marshalR ArrayEltRcshort ad = marshalP ad - marshalR ArrayEltRcushort ad = marshalP ad - marshalR ArrayEltRcint ad = marshalP ad - marshalR ArrayEltRcuint ad = marshalP ad - marshalR ArrayEltRclong ad = marshalP ad - marshalR ArrayEltRculong ad = marshalP ad - marshalR ArrayEltRcllong ad = marshalP ad - marshalR ArrayEltRcullong ad = marshalP ad - marshalR ArrayEltRcchar ad = marshalP ad - marshalR ArrayEltRcschar ad = marshalP ad - marshalR ArrayEltRcuchar ad = marshalP ad - marshalR ArrayEltRcfloat ad = marshalP ad - marshalR ArrayEltRcdouble ad = marshalP ad - marshalR ArrayEltRbool ad = marshalP ad - - marshalR arrayElt adata - - --- TODO FIXME !!! --- --- We will probably need to change marshal to be a bracketed function. We may --- also want to reconsider whether to continue to restrict it to IO. --- -unsafeGetDevicePtr - :: (ArrayElt e, ArrayPtrs e ~ Ptr a, Typeable e, Typeable a, Storable a) - => PTX - -> ArrayData e - -> IO (CUDA.DevicePtr a) -unsafeGetDevicePtr !ptx !ad = - evalPTX ptx $ Prim.withDevicePtr ad (\p -> return (Nothing,p)) - diff --git a/Data/Array/Accelerate/LLVM/PTX/Execute/Stream.hs b/Data/Array/Accelerate/LLVM/PTX/Execute/Stream.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/PTX/Execute/Stream.hs +++ /dev/null @@ -1,181 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE RecordWildCards #-} --- | --- Module : Data.Array.Accelerate.LLVM.PTX.Execute.Stream --- Copyright : [2014..2017] Trevor L. McDonell --- [2014..2014] Vinod Grover (NVIDIA Corporation) --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -module Data.Array.Accelerate.LLVM.PTX.Execute.Stream ( - - Reservoir, new, - Stream, create, destroy, streaming, - -) where - --- accelerate -import Data.Array.Accelerate.Lifetime -import qualified Data.Array.Accelerate.Array.Remote.LRU as Remote - -import Data.Array.Accelerate.LLVM.PTX.Array.Remote ( ) -import Data.Array.Accelerate.LLVM.PTX.Execute.Event ( Event ) -import Data.Array.Accelerate.LLVM.PTX.Target ( PTX(..) ) -import Data.Array.Accelerate.LLVM.State -import qualified Data.Array.Accelerate.LLVM.PTX.Debug as Debug -import qualified Data.Array.Accelerate.LLVM.PTX.Execute.Event as Event -import Data.Array.Accelerate.LLVM.PTX.Execute.Stream.Reservoir as RSV - --- cuda -import Foreign.CUDA.Driver.Error -import qualified Foreign.CUDA.Driver.Stream as Stream - --- standard library -import Control.Exception -import Control.Monad.State - - --- | A 'Stream' represents an independent sequence of computations executed on --- the GPU. Operations in different streams may be executed concurrently with --- each other, but operations in the same stream can never overlap. --- 'Data.Array.Accelerate.LLVM.PTX.Execute.Event.Event's can be used for --- efficient cross-stream synchronisation. --- -type Stream = Lifetime Stream.Stream - - --- Executing operations in streams --- ------------------------------- - --- | Execute an operation in a unique execution stream. The (asynchronous) --- result is passed to a second operation together with an event that will be --- signalled once the operation is complete. The stream and event are released --- after the second operation completes. --- -{-# INLINEABLE streaming #-} -streaming - :: (Stream -> LLVM PTX a) - -> (Event -> a -> LLVM PTX b) - -> LLVM PTX b -streaming !action !after = do - PTX{..} <- gets llvmTarget - stream <- create - first <- action stream - end <- Event.waypoint stream - final <- after end first - liftIO $ do - destroy stream - Event.destroy end - return final - - --- Primitive operations --- -------------------- - -{-- --- | Delete all execution streams from the reservoir --- -{-# INLINEABLE flush #-} -flush :: Context -> Reservoir -> IO () -flush !Context{..} !ref = do - mc <- deRefWeak weakContext - case mc of - Nothing -> message "delete reservoir/dead context" - Just ctx -> do - message "flush reservoir" - old <- swapMVar ref Seq.empty - bracket_ (CUDA.push ctx) CUDA.pop $ Seq.mapM_ Stream.destroy old ---} - - --- | Create a CUDA execution stream. If an inactive stream is available for use, --- use that, otherwise generate a fresh stream. --- --- Note: [Finalising execution streams] --- --- We don't actually ensure that the stream has executed all of its operations --- to completion before attempting to return it to the reservoir for reuse. --- Doing so increases overhead of the LLVM RTS due to 'forkIO', and consumes CPU --- time as 'Stream.block' busy-waits for the stream to complete. It is quicker --- to optimistically return the streams to the end of the reservoir immediately, --- and just check whether the stream is done before reusing it. --- --- > void . forkIO $ do --- > Stream.block stream --- > modifyMVar_ ref $ \rsv -> return (rsv Seq.|> stream) --- -{-# INLINEABLE create #-} -create :: LLVM PTX Stream -create = do - PTX{..} <- gets llvmTarget - s <- create' - stream <- liftIO $ newLifetime s - liftIO $ addFinalizer stream (RSV.insert ptxStreamReservoir s) - return stream - -create' :: LLVM PTX Stream.Stream -create' = do - PTX{..} <- gets llvmTarget - ms <- attempt "create/reservoir" (liftIO $ RSV.malloc ptxStreamReservoir) - `orElse` - attempt "create/new" (liftIO . catchOOM $ Stream.create []) - `orElse` do - Remote.reclaim ptxMemoryTable - liftIO $ do - message "create/new: failed (purging)" - catchOOM $ Stream.create [] - case ms of - Just s -> return s - Nothing -> liftIO $ do - message "create/new: failed (non-recoverable)" - throwIO (ExitCode OutOfMemory) - - where - catchOOM :: IO a -> IO (Maybe a) - catchOOM it = - liftM Just it `catch` \e -> case e of - ExitCode OutOfMemory -> return Nothing - _ -> throwIO e - - attempt :: MonadIO m => String -> m (Maybe a) -> m (Maybe a) - attempt msg ea = do - ma <- ea - case ma of - Nothing -> return Nothing - Just a -> do liftIO (message msg) - return (Just a) - - orElse :: MonadIO m => m (Maybe a) -> m (Maybe a) -> m (Maybe a) - orElse ea eb = do - ma <- ea - case ma of - Just a -> return (Just a) - Nothing -> eb - - --- | Merge a stream back into the reservoir. This must only be done once all --- pending operations in the stream have completed. --- -{-# INLINEABLE destroy #-} -destroy :: Stream -> IO () -destroy = finalize - - --- Debug --- ----- - -{-# INLINE trace #-} -trace :: String -> IO a -> IO a -trace msg next = do - Debug.traceIO Debug.dump_sched ("stream: " ++ msg) - next - -{-# INLINE message #-} -message :: String -> IO () -message s = s `trace` return () - diff --git a/Data/Array/Accelerate/LLVM/PTX/Execute/Stream.hs-boot b/Data/Array/Accelerate/LLVM/PTX/Execute/Stream.hs-boot deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/PTX/Execute/Stream.hs-boot +++ /dev/null @@ -1,32 +0,0 @@ --- | --- Module : Data.Array.Accelerate.LLVM.PTX.Execute.Stream-boot --- Copyright : [2016..2017] Trevor L. McDonell --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -module Data.Array.Accelerate.LLVM.PTX.Execute.Stream ( - - Stream, - streaming, - -) where - -import Data.Array.Accelerate.Lifetime ( Lifetime ) -import Data.Array.Accelerate.LLVM.State ( LLVM ) -import Data.Array.Accelerate.LLVM.PTX.Target ( PTX ) -import {-# SOURCE #-} Data.Array.Accelerate.LLVM.PTX.Execute.Event - -import qualified Foreign.CUDA.Driver.Stream as Stream - - -type Stream = Lifetime Stream.Stream - -streaming - :: (Stream -> LLVM PTX a) - -> (Event -> a -> LLVM PTX b) - -> LLVM PTX b - diff --git a/Data/Array/Accelerate/LLVM/PTX/Execute/Stream/Reservoir.hs b/Data/Array/Accelerate/LLVM/PTX/Execute/Stream/Reservoir.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/PTX/Execute/Stream/Reservoir.hs +++ /dev/null @@ -1,102 +0,0 @@ -{-# LANGUAGE BangPatterns #-} --- | --- Module : Data.Array.Accelerate.LLVM.PTX.Execute.Stream.Reservoir --- Copyright : [2016..2017] Trevor L. McDonell --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -module Data.Array.Accelerate.LLVM.PTX.Execute.Stream.Reservoir ( - - Reservoir, - new, malloc, insert, - -) where - -import Data.Array.Accelerate.LLVM.PTX.Context ( Context ) -import qualified Data.Array.Accelerate.LLVM.PTX.Debug as Debug - -import Control.Concurrent.MVar -import Data.Sequence ( Seq ) -import qualified Data.Sequence as Seq -import qualified Foreign.CUDA.Driver.Stream as Stream - - --- | The reservoir is a place to store CUDA execution streams that are currently --- inactive. When a new stream is requested one is provided from the reservoir --- if available, otherwise a fresh execution stream is created. --- -type Reservoir = MVar (Seq Stream.Stream) - - --- | Generate a new empty reservoir. It is not necessary to pre-populate it with --- any streams because stream creation does not cause a device synchronisation. --- --- Additionally, we do not need to finalise any of the streams. A reservoir is --- tied to a specific execution context, so when the reservoir dies it is --- because the PTX state and contained CUDA context have died, so there is --- nothing more to do. --- -{-# INLINEABLE new #-} -new :: Context -> IO Reservoir -new _ctx = newMVar Seq.empty - - --- | Retrieve an execution stream from the reservoir, if one is available. --- --- Since we put streams back onto the reservoir once we have finished adding --- work to them, not once they have completed execution of the tasks, we must --- check for one which has actually completed. --- --- See note: [Finalising execution streams] --- -{-# INLINEABLE malloc #-} -malloc :: Reservoir -> IO (Maybe Stream.Stream) -malloc !ref = - modifyMVar ref (search Seq.empty) - where - -- scan through the streams in the reservoir looking for the first inactive - -- one. Optimistically adding the streams to the end of the reservoir as - -- soon as we stop assigning new work to them (c.f. async), and just - -- checking they have completed before reusing them, is quicker than having - -- a finaliser thread block until completion before retiring them. - -- - search !acc !rsv = - case Seq.viewl rsv of - Seq.EmptyL -> return (acc, Nothing) - s Seq.:< ss -> do - done <- Stream.finished s - case done of - True -> return (acc Seq.>< ss, Just s) - False -> search (acc Seq.|> s) ss - - --- | Add a stream to the reservoir --- -{-# INLINEABLE insert #-} -insert :: Reservoir -> Stream.Stream -> IO () -insert !ref !stream = do - message ("stash stream " ++ showStream stream) - modifyMVar_ ref $ \rsv -> return (rsv Seq.|> stream) - - --- Debug --- ----- - -{-# INLINE trace #-} -trace :: String -> IO a -> IO a -trace msg next = do - Debug.traceIO Debug.dump_sched ("stream: " ++ msg) - next - -{-# INLINE message #-} -message :: String -> IO () -message s = s `trace` return () - -{-# INLINE showStream #-} -showStream :: Stream.Stream -> String -showStream (Stream.Stream s) = show s - diff --git a/Data/Array/Accelerate/LLVM/PTX/Foreign.hs b/Data/Array/Accelerate/LLVM/PTX/Foreign.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/PTX/Foreign.hs +++ /dev/null @@ -1,81 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} --- | --- Module : Data.Array.Accelerate.LLVM.PTX.Foreign --- Copyright : [2016..2017] Trevor L. McDonell --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -module Data.Array.Accelerate.LLVM.PTX.Foreign ( - - -- Foreign functions - ForeignAcc(..), - ForeignExp(..), - - -- useful re-exports - LLVM, - PTX(..), - Context(..), - liftIO, - withDevicePtr, - module Data.Array.Accelerate.LLVM.PTX.Array.Data, - module Data.Array.Accelerate.LLVM.PTX.Execute.Async, - -) where - -import qualified Data.Array.Accelerate.Array.Sugar as S - -import Data.Array.Accelerate.LLVM.State -import Data.Array.Accelerate.LLVM.CodeGen.Sugar - -import Data.Array.Accelerate.LLVM.Foreign -import Data.Array.Accelerate.LLVM.PTX.Array.Data -import Data.Array.Accelerate.LLVM.PTX.Array.Prim -import Data.Array.Accelerate.LLVM.PTX.Context -import Data.Array.Accelerate.LLVM.PTX.Execute.Async -import Data.Array.Accelerate.LLVM.PTX.Target - -import Control.Monad.State -import Data.Typeable - - -instance Foreign PTX where - foreignAcc _ (ff :: asm (a -> b)) - | Just (ForeignAcc _ asm :: ForeignAcc (a -> b)) <- cast ff = Just asm - | otherwise = Nothing - - foreignExp _ (ff :: asm (x -> y)) - | Just (ForeignExp _ asm :: ForeignExp (x -> y)) <- cast ff = Just asm - | otherwise = Nothing - -instance S.Foreign ForeignAcc where - strForeign (ForeignAcc s _) = s - -instance S.Foreign ForeignExp where - strForeign (ForeignExp s _) = s - - --- Foreign functions in the PTX backend. --- -data ForeignAcc f where - ForeignAcc :: String - -> (Stream -> a -> LLVM PTX b) - -> ForeignAcc (a -> b) - --- Foreign expressions in the PTX backend. --- -data ForeignExp f where - ForeignExp :: String - -> IRFun1 PTX () (x -> y) - -> ForeignExp (x -> y) - -deriving instance Typeable ForeignAcc -deriving instance Typeable ForeignExp - diff --git a/Data/Array/Accelerate/LLVM/PTX/Link.hs b/Data/Array/Accelerate/LLVM/PTX/Link.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/PTX/Link.hs +++ /dev/null @@ -1,153 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} --- | --- Module : Data.Array.Accelerate.LLVM.PTX.Link --- Copyright : [2017] Trevor L. McDonell --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -module Data.Array.Accelerate.LLVM.PTX.Link ( - - module Data.Array.Accelerate.LLVM.Link, - ExecutableR(..), FunctionTable(..), Kernel(..), ObjectCode, - withExecutable, - linkFunctionQ, - -) where - -import Data.Array.Accelerate.Lifetime - -import Data.Array.Accelerate.LLVM.Link -import Data.Array.Accelerate.LLVM.State - -import Data.Array.Accelerate.LLVM.PTX.Analysis.Launch -import Data.Array.Accelerate.LLVM.PTX.Compile -import Data.Array.Accelerate.LLVM.PTX.Context -import Data.Array.Accelerate.LLVM.PTX.Link.Cache -import Data.Array.Accelerate.LLVM.PTX.Link.Object -import Data.Array.Accelerate.LLVM.PTX.Target -import qualified Data.Array.Accelerate.LLVM.PTX.Debug as Debug - --- cuda -import qualified Foreign.CUDA.Analysis as CUDA -import qualified Foreign.CUDA.Driver as CUDA - --- standard library -import Control.Monad.State -import Data.ByteString.Short.Char8 ( ShortByteString, unpack ) -import Foreign.Ptr -import Language.Haskell.TH -import Text.Printf ( printf ) -import qualified Data.ByteString.Unsafe as B -import Prelude as P hiding ( lookup ) - - -instance Link PTX where - data ExecutableR PTX = PTXR { ptxExecutable :: {-# UNPACK #-} !(Lifetime FunctionTable) - } - linkForTarget = link - - --- | Load the generated object code into the current CUDA context. --- -link :: ObjectR PTX -> LLVM PTX (ExecutableR PTX) -link (ObjectR uid cfg obj) = do - target <- gets llvmTarget - cache <- gets ptxKernelTable - funs <- liftIO $ dlsym uid cache $ do - -- Load the SASS object code into the current CUDA context - jit <- B.unsafeUseAsCString obj $ \p -> CUDA.loadDataFromPtrEx (castPtr p) [] - let mdl = CUDA.jitModule jit - - -- Extract the kernel functions - nm <- FunctionTable `fmap` mapM (uncurry (linkFunction mdl)) cfg - oc <- newLifetime mdl - - -- Finalise the module by unloading it from the CUDA context - addFinalizer oc $ do - Debug.traceIO Debug.dump_gc ("gc: unload module: " ++ show nm) - withContext (ptxContext target) (CUDA.unload mdl) - - return (nm, oc) - -- - return $! PTXR funs - - --- | Extract the named function from the module and package into a Kernel --- object, which includes meta-information on resource usage. --- --- If we are in debug mode, print statistics on kernel resource usage, etc. --- -linkFunction - :: CUDA.Module -- the compiled module - -> ShortByteString -- __global__ entry function name - -> LaunchConfig -- launch configuration for this global function - -> IO Kernel -linkFunction mdl name configure = - fst `fmap` linkFunctionQ mdl name configure - -linkFunctionQ - :: CUDA.Module - -> ShortByteString - -> LaunchConfig - -> IO (Kernel, Q (TExp (Int -> Int))) -linkFunctionQ mdl name configure = do - f <- CUDA.getFun mdl (unpack name) - regs <- CUDA.requires f CUDA.NumRegs - ssmem <- CUDA.requires f CUDA.SharedSizeBytes - cmem <- CUDA.requires f CUDA.ConstSizeBytes - lmem <- CUDA.requires f CUDA.LocalSizeBytes - maxt <- CUDA.requires f CUDA.MaxKernelThreadsPerBlock - - let - (occ, cta, grid, dsmem, gridQ) = configure maxt regs ssmem - - msg1, msg2 :: String - msg1 = printf "kernel function '%s' used %d registers, %d bytes smem, %d bytes lmem, %d bytes cmem" - (unpack name) regs (ssmem + dsmem) lmem cmem - - msg2 = printf "multiprocessor occupancy %.1f %% : %d threads over %d warps in %d blocks" - (CUDA.occupancy100 occ) - (CUDA.activeThreads occ) - (CUDA.activeWarps occ) - (CUDA.activeThreadBlocks occ) - - Debug.traceIO Debug.dump_cc (printf "cc: %s\n ... %s" msg1 msg2) - return (Kernel name f dsmem cta grid, gridQ) - - --- | Execute some operation with the supplied executable functions --- -withExecutable :: ExecutableR PTX -> (FunctionTable -> LLVM PTX b) -> LLVM PTX b -withExecutable PTXR{..} f = do - r <- f (unsafeGetValue ptxExecutable) - liftIO $ touchLifetime ptxExecutable - return r - - -{-- --- | Extract the names of the function definitions from the module. --- --- Note: [Extracting global function names] --- --- It is important to run this on the module given to us by code generation. --- After combining modules with 'libdevice', extra function definitions, --- corresponding to basic maths operations, will be added to the module. These --- functions will not be callable as __global__ functions. --- --- The list of names will be exported in the order that they appear in the --- module. --- -globalFunctions :: [Definition] -> [String] -globalFunctions defs = - [ n | GlobalDefinition Function{..} <- defs - , not (null basicBlocks) - , let Name n = name - ] ---} - diff --git a/Data/Array/Accelerate/LLVM/PTX/Link/Cache.hs b/Data/Array/Accelerate/LLVM/PTX/Link/Cache.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/PTX/Link/Cache.hs +++ /dev/null @@ -1,22 +0,0 @@ --- | --- Module : Data.Array.Accelerate.LLVM.PTX.Link.Cache --- Copyright : [2017] Trevor L. McDonell --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -module Data.Array.Accelerate.LLVM.PTX.Link.Cache ( - - KernelTable, - LC.new, LC.dlsym, - -) where - -import Data.Array.Accelerate.LLVM.PTX.Link.Object -import qualified Data.Array.Accelerate.LLVM.Link.Cache as LC - -type KernelTable = LC.LinkCache FunctionTable ObjectCode - diff --git a/Data/Array/Accelerate/LLVM/PTX/Link/Object.hs b/Data/Array/Accelerate/LLVM/PTX/Link/Object.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/PTX/Link/Object.hs +++ /dev/null @@ -1,41 +0,0 @@ --- | --- Module : Data.Array.Accelerate.LLVM.PTX.Link.Object --- Copyright : [2017] Trevor L. McDonell --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -module Data.Array.Accelerate.LLVM.PTX.Link.Object - where - -import Data.Array.Accelerate.Lifetime -import Data.ByteString.Short.Char8 ( ShortByteString, unpack ) -import Data.List -import qualified Foreign.CUDA.Driver as CUDA - - --- | The kernel function table is a list of the kernels implemented by a given --- CUDA device module --- -data FunctionTable = FunctionTable { functionTable :: [Kernel] } -data Kernel = Kernel - { kernelName :: {-# UNPACK #-} !ShortByteString - , kernelFun :: {-# UNPACK #-} !CUDA.Fun - , kernelSharedMemBytes :: {-# UNPACK #-} !Int - , kernelThreadBlockSize :: {-# UNPACK #-} !Int - , kernelThreadBlocks :: (Int -> Int) - } - -instance Show FunctionTable where - showsPrec _ f - = showString "<<" - . showString (intercalate "," [ unpack (kernelName k) | k <- functionTable f ]) - . showString ">>" - --- | Object code consists of executable code in the device address space --- -type ObjectCode = Lifetime CUDA.Module - diff --git a/Data/Array/Accelerate/LLVM/PTX/State.hs b/Data/Array/Accelerate/LLVM/PTX/State.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/PTX/State.hs +++ /dev/null @@ -1,111 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell #-} --- | --- Module : Data.Array.Accelerate.LLVM.PTX.State --- Copyright : [2014..2017] Trevor L. McDonell --- [2014..2014] Vinod Grover (NVIDIA Corporation) --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -module Data.Array.Accelerate.LLVM.PTX.State ( - - evalPTX, - createTargetForDevice, createTargetFromContext, defaultTarget - -) where - --- accelerate -import Data.Array.Accelerate.Error - -import Data.Array.Accelerate.LLVM.PTX.Analysis.Device -import Data.Array.Accelerate.LLVM.PTX.Target -import Data.Array.Accelerate.LLVM.State -import qualified Data.Array.Accelerate.LLVM.PTX.Array.Table as MT -import qualified Data.Array.Accelerate.LLVM.PTX.Context as CT -import qualified Data.Array.Accelerate.LLVM.PTX.Debug as Debug -import qualified Data.Array.Accelerate.LLVM.PTX.Execute.Stream as ST -import qualified Data.Array.Accelerate.LLVM.PTX.Link.Cache as LC - -import Data.Range.Range ( Range(..) ) -import Control.Parallel.Meta ( Executable(..) ) - --- standard library -import Control.Concurrent ( runInBoundThread ) -import Control.Exception ( catch ) -import System.IO.Unsafe ( unsafePerformIO ) -import Foreign.CUDA.Driver.Error -import qualified Foreign.CUDA.Driver as CUDA -import qualified Foreign.CUDA.Driver.Context as Context - - --- | Execute a PTX computation --- -evalPTX :: PTX -> LLVM PTX a -> IO a -evalPTX ptx acc = - runInBoundThread (CT.withContext (ptxContext ptx) (evalLLVM ptx acc)) - `catch` - \e -> $internalError "unhandled" (show (e :: CUDAException)) - - --- | Create a new PTX execution target for the given device --- -createTargetForDevice - :: CUDA.Device - -> CUDA.DeviceProperties - -> [CUDA.ContextFlag] - -> IO PTX -createTargetForDevice dev prp flags = do - ctx <- CT.new dev prp flags - mt <- MT.new ctx - lc <- LC.new - st <- ST.new ctx - return $! PTX ctx mt lc st simpleIO - - --- | Create a PTX execute target for the given device context --- -createTargetFromContext - :: CUDA.Context - -> IO PTX -createTargetFromContext ctx' = do - dev <- Context.device - prp <- CUDA.props dev - ctx <- CT.raw dev prp ctx' - mt <- MT.new ctx - lc <- LC.new - st <- ST.new ctx - return $! PTX ctx mt lc st simpleIO - - -{-# INLINE simpleIO #-} -simpleIO :: Executable -simpleIO = Executable $ \_name _ppt range action -> - case range of - Empty -> return () - IE u v -> action u v 0 - - --- Top-level mutable state --- ----------------------- --- --- It is important to keep some information alive for the entire run of the --- program, not just a single execution. These tokens use 'unsafePerformIO' to --- ensure they are executed only once, and reused for subsequent invocations. --- - --- | Select and initialise the default CUDA device, and create a new target --- context. The device is selected based on compute capability and estimated --- maximum throughput. --- -{-# NOINLINE defaultTarget #-} -defaultTarget :: PTX -defaultTarget = unsafePerformIO $ do - Debug.traceIO Debug.dump_gc "gc: initialise default PTX target" - CUDA.initialise [] - (dev,prp) <- selectBestDevice - createTargetForDevice dev prp [CUDA.SchedAuto] - diff --git a/Data/Array/Accelerate/LLVM/PTX/Target.hs b/Data/Array/Accelerate/LLVM/PTX/Target.hs deleted file mode 100644 --- a/Data/Array/Accelerate/LLVM/PTX/Target.hs +++ /dev/null @@ -1,182 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} --- | --- Module : Data.Array.Accelerate.LLVM.PTX.Target --- Copyright : [2014..2017] Trevor L. McDonell --- [2014..2014] Vinod Grover (NVIDIA Corporation) --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -module Data.Array.Accelerate.LLVM.PTX.Target ( - - module Data.Array.Accelerate.LLVM.Target, - module Data.Array.Accelerate.LLVM.PTX.Target, - -) where - --- llvm-general -import LLVM.AST.AddrSpace -import LLVM.AST.DataLayout -import LLVM.Target hiding ( Target ) -import qualified LLVM.Target as LLVM -import qualified LLVM.Relocation as R -import qualified LLVM.CodeModel as CM -import qualified LLVM.CodeGenOpt as CGO - --- accelerate -import Data.Array.Accelerate.Error - -import Data.Array.Accelerate.LLVM.Target -import Data.Array.Accelerate.LLVM.Util - -import Control.Parallel.Meta ( Executable ) -import Data.Array.Accelerate.LLVM.PTX.Array.Table ( MemoryTable ) -import Data.Array.Accelerate.LLVM.PTX.Context ( Context, deviceProperties ) -import Data.Array.Accelerate.LLVM.PTX.Execute.Stream.Reservoir ( Reservoir ) -import Data.Array.Accelerate.LLVM.PTX.Link.Cache ( KernelTable ) - --- CUDA -import qualified Foreign.CUDA.Driver as CUDA - --- standard library -import Data.ByteString ( ByteString ) -import Data.ByteString.Short ( ShortByteString ) -import Data.String -import System.IO.Unsafe -import Text.Printf -import qualified Data.Map as Map -import qualified Data.Set as Set - - --- | The PTX execution target for NVIDIA GPUs. --- --- The execution target carries state specific for the current execution --- context. The data here --- device memory and execution streams --- are --- implicitly tied to this CUDA execution context. --- --- Don't store anything here that is independent of the context, for example --- state related to [persistent] kernel caching should _not_ go here. --- -data PTX = PTX { - ptxContext :: {-# UNPACK #-} !Context - , ptxMemoryTable :: {-# UNPACK #-} !MemoryTable - , ptxKernelTable :: {-# UNPACK #-} !KernelTable - , ptxStreamReservoir :: {-# UNPACK #-} !Reservoir - , fillP :: {-# UNPACK #-} !Executable - } - -instance Target PTX where - targetTriple _ = Just ptxTargetTriple -#if ACCELERATE_USE_NVVM - targetDataLayout _ = Nothing -- see note: [NVVM and target data layout] -#else - targetDataLayout _ = Just ptxDataLayout -#endif - - --- | Extract the properties of the device the current PTX execution state is --- executing on. --- -ptxDeviceProperties :: PTX -> CUDA.DeviceProperties -ptxDeviceProperties = deviceProperties . ptxContext - - --- | A description of the various data layout properties that may be used during --- optimisation. For CUDA the following data layouts are supported: --- --- 32-bit: --- e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v16:16:16-v32:32:32-v64:64:64-v128:128:128-n16:32:64 --- --- 64-bit: --- e-p:64:64:64-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v16:16:16-v32:32:32-v64:64:64-v128:128:128-n16:32:64 --- --- Thus, only the size of the pointer layout changes depending on the host --- architecture. --- -ptxDataLayout :: DataLayout -ptxDataLayout = DataLayout - { endianness = LittleEndian - , mangling = Nothing - , aggregateLayout = AlignmentInfo 0 64 - , stackAlignment = Nothing - , pointerLayouts = Map.fromList - [ (AddrSpace 0, (wordSize, AlignmentInfo wordSize wordSize)) ] - , typeLayouts = Map.fromList $ - [ ((IntegerAlign, 1), AlignmentInfo 8 8) ] ++ - [ ((IntegerAlign, i), AlignmentInfo i i) | i <- [8,16,32,64]] ++ - [ ((VectorAlign, v), AlignmentInfo v v) | v <- [16,32,64,128]] ++ - [ ((FloatAlign, f), AlignmentInfo f f) | f <- [32,64] ] - , nativeSizes = Just $ Set.fromList [ 16,32,64 ] - } - where - wordSize = bitSize (undefined :: Int) - - --- | String that describes the target host. --- -ptxTargetTriple :: ShortByteString -ptxTargetTriple = - case bitSize (undefined::Int) of - 32 -> "nvptx-nvidia-cuda" - 64 -> "nvptx64-nvidia-cuda" - _ -> $internalError "ptxTargetTriple" "I don't know what architecture I am" - - --- | Bracket creation and destruction of the NVVM TargetMachine. --- -withPTXTargetMachine - :: CUDA.DeviceProperties - -> (TargetMachine -> IO a) - -> IO a -withPTXTargetMachine dev go = - let CUDA.Compute m n = CUDA.computeCapability dev - isa = CPUFeature (ptxISAVersion m n) - sm = fromString (printf "sm_%d%d" m n) - in - withTargetOptions $ \options -> do - withTargetMachine - ptxTarget - ptxTargetTriple - sm - (Map.singleton isa True) -- CPU features - options -- target options - R.Default -- relocation model - CM.Default -- code model - CGO.Default -- optimisation level - go - --- Some libdevice functions require at least ptx40, even though devices at --- that compute capability also accept older ISA versions. --- --- https://github.com/llvm-mirror/llvm/blob/master/lib/Target/NVPTX/NVPTX.td#L72 --- -ptxISAVersion :: Int -> Int -> ByteString -ptxISAVersion 2 _ = "ptx40" -ptxISAVersion 3 7 = "ptx41" -ptxISAVersion 3 _ = "ptx40" -ptxISAVersion 5 0 = "ptx40" -ptxISAVersion 5 2 = "ptx41" -ptxISAVersion 5 3 = "ptx42" -ptxISAVersion 6 _ = "ptx50" -ptxISAVersion 7 _ = "ptx60" -ptxISAVersion _ _ = "ptx40" - - --- | The NVPTX target for this host. --- --- The top-level 'unsafePerformIO' is so that 'initializeAllTargets' is run once --- per program execution (although that might not be necessary?) --- -{-# NOINLINE ptxTarget #-} -ptxTarget :: LLVM.Target -ptxTarget = unsafePerformIO $ do - initializeAllTargets - fst `fmap` lookupTarget Nothing ptxTargetTriple - diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) [2014..2017] The Accelerate Team. All rights reserved. +Copyright (c) [2014..2020] The Accelerate Team. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,14 +1,18 @@ -An LLVM backend for the Accelerate Array Language -================================================= +
+henlo, my name is Theia -[![Build Status](https://travis-ci.org/AccelerateHS/accelerate-llvm.svg)](https://travis-ci.org/AccelerateHS/accelerate-llvm) +# LLVM backends for the Accelerate array language + +[![CI](https://github.com/AccelerateHS/accelerate-llvm/actions/workflows/ci.yml/badge.svg)](https://github.com/AccelerateHS/accelerate-llvm/actions/workflows/ci.yml) +[![Gitter](https://img.shields.io/gitter/room/nwjs/nw.js.svg)](https://gitter.im/AccelerateHS/Lobby) [![Hackage](https://img.shields.io/hackage/v/accelerate-llvm.svg)](https://hackage.haskell.org/package/accelerate-llvm) -[![Docker Automated build](https://img.shields.io/docker/automated/tmcdonell/accelerate-llvm.svg)](https://hub.docker.com/r/tmcdonell/accelerate-llvm/) -[![Docker status](https://images.microbadger.com/badges/image/tmcdonell/accelerate-llvm.svg)](https://microbadger.com/images/tmcdonell/accelerate-llvm) +
+ This package compiles Accelerate code to LLVM IR, and executes that code on -multicore CPUs as well as NVIDIA GPUs. This avoids the need to go through `nvcc` -or `clang`. For details on Accelerate, refer to the [main repository][GitHub]. +multicore CPUs as well as NVIDIA GPUs. This avoids the need to go through +`nvcc` or write C++ code. For details on Accelerate, refer to the [main +repository][GitHub]. We love all kinds of contributions, so feel free to open issues for missing features as well as report (or fix!) bugs on the [issue tracker][Issues]. @@ -18,171 +22,143 @@ * [Dependencies](#dependencies) - * [Docker](#docker) - * [Installing LLVM](#installing-llvm) - * [Homebrew](#homebrew) + * [macOS](#macos) * [Debian/Ubuntu](#debianubuntu) - * [Building from source](#building-from-source) - * [Installing Accelerate-LLVM](#installing-accelerate-llvm) - * [libNVVM](#libNVVM) + * [Arch Linux](#archlinux) + * [Windows](#windows) Dependencies ------------ -Haskell dependencies are available from Hackage, but there are several external +Haskell dependencies are available from Hackage, but there are some external library dependencies that you will need to install as well: - * [`LLVM`](http://llvm.org) - * [`libFFI`](http://sourceware.org/libffi/) (if using the `accelerate-llvm-native` backend for multicore CPUs) - * [`CUDA`](https://developer.nvidia.com/cuda-downloads) (if using the `accelerate-llvm-ptx` backend for NVIDIA GPUs) - - -Docker ------- - -A [docker](https://www.docker.com) container is provided with this package -preinstalled (via stack) at `/opt/accelerate-llvm`. Note that if you wish to use -the `accelerate-llvm-ptx` GPU backend, you will need to install the [NVIDIA -docker](https://github.com/NVIDIA/nvidia-docker) plugin; see that page for more -information. - -```sh -$ docker run -it tmcdonell/accelerate-llvm -``` - - -Installing LLVM ---------------- - -When installing LLVM, make sure that it includes the `libLLVM` shared library. -If you want to use the GPU targeting `accelerate-llvm-ptx` backend, make sure -you install (or build) LLVM with the 'nvptx' target. +- if using `accelerate-llvm-native` for multicore CPU: + [`libFFI`](http://sourceware.org/libffi/) +- if using `accelerate-llvm-ptx` for GPU: + [`CUDA`](https://developer.nvidia.com/cuda-downloads); + [Note that not all versions of CUDA support all NVIDIA GPUs](https://en.wikipedia.org/wiki/CUDA#GPUs_supported) +- [`clang`](https://clang.llvm.org/) (if using `accelerate-llvm-ptx`: version + 16 or higher, built with support for the `nvptx` backend). `accelerate-llvm` + uses the command-line tool as a way to be compatible with many different LLVM + versions, not to compile C code. (Accelerate passes LLVM IR to `clang`.) -## Homebrew +Below are some OS-specific instructions. If anything here is wrong or out of +date, please file an issue. -Example using [Homebrew](http://brew.sh) on macOS: +## macOS -```sh -$ brew install llvm-hs/homebrew-llvm/llvm-4.0 -``` +To get `libFFI`, run `brew install libffi`. `clang` is already provided with +macOS (you may need to `xcode-select --install`), and CUDA is not supported on +macOS. ## Debian/Ubuntu -For Debian/Ubuntu based Linux distributions, the LLVM.org website provides -binary distribution packages. Check [apt.llvm.org](http://apt.llvm.org) for -instructions for adding the correct package database for your OS version, and -then: - -```sh -$ apt-get install llvm-4.0-dev -``` - -## Building from source - -If your OS does not have an appropriate LLVM distribution available, you can also build from source. Detailed build instructions are available on the [LLVM.org website](http://releases.llvm.org/4.0.0/docs/CMake.html). Note that you will require at least [CMake 3.4.3](http://www.cmake.org/cmake/resources/software.html) and a recent C++ compiler; at least Clang 3.1, GCC 4.8, or Visual Studio 2015 (update 3). - - 1. Download and unpack the [LLVM-4.0 source code](http://releases.llvm.org/4.0.0/llvm-4.0.0.src.tar.xz). We'll refer to - the path that the source tree was unpacked to as `LLVM_SRC`. Only the main - LLVM source tree is required, but you can optionally add other components - such as the Clang compiler or Polly loop optimiser. See the [LLVM releases](http://releases.llvm.org/download.html#4.0.0) - page for the complete list. - - 2. Create a temporary build directory and `cd` into it, for example: - ```sh - $ mkdir /tmp/build - $ cd /tmp/build - ``` - - 3. Execute the following to configure the build. Here `INSTALL_PREFIX` is - where LLVM is to be installed, for example `/usr/local` or - `$HOME/opt/llvm`: - ```sh - $ cmake $LLVM_SRC -DCMAKE_INSTALL_PREFIX=$INSTALL_PREFIX -DCMAKE_BUILD_TYPE=Release -DLLVM_ENABLE_ASSERTIONS=ON -DLLVM_BUILD_LLVM_DYLIB=ON -DLLVM_LINK_LLVM_DYLIB=ON - ``` - See [options and variables](http://llvm.org/docs/CMake.html#options-and-variables) - for a list of additional build parameters you can specify. - - 4. Build and install: - ```sh - $ cmake --build . - $ cmake --build . --target install - ``` - - 5. For macOS only, some additional steps are useful to work around issues related - to [System Integrity Protection](https://en.wikipedia.org/wiki/System_Integrity_Protection): - ```sh - cd $INSTALL_PREFIX/lib - ln -s libLLVM.dylib libLLVM-4.0.dylib - install_name_tool -id $PWD/libLTO.dylib libLTO.dylib - install_name_tool -id $PWD/libLLVM.dylib libLLVM.dylib - install_name_tool -change '@rpath/libLLVM.dylib' $PWD/libLLVM.dylib libLTO.dylib - ``` +For `clang`: +- On Ubuntu 24.04 (noble) / Debian trixie or higher: `sudo apt install clang`. +- Otherwise, if you need only the CPU backend (`accelerate-llvm-native`): + `sudo apt install clang` will give you an old version of `clang`, but the CPU + backend is likely to work fine. +- If you are on an older distro and need the GPU backend + (`accelerate-llvm-ptx`): `clang` version 16 or higher is required. + Add the apt source from [apt.llvm.org](https://apt.llvm.org/). The neatest + way to do this is to create a file `/etc/apt/sources.list.d/llvm.list` (the + precise file name does not matter) and put in it, for Ubuntu (change "jammy" + as appropriate): + deb http://apt.llvm.org/jammy/ llvm-toolchain-jammy main + deb-src http://apt.llvm.org/jammy/ llvm-toolchain-jammy main -Installing Accelerate-LLVM --------------------------- + or for Debian (change "bookworm" as appropriate): -Once the dependencies are installed, we are ready to install `accelerate-llvm`. + deb http://apt.llvm.org/bookworm/ llvm-toolchain-bookworm main + deb-src http://apt.llvm.org/bookworm/ llvm-toolchain-bookworm main -For example, installation using [`stack`](http://docs.haskellstack.org/en/stable/README.html) -just requires you to point it to the appropriate configuration file: -```sh -$ ln -s stack-8.0.yaml stack.yaml -$ stack setup -$ stack install -``` + and `sudo apt update; sudo apt install clang`. This gets you the latest + version of `clang`; different sources are also available for specific + versions (see [apt.llvm.org](https://apt.llvm.org)). -Note that the version of [`llvm-hs`](https://hackage.haskell.org/package/llvm-hs) -used must match the installed version of LLVM, which is currently 4.0. +To use the CPU backend (`accelerate-llvm-native`), install `libFFI` using +`sudo apt install libffi-dev`. +To use the GPU backend (`accelerate-llvm-ptx`), install CUDA from +[here](https://developer.nvidia.com/cuda-downloads?target_os=Linux) +("deb (network)" is smoother than the "deb (local)" option). -## libNVVM +## Arch Linux -The `accelerate-llvm-ptx` backend can optionally be compiled to generate GPU -code using the `libNVVM` library, rather than LLVM's inbuilt NVPTX code -generator. `libNVVM` is a closed-source library distributed as part of the -NVIDIA CUDA toolkit, and is what the `nvcc` compiler itself uses internally when -compiling CUDA C code. +Run `sudo pacman -S clang`. To use the CPU backend (`accelerate-llvm-native`), +additionally run `sudo pacman -S libffi`. To use the GPU backend +(`accelerate-llvm-ptx`), additionally run `sudo pacman -S cuda`. -Using `libNVVM` _may_ improve GPU performance compared to the code generator -built in to LLVM. One difficulty with using it however is that since `libNVVM` -is also based on LLVM, and typically lags LLVM by several releases, you must -install `accelerate-llvm` with a "compatible" version of LLVM, which will depend -on the version of the CUDA toolkit you have installed. The following table shows -some combinations: +## Windows -| | LLVM-3.3 | LLVM-3.4 | LLVM-3.5 | LLVM-3.8 | LLVM-3.9 | LLVM-4.0 | -|:------------:|:--------:|:--------:|:--------:|:--------:|:--------:|:--------:| -| **CUDA-7.0** | ⭕ | ❌ | | | | | -| **CUDA-7.5** | | ⭕ | ⭕ | ❌ | | | -| **CUDA-8.0** | | | ⭕ | ⭕ | ❌ | ❌ | +We recommend WSL2 (not WSL1, WSL2!) and following the Ubuntu instructions +above. The remainder of this text attemps to give you a working system on +Windows native. -Where ⭕ = Works, and ❌ = Does not work. +Install `clang`; you have two options: +1. Using + [WinGet](https://learn.microsoft.com/en-us/windows/package-manager/winget/): + `winget install LLVM.LLVM` +2. By downloading the installer directly (WinGet just runs the same installer) + from [here](https://github.com/llvm/llvm-project/releases) (choose + "LLVM-<version>-win64.exe" from the latest release; you may need to click + "Show all 57 assets"). +This will also give you `libFFI`. -Note that the above restrictions on CUDA and LLVM version exist _only_ if you -want to use the NVVM component. Otherwise, you should be free to use any -combination of CUDA and LLVM. +
Optionally, add clang (and more) to your system path. Click to see how. -Also note that `accelerate-llvm-ptx` itself currently requires at least LLVM-3.5. +Accelerate should be able to find `clang` automatically even if you do not do +this. However, for easy access to `clang` and all other LLVM executables, add +`C:\Program Files\LLVM\bin` to the system path as follows: +1. Search for "environment variables" in the start menu +2. Click "Edit the system environment variables" +3. Click on "Environment Variables..." +4. Double-click on the user variable called "Path" +5. And add a new entry containing `C:\Program Files\LLVM\bin`. -Using `stack`, either edit the `stack.yaml` and add the following section: +Note that if you add an entry here manually, it is a good idea to clean it up +again if you uninstall LLVM/clang. (Leaving it there is not very harmful, +however.) -```yaml -flags: - accelerate-llvm-ptx: - nvvm: true -``` +You may find that the LLVM/clang installer has already added the Path entry +automatically (it did not for us); if so, no need to add a second entry. -Or install using the following option on the command line: +—— +
-```sh -$ stack install accelerate-llvm-ptx --flag accelerate-llvm-ptx:nvvm -``` +You may additionally need the VS Build Tools, if you have not yet installed and +set up Visual Studio otherwise. You need this if `clang` complains that it is +`unable to find a Visual Studio installation; try running Clang from a developer command prompt`. -If installing via `cabal`: +1. If you already have the Visual Studio Installer on your system, open it and + check if you already have Visual Studio (Community) installed. Note that + this is completely unrelated to VS _Code_. + - If you already have VS (Community): inside the Visual Studio Installer, + click on "Modify" in the VS (Community) box. This should get you a screen + with "workloads" you can select. + - If you do not yet have VS (Community), install the VS Build Tools: go to + https://visualstudio.microsoft.com/downloads, scroll down to "All + Downloads", open "Tools for Visual Studio", and select "Build Tools for + Visual Studio". If you run the installer, you should get a screen with + "workloads" you can select. +2. Under the Workloads tab, choose the "Desktop development with C++" workload. + If you want to save a bit of disk space (not much), keep only the following + two options selected: + - "MSVC v143 - VE 2022 C++ x64/x86 build tools (Latest)" + - "Windows 11 SDK (…)" (choose the latest option). The attentive reader may + note that the wizard also offers Clang; we recommend a separate Clang + install for Accelerate because the one from VS somehow doesn’t seem to + work properly with Accelerate. If you find out why, please let us know. +3. Install that. This takes a while. -```sh -$ cabal install accelerate-llvm-ptx -fnvvm -``` +It turns out that having both Visual Studio and the Build Tools installed +results in Clang getting confused between the two (it appears that Visual +Studio is 64-bit (x64) and the Build Tools are 32-bit (x86)). If Clang +complains about the bit-ness of your system libraries, double-check that you +haven’t installed both simultaneously. +The GPU backend (`accelerate-llvm-ptx`) probably doesn't work on Windows; in +any case, it is untested. diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/accelerate-llvm-ptx.cabal b/accelerate-llvm-ptx.cabal --- a/accelerate-llvm-ptx.cabal +++ b/accelerate-llvm-ptx.cabal @@ -1,108 +1,39 @@ +cabal-version: 2.2 + name: accelerate-llvm-ptx -version: 1.1.0.1 -cabal-version: >= 1.10 -tested-with: GHC >= 7.10 +version: 1.4.0.0 +tested-with: GHC >= 9.4 build-type: Simple synopsis: Accelerate backend for NVIDIA GPUs description: This library implements a backend for the /Accelerate/ language which - generates LLVM-IR targeting CUDA capable GPUs. For further information, + generates LLVM IR targeting CUDA capable GPUs. For further information, refer to the main package. . [/Dependencies/] . Haskell dependencies are available from Hackage. The following external - libraries are alse required: - . - * - . - * - . - [/Installing LLVM/] - . - /Homebrew/ - . - Example using Homebrew on macOS: - . - > brew install llvm-hs/homebrew-llvm/llvm-5.0 - . - /Debian & Ubuntu/ - . - For Debian/Ubuntu based Linux distributions, the LLVM.org website provides - binary distribution packages. Check for - instructions for adding the correct package database for your OS version, - and then: - . - > apt-get install llvm-5.0-dev - . - /Building from source/ - . - If your OS does not have an appropriate LLVM distribution available, you can - also build from source. Detailed build instructions are available on - . Make sure to - include the cmake build options - @-DLLVM_BUILD_LLVM_DYLIB=ON -DLLVM_LINK_LLVM_DYLIB=ON@ so that the @libLLVM@ - shared library will be built. Also ensure that the @LLVM_TARGETS_TO_BUILD@ - option includes the @NVPTX@ target (if not specified all targets are built). - . - [/Installing accelerate-llvm/] - . - To use @accelerate-llvm@ it is important that the @llvm-hs@ package is - installed against the @libLLVM@ shared library, rather than statically - linked, so that we can use LLVM from GHCi and Template Haskell. This is the - default configuration, but you can also enforce this explicitly by adding - the following to your @stack.yaml@ file: - . - > flags: - > llvm-hs: - > shared-llvm: true - . - Or by specifying the @shared-llvm@ flag to cabal: + dependencies are also required: . - > cabal install llvm-hs -fshared-llvm + * (not used to compile C code, but to compile generated LLVM IR via a mostly LLVM-version-independent interface) + * . + For installation instructions, see the . -license: BSD3 +license: BSD-3-Clause license-file: LICENSE author: Trevor L. McDonell -maintainer: Trevor L. McDonell +maintainer: Trevor L. McDonell bug-reports: https://github.com/AccelerateHS/accelerate/issues -category: Compilers/Interpreters, Concurrency, Data, Parallelism +category: Accelerate, Compilers/Interpreters, Concurrency, Data, Parallelism -extra-source-files: +extra-doc-files: CHANGELOG.md README.md --- Configuration flags --- ------------------- - -Flag nvvm - Default: False - Description: Use the NVVM library to generate optimised PTX - -Flag debug - Default: False - Description: - Enable debug tracing message flags. Note that 'debug' must be enabled in the - base 'accelerate' package as well. See the 'accelerate' package for usage - and available options. - -Flag bounds-checks - Default: True - Description: Enable bounds checking - -Flag unsafe-checks - Default: False - Description: Enable bounds checking in unsafe operations - -Flag internal-checks - Default: False - Description: Enable internal consistency checks - - -- Build configuration -- ------------------- @@ -120,11 +51,15 @@ Data.Array.Accelerate.LLVM.PTX.Array.Table Data.Array.Accelerate.LLVM.PTX.Context Data.Array.Accelerate.LLVM.PTX.Debug + Data.Array.Accelerate.LLVM.PTX.Pool Data.Array.Accelerate.LLVM.PTX.State Data.Array.Accelerate.LLVM.PTX.Target Data.Array.Accelerate.LLVM.PTX.Execute Data.Array.Accelerate.LLVM.PTX.Execute.Async + Data.Array.Accelerate.LLVM.PTX.Execute.Environment + Data.Array.Accelerate.LLVM.PTX.Execute.Event + Data.Array.Accelerate.LLVM.PTX.Execute.Marshal Data.Array.Accelerate.LLVM.PTX.Execute.Stream Data.Array.Accelerate.LLVM.PTX.Execute.Stream.Reservoir @@ -137,14 +72,13 @@ Data.Array.Accelerate.LLVM.PTX.CodeGen.Loop Data.Array.Accelerate.LLVM.PTX.CodeGen.Map Data.Array.Accelerate.LLVM.PTX.CodeGen.Permute - Data.Array.Accelerate.LLVM.PTX.CodeGen.Queue Data.Array.Accelerate.LLVM.PTX.CodeGen.Scan + Data.Array.Accelerate.LLVM.PTX.CodeGen.Stencil + Data.Array.Accelerate.LLVM.PTX.CodeGen.Transform Data.Array.Accelerate.LLVM.PTX.Compile Data.Array.Accelerate.LLVM.PTX.Compile.Cache - Data.Array.Accelerate.LLVM.PTX.Compile.Libdevice Data.Array.Accelerate.LLVM.PTX.Compile.Libdevice.Load - Data.Array.Accelerate.LLVM.PTX.Compile.Libdevice.TH Data.Array.Accelerate.LLVM.PTX.Link Data.Array.Accelerate.LLVM.PTX.Link.Cache @@ -152,67 +86,93 @@ Data.Array.Accelerate.LLVM.PTX.Embed - Data.Array.Accelerate.LLVM.PTX.Execute.Environment - Data.Array.Accelerate.LLVM.PTX.Execute.Event - Data.Array.Accelerate.LLVM.PTX.Execute.Marshal + System.Process.Extra + GHC.Heap.NormalForm Paths_accelerate_llvm_ptx + autogen-modules: + Paths_accelerate_llvm_ptx + build-depends: - base >= 4.7 && < 4.11 - , accelerate == 1.1.* - , accelerate-llvm == 1.1.* + base >= 4.10 && < 5 + , accelerate == 1.4.* + , accelerate-llvm == 1.4.* , bytestring >= 0.10.4 - , containers >= 0.5 && <0.6 - , cuda >= 0.9 + , containers >= 0.5 && < 0.9 + , cuda >= 0.10 , deepseq >= 1.3 , directory >= 1.0 , dlist >= 0.6 - , fclabels >= 2.0 , file-embed >= 0.0.8 , filepath >= 1.0 + , formatting >= 7.0 , hashable >= 1.2 - , llvm-hs >= 4.1 && < 5.2 - , llvm-hs-pure >= 4.1 && < 5.2 + -- , llvm-pretty >= 0.12 , mtl >= 2.2.1 - , nvvm >= 0.7.5 - , pretty >= 1.1 + -- only used to render llvm-pretty output + , pretty + , prettyprinter >= 1.7 + , primitive >= 0.7 , process >= 1.4.3 , template-haskell - , time >= 1.4 + , text >= 1.2 , unordered-containers >= 0.2 - default-language: - Haskell2010 + if impl(ghc >= 8.6) + build-depends: + ghc-heap + else + build-depends: + ghc + , ghci - ghc-options: -O2 -Wall -fwarn-tabs + hs-source-dirs: + src - if impl(ghc >= 8.0) - ghc-options: -Wmissed-specialisations + default-language: + Haskell2010 - if flag(nvvm) - cpp-options: -DACCELERATE_USE_NVVM + ghc-options: + -O2 + -Wall + -fwarn-tabs - if flag(debug) - cpp-options: -DACCELERATE_DEBUG - if flag(bounds-checks) - cpp-options: -DACCELERATE_BOUNDS_CHECKS +test-suite nofib-llvm-ptx + type: exitcode-stdio-1.0 + hs-source-dirs: test/nofib + main-is: Main.hs + other-modules: + Data.Array.Accelerate.LLVM.PTX.NoFib.RunQ - if flag(unsafe-checks) - cpp-options: -DACCELERATE_UNSAFE_CHECKS + build-depends: + base >= 4.10 + , accelerate + , accelerate-llvm-ptx + , tasty + , tasty-hunit - if flag(internal-checks) - cpp-options: -DACCELERATE_INTERNAL_CHECKS + default-language: + Haskell2010 + ghc-options: + -Wall + -O2 + -threaded + -rtsopts + -with-rtsopts=-A128M + -with-rtsopts=-n4M + -- -with-rtsopts=-N + source-repository head type: git location: https://github.com/AccelerateHS/accelerate-llvm.git source-repository this type: git - tag: 1.1.0.1-ptx + tag: v1.4.0.0 location: https://github.com/AccelerateHS/accelerate-llvm.git -- vim: nospell diff --git a/src/Data/Array/Accelerate/LLVM/PTX.hs b/src/Data/Array/Accelerate/LLVM/PTX.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/PTX.hs @@ -0,0 +1,561 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.PTX +-- Copyright : [2014..2020] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- +-- This module implements a backend for the /Accelerate/ language targeting +-- NVPTX for execution on NVIDIA GPUs. Expressions are on-line translated into +-- LLVM code, which is just-in-time executed in parallel on the GPU. +-- +-- * Concurrent kernel execution +-- +-- Accelerate enables copies to and from device memory to occur concurrently +-- with kernel execution. However, in order for kernels to be executed +-- concurrently, you must create your own 'PTX' execution target and pass it to +-- the 'runWith'-style functions. For example: +-- +-- > import Data.Array.Accelerate as A +-- > import qualified Data.Array.Accelerate.LLVM.PTX as PTX +-- > import qualified Foreign.CUDA.Driver as C +-- > +-- > dotp :: Acc (Vector Float) -> Acc (Vector Float) -> Acc (Scalar Float) +-- > dotp xs ys = A.fold (+) 0 (A.zipWith (*) xs ys) +-- > +-- > runDotP = do +-- > C.initialise [] +-- > -- Assuming just one CUDA device +-- > dev0 <- C.device 0 +-- > dev0Props <- C.props dev0 +-- > ptx <- PTX.createTargetForDevice dev0 dev0Props [] +-- > -- Using runAsyncWith +-- > let xs = fromList (Z:.10) [0..] :: Vector Float +-- > ys = fromList (Z:.10) [1,3..] :: Vector Float +-- > asyncDotP <- PTX.runAsyncWith ptx (dotp (use +-- > ... +-- > dotP <- PTX.wait asyncDotP +-- +-- The CUDA scheduler will only execute kernels concurrently if there are +-- sufficient resources available. Concurrency is limited by the number of +-- available threads, blocks, warps and registers; a kernel occupancy of \(n\) +-- does not always imply that \(1-n\) device resources are available. + +module Data.Array.Accelerate.LLVM.PTX ( + + Acc, Arrays, + Afunction, AfunctionR, + + -- * Synchronous execution + run, runWith, + run1, run1With, + runN, runNWith, + stream, streamWith, + + -- * Asynchronous execution + Async, + wait, poll, cancel, + + runAsync, runAsyncWith, + run1Async, run1AsyncWith, + runNAsync, runNAsyncWith, + + -- * Ahead-of-time compilation + runQ, runQWith, + runQAsync, runQAsyncWith, + + -- * Execution targets + PTX, createTargetForDevice, createTargetFromContext, + + -- * Controlling host-side allocation + registerPinnedAllocatorWith, + +) where + +import Data.Array.Accelerate.AST ( PreOpenAfun(..), arraysR, liftALeftHandSide ) +import Data.Array.Accelerate.AST.LeftHandSide ( lhsToTupR ) +import Data.Array.Accelerate.Array.Data +import Data.Array.Accelerate.Async ( Async, asyncBound, wait, poll, cancel ) +import Data.Array.Accelerate.Error +import Data.Array.Accelerate.Representation.Array ( liftArraysR ) +import Data.Array.Accelerate.Smart ( Acc ) +import Data.Array.Accelerate.Sugar.Array ( Arrays, toArr, fromArr, ArraysR ) +import Data.Array.Accelerate.Trafo +import Data.Array.Accelerate.Trafo.Delayed +import Data.Array.Accelerate.Trafo.Sharing ( Afunction(..), AfunctionRepr(..), afunctionRepr ) +import qualified Data.Array.Accelerate.Sugar.Array as Sugar + +import Data.Array.Accelerate.LLVM.PTX.Array.Data +import Data.Array.Accelerate.LLVM.PTX.Compile +import Data.Array.Accelerate.LLVM.PTX.Context +import Data.Array.Accelerate.LLVM.PTX.Debug +import Data.Array.Accelerate.LLVM.PTX.Embed +import Data.Array.Accelerate.LLVM.PTX.Execute +import Data.Array.Accelerate.LLVM.PTX.Execute.Async ( Par, evalPar, getArrays ) +import Data.Array.Accelerate.LLVM.PTX.Execute.Environment +import Data.Array.Accelerate.LLVM.PTX.Link +import Data.Array.Accelerate.LLVM.PTX.State +import Data.Array.Accelerate.LLVM.PTX.Target + +import Foreign.CUDA.Driver as CUDA ( CUDAException, mallocHostForeignPtr ) + +import Control.Exception +import Control.Monad.Trans +import Data.Maybe +import Formatting ( shown ) +import System.IO.Unsafe +import qualified Data.Array.Accelerate.TH.Compat as TH + + +-- Accelerate: LLVM backend for NVIDIA GPUs +-- ---------------------------------------- + +-- | Compile and run a complete embedded array program. +-- +-- This will execute using the first available CUDA device. If you wish to run +-- on a specific device, use 'runWith'. +-- +-- The result is copied back to the host only once the arrays are demanded (or +-- the result is forced to normal form). For results consisting of multiple +-- components (a tuple of arrays or array of tuples) this applies per primitive +-- array. Evaluating the result of 'run' to WHNF will initiate the computation, +-- but does not copy the results back from the device. +-- +-- /NOTE:/ it is recommended to use 'runN' or 'runQ' whenever possible. +-- +run :: Arrays a => Acc a -> a +run a = unsafePerformIO (runIO a) + +-- | As 'run', but execute using the specified target rather than using the +-- default, automatically selected device. +-- +runWith :: Arrays a => PTX -> Acc a -> a +runWith target a = unsafePerformIO (runWithIO target a) + +-- | As 'run', but run the computation asynchronously and return immediately +-- without waiting for the result. The status of the computation can be queried +-- using 'wait', 'poll', and 'cancel'. +-- +-- This will run on the first available CUDA device. If you wish to run on +-- a specific device, use 'runAsyncWith'. +-- +runAsync :: Arrays a => Acc a -> IO (Async a) +runAsync a = asyncBound (runIO a) + +-- | As 'runWith', but execute asynchronously. Be sure not to destroy the context, +-- or attempt to attach it to a different host thread, before all outstanding +-- operations have completed. +-- +runAsyncWith :: Arrays a => PTX -> Acc a -> IO (Async a) +runAsyncWith target a = asyncBound (runWithIO target a) + + +runIO :: Arrays a => Acc a -> IO a +runIO a = withPool defaultTargetPool (\target -> runWithIO target a) + +runWithIO :: forall a. Arrays a => PTX -> Acc a -> IO a +runWithIO target a = execute + where + !acc = convertAcc a + execute = do + dumpGraph acc + evalPTX target $ do + build <- phase Compile (compileAcc acc) >>= dumpStats + exec <- phase Link (linkAcc build) + res <- phase Execute (evalPar (executeAcc exec >>= copyToHostLazy (Sugar.arraysR @a))) + return $ toArr res + + +-- | This is 'runN', specialised to an array program of one argument. +-- +run1 :: (Arrays a, Arrays b) => (Acc a -> Acc b) -> a -> b +run1 = runN + +-- | As 'run1', but execute using the specified target rather than using the +-- default, automatically selected device. +-- +run1With :: (Arrays a, Arrays b) => PTX -> (Acc a -> Acc b) -> a -> b +run1With = runNWith + + +-- | Prepare and execute an embedded array program. +-- +-- This function can be used to improve performance in cases where the array +-- program is constant between invocations, because it enables us to bypass +-- front-end conversion stages and move directly to the execution phase. If you +-- have a computation applied repeatedly to different input data, use this, +-- specifying any changing aspects of the computation via the input parameters. +-- If the function is only evaluated once, this is equivalent to 'run'. +-- +-- In order to use 'runN' you must express your Accelerate program as a function +-- of array terms: +-- +-- > f :: (Arrays a, Arrays b, ... Arrays c) => Acc a -> Acc b -> ... -> Acc c +-- +-- This function then returns the compiled version of 'f': +-- +-- > runN f :: (Arrays a, Arrays b, ... Arrays c) => a -> b -> ... -> c +-- +-- At an example, rather than: +-- +-- > step :: Acc (Vector a) -> Acc (Vector b) +-- > step = ... +-- > +-- > simulate :: Vector a -> Vector b +-- > simulate xs = run $ step (use xs) +-- +-- Instead write: +-- +-- > simulate = runN step +-- +-- You can use the debugging options to check whether this is working +-- successfully. For example, running with the @-ddump-phases@ flag should show +-- that the compilation steps only happen once, not on the second and subsequent +-- invocations of 'simulate'. Note that this typically relies on GHC knowing +-- that it can lift out the function returned by 'runN' and reuse it. +-- +-- As with 'run', the resulting array(s) are only copied back to the host once +-- they are actually demanded (forced to normal form). Thus, splitting a program +-- into multiple 'runN' steps does not imply transferring intermediate +-- computations back and forth between host and device. However note that +-- Accelerate is not able to optimise (fuse) across separate 'runN' invocations. +-- +-- See the programs in the 'accelerate-examples' package for examples. +-- +-- See also 'runQ', which compiles the Accelerate program at _Haskell_ compile +-- time, thus eliminating the runtime overhead altogether. +-- +runN :: forall f. Afunction f => f -> AfunctionR f +runN f = exec + where + !acc = convertAfun f + !exec = unsafeWithPool defaultTargetPool + $ \target -> fromJust (lookup (ptxContext target) afun) + + -- Lazily cache the compiled function linked for each execution context. + -- This includes specialisation for different compute capabilities and + -- device-side memory management. + -- + -- Perhaps this implicit version of 'runN' is not a good idea then, because + -- we might need to migrate data between devices between iterations + -- depending on which GPU gets scheduled. + -- + !afun = flip map (unmanaged defaultTargetPool) + $ \target -> (ptxContext target, runNWith' @f target acc) + + +-- | As 'runN', but execute using the specified target device. +-- +runNWith :: forall f. Afunction f => PTX -> f -> AfunctionR f +runNWith target f = exec + where + !acc = convertAfun f + !exec = runNWith' @f target acc + +runNWith' :: forall f. Afunction f => PTX -> DelayedAfun (ArraysFunctionR f) -> AfunctionR f +runNWith' target acc = go (afunctionRepr @f) afun (return Empty) + where + !afun = unsafePerformIO $ do + dumpGraph acc + evalPTX target $ do + build <- phase Compile (compileAfun acc) >>= dumpStats + link <- phase Link (linkAfun build) + return link + + go :: forall aenv t r trepr. + AfunctionRepr t r trepr + -> ExecOpenAfun PTX aenv trepr + -> Par PTX (Val aenv) + -> r + go (AfunctionReprLam repr) (Alam lhs l) k = \ !arrs -> + let k' = do aenv <- k + a <- useRemoteAsync (lhsToTupR lhs) $ fromArr arrs + return (aenv `push` (lhs, a)) + in go repr l k' + go AfunctionReprBody (Abody b) k = unsafePerformIO . phase Execute . evalPTX target . evalPar $ do + aenv <- k + fut <- executeOpenAcc b aenv + toArr <$> copyToHostLazy (Sugar.arraysR @r) fut + go _ _ _ = error "But that's not right, oh, no, what's the story?" + + +-- | As 'run1', but the computation is executed asynchronously. +-- +run1Async :: (Arrays a, Arrays b) => (Acc a -> Acc b) -> a -> IO (Async b) +run1Async = runNAsync + +-- | As 'run1With', but execute asynchronously. +-- +run1AsyncWith :: (Arrays a, Arrays b) => PTX -> (Acc a -> Acc b) -> a -> IO (Async b) +run1AsyncWith = runNAsyncWith + + +-- | As 'runN', but execute asynchronously. +-- +runNAsync :: (Afunction f, RunAsync r, ArraysFunctionR f ~ RunAsyncR r) => f -> r +runNAsync f = exec + where + !acc = convertAfun f + !exec = unsafeWithPool defaultTargetPool + $ \target -> fromJust (lookup (ptxContext target) afun) + + !afun = flip map (unmanaged defaultTargetPool) + $ \target -> (ptxContext target, runNAsyncWith' target acc) + + +-- | As 'runNWith', but execute asynchronously. +-- +runNAsyncWith :: (Afunction f, RunAsync r, ArraysFunctionR f ~ RunAsyncR r) => PTX -> f -> r +runNAsyncWith target f = exec + where + !acc = convertAfun f + !exec = runNAsyncWith' target acc + +runNAsyncWith' :: RunAsync f => PTX -> DelayedAfun (RunAsyncR f) -> f +runNAsyncWith' target acc = exec + where + !afun = unsafePerformIO $ do + dumpGraph acc + evalPTX target $ do + build <- phase Compile (compileAfun acc) >>= dumpStats + link <- phase Link (linkAfun build) + return link + !exec = runAsync' target afun (return Empty) + +class RunAsync f where + type RunAsyncR f + runAsync' :: PTX -> ExecOpenAfun PTX aenv (RunAsyncR f) -> Par PTX (Val aenv) -> f + +instance (Arrays a, RunAsync b) => RunAsync (a -> b) where + type RunAsyncR (a -> b) = ArraysR a -> RunAsyncR b + runAsync' _ Abody{} _ _ = error "runAsync: function oversaturated" + runAsync' target (Alam lhs l) k !arrs = + let k' = do aenv <- k + a <- useRemoteAsync (Sugar.arraysR @a) $ fromArr arrs + return (aenv `push` (lhs, a)) + in runAsync' target l k' + +instance Arrays b => RunAsync (IO (Async b)) where + type RunAsyncR (IO (Async b)) = ArraysR b + runAsync' _ Alam{} _ = error "runAsync: function not fully applied" + runAsync' target (Abody b) k = asyncBound . phase Execute . evalPTX target . evalPar $ do + aenv <- k + ans <- executeOpenAcc b aenv + arrs <- getArrays (arraysR b) ans + return $ toArr arrs + + +-- | Stream a lazily read list of input arrays through the given program, +-- collecting results as we go. +-- +stream :: (Arrays a, Arrays b) => (Acc a -> Acc b) -> [a] -> [b] +stream f arrs = map go arrs + where + !go = run1 f + +-- | As 'stream', but execute using the specified target. +-- +streamWith :: (Arrays a, Arrays b) => PTX -> (Acc a -> Acc b) -> [a] -> [b] +streamWith target f arrs = map go arrs + where + !go = run1With target f + + +-- | Ahead-of-time compilation for an embedded array program. +-- +-- This function will generate, compile, and link into the final executable, +-- code to execute the given Accelerate computation /at Haskell compile time/. +-- This eliminates any runtime overhead associated with the other @run*@ +-- operations. The generated code will be compiled for the current (default) GPU +-- architecture. +-- +-- Since the Accelerate program will be generated at Haskell compile time, +-- construction of the Accelerate program, in particular via meta-programming, +-- will be limited to operations available to that phase. Also note that any +-- arrays which are embedded into the program via 'Data.Array.Accelerate.use' +-- will be stored as part of the final executable. +-- +-- Usage of this function in your program is similar to that of 'runN'. First, +-- express your Accelerate program as a function of array terms: +-- +-- > f :: (Arrays a, Arrays b, ... Arrays c) => Acc a -> Acc b -> ... -> Acc c +-- +-- This function then returns a compiled version of @f@ as a Template Haskell +-- splice, to be added into your program at Haskell compile time: +-- +-- > {-# LANGUAGE TemplateHaskell #-} +-- > +-- > f' :: a -> b -> ... -> c +-- > f' = $( runQ f ) +-- +-- Note that at the splice point the usage of @f@ must monomorphic; i.e. the +-- types @a@, @b@ and @c@ must be at some known concrete type. +-- +-- See the +-- project for an example. +-- +-- [/Note:/] +-- +-- Due to , this +-- currently must be as an /untyped/ splice. +-- +-- The correct type of this function is similar to that of 'runN': +-- +-- > runQ :: Afunction f => f -> Q (TExp (AfunctionR f)) +-- +-- @since 1.1.0.0 +-- +runQ :: Afunction f => f -> TH.ExpQ +runQ = runQ' [| unsafePerformIO |] + +-- | Ahead-of-time analogue of 'runNWith'. See 'runQ' for more information. +-- +-- /NOTE:/ The supplied (at runtime) target must be compatible with the +-- architecture that this function was compiled for (the 'defaultTarget' of the +-- compiling machine). Running on a device with the same compute capability is +-- best, but this should also be forward compatible to newer architectures. +-- +-- The correct type of this function is: +-- +-- > runQWith :: Afunction f => f -> Q (TExp (PTX -> AfunctionR f)) +-- +-- @since 1.1.0.0 +-- +runQWith :: Afunction f => f -> TH.ExpQ +runQWith f = do + target <- TH.newName "target" + TH.lamE [TH.varP target] (runQWith' [| unsafePerformIO |] (TH.varE target) f) + + +-- | Ahead-of-time analogue of 'runNAsync'. See 'runQ' for more information. +-- +-- The correct type of this function is: +-- +-- > runQAsync :: (Afunction f, RunAsync r, AfunctionR f ~ RunAsyncR r) => f -> Q (TExp r) +-- +-- @since 1.1.0.0 +-- +runQAsync :: Afunction f => f -> TH.ExpQ +runQAsync = runQ' [| asyncBound |] + +-- | Ahead-of-time analogue of 'runNAsyncWith'. See 'runQWith' for more information. +-- +-- The correct type of this function is: +-- +-- > runQAsyncWith :: (Afunction f, RunAsync r, AfunctionR f ~ RunAsyncR r) => f -> Q (TExp (PTX -> r)) +-- +-- @since 1.1.0.0 +-- +runQAsyncWith :: Afunction f => f -> TH.ExpQ +runQAsyncWith f = do + target <- TH.newName "target" + TH.lamE [TH.varP target] (runQWith' [| asyncBound |] (TH.varE target) f) + + +runQ' :: Afunction f => TH.ExpQ -> f -> TH.ExpQ +runQ' using = runQ'_ using (\go -> [| withPool defaultTargetPool (\target -> evalPTX target (evalPar $go)) |]) + +runQWith' :: Afunction f => TH.ExpQ -> TH.ExpQ -> f -> TH.ExpQ +runQWith' using target = runQ'_ using (\go -> [| evalPTX $target (evalPar $go) |]) + +-- Generate a template haskell expression for the given function to be embedded +-- into the current program. The supplied continuation specifies how to execute +-- the given body expression (e.g. using 'evalPTX') +-- +-- NOTE: +-- +-- * Can we do this without requiring an active GPU context? This should be +-- possible with only the DeviceProperties, but we would have to be a little +-- careful if we pass invalid values for the other state components. If we +-- attempt this, at minimum we need to parse the generated .sass to extract +-- resource usage information, rather than loading the module and probing +-- directly. +-- +-- * What happens if we execute this code on a different architecture revision? +-- With runN this will automatically be recompiled for each new architecture +-- (at runtime). +-- +runQ'_ :: Afunction f => TH.ExpQ -> (TH.ExpQ -> TH.ExpQ) -> f -> TH.ExpQ +runQ'_ using k f = do + afun <- let acc = convertAfun f + in TH.runIO $ do + dumpGraph acc + evalPTX defaultTarget $ + phase Compile (compileAfun acc) >>= dumpStats + let + go :: CompiledOpenAfun PTX aenv t -> [TH.PatQ] -> [TH.ExpQ] -> [TH.StmtQ] -> TH.ExpQ + go (Alam lhs l) xs as stmts = do + x <- TH.newName "x" -- lambda bound variable + a <- TH.newName "a" -- local array name + s <- TH.bindS (TH.varP a) [| useRemoteAsync $(TH.unTypeCode $ liftArraysR (lhsToTupR lhs)) (fromArr $(TH.varE x)) |] + go l (TH.bangP (TH.varP x) : xs) ([| ($(TH.unTypeCode $ liftALeftHandSide lhs), $(TH.varE a)) |] : as) (return s : stmts) + + go (Abody b) xs as stmts = do + r <- TH.newName "r" -- result + s <- TH.newName "s" + let + aenv = foldr (\a gamma -> [| $gamma `push` $a |] ) [| Empty |] as + body = embedOpenAcc defaultTarget b + -- + TH.lamE (reverse xs) + [| $using (phase Execute $(k ( + TH.doE ( reverse stmts ++ + [ TH.bindS (TH.varP r) [| executeOpenAcc $(TH.unTypeCode body) $aenv |] + , TH.bindS (TH.varP s) [| copyToHostLazy $(TH.unTypeCode (liftArraysR (arraysR b))) $(TH.varE r) |] + , TH.noBindS [| return $ toArr $(TH.varE s) |] + ])))) + |] + -- + go afun [] [] [] + + +-- Controlling host-side allocation +-- -------------------------------- + +-- | Configure the default execution target to allocate all future host-side +-- arrays using (CUDA) pinned memory. Any newly allocated arrays will be +-- page-locked and directly accessible from the device, enabling high-speed +-- (asynchronous) DMA. +-- +-- Note that since the amount of available pageable memory will be reduced, +-- overall system performance can suffer. +-- +-- registerPinnedAllocator :: IO () +-- registerPinnedAllocator = registerPinnedAllocatorWith defaultTarget + + +-- | All future array allocations will use pinned memory associated with the +-- given execution context. These arrays will be directly accessible from the +-- device, enabling high-speed asynchronous DMA. +-- +-- Note that since the amount of available pageable memory will be reduced, +-- overall system performance can suffer. +-- +registerPinnedAllocatorWith :: HasCallStack => PTX -> IO () +registerPinnedAllocatorWith target = + registerForeignPtrAllocator $ \bytes -> + withContext (ptxContext target) (CUDA.mallocHostForeignPtr [] bytes) + `catch` + \e -> internalError shown (e :: CUDAException) + + +-- Debugging +-- ========= + +dumpStats :: MonadIO m => a -> m a +dumpStats x = liftIO dumpSimplStats >> return x + diff --git a/src/Data/Array/Accelerate/LLVM/PTX/Analysis/Device.hs b/src/Data/Array/Accelerate/LLVM/PTX/Analysis/Device.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/PTX/Analysis/Device.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE ScopedTypeVariables #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.PTX.Analysis.Device +-- Copyright : [2008..2020] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.PTX.Analysis.Device + where + +import Control.Exception +import Data.Function +import Data.List +import Data.Ord +import Foreign.CUDA.Analysis.Device +import Foreign.CUDA.Driver.Context ( Context ) +import Foreign.CUDA.Driver.Device +import Foreign.CUDA.Driver.Error +import qualified Foreign.CUDA.Driver as CUDA + + +-- Select the best of the available CUDA capable devices. This prefers devices +-- with higher compute capability, followed by maximum throughput. +-- +-- For hosts with multiple devices in Exclusive Process mode, this will select +-- the first of the _available_ devices. If no devices are available, an +-- exception is thrown indicating that no devices are available. +-- +selectBestDevice :: IO (Device, DeviceProperties, Context) +selectBestDevice = select =<< enumerateDevices + where + select :: [(Device, DeviceProperties)] -> IO (Device, DeviceProperties, Context) + select [] = cudaErrorIO "No CUDA-capable devices are available" + select ((dev,prp):rest) = do + r <- try $ CUDA.create dev [CUDA.SchedAuto] + case r of + Right ctx -> return (dev,prp,ctx) + Left (_::CUDAException) -> select rest + + +-- Return the list of all connected CUDA devices, sorted by compute +-- compatibility, followed by maximum throughput. +-- +-- Strictly speaking this may not necessary, as the default device enumeration +-- appears to be sorted by some metric already. +-- +-- Ignore the possibility of emulation-mode devices, as this has been deprecated +-- as of CUDA v3.0 (compute-capability == 9999.9999) +-- +enumerateDevices :: IO [(Device, DeviceProperties)] +enumerateDevices = do + devs <- mapM CUDA.device . enumFromTo 0 . subtract 1 =<< CUDA.count + prps <- mapM CUDA.props devs + return $ sortBy (flip compareDevices `on` snd) (zip devs prps) + + +-- Return a ordering of two device with respect to (estimated) performance +-- +compareDevices :: DeviceProperties -> DeviceProperties -> Ordering +compareDevices = cmp + where + compute = computeCapability + flops d = multiProcessorCount d * coresPerMultiProcessor d * clockRate d + cmp x y + | compute x == compute y = comparing flops x y + | otherwise = comparing compute x y + + +-- Number of CUDA cores per streaming multiprocessor for a given architecture +-- revision. This is the number of SIMD arithmetic units per multiprocessor, +-- executing in lockstep in half-warp groupings (16 ALUs). +-- +coresPerMultiProcessor :: DeviceProperties -> Int +coresPerMultiProcessor = coresPerMP . deviceResources + diff --git a/src/Data/Array/Accelerate/LLVM/PTX/Analysis/Launch.hs b/src/Data/Array/Accelerate/LLVM/PTX/Analysis/Launch.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/PTX/Analysis/Launch.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.PTX.Analysis.Launch +-- Copyright : [2008..2020] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.PTX.Analysis.Launch ( + + DeviceProperties, Occupancy, LaunchConfig, + simpleLaunchConfig, launchConfig, + multipleOf, multipleOfQ, + +) where + +import Foreign.CUDA.Analysis as CUDA +import Data.Array.Accelerate.TH.Compat + + +-- | Given information about the resource usage of the compiled kernel, +-- determine the optimum launch parameters. +-- +type LaunchConfig + = Int -- maximum #threads per block + -> Int -- #registers per thread + -> Int -- #bytes of static shared memory + -> ( Occupancy + , Int -- thread block size + , Int -> Int -- grid size required to process the given input size + , Int -- #bytes dynamic shared memory + , CodeQ (Int -> Int) + ) + +-- | Analytics for a simple kernel which requires no additional shared memory or +-- have other constraints on launch configuration. The smallest thread block +-- size, in increments of a single warp, with the highest occupancy is used. +-- +simpleLaunchConfig :: DeviceProperties -> LaunchConfig +simpleLaunchConfig dev = launchConfig dev (decWarp dev) (const 0) multipleOf multipleOfQ + + +-- | Determine the optimal kernel launch configuration for a kernel. +-- +launchConfig + :: DeviceProperties -- ^ Device architecture to optimise for + -> [Int] -- ^ Thread block sizes to consider + -> (Int -> Int) -- ^ Shared memory (#bytes) as a function of thread block size + -> (Int -> Int -> Int) -- ^ Determine grid size for input size 'n' (first arg) over thread blocks of size 'm' (second arg) + -> CodeQ (Int -> Int -> Int) + -> LaunchConfig +launchConfig dev candidates dynamic_smem grid_size grid_sizeQ maxThreads registers static_smem = + let + (cta, occ) = optimalBlockSizeOf dev (filter (<= maxThreads) candidates) (const registers) smem + maxGrid = multiProcessorCount dev * activeThreadBlocks occ + grid n = maxGrid `min` grid_size n cta + smem n = static_smem + dynamic_smem n + gridQ = [|| \n -> (maxGrid::Int) `min` $$grid_sizeQ (n::Int) (cta::Int) ||] + in + ( occ, cta, grid, dynamic_smem cta, gridQ ) + + +-- | The next highest multiple of 'y' from 'x'. +-- +multipleOf :: Int -> Int -> Int +multipleOf x y = ((x + y - 1) `quot` y) + +multipleOfQ :: CodeQ (Int -> Int -> Int) +multipleOfQ = [|| multipleOf ||] + diff --git a/src/Data/Array/Accelerate/LLVM/PTX/Array/Data.hs b/src/Data/Array/Accelerate/LLVM/PTX/Array/Data.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/PTX/Array/Data.hs @@ -0,0 +1,205 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UnboxedTuples #-} +{-# OPTIONS_GHC -Wno-orphans #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.PTX.Array.Data +-- Copyright : [2014..2020] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.PTX.Array.Data ( + + module Data.Array.Accelerate.LLVM.Array.Data, + module Data.Array.Accelerate.LLVM.PTX.Array.Data, + +) where + +import Data.Array.Accelerate.Array.Data +import Data.Array.Accelerate.Array.Unique +import Data.Array.Accelerate.Error +import Data.Array.Accelerate.Lifetime +import Data.Array.Accelerate.Representation.Array +import Data.Array.Accelerate.Representation.Shape +import Data.Array.Accelerate.Representation.Type +import Data.Array.Accelerate.Type + +import Data.Array.Accelerate.LLVM.Array.Data +import Data.Array.Accelerate.LLVM.State + +import Data.Array.Accelerate.LLVM.PTX.State +import Data.Array.Accelerate.LLVM.PTX.Target +import Data.Array.Accelerate.LLVM.PTX.Execute.Async +import qualified Data.Array.Accelerate.LLVM.PTX.Array.Prim as Prim + +import Control.Applicative +import Control.Monad +import Control.Monad.IO.Class ( liftIO ) +import Control.Monad.Reader ( asks ) +import System.IO.Unsafe +import Prelude + +import GHC.Heap.NormalForm + + +-- | Remote memory management for the PTX target. Data can be copied +-- asynchronously using multiple execution engines whenever possible. +-- +instance Remote PTX where + {-# INLINEABLE allocateRemote #-} + {-# INLINEABLE indexRemoteAsync #-} + {-# INLINEABLE useRemoteR #-} + {-# INLINEABLE copyToHostR #-} + {-# INLINEABLE copyToRemoteR #-} + allocateRemote repr@(ArrayR shr tp) !sh = do + let !n = size shr sh + arr <- liftIO $ allocateArray repr sh -- shadow array on the host + liftPar $ runArray tp arr (\m t ad -> Prim.mallocArray t (n*m) ad >> return ad) + + indexRemoteAsync = runIndexArrayAsync Prim.indexArrayAsync + useRemoteR = Prim.useArrayAsync + copyToHostR = Prim.peekArrayAsync + copyToRemoteR = Prim.pokeArrayAsync + copyToPeerR = internalError "not supported yet" + + +-- | Copy an array from the remote device to the host. Although the Accelerate +-- program is hyper-strict and will evaluate the computation as soon as any part +-- of it is demanded, the individual array payloads are copied back to the host +-- _only_ as they are demanded by the Haskell program. This has several +-- consequences: +-- +-- 1. If the device has multiple memcpy engines, only one will be used. The +-- transfers are however associated with a non-default stream. +-- +-- 2. Using 'seq' to force an Array to head-normal form will initiate the +-- computation, but not transfer the results back to the host. Requesting +-- an array element or using 'deepseq' to force to normal form is required +-- to actually transfer the data. +-- +{-# INLINEABLE copyToHostLazy #-} +copyToHostLazy + :: HasCallStack + => ArraysR arrs + -> FutureArraysR PTX arrs + -> Par PTX arrs +copyToHostLazy TupRunit () = return () +copyToHostLazy (TupRpair r1 r2) (f1, f2) = do + a1 <- copyToHostLazy r1 f1 + a2 <- copyToHostLazy r2 f2 + return (a1, a2) +copyToHostLazy (TupRsingle (ArrayR shr tp)) future = do + ptx <- asks llvmTarget + liftIO $ do + Array sh adata <- wait future + + -- Note: [Lazy device-host transfers] + -- + -- This needs must be non-strict at the leaves of the datatype (that + -- is, the UniqueArray pointers). This means we can traverse the + -- ArrayData constructors (in particular, the spine defined by Unit + -- and Pair) until we reach the array we care about, without forcing + -- the other fields. + -- + -- https://github.com/AccelerateHS/accelerate/issues/437 + -- + -- Furthermore, we only want to transfer the data if the host pointer + -- is currently unevaluated. This situation can occur for example if + -- the argument to 'use' or 'unit' is returned as part of the result + -- of a 'run'. Peek at GHC's underlying closure representation and + -- check whether the pointer is a thunk, and only initiate the + -- transfer if so. + -- + let + peekR :: SingleType e + -> ArrayData e + -> Int + -> IO (ArrayData e) + peekR t ad m + | SingleArrayDict <- singleArrayDict t + , UniqueArray uid (Lifetime lft weak fp) <- ad + = unsafeInterleaveIO $ do + yes <- isNormalForm fp + fp' <- if yes + then return fp + else unsafeInterleaveIO . evalPTX ptx . evalPar $ do + !_ <- block =<< Prim.peekArrayAsync t m ad + return fp + -- + return $ UniqueArray uid (Lifetime lft weak fp') + + n = size shr sh + + runR :: TypeR e -> ArrayData e -> IO (ArrayData e) + runR TupRunit !() = return () + runR (TupRpair !t1 !t2) (!ad1, !ad2) = (,) <$> runR t1 ad1 <*> runR t2 ad2 + runR (TupRsingle !t) !ad = + case t of + SingleScalarType s -> peekR s ad n + VectorScalarType (VectorType w s) + | SingleArrayDict <- singleArrayDict s -> peekR s ad (n * w) + + Array sh <$> runR tp adata + +-- | Clone an array into a newly allocated array on the device. +-- +cloneArrayAsync + :: ArrayR (Array sh e) + -> Array sh e + -> Par PTX (Future (Array sh e)) +cloneArrayAsync repr@(ArrayR shr tp) arr@(Array _ src) = do + Array _ dst <- allocateRemote repr sh + Array sh `liftF` copyR tp src dst + where + sh = shape arr + n = size shr sh + + copyR :: TypeR s -> ArrayData s -> ArrayData s -> Par PTX (Future (ArrayData s)) + copyR TupRunit !_ !_ = newFull () + copyR (TupRpair !t1 !t2) !(ad1, ad2) !(ad1', ad2') = liftF2 (,) (copyR t1 ad1 ad1') (copyR t2 ad2 ad2') + copyR (TupRsingle !t) !ad !ad' = + case t of + SingleScalarType s -> copyPrim s ad ad' n + VectorScalarType (VectorType w s) + | SingleArrayDict <- singleArrayDict s -> copyPrim s ad ad' (n * w) + + copyPrim + :: SingleType s + -> ArrayData s + -> ArrayData s + -> Int + -> Par PTX (Future (ArrayData s)) + copyPrim !s !a1 !a2 !m = Prim.copyArrayAsync s m a1 a2 + + liftF :: Async arch + => (a -> b) + -> Par arch (FutureR arch a) + -> Par arch (FutureR arch b) + liftF f x = do + r <- new + x' <- x + put r . f =<< get x' -- don't create a new execution stream for this + return r + + liftF2 :: Async arch + => (a -> b -> c) + -> Par arch (FutureR arch a) + -> Par arch (FutureR arch b) + -> Par arch (FutureR arch c) + liftF2 f x y = do + r <- new + x' <- spawn x + y' <- spawn y + fork $ put r =<< liftM2 f (get x') (get y') + return r + diff --git a/src/Data/Array/Accelerate/LLVM/PTX/Array/Prim.hs b/src/Data/Array/Accelerate/LLVM/PTX/Array/Prim.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/PTX/Array/Prim.hs @@ -0,0 +1,391 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UnboxedTuples #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.PTX.Array.Prim +-- Copyright : [2014..2020] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.PTX.Array.Prim ( + + mallocArray, + useArrayAsync, + indexArrayAsync, + peekArrayAsync, + pokeArrayAsync, + copyArrayAsync, + -- copyArrayPeerAsync, + memsetArrayAsync, + withDevicePtr, + +) where + +import Data.Array.Accelerate.Array.Data +import Data.Array.Accelerate.Array.Unique +import Data.Array.Accelerate.Error +import Data.Array.Accelerate.Lifetime hiding ( withLifetime ) +import Data.Array.Accelerate.Representation.Elt +import Data.Array.Accelerate.Representation.Type +import Data.Array.Accelerate.Type + +import Data.Array.Accelerate.LLVM.State + +import Data.Array.Accelerate.LLVM.PTX.Target +import Data.Array.Accelerate.LLVM.PTX.Execute.Async +import Data.Array.Accelerate.LLVM.PTX.Execute.Event +import Data.Array.Accelerate.LLVM.PTX.Execute.Stream +import Data.Array.Accelerate.LLVM.PTX.Array.Remote as Remote +import qualified Data.Array.Accelerate.LLVM.PTX.Debug as Debug + +import qualified Foreign.CUDA.Driver as CUDA +import qualified Foreign.CUDA.Driver.Stream as CUDA + +import Control.Monad +import Control.Monad.Reader +import Data.IORef +import Data.Text.Lazy.Builder +import Formatting hiding ( bytes ) +import qualified Formatting as F +import Prelude + +import GHC.Base ( IO(..), Int(..), Double(..), touch#, int2Double# ) + + +-- | Allocate a device-side array associated with the given host array. If the +-- allocation fails due to a memory error, we attempt some last-ditch memory +-- cleanup before trying again. If it still fails; error. +-- +{-# INLINEABLE mallocArray #-} +mallocArray + :: HasCallStack + => SingleType e + -> Int + -> ArrayData e + -> LLVM PTX () +mallocArray !t !n !ad = do + message ("mallocArray: " % formatBytes) (n * bytesElt (TupRsingle (SingleScalarType t))) + void $ Remote.malloc t ad n False + + +-- | A combination of 'mallocArray' and 'pokeArray', that allocates remotes +-- memory and uploads an existing array. This is specialised because we tell the +-- allocator that the host-side array is frozen, and thus it is safe to evict +-- the remote memory and re-upload the data at any time. +-- +{-# INLINEABLE useArrayAsync #-} +useArrayAsync + :: HasCallStack + => SingleType e + -> Int + -> ArrayData e + -> Par PTX (Future (ArrayData e)) +useArrayAsync !t !n !ad = do + message ("useArrayAsync: " % formatBytes) (n * bytesElt (TupRsingle (SingleScalarType t))) + alloc <- liftPar $ Remote.malloc t ad n True + if alloc + then pokeArrayAsync t n ad + else newFull ad + + +-- | Copy data from the host to an existing array on the device +-- +{-# INLINEABLE pokeArrayAsync #-} +pokeArrayAsync + :: HasCallStack + => SingleType e + -> Int + -> ArrayData e + -> Par PTX (Future (ArrayData e)) +pokeArrayAsync !t !n !ad + | SingleArrayDict <- singleArrayDict t + , SingleDict <- singleDict t + = do + let !src = CUDA.HostPtr (unsafeUniqueArrayPtr ad) + !bytes = n * bytesElt (TupRsingle (SingleScalarType t)) + -- + stream <- asksParState ptxStream + result <- liftPar $ + withLifetime stream $ \st -> + withDevicePtr t ad $ \dst -> + nonblocking stream $ do + transfer "pokeArray" bytes (Just st) $ do + CUDA.pokeArrayAsync n src dst (Just st) + Debug.memcpy_to_remote bytes + return ad + -- + return result + + +-- | Read an element from an array at the given row-major index. +-- +-- This copies the data via a temporary array on the host, so that packed AoS +-- elements can be copied in a single transfer. +-- +{-# INLINEABLE indexArrayAsync #-} +indexArrayAsync + :: HasCallStack + => Int -- actual number of values per element (i.e. this is >1 for SIMD types) + -> SingleType e + -> ArrayData e + -> Int -- element index + -> Par PTX (Future (ArrayData e)) +indexArrayAsync !n !t !ad_src !i + | SingleArrayDict <- singleArrayDict t + , SingleDict <- singleDict t + = do + ad_dst <- liftIO $ newArrayData (TupRsingle $ SingleScalarType t) n + let !bytes = n * bytesElt (TupRsingle (SingleScalarType t)) + !dst = CUDA.HostPtr (unsafeUniqueArrayPtr ad_dst) + -- + stream <- asksParState ptxStream + result <- liftPar $ + withLifetime stream $ \st -> + withDevicePtr t ad_src $ \src -> + nonblocking stream $ do + transfer "indexArray" bytes (Just st) $ do + CUDA.peekArrayAsync n (src `CUDA.advanceDevPtr` (i*n)) dst (Just st) + Debug.memcpy_from_remote bytes + return ad_dst + -- + return result + + +-- | Copy data from the device into the associated host-side Accelerate array +-- +{-# INLINEABLE peekArrayAsync #-} +peekArrayAsync + :: HasCallStack + => SingleType e + -> Int + -> ArrayData e + -> Par PTX (Future (ArrayData e)) +peekArrayAsync !t !n !ad + | SingleArrayDict <- singleArrayDict t + , SingleDict <- singleDict t + = do + let !bytes = n * bytesElt (TupRsingle (SingleScalarType t)) + !dst = CUDA.HostPtr (unsafeUniqueArrayPtr ad) + -- + stream <- asksParState ptxStream + result <- liftPar $ + withLifetime stream $ \st -> + withDevicePtr t ad $ \src -> + nonblocking stream $ do + transfer "peekArray" bytes (Just st) $ do + CUDA.peekArrayAsync n src dst (Just st) + Debug.memcpy_from_remote bytes + return ad + -- + return result + + +-- | Copy data between arrays in the same context +-- +{-# INLINEABLE copyArrayAsync #-} +copyArrayAsync + :: HasCallStack + => SingleType e + -> Int + -> ArrayData e + -> ArrayData e + -> Par PTX (Future (ArrayData e)) +copyArrayAsync !t !n !ad_src !ad_dst + | SingleArrayDict <- singleArrayDict t + , SingleDict <- singleDict t + = do + let !bytes = n * bytesElt (TupRsingle (SingleScalarType t)) + -- + stream <- asksParState ptxStream + result <- liftPar $ + withLifetime stream $ \st -> + withDevicePtr t ad_src $ \src -> + withDevicePtr t ad_dst $ \dst -> do + (e,r) <- nonblocking stream $ do + transfer "copyArray" bytes (Just st) $ CUDA.copyArrayAsync n src dst (Just st) + return ad_dst + return (e, (e,r)) + -- + return result + + +{-- +-- | Copy data from one device context into a _new_ array on the second context. +-- It is an error if the destination array already exists. +-- +{-# INLINEABLE copyArrayPeerAsync #-} +copyArrayPeerAsync + :: SingleType e + -> Context -- destination context + -> MemoryTable -- destination memory table + -> Stream + -> Int + -> ArrayData e + -> LLVM PTX () +copyArrayPeerAsync = error "copyArrayPeerAsync" +{-- +copyArrayPeerAsync !t !ctx2 !mt2 !st !n !ad = do + let !bytes = n * sizeOfSingleType t + src <- devicePtr mt1 ad + dst <- mallocArray ctx2 mt2 n ad + transfer "copyArrayPeer" bytes (Just st) $ + CUDA.copyArrayPeerAsync n src (deviceContext ctx1) dst (deviceContext ctx2) (Just st) +--} + +-- | Copy part of an array from one device context to another. Both source and +-- destination arrays must exist. +-- +{-# INLINEABLE copyArrayPeerAsyncR #-} +copyArrayPeerAsync + :: SingleType e + -> Context -- destination context + -> MemoryTable -- destination memory table + -> Stream + -> Int + -> Int + -> ArrayData e + -> LLVM PTX () +copyArrayPeerAsync = error "copyArrayPeerAsyncR" +{-- +copyArrayPeerAsyncR !t !ctx2 !mt2 !st !from !n !ad = do + let !bytes = n * sizeOfSingleType t + !offset = from * sizeOfSingleType t + src <- devicePtr mt1 ad :: IO (CUDA.DevicePtr a) + dst <- devicePtr mt2 ad :: IO (CUDA.DevicePtr a) + transfer "copyArrayPeer" bytes (Just st) $ + CUDA.copyArrayPeerAsync n (src `CUDA.plusDevPtr` offset) (deviceContext ctx1) + (dst `CUDA.plusDevPtr` offset) (deviceContext ctx2) (Just st) +--} +--} + +-- | Set elements of the array to the specified value. Only 8-, 16-, and 32-bit +-- values are supported. +-- +{-# INLINEABLE memsetArrayAsync #-} +memsetArrayAsync + :: HasCallStack + => SingleType e + -> Int + -> ScalarArrayDataR e + -> ArrayData e + -> Par PTX (Future (ArrayData e)) +memsetArrayAsync !t !n !v !ad + | SingleArrayDict <- singleArrayDict t + , SingleDict <- singleDict t + = do + let !bytes = n * bytesElt (TupRsingle (SingleScalarType t)) + -- + stream <- asksParState ptxStream + result <- liftPar $ + withLifetime stream $ \st -> + withDevicePtr t ad $ \ptr -> + nonblocking stream $ do + transfer "memset" bytes (Just st) $ CUDA.memsetAsync ptr n v (Just st) + return ad + -- + return result + + +-- Auxiliary +-- --------- + +-- | Lookup the device memory associated with a given host array and do +-- something with it. +-- +{-# INLINEABLE withDevicePtr #-} +withDevicePtr + :: HasCallStack + => SingleType e + -> ArrayData e + -> (CUDA.DevicePtr (ScalarArrayDataR e) -> LLVM PTX (Maybe Event, r)) + -> LLVM PTX r +withDevicePtr !t !ad !f = do + mr <- withRemote t ad f + case mr of + Nothing -> internalError "array does not exist on the device" + Just r -> return r + +{-- +-- | Lookup the device memory associated with a given host array +-- +{-# INLINEABLE devicePtr #-} +devicePtr + :: (ArrayElt e, ArrayPtrs e ~ Ptr a, Typeable a, Typeable b) + => ArrayData e + -> LLVM PTX (CUDA.DevicePtr b) +devicePtr !ad = do + undefined + {-- + mv <- Table.lookup mt ad + case mv of + Just v -> return v + Nothing -> $internalError "devicePtr" "lost device memory" + --} +--} + +-- | Execute a (presumable asynchronous) operation and return the result +-- together with an event recorded immediately afterwards in the given stream. +-- +{-# INLINE nonblocking #-} +nonblocking :: Stream -> LLVM PTX a -> LLVM PTX (Maybe Event, Future a) +nonblocking !stream !action = do + result <- action + event <- waypoint stream + ready <- liftIO (query event) + if ready + then do + future <- Future <$> liftIO (newIORef (Full result)) + return (Nothing, future) + + else do + future <- Future <$> liftIO (newIORef (Pending event (return ()) result)) + return (Just event, future) + +{-# INLINE withLifetime #-} +withLifetime :: MonadIO m => Lifetime a -> (a -> m b) -> m b +withLifetime (Lifetime ref _ a) f = do + r <- f a + liftIO (touchIORef ref) + return r + +{-# INLINE touchIORef #-} +touchIORef :: IORef a -> IO () +touchIORef r = IO $ \s -> case touch# r s of s' -> (# s', () #) + + +-- Debug +-- ----- + +{-# INLINE double #-} +double :: Int -> Double +double (I# i#) = D# (int2Double# i#) + +{-# INLINE formatBytes #-} +formatBytes :: Format r (Int -> r) +formatBytes = F.bytes @Double shortest + +{-# INLINE message #-} +message :: MonadIO m => Format (m ()) a -> a +message fmt = Debug.traceM Debug.dump_gc ("gc: " % fmt) + +{-# INLINE transfer #-} +transfer :: MonadIO m => Builder -> Int -> Maybe CUDA.Stream -> IO () -> m () +transfer name bytes stream action = + let fmt wall cpu gpu = + message (builder % ": " % F.bytes @Double shortest % " @ " % Debug.formatSIBase (Just 3) 1024 % "B/s, " % Debug.elapsed) + name bytes (double bytes / wall) wall cpu gpu + in + liftIO (Debug.timed Debug.dump_gc fmt stream action) + diff --git a/src/Data/Array/Accelerate/LLVM/PTX/Array/Remote.hs b/src/Data/Array/Accelerate/LLVM/PTX/Array/Remote.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/PTX/Array/Remote.hs @@ -0,0 +1,167 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.PTX.Array.Remote +-- Copyright : [2014..2020] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.PTX.Array.Remote ( + + withRemote, malloc, + +) where + +import Data.Array.Accelerate.LLVM.State +import Data.Array.Accelerate.LLVM.PTX.Target +import {-# SOURCE #-} Data.Array.Accelerate.LLVM.PTX.Execute.Event +import {-# SOURCE #-} Data.Array.Accelerate.LLVM.PTX.Execute.Stream + +import Data.Array.Accelerate.Array.Data +import Data.Array.Accelerate.Array.Unique +import Data.Array.Accelerate.Lifetime +import Data.Array.Accelerate.Representation.Elt +import Data.Array.Accelerate.Representation.Type +import Data.Array.Accelerate.Type +import qualified Data.Array.Accelerate.Array.Remote as Remote +import qualified Data.Array.Accelerate.LLVM.PTX.Debug as Debug + +import Foreign.CUDA.Driver.Error +import qualified Foreign.CUDA.Ptr as CUDA +import qualified Foreign.CUDA.Driver as CUDA +import qualified Foreign.CUDA.Driver.Stream as CUDA + +import Control.Exception +import Control.Monad.Reader +import Data.Text.Lazy.Builder +import Formatting hiding ( bytes ) +import qualified Formatting as F + +import GHC.Base ( Int(..), Double(..), int2Double# ) + + +-- Events signal once a computation has completed +-- +instance Remote.Task (Maybe Event) where + completed Nothing = return True + completed (Just e) = query e + +instance Remote.RemoteMemory (LLVM PTX) where + type RemotePtr (LLVM PTX) = CUDA.DevicePtr + -- + mallocRemote n + | n <= 0 = return (Just CUDA.nullDevPtr) + | otherwise = do + name <- asks ptxDeviceName + liftIO $ do + ep <- try (CUDA.mallocArray n) + case ep of + Right p -> do Debug.remote_memory_alloc name (CUDA.useDevicePtr p) n + return (Just p) + Left (ExitCode OutOfMemory) -> do return Nothing + Left e -> do message ("malloc failed with error: " % shown) e + throwIO e + + peekRemote t n src ad + | SingleArrayDict <- singleArrayDict t + , SingleDict <- singleDict t + = let bytes = n * bytesElt (TupRsingle (SingleScalarType t)) + dst = CUDA.HostPtr (unsafeUniqueArrayPtr ad) + in + blocking $ \stream -> + withLifetime stream $ \st -> do + Debug.memcpy_from_remote bytes + transfer "peekRemote" bytes (Just st) $ CUDA.peekArrayAsync n src dst (Just st) + + pokeRemote t n dst ad + | SingleArrayDict <- singleArrayDict t + , SingleDict <- singleDict t + = let bytes = n * bytesElt (TupRsingle (SingleScalarType t)) + src = CUDA.HostPtr (unsafeUniqueArrayPtr ad) + in + blocking $ \stream -> + withLifetime stream $ \st -> do + Debug.memcpy_to_remote bytes + transfer "pokeRemote" bytes (Just st) $ CUDA.pokeArrayAsync n src dst (Just st) + + castRemotePtr = CUDA.castDevPtr + availableRemoteMem = liftIO $ fst `fmap` CUDA.getMemInfo + totalRemoteMem = liftIO $ snd `fmap` CUDA.getMemInfo + remoteAllocationSize = return 4096 + + + +-- | Allocate an array in the remote memory space sufficient to hold the given +-- number of elements, and associated with the given host side array. Space will +-- be freed from the remote device if necessary. +-- +{-# INLINEABLE malloc #-} +malloc + :: SingleType e + -> ArrayData e + -> Int + -> Bool + -> LLVM PTX Bool +malloc !tp !ad !n !frozen = do + PTX{..} <- asks llvmTarget + Remote.malloc ptxMemoryTable tp ad frozen n + + +-- | Lookup up the remote array pointer for the given host-side array +-- +{-# INLINEABLE withRemote #-} +withRemote + :: SingleType e + -> ArrayData e + -> (CUDA.DevicePtr (ScalarArrayDataR e) -> LLVM PTX (Maybe Event, r)) + -> LLVM PTX (Maybe r) +withRemote !tp !ad !f = do + PTX{..} <- asks llvmTarget + Remote.withRemote ptxMemoryTable tp ad f + + +-- Auxiliary +-- --------- + +-- | Execute the given operation in a new stream, and wait for the operation to +-- complete before returning. +-- +{-# INLINE blocking #-} +blocking :: (Stream -> IO a) -> LLVM PTX a +blocking !fun = + streaming (liftIO . fun) $ \e r -> do + liftIO $ block e + return r + +{-# INLINE double #-} +double :: Int -> Double +double (I# i#) = D# (int2Double# i#) + + +-- Debugging +-- --------- + +{-# INLINE message #-} +message :: Format (IO ()) a -> a +message fmt = Debug.traceM Debug.dump_gc ("gc: " % fmt) + +{-# INLINE transfer #-} +transfer :: Builder -> Int -> Maybe CUDA.Stream -> IO () -> IO () +transfer name bytes stream action = + let fmt wall cpu gpu = + message (builder % ": " % F.bytes @Double shortest % " @ " % Debug.formatSIBase (Just 3) 1024 % "B/s, " % Debug.elapsed) + name bytes (double bytes / wall) wall cpu gpu + in + Debug.timed Debug.dump_gc fmt stream action + diff --git a/src/Data/Array/Accelerate/LLVM/PTX/Array/Table.hs b/src/Data/Array/Accelerate/LLVM/PTX/Array/Table.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/PTX/Array/Table.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.PTX.Array.Table +-- Copyright : [2014..2020] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.PTX.Array.Table ( + + MemoryTable, + new, + +) where + +import Data.Array.Accelerate.LLVM.PTX.Context ( Context, withContext ) +import qualified Data.Array.Accelerate.LLVM.PTX.Context as Context +import qualified Data.Array.Accelerate.Array.Remote as Remote +import qualified Data.Array.Accelerate.LLVM.PTX.Debug as Debug +import {-# SOURCE #-} Data.Array.Accelerate.LLVM.PTX.Execute.Event + +import qualified Foreign.CUDA.Ptr as CUDA +import qualified Foreign.CUDA.Driver as CUDA + +import Formatting + + +-- Remote memory tables. This builds upon the LRU-cached memory tables provided +-- by the base Accelerate package. +-- +type MemoryTable = Remote.MemoryTable CUDA.DevicePtr (Maybe Event) + + +-- | Create a new PTX memory table. This is specific to a given PTX target, as +-- devices arrays are unique to a CUDA context. +-- +{-# INLINEABLE new #-} +new :: Context -> IO MemoryTable +new !ctx = Remote.new freeRemote + where + freeRemote :: CUDA.DevicePtr a -> IO () + freeRemote !ptr = do + message ("freeRemote " % shown) ptr + Context.contextFinalizeResource ctx $ + withContext ctx (CUDA.free ptr) + + +-- Debugging +-- --------- + +{-# INLINE message #-} +message :: Format (IO ()) a -> a +message fmt = Debug.traceM Debug.dump_gc ("gc: " % fmt) + diff --git a/src/Data/Array/Accelerate/LLVM/PTX/CodeGen.hs b/src/Data/Array/Accelerate/LLVM/PTX/CodeGen.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/PTX/CodeGen.hs @@ -0,0 +1,45 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.PTX.CodeGen +-- Copyright : [2014..2020] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.PTX.CodeGen ( + + KernelMetadata(..), + +) where + +-- accelerate +import Data.Array.Accelerate.LLVM.CodeGen + +import Data.Array.Accelerate.LLVM.PTX.CodeGen.Base +import Data.Array.Accelerate.LLVM.PTX.CodeGen.Fold +import Data.Array.Accelerate.LLVM.PTX.CodeGen.FoldSeg +import Data.Array.Accelerate.LLVM.PTX.CodeGen.Generate +import Data.Array.Accelerate.LLVM.PTX.CodeGen.Intrinsic () +import Data.Array.Accelerate.LLVM.PTX.CodeGen.Map +import Data.Array.Accelerate.LLVM.PTX.CodeGen.Permute +import Data.Array.Accelerate.LLVM.PTX.CodeGen.Scan +import Data.Array.Accelerate.LLVM.PTX.CodeGen.Stencil +import Data.Array.Accelerate.LLVM.PTX.CodeGen.Transform +import Data.Array.Accelerate.LLVM.PTX.Target + + +instance Skeleton PTX where + map = mkMap + generate = mkGenerate + transform = mkTransform + fold = mkFold + foldSeg = mkFoldSeg + scan = mkScan + scan' = mkScan' + permute = mkPermute + stencil1 = mkStencil1 + stencil2 = mkStencil2 + diff --git a/src/Data/Array/Accelerate/LLVM/PTX/CodeGen/Base.hs b/src/Data/Array/Accelerate/LLVM/PTX/CodeGen/Base.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/PTX/CodeGen/Base.hs @@ -0,0 +1,825 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-orphans #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.PTX.CodeGen.Base +-- Copyright : [2014..2020] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.PTX.CodeGen.Base ( + + -- Types + DeviceProperties, KernelMetadata(..), + + -- Thread identifiers + blockDim, gridDim, threadIdx, blockIdx, warpSize, + gridSize, globalThreadIdx, + + -- Other intrinsics + laneId, warpId, + laneMask_eq, laneMask_lt, laneMask_le, laneMask_gt, laneMask_ge, + atomicAdd_f, + nanosleep, + + -- Barriers and synchronisation + __syncthreads, __syncthreads_count, __syncthreads_and, __syncthreads_or, + __syncwarp, __syncwarp_mask, + __threadfence_block, __threadfence_grid, + + -- Warp shuffle instructions + __shfl_up, __shfl_down, __shfl_idx, __broadcast, + + -- Shared memory + staticSharedMem, + sharedMemorySizeAdd, + dynamicSharedMem, + sharedMemAddrSpace, sharedMemVolatility, + + -- Kernel definitions + (+++), + makeOpenAcc, makeOpenAccWith, + +) where + +import Data.Primitive.Vec +import Data.Array.Accelerate.Error +import Data.Array.Accelerate.LLVM.CodeGen.Arithmetic as A +import Data.Array.Accelerate.LLVM.CodeGen.Base +import Data.Array.Accelerate.LLVM.CodeGen.IR +import Data.Array.Accelerate.LLVM.CodeGen.Module +import Data.Array.Accelerate.LLVM.CodeGen.Monad +import Data.Array.Accelerate.LLVM.CodeGen.Ptr +import Data.Array.Accelerate.LLVM.CodeGen.Sugar +import Data.Array.Accelerate.LLVM.Compile.Cache +import Data.Array.Accelerate.LLVM.PTX.Analysis.Launch +import Data.Array.Accelerate.LLVM.PTX.Target +import Data.Array.Accelerate.Representation.Array +import Data.Array.Accelerate.Representation.Elt +import Data.Array.Accelerate.Representation.Shape +import Data.Array.Accelerate.Representation.Type +import qualified Data.Array.Accelerate.LLVM.CodeGen.Constant as A + +import Foreign.CUDA.Analysis ( Compute(..), computeCapability ) +import qualified Foreign.CUDA.Analysis as CUDA + +import LLVM.AST.Type.Constant +import LLVM.AST.Type.Downcast +import LLVM.AST.Type.Function +import LLVM.AST.Type.GetElementPtr +import LLVM.AST.Type.Instruction +import LLVM.AST.Type.Instruction.Atomic +import qualified LLVM.AST.Type.Instruction.RMW as RMW +import LLVM.AST.Type.Instruction.Volatile +import LLVM.AST.Type.Metadata +import LLVM.AST.Type.Name +import LLVM.AST.Type.Operand +import LLVM.AST.Type.Representation +import qualified Data.Array.Accelerate.LLVM.Internal.LLVMPretty as LP + +import Control.Applicative +import Control.Monad ( void ) +import Control.Monad.Reader ( asks ) +import Data.Bits +import Data.Proxy +import Data.String +import Foreign.Storable +import Prelude as P + +import GHC.TypeLits + + + +-- Thread identifiers +-- ------------------ + +-- | Read the builtin registers that store CUDA thread and grid identifiers +-- +-- +-- +specialPTXReg :: Label -> CodeGen PTX (Operands Int32) +specialPTXReg f = + call (Body type' (Just Tail) f) [NoUnwind, ReadNone] + +blockDim, gridDim, threadIdx, blockIdx, warpSize :: CodeGen PTX (Operands Int32) +blockDim = specialPTXReg "llvm.nvvm.read.ptx.sreg.ntid.x" +gridDim = specialPTXReg "llvm.nvvm.read.ptx.sreg.nctaid.x" +threadIdx = specialPTXReg "llvm.nvvm.read.ptx.sreg.tid.x" +blockIdx = specialPTXReg "llvm.nvvm.read.ptx.sreg.ctaid.x" +warpSize = specialPTXReg "llvm.nvvm.read.ptx.sreg.warpsize" + +laneId :: CodeGen PTX (Operands Int32) +laneId = specialPTXReg "llvm.nvvm.read.ptx.sreg.laneid" + +laneMask_eq, laneMask_lt, laneMask_le, laneMask_gt, laneMask_ge :: CodeGen PTX (Operands Int32) +laneMask_eq = specialPTXReg "llvm.nvvm.read.ptx.sreg.lanemask.eq" +laneMask_lt = specialPTXReg "llvm.nvvm.read.ptx.sreg.lanemask.lt" +laneMask_le = specialPTXReg "llvm.nvvm.read.ptx.sreg.lanemask.le" +laneMask_gt = specialPTXReg "llvm.nvvm.read.ptx.sreg.lanemask.gt" +laneMask_ge = specialPTXReg "llvm.nvvm.read.ptx.sreg.lanemask.ge" + + +-- | NOTE: The special register %warpid as volatile value and is not guaranteed +-- to be constant over the lifetime of a thread or thread block. +-- +-- http://docs.nvidia.com/cuda/cuda-c-programming-guide/index.html#sm-id-and-warp-id +-- +-- http://docs.nvidia.com/cuda/parallel-thread-execution/index.html#special-registers-warpid +-- +warpId :: CodeGen PTX (Operands Int32) +warpId = do + dev <- liftCodeGen $ asks ptxDeviceProperties + tid <- threadIdx + A.quot integralType tid (A.liftInt32 (P.fromIntegral (CUDA.warpSize dev))) + +_warpId :: CodeGen PTX (Operands Int32) +_warpId = specialPTXReg "llvm.ptx.read.warpid" + + +-- | The size of the thread grid +-- +-- > gridDim.x * blockDim.x +-- +gridSize :: CodeGen PTX (Operands Int32) +gridSize = do + ncta <- gridDim + nt <- blockDim + mul numType ncta nt + + +-- | The global thread index +-- +-- > blockDim.x * blockIdx.x + threadIdx.x +-- +globalThreadIdx :: CodeGen PTX (Operands Int32) +globalThreadIdx = do + ntid <- blockDim + ctaid <- blockIdx + tid <- threadIdx + -- + u <- mul numType ntid ctaid + v <- add numType tid u + return v + + +{-- +-- | Generate function parameters that will specify the first and last (linear) +-- index of the array this kernel should evaluate. +-- +gangParam :: (Operands Int, Operands Int, [LLVM.Parameter]) +gangParam = + let start = "ix.start" + end = "ix.end" + in + (local start, local end, parameter start ++ parameter end ) +--} + + +-- Barriers and synchronisation +-- ---------------------------- + +-- | Call a built-in CUDA synchronisation intrinsic +-- +barrier :: Label -> CodeGen PTX () +barrier f = void $ call (Body VoidType (Just Tail) f) [NoUnwind, NoDuplicate, Convergent] + +barrier_op :: Label -> Operands Int32 -> CodeGen PTX (Operands Int32) +barrier_op f x = call (Lam primType (op integralType x) (Body type' (Just Tail) f)) [NoUnwind, NoDuplicate, Convergent] + + +-- | Wait until all threads in the thread block have reached this point, and all +-- global and shared memory accesses made by these threads prior to the +-- __syncthreads() are visible to all threads in the block. +-- +-- +-- +__syncthreads :: CodeGen PTX () +__syncthreads = barrier "llvm.nvvm.barrier0" + +-- | Identical to __syncthreads() with the additional feature that it returns +-- the number of threads in the block for which the predicate evaluates to +-- non-zero. +-- +__syncthreads_count :: Operands Int32 -> CodeGen PTX (Operands Int32) +__syncthreads_count = barrier_op "llvm.nvvm.barrier0.popc" + +-- | Identical to __syncthreads() with the additional feature that it returns +-- non-zero iff the predicate evaluates to non-zero for all threads in the +-- block. +-- +__syncthreads_and :: Operands Int32 -> CodeGen PTX (Operands Int32) +__syncthreads_and = barrier_op "llvm.nvvm.barrier0.and" + +-- | Identical to __syncthreads() with the additional feature that it returns +-- non-zero iff the predicate evaluates to non-zero for any thread in the block. +-- +__syncthreads_or :: Operands Int32 -> CodeGen PTX (Operands Int32) +__syncthreads_or = barrier_op "llvm.nvvm.barrier0.or" + + +-- | Wait until all warp lanes have reached this point. +-- +__syncwarp :: HasCallStack => CodeGen PTX () +__syncwarp = __syncwarp_mask (liftWord32 0xffffffff) + +-- | Wait until all warp lanes named in the mask have executed a __syncwarp() +-- with the same mask. All non-exited threads named in the mask must execute +-- a corresponding __syncwarp with the same mask, or the result is undefined. +-- +-- This guarantees memory ordering among threads participating in the barrier. +-- +-- Requires LLVM-6.0 or higher. +-- Only required for devices of SM7 and later. +-- +__syncwarp_mask :: HasCallStack => Operands Word32 -> CodeGen PTX () +__syncwarp_mask mask = do + llvmver <- getLLVMversion + dev <- liftCodeGen $ asks ptxDeviceProperties + case (computeCapability dev >= Compute 7 0, llvmver >= 6) of + (True, True) -> void $ call (Lam primType (op primType mask) (Body VoidType (Just Tail) "llvm.nvvm.bar.warp.sync")) [NoUnwind, NoDuplicate, Convergent] + (True, False) -> internalError "LLVM-6.0 or above is required for Volta devices and later" + (False, _) -> return () + + +-- | Ensure that all writes to shared and global memory before the call to +-- __threadfence_block() are observed by all threads in the *block* of the +-- calling thread as occurring before all writes to shared and global memory +-- made by the calling thread after the call. +-- +-- +-- +__threadfence_block :: CodeGen PTX () +__threadfence_block = barrier "llvm.nvvm.membar.cta" + + +-- | As __threadfence_block(), but the synchronisation is for *all* thread blocks. +-- In CUDA this is known simply as __threadfence(). +-- +__threadfence_grid :: CodeGen PTX () +__threadfence_grid = barrier "llvm.nvvm.membar.gl" + + +-- Atomic functions +-- ---------------- + +-- LLVM provides atomic instructions for integer arguments only. CUDA provides +-- additional support for atomic add on floating point types, which can be +-- accessed through the following intrinsics. +-- +-- Double precision is supported on Compute 6.0 devices and later. Half +-- precision is supported on Compute 7.0 devices and later. +-- +-- LLVM-4.0 currently lacks support for this intrinsic, however it is +-- accessible via inline assembly. +-- +-- LLVM-9 integrated floating-point atomic operations into the AtomicRMW +-- instruction, but this functionality is missing from llvm-hs-9. We access +-- it via inline assembly.. +-- +-- +-- +atomicAdd_f :: HasCallStack => FloatingType a -> Operand (Ptr a) -> Operand a -> CodeGen PTX () +atomicAdd_f t addr val = do + llvmver <- getLLVMversion + if | llvmver >= 10 -> + void . instr' $ AtomicRMW (FloatingNumType t) NonVolatile RMW.Add addr val (CrossThread, AcquireRelease) + + | otherwise -> + internalError "LLVM < 10 not supported" + + +-- Warp shuffle functions +-- ---------------------- +-- +-- Exchange a variable between threads within a warp. Requires compute +-- capability 3.0 or higher. +-- +-- +-- +-- Each of the shfl primitives also exists in ".p" form. This version +-- returns, alongside the normal value, a boolean that returns whether the +-- source lane was in range. This could be useful when doing bounds checks +-- in folds and scans. +-- + +data ShuffleOp + = Idx -- ^ Direct copy from indexed lane + | Up -- ^ Copy from a lane with lower ID relative to the caller + | Down -- ^ Copy from a lane with higher ID relative to the caller + | XOR -- ^ Copy from a lane based on bitwise XOR of own lane ID + +-- | Each thread gets the value provided by lower threads +-- +__shfl_up :: TypeR a -> Operands a -> Operands Word32 -> CodeGen PTX (Operands a) +__shfl_up = shfl Up + +-- | Each thread gets the value provided by higher threads +-- +__shfl_down :: TypeR a -> Operands a -> Operands Word32 -> CodeGen PTX (Operands a) +__shfl_down = shfl Down + +-- | shfl_idx takes an argument representing the source lane index. +-- +__shfl_idx :: TypeR a -> Operands a -> Operands Word32 -> CodeGen PTX (Operands a) +__shfl_idx = shfl Idx + +-- | Distribute the value from lane 0 across the warp +-- +__broadcast :: TypeR a -> Operands a -> CodeGen PTX (Operands a) +__broadcast aR a = __shfl_idx aR a (liftWord32 0) + + +shfl :: ShuffleOp + -> TypeR a + -> Operands a + -> Operands Word32 + -> CodeGen PTX (Operands a) +shfl sop tR val delta = go tR val + where + delta' :: Operand Word32 + delta' = op integralType delta + + go :: TypeR s -> Operands s -> CodeGen PTX (Operands s) + go TupRunit OP_Unit = return OP_Unit + go (TupRpair aR bR) (OP_Pair a b) = OP_Pair <$> go aR a <*> go bR b + go (TupRsingle t) a = scalar t a + + scalar :: ScalarType s -> Operands s -> CodeGen PTX (Operands s) + scalar (SingleScalarType t) = single t + scalar (VectorScalarType t) = vector t + + single :: SingleType s -> Operands s -> CodeGen PTX (Operands s) + single (NumSingleType t) = num t + + vector :: forall n s. VectorType (Vec n s) -> Operands (Vec n s) -> CodeGen PTX (Operands (Vec n s)) + vector v@(VectorType w t) a + | SingleDict <- singleDict t + = let bytes = sizeOf (undefined::s) + (m,r) = P.quotRem (w * bytes) 4 + + withSomeNat :: Int -> (forall m. KnownNat m => Proxy m -> b) -> b + withSomeNat n k = + case someNatVal (toInteger n) of + Nothing -> error "Welcome to overthinkers club. The first rule of overthinkers club is: yet to be decided." + Just (SomeNat p) -> k p + in + if r == 0 + -- bitcast into a vector + -- special case for a single element vector + then + if m == 1 + then do + b <- A.bitcast (VectorScalarType v) (scalarType @Int32) a + c <- integral (integralType @Int32) b + d <- A.bitcast scalarType (VectorScalarType v) c + return d + + else + let + vec :: forall m. KnownNat m => Proxy m -> CodeGen PTX (Operands (Vec n s)) + vec _ = do + let v' = VectorType m (singleType @Int32) + + b <- A.bitcast (VectorScalarType v) (VectorScalarType v') a + + let c = op v' b + + repack :: Int32 -> CodeGen PTX (Operands (Vec m Int32)) + repack 0 = return $ ir v' (A.undef (VectorScalarType v')) + repack i = do + d <- instr $ ExtractElement (i-1) c + e <- integral integralType d + f <- repack (i-1) + g <- instr $ InsertElement (i-1) (op v' f) (op integralType e) + return g + + h <- repack (P.fromIntegral m) + i <- A.bitcast (VectorScalarType v') (VectorScalarType v) h + return i + in + withSomeNat m vec + + -- Round up to the next multiple of 32: + -- + -- 1. bitcast to an integer of the same number of bits: e.g. bitcast <3 x i16> i48 + -- 2. extend that to the next multiple of 32: e.g. zext i48 i64 + -- 3. bitcast to : e.g. bitcast i64 <2 x i32> + -- + else + let raw :: LP.Type -> LP.Instr -> CodeGen PTX (LP.Typed LP.Value) + raw ty ins = do + name <- freshLocalName + instr_ (LP.Result (nameToPrettyI name) ins [] []) + return (LP.Typed ty (LP.ValIdent (nameToPrettyI name))) + + rawUp :: Type u -> LP.Instr -> CodeGen PTX (Operand u) + rawUp ty ins = do + name <- freshLocalName + instr_ (LP.Result (nameToPrettyI name) ins [] []) + return (LocalReference ty name) + + + vec :: forall m. KnownNat m => Proxy m -> CodeGen PTX (Operands (Vec n s)) + vec _ = do + let t0Up :: Type (Vec n s) + t0Up = PrimType (ScalarPrimType (VectorScalarType v)) + t0 = downcast t0Up + + t1 = LP.PrimType (LP.Integer (P.fromIntegral ((w*bytes) * 8))) + t2 = LP.PrimType (LP.Integer (P.fromIntegral ((m+1) * 4 * 8))) + + v' :: VectorType (Vec m Int32) + v' = VectorType (m+1) (singleType @Int32) + t3Up :: Type (Vec m Int32) + t3Up = PrimType (ScalarPrimType (VectorScalarType v')) + t3 = downcast t3Up + + b <- raw t1 (LP.Conv LP.BitCast (downcast (op v a)) t1) + c <- raw t2 (LP.Conv (LP.ZExt False) b t2) + d <- rawUp t3Up (LP.Conv LP.BitCast c t3) + e <- vector v' (ir v' d) + f <- raw t2 (LP.Conv LP.BitCast (downcast (op v' e)) t2) + g <- raw t1 (LP.Conv (LP.Trunc False False) f t1) + h <- rawUp t0Up (LP.Conv LP.BitCast g t0) + return (ir v h) + in + withSomeNat (m+1) vec + + num :: NumType s -> Operands s -> CodeGen PTX (Operands s) + num (IntegralNumType t) = integral t + num (FloatingNumType t) = floating t + + integral :: forall s. IntegralType s -> Operands s -> CodeGen PTX (Operands s) + integral TypeInt32 a = shfl_op sop ShuffleInt32 delta' a + integral t a + | IntegralDict <- integralDict t + = case finiteBitSize (undefined::s) of + 64 -> do + let ta = SingleScalarType (NumSingleType (IntegralNumType t)) + tb = scalarType @(Vec 2 Int32) + -- + b <- A.bitcast ta tb a + c <- vector (VectorType 2 singleType) b + d <- A.bitcast tb ta c + return d + + _ -> do + b <- A.fromIntegral t (numType @Int32) a + c <- integral integralType b + d <- A.fromIntegral integralType (IntegralNumType t) c + return d + + floating :: FloatingType s -> Operands s -> CodeGen PTX (Operands s) + floating TypeFloat a = shfl_op sop ShuffleFloat delta' a + floating TypeDouble a = do + b <- A.bitcast scalarType (scalarType @(Vec 2 Int32)) a + c <- vector (VectorType 2 singleType) b + d <- A.bitcast scalarType (scalarType @Double) c + return d + floating TypeHalf a = do + b <- A.bitcast scalarType (scalarType @Int16) a + c <- integral integralType b + d <- A.bitcast scalarType (scalarType @Half) c + return d + + +data ShuffleType a where + ShuffleInt32 :: ShuffleType Int32 + ShuffleFloat :: ShuffleType Float + +shfl_op + :: forall a. + ShuffleOp + -> ShuffleType a + -> Operand Word32 -- delta + -> Operands a -- value to give + -> CodeGen PTX (Operands a) -- value received +shfl_op sop t delta val = do + dev <- liftCodeGen $ asks ptxDeviceProperties + + let + -- The CUDA __shfl* instruction take an optional final parameter + -- which is the warp size. Setting this value to something (always + -- a power-of-two) other than 32 emulates the shfl behaviour at that + -- warp size. Behind the scenes, a bunch of instructions happen with + -- this width parameter before they get passed into the actual shfl + -- instruction. Here, we have to directly set them to the 'actual' + -- width parameter. The formula that clang compiles to is in the + -- comments + -- + width :: Operand Int32 + width = case sop of + Up -> A.integral integralType 0 -- ((32 - warpSize) `shiftL` 8) + Down -> A.integral integralType 31 -- ((32 - warpSize) `shiftL` 8) `or` 31 + Idx -> A.integral integralType 31 -- ((32 - warpSize) `shiftL` 8) `or` 31 + XOR -> A.integral integralType 31 -- ((32 - warpSize) `shiftL` 8) `or` 31 + + -- Starting CUDA 9.0, the normal `shfl` primitives are deprecated in + -- favour of the newer `shfl_sync` primitives. They behave the same + -- way, except they start with a 'mask' argument specifying which + -- threads participate in the shuffle. + -- + mask :: Operand Int32 + mask = A.integral integralType (-1) -- all threads participate + + useSyncShfl = CUDA.computeCapability dev >= Compute 7 0 + + call' = if useSyncShfl + then call . Lam primType mask + else call + + sync = if useSyncShfl then "sync." else "" + asm = "llvm.nvvm.shfl." + <> sync + <> case sop of + Idx -> "idx." + Up -> "up." + Down -> "down." + XOR -> "bfly." + <> case t of + ShuffleInt32 -> "i32" + ShuffleFloat -> "f32" + + t_val = case t of + ShuffleInt32 -> primType :: PrimType Int32 + ShuffleFloat -> primType :: PrimType Float + + call' (Lam t_val (op t_val val) (Lam primType delta (Lam primType width (Body (PrimType t_val) (Just Tail) asm)))) [Convergent, NoUnwind, InaccessibleMemOnly] + + +-- Shared memory +-- ------------- + +sharedMemAddrSpace :: AddrSpace +sharedMemAddrSpace = AddrSpace 3 + +sharedMemVolatility :: Volatility +sharedMemVolatility = Volatile + + +-- Declare a new statically allocated array in the __shared__ memory address +-- space, with enough storage to contain the given number of elements. +-- +-- Previously, like initialiseDynamicSharedMemory, this function declared an +-- external global, e.g. for 1 i64: +-- @sdata = external addrspace(3) global [1 x i64], align 8 +-- This would correspond to the following CUDA source: +-- extern __shared__ int64_t sdata[1]; +-- +-- But this CUDA C++ is rejected by Clang. When LLVM is fed LLVM IR, however, +-- things are more subtle; in the old llvm-hs backend where we linked against +-- LLVM, with LLVM 15, the above IR (defining @0) was accepted. However, +-- passing this same IR to Clang 18 with the llvm-pretty backend (yes I'm aware +-- the clang version is also changing here), clang first calls ptxas and then +-- nvlink; nvlink complains: +-- Undefined reference to 'sdata' in '/tmp/test-409abe.cubin' +-- When linking against LLVM 15, nvlink is never invoked, but instead ptxas is +-- _not_ given the -c flag and it immediately produces a SASS file. +-- +-- Because Clang doesn't even accept the corresponding C++ code, but does +-- accept this: +-- __shared__ int64_t sdata[1]; +-- the global created in this function was changed to be of internal linkage +-- instead. The assigned value is 'undef', just like what Clang generates for +-- the internal sdata C++ declaration. +staticSharedMem + :: TypeR e + -> Word64 + -> CodeGen PTX (IRArray (Vector e)) +staticSharedMem tp n = do + ad <- go tp + return $ IRArray { irArrayRepr = ArrayR dim1 tp + , irArrayShape = OP_Pair OP_Unit $ OP_Int $ A.integral integralType $ P.fromIntegral n + , irArrayData = ad + , irArrayAddrSpace = sharedMemAddrSpace + , irArrayVolatility = sharedMemVolatility + } + where + go :: TypeR s -> CodeGen PTX (Operands s) + go TupRunit = return OP_Unit + go (TupRpair t1 t2) = OP_Pair <$> go t1 <*> go t2 + go tt@(TupRsingle t) = do + -- Declare a new global reference for the statically allocated array + -- located in the __shared__ memory space. + nm <- freshGlobalName + let arrt = ArrayPrimType n t + ptrarrt = PrimType (PtrPrimType arrt sharedMemAddrSpace) + sm <- return $ ConstantOperand $ GlobalReference ptrarrt nm + declareGlobalVar $ LP.Global + { LP.globalSym = nameToPrettyS nm + , LP.globalAttrs = LP.GlobalAttrs + { LP.gaLinkage = Just LP.Internal + , LP.gaVisibility = Nothing + , LP.gaAddrSpace = sharedMemAddrSpace + , LP.gaConstant = False } + , LP.globalType = LP.Array n (downcast t) + , LP.globalValue = Just LP.ValUndef + , LP.globalAlign = Just (4 `P.max` P.fromIntegral (bytesElt tt)) + , LP.globalMetadata = mempty + } + + -- Return a pointer to the first element of the __shared__ memory array. + -- We do this rather than just returning the global reference directly due + -- to how __shared__ memory needs to be indexed with the GEP instruction. + p <- instr' $ GetElementPtr (GEP (PrimType arrt) sm (A.num numType 0 :: Operand Int32) + (GEPArray (A.num numType 0 :: Operand Int32) (GEPEmpty (ScalarPrimType t)))) + q <- instr' $ PtrCast (PtrPrimType (ScalarPrimType t) sharedMemAddrSpace) p + + return $ ir t (unPtr q) + + +-- External declaration in shared memory address space. This must be declared in +-- order to access memory allocated dynamically by the CUDA driver. This results +-- in the following global declaration: +-- +-- > @__shared__ = external addrspace(3) global [0 x i8] +-- +initialiseDynamicSharedMemory :: CodeGen PTX (Operand (Ptr Int8)) +initialiseDynamicSharedMemory = do + declareGlobalVar $ LP.Global + { LP.globalSym = LP.Symbol "__shared__" + , LP.globalAttrs = LP.GlobalAttrs + { LP.gaLinkage = Just LP.External + , LP.gaVisibility = Nothing + , LP.gaAddrSpace = sharedMemAddrSpace + , LP.gaConstant = False } + , LP.globalType = LP.Array 0 (LP.PrimType (LP.Integer 8)) + , LP.globalValue = Nothing + , LP.globalAlign = Nothing + , LP.globalMetadata = mempty + } + return $ ConstantOperand + $ ConstantGetElementPtr (GEP (PrimType (ArrayPrimType 0 (scalarType @Int8))) + (GlobalReference (PrimType (PtrPrimType (ArrayPrimType 0 scalarType) sharedMemAddrSpace)) "__shared__") + (ScalarConstant (scalarType @Int32) 0) + (GEPArray (ScalarConstant (scalarType @Int32) 0) (GEPEmpty primType))) + +sharedMemorySizeAdd + :: TypeR e + -> Int -- number of array elements + -> Int -- #bytes of shared memory the have already been allocated + -> Int +sharedMemorySizeAdd tp n i = case tp of + TupRunit -> i + TupRpair t2 t1 -> + -- First handle the second element of the tuple, then the first, + -- to match the behaviour of dynamicSharedMem + sharedMemorySizeAdd t2 n $ sharedMemorySizeAdd t1 n i + TupRsingle t -> + let + bytes = bytesElt tp + -- Align 'i' to the alignment of t + aligned = alignTo (scalarAlignment t) i + in + aligned + bytes * n + +-- Declare a new dynamically allocated array in the __shared__ memory space +-- with enough space to contain the given number of elements. +-- +dynamicSharedMem + :: forall e int. + TypeR e + -> IntegralType int + -> Operands int -- number of array elements + -> Operands int -- #bytes of shared memory that have already been allocated + -> CodeGen PTX (IRArray (Vector e)) +dynamicSharedMem tp int n@(op int -> m) (op int -> offset) + | IntegralDict <- integralDict int = do + smem <- initialiseDynamicSharedMemory + let + numTp = IntegralNumType int + + go :: TypeR s -> Operand int -> CodeGen PTX (Operand int, Operands s) + go TupRunit i = return (i, OP_Unit) + go (TupRpair t2 t1) i0 = do + (i1, p1) <- go t1 i0 + (i2, p2) <- go t2 i1 + return $ (i2, OP_Pair p2 p1) + go (TupRsingle t) i = do + let bytes = bytesElt (TupRsingle t) + let align = scalarAlignment t + i' <- instr' $ Add numTp i (A.integral int $ P.fromIntegral $ align - 1) + aligned <- instr' $ BAnd int i' (A.integral int $ P.fromIntegral $ Data.Bits.complement $ align - 1) + p <- instr' $ GetElementPtr (GEP1 scalarType smem aligned) + q <- instr' $ PtrCast (PtrPrimType (ScalarPrimType t) sharedMemAddrSpace) p + a <- instr' $ Mul numTp m (A.integral int (P.fromIntegral bytes)) + b <- instr' $ Add numTp aligned a + return (b, ir t (unPtr q)) + -- + (_, ad) <- go tp offset + sz <- A.fromIntegral int (numType :: NumType Int) n + return $ IRArray { irArrayRepr = ArrayR dim1 tp + , irArrayShape = OP_Pair OP_Unit sz + , irArrayData = ad + , irArrayAddrSpace = sharedMemAddrSpace + , irArrayVolatility = sharedMemVolatility + } + + +-- Other functions +-- --------------- + +-- Sleep the thread for (approximately) the given number of nanoseconds. +-- Requires compute capability >= 7.0 +-- +nanosleep :: Operands Int32 -> CodeGen PTX () +nanosleep ns = do + -- This is an acc prelude function because it requires inline assembly, and + -- llvm-pretty does not yet support caling inline assembly snippets. Thus we + -- manually wrap the assembly in an inlineable function and call that. + let label = makeAccPreludeLabel "nanosleep" + void $ instr (Call (Lam primType (op integralType ns) (Body VoidType (Just Tail) (Right label)))) + + +-- Global kernel definitions +-- ------------------------- + +data instance KernelMetadata PTX = KM_PTX LaunchConfig + +-- | Combine kernels into a single program +-- +(+++) :: IROpenAcc PTX aenv a -> IROpenAcc PTX aenv a -> IROpenAcc PTX aenv a +IROpenAcc k1 +++ IROpenAcc k2 = IROpenAcc (k1 ++ k2) + + +-- | Create a single kernel program with the default launch configuration. +-- +makeOpenAcc + :: UID + -> Label + -> [LP.Typed LP.Ident] + -> CodeGen PTX () + -> CodeGen PTX (IROpenAcc PTX aenv a) +makeOpenAcc uid name param kernel = do + dev <- liftCodeGen $ asks ptxDeviceProperties + makeOpenAccWith (simpleLaunchConfig dev) uid name param kernel + +-- | Create a single kernel program with the given launch analysis information. +-- +makeOpenAccWith + :: LaunchConfig + -> UID + -> Label + -> [LP.Typed LP.Ident] + -> CodeGen PTX () + -> CodeGen PTX (IROpenAcc PTX aenv a) +makeOpenAccWith config uid name param kernel = do + body <- makeKernel config (name <> fromString ('_' : show uid)) param kernel + return $ IROpenAcc [body] + +-- | Create a complete kernel function by running the code generation process +-- specified in the final parameter. +-- +makeKernel + :: LaunchConfig + -> Label + -> [LP.Typed LP.Ident] + -> CodeGen PTX () + -> CodeGen PTX (Kernel PTX aenv a) +makeKernel config name param kernel = do + _ <- kernel + code <- createBlocks + let define = LP.Define + { LP.defLinkage = Nothing + , LP.defVisibility = Nothing + , LP.defRetType = LP.PrimType LP.Void + , LP.defName = labelToPrettyS name + , LP.defArgs = param + , LP.defVarArgs = False + , LP.defAttrs = [] + , LP.defSection = Nothing + , LP.defGC = Nothing + , LP.defBody = code + , LP.defMetadata = mempty + , LP.defComdat = Nothing + } + addMetadata "nvvm.annotations" + [ Just . MetadataConstantOperand + $ LP.Typed (LP.defFunType define) (LP.ValSymbol (labelToPrettyS name)) + , Just . MetadataStringOperand $ "kernel" + , Just . MetadataConstantOperand $ LP.Typed (LP.PrimType (LP.Integer 32)) (LP.ValInteger 1) + ] + return $ Kernel + { kernelMetadata = KM_PTX config + , unKernel = define + } + +scalarAlignment :: ScalarType t -> Int +scalarAlignment t@(SingleScalarType _) = bytesElt (TupRsingle t) +scalarAlignment (VectorScalarType (VectorType _ t)) = bytesElt (TupRsingle $ SingleScalarType t) + +-- Align 'ptr' to the given alignment. +-- Assumes 'align' is a power of 2. +alignTo :: Int -> Int -> Int +alignTo align ptr = (ptr + align - 1) .&. Data.Bits.complement (align - 1) diff --git a/src/Data/Array/Accelerate/LLVM/PTX/CodeGen/Fold.hs b/src/Data/Array/Accelerate/LLVM/PTX/CodeGen/Fold.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/PTX/CodeGen/Fold.hs @@ -0,0 +1,616 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.PTX.CodeGen.Fold +-- Copyright : [2016..2020] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.PTX.CodeGen.Fold + where + +import Data.Array.Accelerate.Representation.Array +import Data.Array.Accelerate.Representation.Shape hiding ( size ) +import Data.Array.Accelerate.Representation.Type + +import Data.Array.Accelerate.LLVM.CodeGen.Arithmetic as A +import Data.Array.Accelerate.LLVM.CodeGen.Array +import Data.Array.Accelerate.LLVM.CodeGen.Base +import Data.Array.Accelerate.LLVM.CodeGen.Constant +import Data.Array.Accelerate.LLVM.CodeGen.Environment +import Data.Array.Accelerate.LLVM.CodeGen.Exp +import Data.Array.Accelerate.LLVM.CodeGen.IR +import Data.Array.Accelerate.LLVM.CodeGen.Loop as Loop +import Data.Array.Accelerate.LLVM.CodeGen.Monad +import Data.Array.Accelerate.LLVM.CodeGen.Sugar +import Data.Array.Accelerate.LLVM.Compile.Cache + +import Data.Array.Accelerate.LLVM.PTX.Analysis.Launch +import Data.Array.Accelerate.LLVM.PTX.CodeGen.Base +import Data.Array.Accelerate.LLVM.PTX.CodeGen.Generate +import Data.Array.Accelerate.LLVM.PTX.Target + +import LLVM.AST.Type.Representation + +import qualified Foreign.CUDA.Analysis as CUDA + +import Control.Monad ( (>=>) ) +import Control.Monad.Reader ( asks ) +import Data.String ( fromString ) +import Data.Bits as P +import Prelude as P + + +-- Reduce an array along the innermost dimension. The reduction function must be +-- associative to allow for an efficient parallel implementation, but the +-- initial element does /not/ need to be a neutral element of operator. +-- +-- TODO: Specialise for commutative operations (such as (+)) and those with +-- a neutral element {(+), 0} +-- +mkFold + :: forall aenv sh e. + UID + -> Gamma aenv + -> ArrayR (Array sh e) + -> IRFun2 PTX aenv (e -> e -> e) + -> Maybe (IRExp PTX aenv e) + -> MIRDelayed PTX aenv (Array (sh, Int) e) + -> CodeGen PTX (IROpenAcc PTX aenv (Array sh e)) +mkFold uid aenv repr f z acc = case z of + Just z' -> (+++) <$> codeFold <*> mkFoldFill uid aenv repr z' + Nothing -> codeFold + where + codeFold = case repr of + ArrayR ShapeRz tp -> mkFoldAll uid aenv tp f z acc + _ -> mkFoldDim uid aenv repr f z acc + + +-- Reduce an array to a single element. +-- +-- Since reductions consume arrays that have been fused into them, parallel +-- reduction requires two separate kernels. At an example, take vector dot +-- product: +-- +-- > dotp xs ys = fold (+) 0 (zipWith (*) xs ys) +-- +-- 1. The first pass reads in the fused array data, in this case corresponding +-- to the function (\i -> (xs!i) * (ys!i)). +-- +-- 2. The second pass reads in the manifest array data from the first step and +-- directly reduces the array. This can be done recursively in-place until +-- only a single element remains. +-- +-- In both phases, thread blocks cooperatively reduce a stripe of the input (one +-- element per thread) to a single element, which is stored to the output array. +-- +mkFoldAll + :: forall aenv e. + UID + -> Gamma aenv -- ^ array environment + -> TypeR e + -> IRFun2 PTX aenv (e -> e -> e) -- ^ combination function + -> MIRExp PTX aenv e -- ^ (optional) initial element for exclusive reductions + -> MIRDelayed PTX aenv (Vector e) -- ^ input data + -> CodeGen PTX (IROpenAcc PTX aenv (Scalar e)) +mkFoldAll uid aenv tp combine mseed macc = do + dev <- liftCodeGen $ asks ptxDeviceProperties + foldr1 (+++) <$> sequence [ mkFoldAllS uid dev aenv tp combine mseed macc + , mkFoldAllM1 uid dev aenv tp combine macc + , mkFoldAllM2 uid dev aenv tp combine mseed + ] + + +-- Reduction to an array to a single element, for small arrays which can be +-- processed by a single thread block. +-- +mkFoldAllS + :: forall aenv e. + UID + -> DeviceProperties -- ^ properties of the target GPU + -> Gamma aenv -- ^ array environment + -> TypeR e + -> IRFun2 PTX aenv (e -> e -> e) -- ^ combination function + -> MIRExp PTX aenv e -- ^ (optional) initial element for exclusive reductions + -> MIRDelayed PTX aenv (Vector e) -- ^ input data + -> CodeGen PTX (IROpenAcc PTX aenv (Scalar e)) +mkFoldAllS uid dev aenv tp combine mseed marr = + let + (arrOut, paramOut) = mutableArray (ArrayR dim0 tp) "out" + (arrIn, paramIn) = delayedArray "in" marr + paramEnv = envParam aenv + -- + config = launchConfig dev (CUDA.incWarp dev) smem multipleOf multipleOfQ + smem n = sharedMemorySizeAdd tp warps 0 + where + ws = CUDA.warpSize dev + warps = n `P.quot` ws + in + makeOpenAccWith config uid "foldAllS" (paramOut ++ paramIn ++ paramEnv) $ do + + tid <- threadIdx + bd <- blockDim + + sh <- delayedExtent arrIn + end <- shapeSize dim1 sh + + -- We can assume that there is only a single thread block + start' <- return (liftInt32 0) + end' <- i32 end + i0 <- A.add numType start' tid + sz <- A.sub numType end' start' + when (A.lt singleType i0 sz) $ do + + -- Thread reads initial element and then participates in block-wide + -- reduction. + x0 <- app1 (delayedLinearIndex arrIn) =<< int i0 + r0 <- if (tp, A.eq singleType sz bd) + then reduceBlock dev tp combine Nothing x0 + else reduceBlock dev tp combine (Just sz) x0 + + when (A.eq singleType tid (liftInt32 0)) $ + writeArray TypeInt32 arrOut tid =<< + case mseed of + Nothing -> return r0 + Just z -> flip (app2 combine) r0 =<< z -- Note: initial element on the left + + return_ + + +-- Reduction of an entire array to a single element. This kernel implements step +-- one for reducing large arrays which must be processed by multiple thread +-- blocks. +-- +mkFoldAllM1 + :: forall aenv e. + UID + -> DeviceProperties -- ^ properties of the target GPU + -> Gamma aenv -- ^ array environment + -> TypeR e + -> IRFun2 PTX aenv (e -> e -> e) -- ^ combination function + -> MIRDelayed PTX aenv (Vector e) -- ^ input data + -> CodeGen PTX (IROpenAcc PTX aenv (Scalar e)) +mkFoldAllM1 uid dev aenv tp combine marr = + let + (arrTmp, paramTmp) = mutableArray (ArrayR dim1 tp) "tmp" + (arrIn, paramIn) = delayedArray "in" marr + paramEnv = envParam aenv + start = liftInt 0 + -- + config = launchConfig dev (CUDA.incWarp dev) smem const [|| const ||] + smem n = sharedMemorySizeAdd tp warps 0 + where + ws = CUDA.warpSize dev + warps = n `P.quot` ws + in + makeOpenAccWith config uid "foldAllM1" (paramTmp ++ paramIn ++ paramEnv) $ do + + -- Each thread block cooperatively reduces a stripe of the input and stores + -- that value into a temporary array at a corresponding index. Since the + -- order of operations remains fixed, this method supports non-commutative + -- reductions. + -- + tid <- threadIdx + bd <- int =<< blockDim + sz <- indexHead <$> delayedExtent arrIn + end <- shapeSize dim1 (irArrayShape arrTmp) + + imapFromTo start end $ \seg -> do + + -- Wait for all threads to catch up before beginning the stripe + __syncthreads + + -- Bounds of the input array we will reduce between + from <- A.mul numType seg bd + step <- A.add numType from bd + to <- A.min singleType sz step + + -- Threads cooperatively reduce this stripe + reduceFromTo dev tp from to combine + (app1 (delayedLinearIndex arrIn)) + (when (A.eq singleType tid (liftInt32 0)) . writeArray TypeInt arrTmp seg) + + return_ + + +-- Reduction of an array to a single element, (recursive) step 2 of multi-block +-- reduction algorithm. +-- +mkFoldAllM2 + :: forall aenv e. + UID + -> DeviceProperties + -> Gamma aenv + -> TypeR e + -> IRFun2 PTX aenv (e -> e -> e) + -> MIRExp PTX aenv e + -> CodeGen PTX (IROpenAcc PTX aenv (Scalar e)) +mkFoldAllM2 uid dev aenv tp combine mseed = + let + (arrTmp, paramTmp) = mutableArray (ArrayR dim1 tp) "tmp" + (arrOut, paramOut) = mutableArray (ArrayR dim1 tp) "out" + paramEnv = envParam aenv + start = liftInt 0 + -- + config = launchConfig dev (CUDA.incWarp dev) smem const [|| const ||] + smem n = sharedMemorySizeAdd tp warps 0 + where + ws = CUDA.warpSize dev + warps = n `P.quot` ws + in + makeOpenAccWith config uid "foldAllM2" (paramTmp ++ paramOut ++ paramEnv) $ do + + -- Threads cooperatively reduce a stripe of the input (temporary) array + -- output from the first phase, storing the results into another temporary. + -- When only a single thread block remains, we have reached the final + -- reduction step and add the initial element (for exclusive reductions). + -- + tid <- threadIdx + gd <- gridDim + bd <- int =<< blockDim + sz <- return $ indexHead (irArrayShape arrTmp) + end <- shapeSize dim1 (irArrayShape arrOut) + + imapFromTo start end $ \seg -> do + + -- Wait for all threads to catch up before beginning the stripe + __syncthreads + + -- Bounds of the input we will reduce between + from <- A.mul numType seg bd + step <- A.add numType from bd + to <- A.min singleType sz step + + -- Threads cooperatively reduce this stripe + reduceFromTo dev tp from to combine (readArray TypeInt arrTmp) $ \r -> + when (A.eq singleType tid (liftInt32 0)) $ + writeArray TypeInt arrOut seg =<< + case mseed of + Nothing -> return r + Just z -> if (tp, A.eq singleType gd (liftInt32 1)) + then flip (app2 combine) r =<< z -- Note: initial element on the left + else return r + + return_ + + +-- Reduce an array of arbitrary rank along the innermost dimension only. +-- +-- For simplicity, each element of the output (reduction along an +-- innermost-dimension index) is computed by a single thread block, meaning we +-- don't have to worry about inter-block synchronisation. A more balanced method +-- would be a segmented reduction (specialised, since the length of each segment +-- is known a priori). +-- +mkFoldDim + :: forall aenv sh e. + UID + -> Gamma aenv -- ^ array environment + -> ArrayR (Array sh e) + -> IRFun2 PTX aenv (e -> e -> e) -- ^ combination function + -> MIRExp PTX aenv e -- ^ (optional) seed element, if this is an exclusive reduction + -> MIRDelayed PTX aenv (Array (sh, Int) e) -- ^ input data + -> CodeGen PTX (IROpenAcc PTX aenv (Array sh e)) +mkFoldDim uid aenv repr@(ArrayR shr tp) combine mseed marr = do + dev <- liftCodeGen $ asks ptxDeviceProperties + -- + let + (arrOut, paramOut) = mutableArray repr "out" + (arrIn, paramIn) = delayedArray "in" marr + paramEnv = envParam aenv + -- + config = launchConfig dev (CUDA.incWarp dev) smem const [|| const ||] + smem n = sharedMemorySizeAdd tp warps 0 + where + ws = CUDA.warpSize dev + warps = n `P.quot` ws + -- + makeOpenAccWith config uid "fold" (paramOut ++ paramIn ++ paramEnv) $ do + + -- If the innermost dimension is smaller than the number of threads in the + -- block, those threads will never contribute to the output. + tid <- threadIdx + sz <- indexHead <$> delayedExtent arrIn + sz' <- i32 sz + + when (A.lt singleType tid sz') $ do + + start <- return (liftInt 0) + end <- shapeSize shr (irArrayShape arrOut) + + -- Thread blocks iterate over the outer dimensions, each thread block + -- cooperatively reducing along each outermost index to a single value. + -- + imapFromTo start end $ \seg -> do + + -- Wait for threads to catch up before starting this segment. We could + -- also place this at the bottom of the loop, but here allows threads to + -- exit quickly on the last iteration. + __syncthreads + + -- Step 1: initialise local sums + from <- A.mul numType seg sz -- first linear index this block will reduce + to <- A.add numType from sz -- last linear index this block will reduce (exclusive) + + i0 <- A.add numType from =<< int tid + x0 <- app1 (delayedLinearIndex arrIn) i0 + bd <- blockDim + r0 <- if (tp, A.gte singleType sz' bd) + then reduceBlock dev tp combine Nothing x0 + else reduceBlock dev tp combine (Just sz') x0 + + -- Step 2: keep walking over the input + bd' <- int bd + next <- A.add numType from bd' + r <- iterFromStepTo tp next bd' to r0 $ \offset r -> do + + -- Wait for all threads to catch up before starting the next stripe + __syncthreads + + -- Threads cooperatively reduce this stripe of the input + i <- A.add numType offset =<< int tid + v' <- A.sub numType to offset + r' <- if (tp, A.gte singleType v' bd') + -- All threads of the block are valid, so we can avoid + -- bounds checks. + then do + x <- app1 (delayedLinearIndex arrIn) i + y <- reduceBlock dev tp combine Nothing x + return y + + -- Otherwise, we require bounds checks when reading the input + -- and during the reduction. Note that even though only the + -- valid threads will contribute useful work in the + -- reduction, we must still have all threads enter the + -- reduction procedure to avoid synchronisation divergence. + else do + x <- if (tp, A.lt singleType i to) + then app1 (delayedLinearIndex arrIn) i + else let + go :: TypeR a -> Operands a + go TupRunit = OP_Unit + go (TupRpair a b) = OP_Pair (go a) (go b) + go (TupRsingle t) = ir t (undef t) + in + return $ go tp + + v <- i32 v' + y <- reduceBlock dev tp combine (Just v) x + return y + + if (tp, A.eq singleType tid (liftInt32 0)) + then app2 combine r r' + else return r' + + -- Step 3: Thread 0 writes the aggregate reduction of this dimension to + -- memory. If this is an exclusive fold, combine with the initial element. + -- + when (A.eq singleType tid (liftInt32 0)) $ + writeArray TypeInt arrOut seg =<< + case mseed of + Nothing -> return r + Just z -> flip (app2 combine) r =<< z -- Note: initial element on the left + + return_ + + +-- Exclusive reductions over empty arrays (of any dimension) fill the lower +-- dimensions with the initial element. +-- +mkFoldFill + :: UID + -> Gamma aenv + -> ArrayR (Array sh e) + -> IRExp PTX aenv e + -> CodeGen PTX (IROpenAcc PTX aenv (Array sh e)) +mkFoldFill uid aenv repr seed = + mkGenerate uid aenv repr (IRFun1 (const seed)) + + +-- Efficient threadblock-wide reduction using the specified operator. The +-- aggregate reduction value is stored in thread zero. Supports non-commutative +-- operators. +-- +-- Requires dynamically allocated memory: (#warps * (1 + 1.5 * warp size)). +-- +-- Example: https://github.com/NVlabs/cub/blob/1.5.2/cub/block/specializations/block_reduce_warp_reductions.cuh +-- +reduceBlock + :: forall aenv e. + DeviceProperties -- ^ properties of the target device + -> TypeR e + -> IRFun2 PTX aenv (e -> e -> e) -- ^ combination function + -> Maybe (Operands Int32) -- ^ number of valid elements (may be less than block size) + -> Operands e -- ^ calling thread's input element + -> CodeGen PTX (Operands e) -- ^ thread-block-wide reduction using the specified operator (lane 0 only) +reduceBlock dev tp combine size = warpReduce >=> warpAggregate + where + int32 :: Integral a => a -> Operands Int32 + int32 = liftInt32 . P.fromIntegral + + -- Step 1: Reduction in every warp + -- + warpReduce :: Operands e -> CodeGen PTX (Operands e) + warpReduce input = do + wid <- warpId + -- Are we doing bounds checking for this warp? + case size of + -- The entire thread block is valid, so skip bounds checks. + Nothing -> reduceWarp dev tp combine Nothing input + + -- Otherwise check how many elements are valid for this warp. If it is + -- full then we can still skip bounds checks for it. + Just n -> do + offset <- A.mul numType wid (int32 (CUDA.warpSize dev)) + valid <- A.sub numType n offset + if (tp, A.gte singleType valid (int32 (CUDA.warpSize dev))) + then reduceWarp dev tp combine Nothing input + else reduceWarp dev tp combine (Just valid) input + + -- Step 2: Aggregate per-warp reductions + -- + warpAggregate :: Operands e -> CodeGen PTX (Operands e) + warpAggregate input = do + -- Allocate #warps elements of shared memory + bd <- blockDim + warps <- A.quot integralType bd (int32 (CUDA.warpSize dev)) + smem <- dynamicSharedMem tp TypeInt32 warps (liftInt32 0) + + -- Share the per-lane aggregates + wid <- warpId + lane <- laneId + when (A.eq singleType lane (liftInt32 0)) $ do + writeArray TypeInt32 smem wid input + + -- Wait for each warp to finish its local reduction + __syncthreads + + -- -- Now, warp 0 will reduce all the warp-wide results. + -- -- TODO: this means that the block can only consist of 32 warps, + -- -- reducing 1024 elements total. Check if this gets handled by callers! + -- if (tp, A.eq singleType wid (liftInt32 0)) + -- then warpReduce input + -- else + -- return input + + -- Update the total aggregate. Thread 0 just does this sequentially (as is + -- done in CUB), but we could also do this cooperatively (better for + -- larger thread blocks?) + -- + tid <- threadIdx + if (tp, A.eq singleType tid (liftInt32 0)) + then do + steps <- case size of + Nothing -> return warps + Just n -> do + a <- A.add numType n (int32 (CUDA.warpSize dev - 1)) + b <- A.quot integralType a (int32 (CUDA.warpSize dev)) + return b + iterFromStepTo tp (liftInt32 1) (liftInt32 1) steps input $ \step x -> + app2 combine x =<< readArray TypeInt32 smem step + else + return input + + +-- Efficient warp-wide reduction using shared memory. The aggregate reduction +-- value for the warp is stored in thread lane zero. +-- +-- Each warp requires 48 (1.5 x warp size) elements of shared memory. The +-- routine assumes that is is allocated individually per-warp (i.e. can be +-- indexed in the range [0,warp size)). +-- +-- Example: https://github.com/NVlabs/cub/blob/1.5.2/cub/warp/specializations/warp_reduce_smem.cuh#L128 +-- +reduceWarp + :: forall e aenv. DeviceProperties + -> TypeR e + -> IRFun2 PTX aenv (e -> e -> e) -- ^ combination function + -> Maybe (Operands Int32) -- ^ number of items that will be reduced by this warp, otherwise all lanes are valid + -> Operands e -- ^ this thread's input value + -> CodeGen PTX (Operands e) -- ^ final result +reduceWarp dev typer combine size = reduce 0 + where + log2 :: Double -> Double + log2 = P.logBase 2 + + -- Number steps required to reduce warp + steps = P.floor . log2 . P.fromIntegral . CUDA.warpSize $ dev + + valid offset = do + lane <- laneId + i <- A.add numType lane (liftInt32 offset) + case size of + Nothing -> A.lt singleType i (liftInt32 (P.fromIntegral (CUDA.warpSize dev))) + Just n -> A.lt singleType i n + + -- Unfold the reduction as a recursive code generation function. + reduce :: Int -> Operands e -> CodeGen PTX (Operands e) + reduce step x + | step > steps = return x + | otherwise = do + let + offset :: (Bits i, Integral i) => i + offset = 1 `P.shiftL` step + + y <- __shfl_down typer x (liftWord32 offset) + x' <- if (typer, valid offset) + then app2 combine x y + else return x + reduce (step + 1) x' + + + +-- Reduction loops +-- --------------- + +reduceFromTo + :: DeviceProperties + -> TypeR a + -> Operands Int -- ^ starting index + -> Operands Int -- ^ final index (exclusive) + -> (IRFun2 PTX aenv (a -> a -> a)) -- ^ combination function + -> (Operands Int -> CodeGen PTX (Operands a)) -- ^ function to retrieve element at index + -> (Operands a -> CodeGen PTX ()) -- ^ what to do with the value + -> CodeGen PTX () +reduceFromTo dev tp from to combine get set = do + + tid <- int =<< threadIdx + bd <- int =<< blockDim + + valid <- A.sub numType to from + i <- A.add numType from tid + + _ <- if (TupRunit, A.gte singleType valid bd) + then do + -- All threads in the block will participate in the reduction, so + -- we can avoid bounds checks + x <- get i + r <- reduceBlock dev tp combine Nothing x + set r + + return (lift TupRunit ()) + else do + -- Only in-bounds threads can read their input and participate in + -- the reduction + when (A.lt singleType i to) $ do + x <- get i + v <- i32 valid + r <- reduceBlock dev tp combine (Just v) x + set r + + return (lift TupRunit ()) + + return () + + +-- Utilities +-- --------- + +i32 :: Operands Int -> CodeGen PTX (Operands Int32) +i32 = A.fromIntegral integralType numType + +int :: Operands Int32 -> CodeGen PTX (Operands Int) +int = A.fromIntegral integralType numType + +imapFromTo + :: Operands Int + -> Operands Int + -> (Operands Int -> CodeGen PTX ()) + -> CodeGen PTX () +imapFromTo start end body = do + bid <- int =<< blockIdx + gd <- int =<< gridDim + i0 <- A.add numType start bid + imapFromStepTo i0 gd end body + diff --git a/src/Data/Array/Accelerate/LLVM/PTX/CodeGen/FoldSeg.hs b/src/Data/Array/Accelerate/LLVM/PTX/CodeGen/FoldSeg.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/PTX/CodeGen/FoldSeg.hs @@ -0,0 +1,476 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.PTX.CodeGen.FoldSeg +-- Copyright : [2016..2020] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.PTX.CodeGen.FoldSeg + where + +import Data.Array.Accelerate.Representation.Array +import Data.Array.Accelerate.Representation.Shape +import Data.Array.Accelerate.Representation.Type + +import Data.Array.Accelerate.LLVM.CodeGen.Arithmetic as A +import Data.Array.Accelerate.LLVM.CodeGen.Array +import Data.Array.Accelerate.LLVM.CodeGen.Base +import Data.Array.Accelerate.LLVM.CodeGen.Constant +import Data.Array.Accelerate.LLVM.CodeGen.Environment +import Data.Array.Accelerate.LLVM.CodeGen.Exp +import Data.Array.Accelerate.LLVM.CodeGen.IR +import Data.Array.Accelerate.LLVM.CodeGen.Loop as Loop +import Data.Array.Accelerate.LLVM.CodeGen.Monad +import Data.Array.Accelerate.LLVM.CodeGen.Sugar +import Data.Array.Accelerate.LLVM.Compile.Cache + +import Data.Array.Accelerate.LLVM.PTX.Analysis.Launch +import Data.Array.Accelerate.LLVM.PTX.CodeGen.Base +import qualified Data.Array.Accelerate.LLVM.PTX.CodeGen.Fold as Fold ( reduceBlock, reduceWarp, imapFromTo ) +import Data.Array.Accelerate.LLVM.PTX.Target + +import LLVM.AST.Type.Representation + +import qualified Foreign.CUDA.Analysis as CUDA + +import Control.Monad ( void ) +import Control.Monad.Reader ( asks ) +import Data.String ( fromString ) +import Prelude as P + + +-- Segmented reduction along the innermost dimension of an array. Performs one +-- reduction per segment of the source array. +-- +mkFoldSeg + :: forall aenv sh i e. + UID + -> Gamma aenv + -> ArrayR (Array (sh, Int) e) + -> IntegralType i + -> IRFun2 PTX aenv (e -> e -> e) + -> Maybe (IRExp PTX aenv e) + -> MIRDelayed PTX aenv (Array (sh, Int) e) + -> MIRDelayed PTX aenv (Segments i) + -> CodeGen PTX (IROpenAcc PTX aenv (Array (sh, Int) e)) +mkFoldSeg uid aenv repr intTp combine seed arr seg = + (+++) <$> mkFoldSegP_block uid aenv repr intTp combine seed arr seg + <*> mkFoldSegP_warp uid aenv repr intTp combine seed arr seg + + +-- This implementation assumes that the segments array represents the offset +-- indices to the source array, rather than the lengths of each segment. The +-- segment-offset approach is required for parallel implementations. +-- +-- Each segment is computed by a single thread block, meaning we don't have to +-- worry about inter-block synchronisation. +-- +mkFoldSegP_block + :: forall aenv sh i e. + UID + -> Gamma aenv + -> ArrayR (Array (sh, Int) e) + -> IntegralType i + -> IRFun2 PTX aenv (e -> e -> e) + -> MIRExp PTX aenv e + -> MIRDelayed PTX aenv (Array (sh, Int) e) + -> MIRDelayed PTX aenv (Segments i) + -> CodeGen PTX (IROpenAcc PTX aenv (Array (sh, Int) e)) +mkFoldSegP_block uid aenv repr@(ArrayR shr tp) intTp combine mseed marr mseg = do + dev <- liftCodeGen $ asks ptxDeviceProperties + -- + let + (arrOut, paramOut) = mutableArray repr "out" + (arrIn, paramIn) = delayedArray "in" marr + (arrSeg, paramSeg) = delayedArray "seg" mseg + paramEnv = envParam aenv + -- + config = launchConfig dev (CUDA.decWarp dev) dsmem const [|| const ||] + dsmem n = sharedMemorySizeAdd tp warps 0 + where + ws = CUDA.warpSize dev + warps = n `P.quot` ws + -- + makeOpenAccWith config uid "foldSeg_block" (paramOut ++ paramIn ++ paramSeg ++ paramEnv) $ do + + -- We use a dynamically scheduled work queue in order to evenly distribute + -- the uneven workload, due to the variable length of each segment, over the + -- available thread blocks. + -- queue <- globalWorkQueue + + -- All threads in the block need to know what the start and end indices of + -- this segment are in order to participate in the reduction. We use + -- variables in __shared__ memory to communicate these values between + -- threads in the block. Furthermore, by using a 2-element array, we can + -- have the first two threads of the block read the start and end indices as + -- a single coalesced read, since they will be sequential in the + -- segment-offset array. + -- + smem <- staticSharedMem (TupRsingle scalarTypeInt) 2 + + -- Compute the number of segments and size of the innermost dimension. These + -- are required if we are reducing a rank-2 or higher array, to properly + -- compute the start and end indices of the portion of the array this thread + -- block reduces. Note that this is a segment-offset array computed by + -- 'scanl (+) 0' of the segment length array, so its size has increased by + -- one. + -- + sz <- indexHead <$> delayedExtent arrIn + ss <- do n <- indexHead <$> delayedExtent arrSeg + A.sub numType n (liftInt 1) + + -- Each thread block cooperatively reduces a segment. + -- s0 <- dequeue queue (lift 1) + -- for s0 (\s -> A.lt singleType s end) (\_ -> dequeue queue (lift 1)) $ \s -> do + + start <- return (liftInt 0) + end <- shapeSize shr (irArrayShape arrOut) + + Fold.imapFromTo start end $ \s -> do + + -- The first two threads of the block determine the indices of the + -- segments array that we will reduce between and distribute those values + -- to the other threads in the block. + tid <- threadIdx + when (A.lt singleType tid (liftInt32 2)) $ do + i <- case shr of + ShapeRsnoc ShapeRz -> return s + _ -> A.rem integralType s ss + j <- A.add numType i =<< int tid + v <- app1 (delayedLinearIndex arrSeg) j + writeArray TypeInt32 smem tid =<< A.fromIntegral intTp numType v + + -- Once all threads have caught up, begin work on the new segment. + __syncthreads + + u <- readArray TypeInt32 smem (liftInt32 0) + v <- readArray TypeInt32 smem (liftInt32 1) + + -- Determine the index range of the input array we will reduce over. + -- Necessary for multidimensional segmented reduction. + (inf,sup) <- A.unpair <$> case shr of + ShapeRsnoc ShapeRz -> return (A.pair u v) + _ -> do q <- A.quot integralType s ss + a <- A.mul numType q sz + A.pair <$> A.add numType u a + <*> A.add numType v a + + void $ + if (TupRunit, A.eq singleType inf sup) + -- This segment is empty. If this is an exclusive reduction the + -- first thread writes out the initial element for this segment. + then do + case mseed of + Nothing -> return (lift TupRunit ()) + Just z -> do + when (A.eq singleType tid (liftInt32 0)) $ writeArray TypeInt arrOut s =<< z + return (lift TupRunit ()) + + -- This is a non-empty segment. + else do + -- Step 1: initialise local sums + -- + -- NOTE: We require all threads to enter this branch and execute the + -- first step, even if they do not have a valid element and must + -- return 'undef'. If we attempt to skip this entire section for + -- non-participating threads (i.e. 'when (i0 < sup)'), it seems that + -- those threads die and will not participate in the computation of + -- _any_ further segment. I'm not sure if this is a CUDA oddity + -- (e.g. we must have all threads convergent on __syncthreads) or + -- a bug in NVPTX / ptxas. + -- + i0 <- A.add numType inf =<< int tid + x0 <- if (tp, A.lt singleType i0 sup) + then app1 (delayedLinearIndex arrIn) i0 + else let + go :: TypeR a -> Operands a + go TupRunit = OP_Unit + go (TupRpair a b) = OP_Pair (go a) (go b) + go (TupRsingle t) = ir t (undef t) + in + return $ go tp + + bd <- int =<< blockDim + v0 <- A.sub numType sup inf + v0' <- i32 v0 + r0 <- if (tp, A.gte singleType v0 bd) + then Fold.reduceBlock dev tp combine Nothing x0 + else Fold.reduceBlock dev tp combine (Just v0') x0 + + -- Step 2: keep walking over the input + nxt <- A.add numType inf bd + r <- iterFromStepTo tp nxt bd sup r0 $ \offset r -> do + + -- Wait for threads to catch up before starting the next stripe + __syncthreads + + i' <- A.add numType offset =<< int tid + v' <- A.sub numType sup offset + r' <- if (tp, A.gte singleType v' bd) + -- All threads in the block are in bounds, so we + -- can avoid bounds checks. + then do + x <- app1 (delayedLinearIndex arrIn) i' + y <- Fold.reduceBlock dev tp combine Nothing x + return y + + -- Not all threads are valid. Note that we still + -- have all threads enter the reduction procedure + -- to avoid thread divergence on synchronisation + -- points, similar to the above NOTE. + else do + x <- if (tp, A.lt singleType i' sup) + then app1 (delayedLinearIndex arrIn) i' + else let + go :: TypeR a -> Operands a + go TupRunit = OP_Unit + go (TupRpair a b) = OP_Pair (go a) (go b) + go (TupRsingle t) = ir t (undef t) + in + return $ go tp + + z <- i32 v' + y <- Fold.reduceBlock dev tp combine (Just z) x + return y + + -- first thread incorporates the result from the previous + -- iteration + if (tp, A.eq singleType tid (liftInt32 0)) + then app2 combine r r' + else return r' + + -- Step 3: Thread zero writes the aggregate reduction for this + -- segment to memory. If this is an exclusive fold combine with the + -- initial element as well. + when (A.eq singleType tid (liftInt32 0)) $ + writeArray TypeInt arrOut s =<< + case mseed of + Nothing -> return r + Just z -> flip (app2 combine) r =<< z -- Note: initial element on the left + + return (lift TupRunit ()) + + return_ + + +-- This implementation assumes that the segments array represents the offset +-- indices to the source array, rather than the lengths of each segment. The +-- segment-offset approach is required for parallel implementations. +-- +-- Each segment is computed by a single warp, meaning we don't have to worry +-- about inter- or intra-block synchronisation. +-- +mkFoldSegP_warp + :: forall aenv sh i e. + UID + -> Gamma aenv + -> ArrayR (Array (sh, Int) e) + -> IntegralType i + -> IRFun2 PTX aenv (e -> e -> e) + -> MIRExp PTX aenv e + -> MIRDelayed PTX aenv (Array (sh, Int) e) + -> MIRDelayed PTX aenv (Segments i) + -> CodeGen PTX (IROpenAcc PTX aenv (Array (sh, Int) e)) +mkFoldSegP_warp uid aenv repr@(ArrayR shr tp) intTp combine mseed marr mseg = do + dev <- liftCodeGen $ asks ptxDeviceProperties + -- + let + (arrOut, paramOut) = mutableArray repr "out" + (arrIn, paramIn) = delayedArray "in" marr + (arrSeg, paramSeg) = delayedArray "seg" mseg + paramEnv = envParam aenv + -- + config = launchConfig dev (CUDA.decWarp dev) dsmem grid gridQ + where dsmem _n = 0 + -- + grid n m = multipleOf n (m `P.quot` ws) + gridQ = [|| \n m -> $$multipleOfQ n (m `P.quot` ws) ||] + -- + ws = CUDA.warpSize dev + + int32 :: Integral a => a -> Operands Int32 + int32 = liftInt32 . P.fromIntegral + -- + makeOpenAccWith config uid "foldSeg_warp" (paramOut ++ paramIn ++ paramSeg ++ paramEnv) $ do + + -- Each warp works independently. + -- Determine the ID of this warp within the thread block. + tid <- threadIdx + wid <- A.quot integralType tid (int32 ws) + + -- Number of warps per thread block + bd <- blockDim + wpb <- A.quot integralType bd (int32 ws) + + -- ID of this warp within the grid + bid <- blockIdx + gwid <- do a <- A.mul numType bid wpb + b <- A.add numType wid a + return b + + -- Compute the number of segments and size of the innermost dimension. These + -- are required if we are reducing a rank-2 or higher array, to properly + -- compute the start and end indices of the portion of the array this warp + -- reduces. Note that this is a segment-offset array computed by 'scanl (+) 0' + -- of the segment length array, so its size has increased by one. + -- + sz <- indexHead <$> delayedExtent arrIn + ss <- do a <- indexHead <$> delayedExtent arrSeg + b <- A.sub numType a (liftInt 1) + return b + + -- Each thread reduces a segment independently + s0 <- int gwid + gd <- int =<< gridDim + wpb' <- int wpb + step <- A.mul numType wpb' gd + end <- shapeSize shr (irArrayShape arrOut) + imapFromStepTo s0 step end $ \s -> do + + __syncwarp + + -- The first two threads of the warp determine the indices of the segments + -- array that we will reduce between and distribute those values to the + -- other threads in the warp + lane <- laneId + idx <- if (TupRsingle scalarTypeInt, A.lt singleType lane (liftInt32 2)) + then do + a <- case shr of + ShapeRsnoc ShapeRz -> return s + _ -> A.rem integralType s ss + b <- A.add numType a =<< int lane + c <- app1 (delayedLinearIndex arrSeg) b + d <- A.fromIntegral intTp numType c + return d + else + return (ir integralType (undef scalarType)) + + __syncwarp + + -- Determine the index range of the input array we will reduce over. + -- Necessary for multidimensional segmented reduction. + (inf,sup) <- do + u <- __shfl_idx (TupRsingle scalarTypeInt) idx (liftWord32 0) + + v <- __shfl_idx (TupRsingle scalarTypeInt) idx (liftWord32 1) + A.unpair <$> case shr of + ShapeRsnoc ShapeRz -> return (A.pair u v) + _ -> do q <- A.quot integralType s ss + a <- A.mul numType q sz + A.pair <$> A.add numType u a + <*> A.add numType v a + + __syncwarp + + void $ + if (TupRunit, A.eq singleType inf sup) + -- This segment is empty. If this is an exclusive reduction the first + -- lane writes out the initial element for this segment. + then do + case mseed of + Nothing -> return (lift TupRunit ()) + Just z -> do + when (A.eq singleType lane (liftInt32 0)) $ writeArray TypeInt arrOut s =<< z + return (lift TupRunit ()) + + -- This is a non-empty segment. + else do + -- Step 1: initialise local sums + -- + -- See comment above why we initialise the loop in this way + -- + i0 <- A.add numType inf =<< int lane + x0 <- if (tp, A.lt singleType i0 sup) + then app1 (delayedLinearIndex arrIn) i0 + else let + go :: TypeR a -> Operands a + go TupRunit = OP_Unit + go (TupRpair a b) = OP_Pair (go a) (go b) + go (TupRsingle t) = ir t (undef t) + in + return $ go tp + + v0 <- A.sub numType sup inf + v0' <- i32 v0 + r0 <- if (tp, A.gte singleType v0 (liftInt ws)) + then reduceWarp dev tp combine Nothing x0 + else reduceWarp dev tp combine (Just v0') x0 + + -- Step 2: Keep walking over the rest of the segment + nx <- A.add numType inf (liftInt ws) + r <- iterFromStepTo tp nx (liftInt ws) sup r0 $ \offset r -> do + + -- __syncwarp + __syncthreads -- TLM: why is this necessary? + + i' <- A.add numType offset =<< int lane + v' <- A.sub numType sup offset + r' <- if (tp, A.gte singleType v' (liftInt ws)) + then do + -- All lanes are in bounds, so avoid bounds checks + x <- app1 (delayedLinearIndex arrIn) i' + y <- reduceWarp dev tp combine Nothing x + return y + + else do + x <- if (tp, A.lt singleType i' sup) + then app1 (delayedLinearIndex arrIn) i' + else let + go :: TypeR a -> Operands a + go TupRunit = OP_Unit + go (TupRpair a b) = OP_Pair (go a) (go b) + go (TupRsingle t) = ir t (undef t) + in + return $ go tp + + z <- i32 v' + y <- reduceWarp dev tp combine (Just z) x + return y + + -- The first lane incorporates the result from the previous + -- iteration + if (tp, A.eq singleType lane (liftInt32 0)) + then app2 combine r r' + else return r' + + -- Step 3: Lane zero writes the aggregate reduction for this + -- segment to memory. If this is an exclusive reduction, also + -- combine with the initial element + when (A.eq singleType lane (liftInt32 0)) $ + writeArray TypeInt arrOut s =<< + case mseed of + Nothing -> return r + Just z -> flip (app2 combine) r =<< z -- Note: initial element on the left + + return (lift TupRunit ()) + + return_ + + +i32 :: IsIntegral i => Operands i -> CodeGen PTX (Operands Int32) +i32 = A.fromIntegral integralType numType + +int :: IsIntegral i => Operands i -> CodeGen PTX (Operands Int) +int = A.fromIntegral integralType numType + +reduceWarp + :: forall aenv e. + DeviceProperties -- ^ properties of the target device + -> TypeR e + -> IRFun2 PTX aenv (e -> e -> e) -- ^ combination function + -> Maybe (Operands Int32) -- ^ number of items that will be reduced by this warp, otherwise all lanes are valid + -> Operands e -- ^ calling thread's input element + -> CodeGen PTX (Operands e) -- ^ warp-wide reduction using the specified operator (lane 0 only) +reduceWarp dev t c = Fold.reduceWarp dev t c + diff --git a/src/Data/Array/Accelerate/LLVM/PTX/CodeGen/Generate.hs b/src/Data/Array/Accelerate/LLVM/PTX/CodeGen/Generate.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/PTX/CodeGen/Generate.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.PTX.CodeGen.Generate +-- Copyright : [2014..2020] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.PTX.CodeGen.Generate + where + +import Prelude hiding ( fromIntegral ) + +-- accelerate +import Data.Array.Accelerate.Representation.Array +import Data.Array.Accelerate.Type + +import Data.Array.Accelerate.LLVM.CodeGen.Arithmetic +import Data.Array.Accelerate.LLVM.CodeGen.Array +import Data.Array.Accelerate.LLVM.CodeGen.Base +import Data.Array.Accelerate.LLVM.CodeGen.Environment +import Data.Array.Accelerate.LLVM.CodeGen.Exp +import Data.Array.Accelerate.LLVM.CodeGen.Monad +import Data.Array.Accelerate.LLVM.CodeGen.Sugar +import Data.Array.Accelerate.LLVM.Compile.Cache + +import Data.Array.Accelerate.LLVM.PTX.CodeGen.Base +import Data.Array.Accelerate.LLVM.PTX.CodeGen.Loop +import Data.Array.Accelerate.LLVM.PTX.Target ( PTX ) + + +-- Construct a new array by applying a function to each index. Each thread +-- processes multiple adjacent elements. +-- +mkGenerate + :: UID + -> Gamma aenv + -> ArrayR (Array sh e) + -> IRFun1 PTX aenv (sh -> e) + -> CodeGen PTX (IROpenAcc PTX aenv (Array sh e)) +mkGenerate uid aenv repr@(ArrayR shr _) apply = + let + (arrOut, paramOut) = mutableArray repr "out" + paramEnv = envParam aenv + in + makeOpenAcc uid "generate" (paramOut ++ paramEnv) $ do + + start <- return (liftInt 0) + end <- shapeSize shr (irArrayShape arrOut) + + imapFromTo start end $ \i -> do + ix <- indexOfInt shr (irArrayShape arrOut) i -- convert to multidimensional index + r <- app1 apply ix -- apply generator function + writeArray TypeInt arrOut i r -- store result + + return_ + diff --git a/src/Data/Array/Accelerate/LLVM/PTX/CodeGen/Intrinsic.hs b/src/Data/Array/Accelerate/LLVM/PTX/CodeGen/Intrinsic.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/PTX/CodeGen/Intrinsic.hs @@ -0,0 +1,360 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.PTX.CodeGen.Intrinsic +-- Copyright : [2017..2020] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.PTX.CodeGen.Intrinsic ( ) + where + +import LLVM.AST.Type.Name ( Label(..) ) + +import Data.Array.Accelerate.LLVM.CodeGen.Intrinsic +import Data.Array.Accelerate.LLVM.PTX.Target + +import Data.ByteString.Short ( ShortByteString ) +import Data.HashMap.Strict ( HashMap ) +import Data.Monoid +import qualified Data.HashMap.Strict as HashMap +import Prelude as P + + +instance Intrinsic PTX where + intrinsicForTarget = libdeviceIndex + +-- The list of functions implemented by libdevice. These are all more-or-less +-- named consistently based on the standard mathematical functions they +-- implement, with the "__nv_" prefix stripped. +-- +libdeviceIndex :: HashMap ShortByteString Label +libdeviceIndex = + let nv base = (base, Label $ "__nv_" <> base) + in + HashMap.fromList $ map nv + [ "abs" + , "acos" + , "acosf" + , "acosh" + , "acoshf" + , "asin" + , "asinf" + , "asinh" + , "asinhf" + , "atan" + , "atan2" + , "atan2f" + , "atanf" + , "atanh" + , "atanhf" + , "brev" + , "brevll" + , "byte_perm" + , "cbrt" + , "cbrtf" + , "ceil" + , "ceilf" + , "clz" + , "clzll" + , "copysign" + , "copysignf" + , "cos" + , "cosf" + , "cosh" + , "coshf" + , "cospi" + , "cospif" + , "dadd_rd" + , "dadd_rn" + , "dadd_ru" + , "dadd_rz" + , "ddiv_rd" + , "ddiv_rn" + , "ddiv_ru" + , "ddiv_rz" + , "dmul_rd" + , "dmul_rn" + , "dmul_ru" + , "dmul_rz" + , "double2float_rd" + , "double2float_rn" + , "double2float_ru" + , "double2float_rz" + , "double2hiint" + , "double2int_rd" + , "double2int_rn" + , "double2int_ru" + , "double2int_rz" + , "double2ll_rd" + , "double2ll_rn" + , "double2ll_ru" + , "double2ll_rz" + , "double2loint" + , "double2uint_rd" + , "double2uint_rn" + , "double2uint_ru" + , "double2uint_rz" + , "double2ull_rd" + , "double2ull_rn" + , "double2ull_ru" + , "double2ull_rz" + , "double_as_longlong" + , "drcp_rd" + , "drcp_rn" + , "drcp_ru" + , "drcp_rz" + , "dsqrt_rd" + , "dsqrt_rn" + , "dsqrt_ru" + , "dsqrt_rz" + , "erf" + , "erfc" + , "erfcf" + , "erfcinv" + , "erfcinvf" + , "erfcx" + , "erfcxf" + , "erff" + , "erfinv" + , "erfinvf" + , "exp" + , "exp10" + , "exp10f" + , "exp2" + , "exp2f" + , "expf" + , "expm1" + , "expm1f" + , "fabs" + , "fabsf" + , "fadd_rd" + , "fadd_rn" + , "fadd_ru" + , "fadd_rz" + , "fast_cosf" + , "fast_exp10f" + , "fast_expf" + , "fast_fdividef" + , "fast_log10f" + , "fast_log2f" + , "fast_logf" + , "fast_powf" + , "fast_sincosf" + , "fast_sinf" + , "fast_tanf" + , "fdim" + , "fdimf" + , "fdiv_rd" + , "fdiv_rn" + , "fdiv_ru" + , "fdiv_rz" + , "ffs" + , "ffsll" + , "finitef" + , "float2half_rn" + , "float2int_rd" + , "float2int_rn" + , "float2int_ru" + , "float2int_rz" + , "float2ll_rd" + , "float2ll_rn" + , "float2ll_ru" + , "float2ll_rz" + , "float2uint_rd" + , "float2uint_rn" + , "float2uint_ru" + , "float2uint_rz" + , "float2ull_rd" + , "float2ull_rn" + , "float2ull_ru" + , "float2ull_rz" + , "float_as_int" + , "floor" + , "floorf" + , "fma" + , "fma_rd" + , "fma_rn" + , "fma_ru" + , "fma_rz" + , "fmaf" + , "fmaf_rd" + , "fmaf_rn" + , "fmaf_ru" + , "fmaf_rz" + , "fmax" + , "fmaxf" + , "fmin" + , "fminf" + , "fmod" + , "fmodf" + , "fmul_rd" + , "fmul_rn" + , "fmul_ru" + , "fmul_rz" + , "frcp_rd" + , "frcp_rn" + , "frcp_ru" + , "frcp_rz" + , "frexp" + , "frexpf" + , "frsqrt_rn" + , "fsqrt_rd" + , "fsqrt_rn" + , "fsqrt_ru" + , "fsqrt_rz" + , "fsub_rd" + , "fsub_rn" + , "fsub_ru" + , "fsub_rz" + , "hadd" + , "half2float" + , "hiloint2double" + , "hypot" + , "hypotf" + , "ilogb" + , "ilogbf" + , "int2double_rn" + , "int2float_rd" + , "int2float_rn" + , "int2float_ru" + , "int2float_rz" + , "int_as_float" + , "isfinited" + , "isinfd" + , "isinff" + , "isnand" + , "isnanf" + , "j0" + , "j0f" + , "j1" + , "j1f" + , "jn" + , "jnf" + , "ldexp" + , "ldexpf" + , "lgamma" + , "lgammaf" + , "ll2double_rd" + , "ll2double_rn" + , "ll2double_ru" + , "ll2double_rz" + , "ll2float_rd" + , "ll2float_rn" + , "ll2float_ru" + , "ll2float_rz" + , "llabs" + , "llmax" + , "llmin" + , "llrint" + , "llrintf" + , "llround" + , "llroundf" + , "log" + , "log10" + , "log10f" + , "log1p" + , "log1pf" + , "log2" + , "log2f" + , "logb" + , "logbf" + , "logf" + , "longlong_as_double" + , "max" + , "min" + , "modf" + , "modff" + , "mul24" + , "mul64hi" + , "mulhi" + , "nan" + , "nanf" + , "nearbyint" + , "nearbyintf" + , "nextafter" + , "nextafterf" + , "normcdf" + , "normcdff" + , "normcdfinv" + , "normcdfinvf" + , "popc" + , "popcll" + , "pow" + , "powf" + , "powi" + , "powif" + , "rcbrt" + , "rcbrtf" + , "remainder" + , "remainderf" + , "remquo" + , "remquof" + , "rhadd" + , "rint" + , "rintf" + , "round" + , "roundf" + , "rsqrt" + , "rsqrtf" + , "sad" + , "saturatef" + , "scalbn" + , "scalbnf" + , "signbitd" + , "signbitf" + , "sin" + , "sincos" + , "sincosf" + , "sincospi" + , "sincospif" + , "sinf" + , "sinh" + , "sinhf" + , "sinpi" + , "sinpif" + , "sqrt" + , "sqrtf" + , "tan" + , "tanf" + , "tanh" + , "tanhf" + , "tgamma" + , "tgammaf" + , "trunc" + , "truncf" + , "uhadd" + , "uint2double_rn" + , "uint2float_rd" + , "uint2float_rn" + , "uint2float_ru" + , "uint2float_rz" + , "ull2double_rd" + , "ull2double_rn" + , "ull2double_ru" + , "ull2double_rz" + , "ull2float_rd" + , "ull2float_rn" + , "ull2float_ru" + , "ull2float_rz" + , "ullmax" + , "ullmin" + , "umax" + , "umin" + , "umul24" + , "umul64hi" + , "umulhi" + , "urhadd" + , "usad" + , "y0" + , "y0f" + , "y1" + , "y1f" + , "yn" + , "ynf" + ] + diff --git a/src/Data/Array/Accelerate/LLVM/PTX/CodeGen/Loop.hs b/src/Data/Array/Accelerate/LLVM/PTX/CodeGen/Loop.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/PTX/CodeGen/Loop.hs @@ -0,0 +1,48 @@ +-- | +-- Module : Data.Array.Accelerate.LLVM.PTX.CodeGen.Loop +-- Copyright : [2015..2020] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.PTX.CodeGen.Loop + where + +-- accelerate +import Data.Array.Accelerate.Type + +import Data.Array.Accelerate.LLVM.CodeGen.Arithmetic as A +import Data.Array.Accelerate.LLVM.CodeGen.IR +import Data.Array.Accelerate.LLVM.CodeGen.Monad +import qualified Data.Array.Accelerate.LLVM.CodeGen.Loop as Loop + +import Data.Array.Accelerate.LLVM.PTX.CodeGen.Base +import Data.Array.Accelerate.LLVM.PTX.Target + + +-- | A standard loop where the CUDA threads cooperatively step over an index +-- space from the start to end indices. The threads stride the array in a way +-- that maintains memory coalescing. +-- +-- The start and end array indices are given as natural array indexes, and the +-- thread specific indices are calculated by the loop. +-- +-- > for ( int i = blockDim.x * blockIdx.x + threadIdx.x + start +-- > ; i < end +-- > ; i += blockDim.x * gridDim.x ) +-- +-- TODO: This assumes that the starting offset retains alignment to the warp +-- boundary. This might not always be the case, so provide a version that +-- explicitly aligns reads to the warp boundary. +-- +imapFromTo :: Operands Int -> Operands Int -> (Operands Int -> CodeGen PTX ()) -> CodeGen PTX () +imapFromTo start end body = do + step <- A.fromIntegral integralType numType =<< gridSize + tid <- A.fromIntegral integralType numType =<< globalThreadIdx + i0 <- add numType tid start + -- + Loop.imapFromStepTo i0 step end body + diff --git a/src/Data/Array/Accelerate/LLVM/PTX/CodeGen/Map.hs b/src/Data/Array/Accelerate/LLVM/PTX/CodeGen/Map.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/PTX/CodeGen/Map.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.PTX.CodeGen.Map +-- Copyright : [2014..2020] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.PTX.CodeGen.Map + where + +-- accelerate +import Data.Array.Accelerate.Representation.Array +import Data.Array.Accelerate.Representation.Type +import Data.Array.Accelerate.Type + +import Data.Array.Accelerate.LLVM.CodeGen.Arithmetic +import Data.Array.Accelerate.LLVM.CodeGen.Array +import Data.Array.Accelerate.LLVM.CodeGen.Base +import Data.Array.Accelerate.LLVM.CodeGen.Environment +import Data.Array.Accelerate.LLVM.CodeGen.Exp +import Data.Array.Accelerate.LLVM.CodeGen.Monad +import Data.Array.Accelerate.LLVM.CodeGen.Sugar +import Data.Array.Accelerate.LLVM.Compile.Cache + +import Data.Array.Accelerate.LLVM.PTX.CodeGen.Base +import Data.Array.Accelerate.LLVM.PTX.CodeGen.Loop +import Data.Array.Accelerate.LLVM.PTX.Target ( PTX ) + + +-- Apply a unary function to each element of an array. Each thread processes +-- multiple elements, striding the array by the grid size. +-- +mkMap :: UID + -> Gamma aenv + -> ArrayR (Array sh a) + -> TypeR b + -> IRFun1 PTX aenv (a -> b) + -> CodeGen PTX (IROpenAcc PTX aenv (Array sh b)) +mkMap uid aenv repr@(ArrayR shr _) tp' apply = + let + (arrOut, paramOut) = mutableArray (ArrayR shr tp') "out" + (arrIn, paramIn) = mutableArray repr "in" + paramEnv = envParam aenv + in + makeOpenAcc uid "map" (paramOut ++ paramIn ++ paramEnv) $ do + + start <- return (liftInt 0) + end <- shapeSize shr (irArrayShape arrIn) + + imapFromTo start end $ \i -> do + xs <- readArray TypeInt arrIn i + ys <- app1 apply xs + writeArray TypeInt arrOut i ys + + return_ + diff --git a/src/Data/Array/Accelerate/LLVM/PTX/CodeGen/Permute.hs b/src/Data/Array/Accelerate/LLVM/PTX/CodeGen/Permute.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/PTX/CodeGen/Permute.hs @@ -0,0 +1,439 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.PTX.CodeGen.Permute +-- Copyright : [2016..2020] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.PTX.CodeGen.Permute ( + + mkPermute, + +) where + +import Data.Array.Accelerate.AST +import Data.Array.Accelerate.Error +import Data.Array.Accelerate.Representation.Array +import Data.Array.Accelerate.Representation.Elt +import Data.Array.Accelerate.Representation.Shape +import Data.Array.Accelerate.Representation.Type + +import Data.Array.Accelerate.LLVM.CodeGen.Arithmetic as A +import Data.Array.Accelerate.LLVM.CodeGen.Array +import Data.Array.Accelerate.LLVM.CodeGen.Base +import Data.Array.Accelerate.LLVM.CodeGen.Constant +import Data.Array.Accelerate.LLVM.CodeGen.Environment +import Data.Array.Accelerate.LLVM.CodeGen.Exp +import Data.Array.Accelerate.LLVM.CodeGen.IR +import Data.Array.Accelerate.LLVM.CodeGen.Monad +import Data.Array.Accelerate.LLVM.CodeGen.Permute +import Data.Array.Accelerate.LLVM.CodeGen.Ptr +import Data.Array.Accelerate.LLVM.CodeGen.Sugar +import Data.Array.Accelerate.LLVM.Compile.Cache + +import Data.Array.Accelerate.LLVM.PTX.CodeGen.Base +import Data.Array.Accelerate.LLVM.PTX.CodeGen.Loop +import Data.Array.Accelerate.LLVM.PTX.Target + +import LLVM.AST.Type.Instruction +import LLVM.AST.Type.Instruction.Atomic +import LLVM.AST.Type.Instruction.RMW as RMW +import LLVM.AST.Type.Instruction.Volatile +import LLVM.AST.Type.GetElementPtr +import LLVM.AST.Type.Operand +import LLVM.AST.Type.Representation + +import Foreign.CUDA.Analysis + +import Control.Monad ( void ) +import Control.Monad.Reader ( asks ) +import Prelude + + +-- Forward permutation specified by an indexing mapping. The resulting array is +-- initialised with the given defaults, and any further values that are permuted +-- into the result array are added to the current value using the combination +-- function. +-- +-- The combination function must be /associative/ and /commutative/. Elements +-- that are mapped to the magic index 'ignore' are dropped. +-- +-- Parallel forward permutation has to take special care because different +-- threads could concurrently try to update the same memory location. Where +-- available we make use of special atomic instructions and other optimisations, +-- but in the general case each element of the output array has a lock which +-- must be obtained by the thread before it can update that memory location. +-- +-- TODO: After too many failures to acquire the lock on an element, the thread +-- should back off and try a different element, adding this failed element to +-- a queue or some such. +-- +mkPermute + :: HasCallStack + => UID + -> Gamma aenv + -> ArrayR (Array sh e) + -> ShapeR sh' + -> IRPermuteFun PTX aenv (e -> e -> e) + -> IRFun1 PTX aenv (sh -> PrimMaybe sh') + -> MIRDelayed PTX aenv (Array sh e) + -> CodeGen PTX (IROpenAcc PTX aenv (Array sh' e)) +mkPermute uid aenv repr shr' IRPermuteFun{..} project arr = + case atomicRMW of + Just (rmw, f) -> mkPermute_rmw uid aenv repr shr' rmw f project arr + _ -> mkPermute_mutex uid aenv repr shr' combine project arr + + +-- Parallel forward permutation function which uses atomic instructions to +-- implement lock-free array updates. +-- +-- Atomic instruction support on CUDA devices is a bit patchy, so depending on +-- the element type and compute capability of the target hardware we may need to +-- emulate the operation using atomic compare-and-swap. +-- +-- Int32 Int64 Float16 Float32 Float64 +-- +------------------------------------------------- +-- (+) | 2.0 2.0 7.0 2.0 6.0 +-- (-) | 2.0 2.0 x x x +-- (.&.) | 2.0 3.2 +-- (.|.) | 2.0 3.2 +-- xor | 2.0 3.2 +-- min | 2.0 3.2 x x x +-- max | 2.0 3.2 x x x +-- CAS | 2.0 2.0 +-- +-- Note that NVPTX requires at least compute 2.0, so we can always implement the +-- lockfree update operations in terms of compare-and-swap. +-- +mkPermute_rmw + :: HasCallStack + => UID + -> Gamma aenv + -> ArrayR (Array sh e) + -> ShapeR sh' + -> RMWOperation + -> IRFun1 PTX aenv (e -> e) + -> IRFun1 PTX aenv (sh -> PrimMaybe sh') + -> MIRDelayed PTX aenv (Array sh e) + -> CodeGen PTX (IROpenAcc PTX aenv (Array sh' e)) +mkPermute_rmw uid aenv (ArrayR shr tp) shr' rmw update project marr = do + dev <- liftCodeGen $ asks ptxDeviceProperties + -- + let + outR = ArrayR shr' tp + (arrOut, paramOut) = mutableArray outR "out" + (arrIn, paramIn) = delayedArray "in" marr + paramEnv = envParam aenv + start = liftInt 0 + -- + bytes = bytesElt tp + compute = computeCapability dev + compute32 = Compute 3 2 + compute60 = Compute 6 0 + compute70 = Compute 7 0 + -- + makeOpenAcc uid "permute_rmw" (paramOut ++ paramIn ++ paramEnv) $ do + + shIn <- delayedExtent arrIn + end <- shapeSize shr shIn + + imapFromTo start end $ \i -> do + + ix <- indexOfInt shr shIn i + ix' <- app1 project ix + + when (isJust ix') $ do + j <- intOfIndex shr' (irArrayShape arrOut) =<< fromJust ix' + x <- app1 (delayedLinearIndex arrIn) i + r <- app1 update x + + case rmw of + Exchange + -> writeArray TypeInt arrOut j r + -- + _ | TupRsingle (SingleScalarType s) <- tp + , adata <- irArrayData arrOut + -> do + addr <- instr' $ GetElementPtr $ GEP1 (SingleScalarType s) (asPtr defaultAddrSpace (op s adata)) (op integralType j) + -- + let + rmw_integral :: IntegralType t -> Operand (Ptr t) -> Operand t -> CodeGen PTX () + rmw_integral t ptr val + | primOk = void . instr' $ AtomicRMW (IntegralNumType t) NonVolatile rmw ptr val (CrossThread, AcquireRelease) + | otherwise = + case rmw of + RMW.And -> atomicCAS_rmw s' (A.band t (ir t val)) ptr + RMW.Or -> atomicCAS_rmw s' (A.bor t (ir t val)) ptr + RMW.Xor -> atomicCAS_rmw s' (A.xor t (ir t val)) ptr + RMW.Min -> atomicCAS_cmp s' A.lt ptr val + RMW.Max -> atomicCAS_cmp s' A.gt ptr val + _ -> internalError "unexpected transition" + where + s' = NumSingleType (IntegralNumType t) + primOk = compute >= compute32 + || bytes == 4 + || case rmw of + RMW.Add -> True + RMW.Sub -> True + _ -> False + + rmw_floating :: FloatingType t -> Operand (Ptr t) -> Operand t -> CodeGen PTX () + rmw_floating t ptr val = + case rmw of + RMW.Min -> atomicCAS_cmp s' A.lt ptr val + RMW.Max -> atomicCAS_cmp s' A.gt ptr val + RMW.Sub -> atomicCAS_rmw s' (A.sub n (ir t val)) ptr + RMW.Add + | primAdd -> atomicAdd_f t ptr val + | otherwise -> atomicCAS_rmw s' (A.add n (ir t val)) ptr + _ -> internalError "unexpected transition" + where + n = FloatingNumType t + s' = NumSingleType n + primAdd = + case t of + TypeHalf -> compute >= compute70 + TypeFloat -> True + TypeDouble -> compute >= compute60 + case s of + NumSingleType (IntegralNumType t) -> rmw_integral t addr (op t r) + NumSingleType (FloatingNumType t) -> rmw_floating t addr (op t r) + -- + _ -> internalError "unexpected transition" + + return_ + + +-- Parallel forward permutation function which uses a spinlock to acquire +-- a mutex before updating the value at that location. +-- +mkPermute_mutex + :: UID + -> Gamma aenv + -> ArrayR (Array sh e) + -> ShapeR sh' + -> IRFun2 PTX aenv (e -> e -> e) + -> IRFun1 PTX aenv (sh -> PrimMaybe sh') + -> MIRDelayed PTX aenv (Array sh e) + -> CodeGen PTX (IROpenAcc PTX aenv (Array sh' e)) +mkPermute_mutex uid aenv (ArrayR shr tp) shr' combine project marr = + let + outR = ArrayR shr' tp + lockR = ArrayR (ShapeRsnoc ShapeRz) (TupRsingle scalarTypeWord32) + (arrOut, paramOut) = mutableArray outR "out" + (arrLock, paramLock) = mutableArray lockR "lock" + (arrIn, paramIn) = delayedArray "in" marr + paramEnv = envParam aenv + start = liftInt 0 + in + makeOpenAcc uid "permute_mutex" (paramOut ++ paramLock ++ paramIn ++ paramEnv) $ do + + shIn <- delayedExtent arrIn + end <- shapeSize shr shIn + + imapFromTo start end $ \i -> do + + ix <- indexOfInt shr shIn i + ix' <- app1 project ix + + -- project element onto the destination array and (atomically) update + when (isJust ix') $ do + j <- intOfIndex shr' (irArrayShape arrOut) =<< fromJust ix' + x <- app1 (delayedLinearIndex arrIn) i + + atomically arrLock j $ do + y <- readArray TypeInt arrOut j + r <- app2 combine x y + writeArray TypeInt arrOut j r + + return_ + + +-- Atomically execute the critical section only when the lock at the given +-- array indexed is obtained. +-- +atomically + :: IRArray (Vector Word32) + -> Operands Int + -> CodeGen PTX a + -> CodeGen PTX a +atomically barriers i action = do + dev <- liftCodeGen $ asks ptxDeviceProperties + if computeCapability dev >= Compute 7 0 + then atomically_thread barriers i action + else atomically_warp barriers i action + + +-- Atomically execute the critical section only when the lock at the given +-- array index is obtained. The thread spins waiting for the lock to be +-- released with exponential backoff on failure in case the lock is +-- contended. +-- +-- > uint32_t ns = 8; +-- > while ( atomic_exchange(&lock[i], 1) == 1 ) { +-- > __nanosleep(ns); +-- > if ( ns < 256 ) { +-- > ns *= 2; +-- > } +-- > } +-- +-- Requires independent thread scheduling features of SM7+. +-- +atomically_thread + :: IRArray (Vector Word32) + -> Operands Int + -> CodeGen PTX a + -> CodeGen PTX a +atomically_thread barriers i action = do + let + lock = integral integralType 1 + unlock = integral integralType 0 + unlock' = ir TypeWord32 unlock + i32 = TupRsingle scalarTypeInt32 + -- + entry <- newBlock "spinlock.entry" + sleep <- newBlock "spinlock.backoff" + moar <- newBlock "spinlock.backoff-moar" + start <- newBlock "spinlock.critical-start" + end <- newBlock "spinlock.critical-end" + exit <- newBlock "spinlock.exit" + ns <- fresh i32 + + addr <- instr' $ GetElementPtr $ GEP1 scalarType (asPtr defaultAddrSpace (op integralType (irArrayData barriers))) (op integralType i) + top <- br entry + + -- Loop until this thread has completed its critical section. If the slot + -- was unlocked we just acquired the lock and the thread can perform its + -- critical section, otherwise sleep the thread and try again later. + setBlock entry + old <- instr $ AtomicRMW numType NonVolatile Exchange addr lock (CrossThread, Acquire) + ok <- A.eq singleType old unlock' + _ <- cbr ok start sleep + + -- We did not acquire the lock. Sleep the thread for a small amount of + -- time and (possibly) increase the sleep duration for the next round + setBlock sleep + _ <- nanosleep ns + p <- A.lt singleType ns (ir TypeInt32 (integral integralType 256)) + _ <- cbr p moar entry + + setBlock moar + ns' <- A.mul numType ns (ir TypeInt32 (integral integralType 2)) + _ <- phi' i32 entry ns [(ir TypeInt32 (integral (integralType) 8), top), (ns, sleep), (ns', moar)] + _ <- br entry + + -- If we just acquired the lock, execute the critical section, then + -- release the lock and continue with your day. + setBlock start + r <- action + _ <- br end + + setBlock end + _ <- instr $ AtomicRMW numType NonVolatile Exchange addr unlock (CrossThread, AcquireRelease) + _ <- __threadfence_grid -- TODO: why is this required? + _ <- br exit + + setBlock exit + return r + + +-- Atomically execute the critical section only when the lock at the given array +-- index is obtained. The thread spins waiting for the lock to be released and +-- there is no backoff strategy in case the lock is contended. +-- +-- The canonical implementation of a spin-lock looks like this: +-- +-- > do { +-- > old = atomic_exchange(&lock[i], 1); +-- > } while (old == 1); +-- > +-- > /* critical section */ +-- > +-- > atomic_exchange(&lock[i], 0); +-- +-- The initial loop repeatedly attempts to take the lock by writing a 1 (locked) +-- into the lock slot. Once the 'old' state of the lock returns 0 (unlocked), +-- then we just acquired the lock and the atomic section can be computed. +-- Finally, the lock is released by writing 0 back to the lock slot. +-- +-- However, there is a complication with CUDA devices because all threads in +-- a warp must execute in lockstep (with predicated execution). In the above +-- setup, once a thread acquires a lock, then it will be disabled and stop +-- participating in the loop, waiting for all other threads (to acquire their +-- locks) before continuing program execution. If two threads in the same warp +-- attempt to acquire the same lock, then once the lock is acquired by one +-- thread then it will sit idle waiting while the second thread spins attempting +-- to grab a lock that will never be released because the first thread (which +-- holds the lock) can not make progress. DEADLOCK. +-- +-- To prevent this situation we must invert the algorithm so that threads can +-- always make progress, until each warp in the thread has committed their +-- result. +-- +-- > done = 0; +-- > do { +-- > if ( atomic_exchange(&lock[i], 1) == 0 ) { +-- > +-- > /* critical section */ +-- > +-- > done = 1; +-- > atomic_exchange(&lock[i], 0); +-- > } +-- > } while ( done == 0 ); +-- +atomically_warp + :: IRArray (Vector Word32) + -> Operands Int + -> CodeGen PTX a + -> CodeGen PTX a +atomically_warp barriers i action = do + let + lock = integral integralType 1 + unlock = integral integralType 0 + unlock' = ir TypeWord32 unlock + -- + entry <- newBlock "spinlock.entry" + start <- newBlock "spinlock.critical-start" + end <- newBlock "spinlock.critical-end" + exit <- newBlock "spinlock.exit" + + addr <- instr' $ GetElementPtr $ GEP1 scalarType (asPtr defaultAddrSpace (op integralType (irArrayData barriers))) (op integralType i) + _ <- br entry + + -- Loop until this thread has completed its critical section. If the slot was + -- unlocked then we just acquired the lock and the thread can perform the + -- critical section, otherwise skip to the bottom of the critical section. + setBlock entry + old <- instr $ AtomicRMW numType NonVolatile Exchange addr lock (CrossThread, Acquire) + ok <- A.eq singleType old unlock' + no <- cbr ok start end + + -- If we just acquired the lock, execute the critical section + setBlock start + r <- action + _ <- instr $ AtomicRMW numType NonVolatile Exchange addr unlock (CrossThread, AcquireRelease) + yes <- br end + + -- At the base of the critical section, threads participate in a memory fence + -- to ensure the lock state is committed to memory. Depending on which + -- incoming edge the thread arrived at this block from determines whether they + -- have completed their critical section. + setBlock end + res <- freshLocalName + done <- phi1 end res [(boolean True, yes), (boolean False, no)] + + __syncthreads + _ <- cbr (OP_Bool done) exit entry + + setBlock exit + return r + diff --git a/src/Data/Array/Accelerate/LLVM/PTX/CodeGen/Scan.hs b/src/Data/Array/Accelerate/LLVM/PTX/CodeGen/Scan.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/PTX/CodeGen/Scan.hs @@ -0,0 +1,1300 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.PTX.CodeGen.Scan +-- Copyright : [2016..2020] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.PTX.CodeGen.Scan ( + + mkScan, mkScan', + +) where + +import Data.Array.Accelerate.AST ( Direction(..) ) +import Data.Array.Accelerate.Representation.Array +import Data.Array.Accelerate.Representation.Shape +import Data.Array.Accelerate.Representation.Type + +import Data.Array.Accelerate.LLVM.CodeGen.Arithmetic as A +import Data.Array.Accelerate.LLVM.CodeGen.Array +import Data.Array.Accelerate.LLVM.CodeGen.Base +import Data.Array.Accelerate.LLVM.CodeGen.Constant +import Data.Array.Accelerate.LLVM.CodeGen.Environment +import Data.Array.Accelerate.LLVM.CodeGen.Exp +import Data.Array.Accelerate.LLVM.CodeGen.IR +import Data.Array.Accelerate.LLVM.CodeGen.Loop +import Data.Array.Accelerate.LLVM.CodeGen.Monad +import Data.Array.Accelerate.LLVM.CodeGen.Sugar +import Data.Array.Accelerate.LLVM.Compile.Cache +import Data.Array.Accelerate.LLVM.PTX.Analysis.Launch +import Data.Array.Accelerate.LLVM.PTX.CodeGen.Base +import Data.Array.Accelerate.LLVM.PTX.CodeGen.Generate +import Data.Array.Accelerate.LLVM.PTX.Target + +import LLVM.AST.Type.Representation + +import qualified Foreign.CUDA.Analysis as CUDA + +import Control.Applicative +import Control.Monad ( (>=>), void ) +import Control.Monad.Reader ( asks ) +import Data.String ( fromString ) +import Data.Coerce as Safe +import Data.Bits as P +import Prelude as P hiding ( last ) + + + +-- 'Data.List.scanl' or 'Data.List.scanl1' style exclusive scan, but with the +-- restriction that the combination function must be associative to enable +-- efficient parallel implementation. +-- +-- > scanl (+) 10 (use $ fromList (Z :. 10) [0..]) +-- > +-- > ==> Array (Z :. 11) [10,10,11,13,16,20,25,31,38,46,55] +-- +mkScan + :: forall aenv sh e. + UID + -> Gamma aenv + -> ArrayR (Array (sh, Int) e) + -> Direction + -> IRFun2 PTX aenv (e -> e -> e) + -> Maybe (IRExp PTX aenv e) + -> MIRDelayed PTX aenv (Array (sh, Int) e) + -> CodeGen PTX (IROpenAcc PTX aenv (Array (sh, Int) e)) +mkScan uid aenv repr dir combine seed arr + = foldr1 (+++) <$> sequence (codeScan ++ codeFill) + + where + codeScan = case repr of + ArrayR (ShapeRsnoc ShapeRz) tp -> [ mkScanAllP1 dir uid aenv tp combine seed arr + , mkScanAllP2 dir uid aenv tp combine + , mkScanAllP3 dir uid aenv tp combine seed + ] + _ -> [ mkScanDim dir uid aenv repr combine seed arr + ] + codeFill = case seed of + Just s -> [ mkScanFill uid aenv repr s ] + Nothing -> [] + + +-- Variant of 'scanl' where the final result is returned in a separate array. +-- +-- > scanr' (+) 10 (use $ fromList (Z :. 10) [0..]) +-- > +-- > ==> ( Array (Z :. 10) [10,10,11,13,16,20,25,31,38,46] +-- , Array Z [55] +-- ) +-- +mkScan' + :: forall aenv sh e. + UID + -> Gamma aenv + -> ArrayR (Array (sh, Int) e) + -> Direction + -> IRFun2 PTX aenv (e -> e -> e) + -> IRExp PTX aenv e + -> MIRDelayed PTX aenv (Array (sh, Int) e) + -> CodeGen PTX (IROpenAcc PTX aenv (Array (sh, Int) e, Array sh e)) +mkScan' uid aenv repr dir combine seed arr + | ArrayR (ShapeRsnoc ShapeRz) tp <- repr + = foldr1 (+++) <$> sequence [ mkScan'AllP1 dir uid aenv tp combine seed arr + , mkScan'AllP2 dir uid aenv tp combine + , mkScan'AllP3 dir uid aenv tp combine + , mkScan'Fill uid aenv repr seed + ] + -- + | otherwise + = (+++) <$> mkScan'Dim dir uid aenv repr combine seed arr + <*> mkScan'Fill uid aenv repr seed + + +-- Device wide scans +-- ----------------- +-- +-- This is a classic two-pass algorithm which proceeds in two phases and +-- requires ~4n data movement to global memory. In future we would like to +-- replace this with a single pass algorithm. +-- + +-- Parallel scan, step 1. +-- +-- Threads scan a stripe of the input into a temporary array, incorporating the +-- initial element and any fused functions on the way. The final reduction +-- result of this chunk is written to a separate array. +-- +mkScanAllP1 + :: forall aenv e. + Direction + -> UID + -> Gamma aenv -- ^ array environment + -> TypeR e + -> IRFun2 PTX aenv (e -> e -> e) -- ^ combination function + -> MIRExp PTX aenv e -- ^ seed element, if this is an exclusive scan + -> MIRDelayed PTX aenv (Vector e) -- ^ input data + -> CodeGen PTX (IROpenAcc PTX aenv (Vector e)) +mkScanAllP1 dir uid aenv tp combine mseed marr = do + dev <- liftCodeGen $ asks ptxDeviceProperties + -- + let + (arrOut, paramOut) = mutableArray (ArrayR dim1 tp) "out" + (arrTmp, paramTmp) = mutableArray (ArrayR dim1 tp) "tmp" + (arrIn, paramIn) = delayedArray "in" marr + end = indexHead (irArrayShape arrTmp) + paramEnv = envParam aenv + -- + config = launchConfig dev (CUDA.incWarp dev) (scanSMemSize dev tp) const [|| const ||] + -- + makeOpenAccWith config uid "scanP1" (paramTmp ++ paramOut ++ paramIn ++ paramEnv) $ do + + -- Size of the input array + sz <- indexHead <$> delayedExtent arrIn + + -- A thread block scans a non-empty stripe of the input, storing the final + -- block-wide aggregate into a separate array + -- + -- For exclusive scans, thread 0 of segment 0 must incorporate the initial + -- element into the input and output. Threads shuffle their indices + -- appropriately. + -- + bid <- blockIdx + gd <- gridDim + gd' <- int gd + s0 <- int bid + + -- iterating over thread-block-wide segments + -- Note that 'end' is a multiple of the gd', and the control flow is thus uniform in the loop. + -- This is set in scanAllOp in Data.Array.Accelerate.LLVM.PTX.Execute. + -- Hence we can run __syncthreads safely. + imapFromStepTo s0 gd' end $ \chunk -> do + + -- Make sure all threads have finished previous iterations, + -- so we can reuse (and overwrite) shared memory. + __syncthreads + + bd <- blockDim + bd' <- int bd + inf <- A.mul numType chunk bd' + + -- index i* is the index that this thread will read data from. Recall that + -- the supremum index is exclusive + tid <- threadIdx + tid' <- int tid + i0 <- case dir of + LeftToRight -> A.add numType inf tid' + RightToLeft -> do x <- A.sub numType sz inf + y <- A.sub numType x tid' + z <- A.sub numType y (liftInt 1) + return z + + -- index j* is the index that we write to. Recall that for exclusive scans + -- the output array is one larger than the input; the initial element will + -- be written into this spot by thread 0 of the first thread block. + j0 <- case mseed of + Nothing -> return i0 + Just _ -> case dir of + LeftToRight -> A.add numType i0 (liftInt 1) + RightToLeft -> return i0 + + -- If this thread has input, read data and participate in thread-block scan + let valid i = case dir of + LeftToRight -> A.lt singleType i sz + RightToLeft -> A.gte singleType i (liftInt 0) + + when (valid i0) $ do + x0 <- app1 (delayedLinearIndex arrIn) i0 + x1 <- case mseed of + Nothing -> return x0 + Just seed -> + if (tp, A.eq singleType tid (liftInt32 0) `A.land'` A.eq singleType chunk (liftInt 0)) + then do + z <- seed + case dir of + LeftToRight -> writeArray TypeInt32 arrOut (liftInt32 0) z >> app2 combine z x0 + RightToLeft -> writeArray TypeInt arrOut sz z >> app2 combine x0 z + else + return x0 + + n <- A.sub numType sz inf + n' <- i32 n + x2 <- if (tp, A.gte singleType n bd') + then scanBlock dir dev tp combine Nothing x1 + else scanBlock dir dev tp combine (Just n') x1 + + -- Write this thread's scan result to memory + writeArray TypeInt arrOut j0 x2 + + -- The last thread also writes its result---the aggregate for this + -- thread block---to the temporary partial sums array. This is only + -- necessary for full blocks in a multi-block scan; the final + -- partially-full tile does not have a successor block. + last <- A.sub numType bd (liftInt32 1) + when (A.gt singleType gd (liftInt32 1) `land'` A.eq singleType tid last) $ + case dir of + LeftToRight -> writeArray TypeInt arrTmp chunk x2 + RightToLeft -> do u <- A.sub numType end chunk + v <- A.sub numType u (liftInt 1) + writeArray TypeInt arrTmp v x2 + + return_ + + +-- Parallel scan, step 2 +-- +-- A single thread block performs a scan of the per-block aggregates computed in +-- step 1. This gives the per-block prefix which must be added to each element +-- in step 3. +-- +mkScanAllP2 + :: forall aenv e. + Direction + -> UID + -> Gamma aenv -- ^ array environment + -> TypeR e + -> IRFun2 PTX aenv (e -> e -> e) -- ^ combination function + -> CodeGen PTX (IROpenAcc PTX aenv (Vector e)) +mkScanAllP2 dir uid aenv tp combine = do + dev <- liftCodeGen $ asks ptxDeviceProperties + -- + let + (arrTmp, paramTmp) = mutableArray (ArrayR dim1 tp) "tmp" + paramEnv = envParam aenv + start = liftInt 0 + end = indexHead (irArrayShape arrTmp) + -- + config = launchConfig dev (CUDA.incWarp dev) (scanSMemSize dev tp) grid gridQ + grid _ _ = 1 + gridQ = [|| \_ _ -> 1 ||] + -- + makeOpenAccWith config uid "scanP2" (paramTmp ++ paramEnv) $ do + + -- The first and last threads of the block need to communicate the + -- block-wide aggregate as a carry-in value across iterations. + -- + -- TODO: We could optimise this a bit if we can get access to the shared + -- memory area used by 'scanBlockSMem', and from there directly read the + -- value computed by the last thread. + carry <- staticSharedMem tp 1 + + bd <- blockDim + bd' <- int bd + + imapFromStepTo start bd' end $ \offset -> do + + -- Index of the partial sums array that this thread will process. + tid <- threadIdx + tid' <- int tid + i0 <- case dir of + LeftToRight -> A.add numType offset tid' + RightToLeft -> do x <- A.sub numType end offset + y <- A.sub numType x tid' + z <- A.sub numType y (liftInt 1) + return z + + let valid i = case dir of + LeftToRight -> A.lt singleType i end + RightToLeft -> A.gte singleType i start + + -- wait for the carry-in value to be updated + __syncthreads + + when (valid i0) $ do + x0 <- readArray TypeInt arrTmp i0 + x1 <- if (tp, A.gt singleType offset (liftInt 0) `land'` A.eq singleType tid (liftInt32 0)) + then do + c <- readArray TypeInt32 carry (liftInt32 0) + case dir of + LeftToRight -> app2 combine c x0 + RightToLeft -> app2 combine x0 c + else do + return x0 + + n <- A.sub numType end offset + n' <- i32 n + x2 <- if (tp, A.gte singleType n bd') + then scanBlock dir dev tp combine Nothing x1 + else scanBlock dir dev tp combine (Just n') x1 + + -- Update the temporary array with this thread's result + writeArray TypeInt arrTmp i0 x2 + + -- The last thread writes the carry-out value. If the last thread is not + -- active, then this must be the last stripe anyway. + last <- A.sub numType bd (liftInt32 1) + when (A.eq singleType tid last) $ + writeArray TypeInt32 carry (liftInt32 0) x2 + + return_ + + +-- Parallel scan, step 3. +-- +-- Threads combine every element of the partial block results with the carry-in +-- value computed in step 2. +-- +mkScanAllP3 + :: forall aenv e. + Direction + -> UID + -> Gamma aenv -- ^ array environment + -> TypeR e + -> IRFun2 PTX aenv (e -> e -> e) -- ^ combination function + -> MIRExp PTX aenv e -- ^ seed element, if this is an exclusive scan + -> CodeGen PTX (IROpenAcc PTX aenv (Vector e)) +mkScanAllP3 dir uid aenv tp combine mseed = do + dev <- liftCodeGen $ asks ptxDeviceProperties + -- + let + (arrOut, paramOut) = mutableArray (ArrayR dim1 tp) "out" + (arrTmp, paramTmp) = mutableArray (ArrayR dim1 tp) "tmp" + paramEnv = envParam aenv + -- + stride = local (TupRsingle scalarTypeInt) "ix.stride" + paramStride = parameter (TupRsingle scalarTypeInt) "ix.stride" + -- + config = launchConfig dev (CUDA.incWarp dev) (const 0) const [|| const ||] + -- + makeOpenAccWith config uid "scanP3" (paramTmp ++ paramOut ++ paramStride ++ paramEnv) $ do + + sz <- return $ indexHead (irArrayShape arrOut) + tid <- int =<< threadIdx + + -- Threads that will never contribute can just exit immediately. The size of + -- each chunk is set by the block dimension of the step 1 kernel, which may + -- be different from the block size of this kernel. + when (A.lt singleType tid stride) $ do + + -- Iterate over the segments computed in phase 1. Note that we have one + -- fewer chunk to process because the first has no carry-in. + bid <- int =<< blockIdx + gd <- int =<< gridDim + end <- A.sub numType (indexHead (irArrayShape arrTmp)) (liftInt 1) + + imapFromStepTo bid gd end $ \chunk -> do + + -- Determine the start and end indicies of this chunk to which we will + -- carry-in the value. Returned for left-to-right traversal. + (inf,sup) <- case dir of + LeftToRight -> do + a <- A.add numType chunk (liftInt 1) + b <- A.mul numType stride a + case mseed of + Just{} -> do + c <- A.add numType b (liftInt 1) + d <- A.add numType c stride + e <- A.min singleType d sz + return (c,e) + Nothing -> do + c <- A.add numType b stride + d <- A.min singleType c sz + return (b,d) + RightToLeft -> do + a <- A.sub numType end chunk + b <- A.mul numType stride a + c <- A.sub numType sz b + case mseed of + Just{} -> do + d <- A.sub numType c (liftInt 1) + e <- A.sub numType d stride + f <- A.max singleType e (liftInt 0) + return (f,d) + Nothing -> do + d <- A.sub numType c stride + e <- A.max singleType d (liftInt 0) + return (e,c) + + -- Read the carry-in value + carry <- case dir of + LeftToRight -> readArray TypeInt arrTmp chunk + RightToLeft -> do + a <- A.add numType chunk (liftInt 1) + b <- readArray TypeInt arrTmp a + return b + + -- Apply the carry-in value to each element in the chunk + bd <- int =<< blockDim + i0 <- A.add numType inf tid + imapFromStepTo i0 bd sup $ \i -> do + v <- readArray TypeInt arrOut i + u <- case dir of + LeftToRight -> app2 combine carry v + RightToLeft -> app2 combine v carry + writeArray TypeInt arrOut i u + + return_ + + +-- Parallel scan', step 1. +-- +-- Similar to mkScanAllP1. Threads scan a stripe of the input into a temporary +-- array, incorporating the initial element and any fused functions on the way. +-- The final reduction result of this chunk is written to a separate array. +-- +mkScan'AllP1 + :: forall aenv e. + Direction + -> UID + -> Gamma aenv + -> TypeR e + -> IRFun2 PTX aenv (e -> e -> e) + -> IRExp PTX aenv e + -> MIRDelayed PTX aenv (Vector e) + -> CodeGen PTX (IROpenAcc PTX aenv (Vector e, Scalar e)) +mkScan'AllP1 dir uid aenv tp combine seed marr = do + dev <- liftCodeGen $ asks ptxDeviceProperties + -- + let + (arrOut, paramOut) = mutableArray (ArrayR dim1 tp) "out" + (arrTmp, paramTmp) = mutableArray (ArrayR dim1 tp) "tmp" + (arrIn, paramIn) = delayedArray "in" marr + end = indexHead (irArrayShape arrTmp) + paramEnv = envParam aenv + -- + config = launchConfig dev (CUDA.incWarp dev) (scanSMemSize dev tp) const [|| const ||] + -- + makeOpenAccWith config uid "scanP1" (paramTmp ++ paramOut ++ paramIn ++ paramEnv) $ do + + -- Size of the input array + sz <- indexHead <$> delayedExtent arrIn + + -- A thread block scans a non-empty stripe of the input, storing the partial + -- result and the final block-wide aggregate + bid <- int =<< blockIdx + gd <- int =<< gridDim + + -- iterate over thread-block wide segments + -- Note that 'end' is a multiple of the gd', and the control flow is thus uniform in the loop. + -- This is set in scan'AllOp in Data.Array.Accelerate.LLVM.PTX.Execute. + -- Hence we can run __syncthreads safely. + imapFromStepTo bid gd end $ \seg -> do + + -- Make sure all threads have finished previous iterations, + -- so we can reuse (and overwrite) shared memory. + __syncthreads + + bd <- int =<< blockDim + inf <- A.mul numType seg bd + + -- i* is the index that this thread will read data from + tid <- int =<< threadIdx + i0 <- case dir of + LeftToRight -> A.add numType inf tid + RightToLeft -> do x <- A.sub numType sz inf + y <- A.sub numType x tid + z <- A.sub numType y (liftInt 1) + return z + + -- j* is the index this thread will write to. This is just shifted by one + -- to make room for the initial element + j0 <- case dir of + LeftToRight -> A.add numType i0 (liftInt 1) + RightToLeft -> A.sub numType i0 (liftInt 1) + + -- If this thread has input it participates in the scan + let valid i = case dir of + LeftToRight -> A.lt singleType i sz + RightToLeft -> A.gte singleType i (liftInt 0) + + when (valid i0) $ do + x0 <- app1 (delayedLinearIndex arrIn) i0 + + -- Thread 0 of the first segment must also evaluate and store the + -- initial element + ti <- threadIdx + x1 <- if (tp, A.eq singleType ti (liftInt32 0) `A.land'` A.eq singleType seg (liftInt 0)) + then do + z <- seed + writeArray TypeInt arrOut i0 z + case dir of + LeftToRight -> app2 combine z x0 + RightToLeft -> app2 combine x0 z + else + return x0 + + -- Block-wide scan + n <- A.sub numType sz inf + n' <- i32 n + x2 <- if (tp, A.gte singleType n bd) + then scanBlock dir dev tp combine Nothing x1 + else scanBlock dir dev tp combine (Just n') x1 + + -- Write this thread's scan result to memory. Recall that we had to make + -- space for the initial element, so the very last thread does not store + -- its result here. + case dir of + LeftToRight -> when (A.lt singleType j0 sz) $ writeArray TypeInt arrOut j0 x2 + RightToLeft -> when (A.gte singleType j0 (liftInt 0)) $ writeArray TypeInt arrOut j0 x2 + + -- Last active thread writes its result to the partial sums array. These + -- will be used to compute the carry-in value in step 2. + m <- do x <- A.min singleType n bd + y <- A.sub numType x (liftInt 1) + return y + when (A.eq singleType tid m) $ + case dir of + LeftToRight -> writeArray TypeInt arrTmp seg x2 + RightToLeft -> do x <- A.sub numType end seg + y <- A.sub numType x (liftInt 1) + writeArray TypeInt arrTmp y x2 + + return_ + + +-- Parallel scan', step 2 +-- +-- A single thread block performs an inclusive scan of the partial sums array to +-- compute the per-block carry-in values, as well as the final reduction result. +-- +mkScan'AllP2 + :: forall aenv e. + Direction + -> UID + -> Gamma aenv + -> TypeR e + -> IRFun2 PTX aenv (e -> e -> e) + -> CodeGen PTX (IROpenAcc PTX aenv (Vector e, Scalar e)) +mkScan'AllP2 dir uid aenv tp combine = do + dev <- liftCodeGen $ asks ptxDeviceProperties + -- + let + (arrTmp, paramTmp) = mutableArray (ArrayR dim1 tp) "tmp" + (arrSum, paramSum) = mutableArray (ArrayR dim0 tp) "sum" + paramEnv = envParam aenv + start = liftInt 0 + end = indexHead (irArrayShape arrTmp) + -- + config = launchConfig dev (CUDA.incWarp dev) (scanSMemSize dev tp) grid gridQ + grid _ _ = 1 + gridQ = [|| \_ _ -> 1 ||] + -- + makeOpenAccWith config uid "scanP2" (paramTmp ++ paramSum ++ paramEnv) $ do + + -- The first and last threads of the block need to communicate the + -- block-wide aggregate as a carry-in value across iterations. + carry <- staticSharedMem tp 1 + + -- A single thread block iterates over the per-block partial results from + -- step 1 + tid <- threadIdx + tid' <- int tid + bd <- int =<< blockDim + + imapFromStepTo start bd end $ \offset -> do + + i0 <- case dir of + LeftToRight -> A.add numType offset tid' + RightToLeft -> do x <- A.sub numType end offset + y <- A.sub numType x tid' + z <- A.sub numType y (liftInt 1) + return z + + let valid i = case dir of + LeftToRight -> A.lt singleType i end + RightToLeft -> A.gte singleType i start + + -- wait for the carry-in value to be updated + __syncthreads + + x0 <- if (tp, valid i0) + then readArray TypeInt arrTmp i0 + else + return $ tupUndef tp + + x1 <- if (tp, A.gt singleType offset (liftInt 0) `A.land'` A.eq singleType tid (liftInt32 0)) + then do + c <- readArray TypeInt32 carry (liftInt32 0) + case dir of + LeftToRight -> app2 combine c x0 + RightToLeft -> app2 combine x0 c + else + return x0 + + n <- A.sub numType end offset + n' <- i32 n + x2 <- if (tp, A.gte singleType n bd) + then scanBlock dir dev tp combine Nothing x1 + else scanBlock dir dev tp combine (Just n') x1 + + -- Update the partial results array + when (valid i0) $ + writeArray TypeInt arrTmp i0 x2 + + -- The last active thread saves its result as the carry-out value. + m <- do x <- A.min singleType bd n + y <- A.sub numType x (liftInt 1) + z <- i32 y + return z + when (A.eq singleType tid m) $ + writeArray TypeInt32 carry (liftInt32 0) x2 + + -- First thread stores the final carry-out values at the final reduction + -- result for the entire array + __syncthreads + + when (A.eq singleType tid (liftInt32 0)) $ + writeArray TypeInt32 arrSum (liftInt32 0) =<< readArray TypeInt32 carry (liftInt32 0) + + return_ + + +-- Parallel scan', step 3. +-- +-- Threads combine every element of the partial block results with the carry-in +-- value computed in step 2. +-- +mkScan'AllP3 + :: forall aenv e. + Direction + -> UID + -> Gamma aenv -- ^ array environment + -> TypeR e + -> IRFun2 PTX aenv (e -> e -> e) -- ^ combination function + -> CodeGen PTX (IROpenAcc PTX aenv (Vector e, Scalar e)) +mkScan'AllP3 dir uid aenv tp combine = do + dev <- liftCodeGen $ asks ptxDeviceProperties + -- + let + (arrOut, paramOut) = mutableArray (ArrayR dim1 tp) "out" + (arrTmp, paramTmp) = mutableArray (ArrayR dim1 tp) "tmp" + paramEnv = envParam aenv + -- + stride = local (TupRsingle scalarTypeInt) "ix.stride" + paramStride = parameter (TupRsingle scalarTypeInt) "ix.stride" + -- + config = launchConfig dev (CUDA.incWarp dev) (const 0) const [|| const ||] + -- + makeOpenAccWith config uid "scanP3" (paramTmp ++ paramOut ++ paramStride ++ paramEnv) $ do + + sz <- return $ indexHead (irArrayShape arrOut) + tid <- int =<< threadIdx + + when (A.lt singleType tid stride) $ do + + bid <- int =<< blockIdx + gd <- int =<< gridDim + end <- A.sub numType (indexHead (irArrayShape arrTmp)) (liftInt 1) + + imapFromStepTo bid gd end $ \chunk -> do + + (inf,sup) <- case dir of + LeftToRight -> do + a <- A.add numType chunk (liftInt 1) + b <- A.mul numType stride a + c <- A.add numType b (liftInt 1) + d <- A.add numType c stride + e <- A.min singleType d sz + return (c,e) + RightToLeft -> do + a <- A.sub numType end chunk + b <- A.mul numType stride a + c <- A.sub numType sz b + d <- A.sub numType c (liftInt 1) + e <- A.sub numType d stride + f <- A.max singleType e (liftInt 0) + return (f,d) + + carry <- case dir of + LeftToRight -> readArray TypeInt arrTmp chunk + RightToLeft -> do + a <- A.add numType chunk (liftInt 1) + b <- readArray TypeInt arrTmp a + return b + + -- Apply the carry-in value to each element in the chunk + bd <- int =<< blockDim + i0 <- A.add numType inf tid + imapFromStepTo i0 bd sup $ \i -> do + v <- readArray TypeInt arrOut i + u <- case dir of + LeftToRight -> app2 combine carry v + RightToLeft -> app2 combine v carry + writeArray TypeInt arrOut i u + + return_ + + +-- Multidimensional scans +-- ---------------------- + +-- Multidimensional scan along the innermost dimension +-- +-- A thread block individually computes along each innermost dimension. This is +-- a single-pass operation. +-- +-- * We can assume that the array is non-empty; exclusive scans with empty +-- innermost dimension will be instead filled with the seed element via +-- 'mkScanFill'. +-- +-- * Small but non-empty innermost dimension arrays (size << thread +-- block size) will have many threads which do no work. +-- +mkScanDim + :: forall aenv sh e. + Direction + -> UID + -> Gamma aenv -- ^ array environment + -> ArrayR (Array (sh, Int) e) + -> IRFun2 PTX aenv (e -> e -> e) -- ^ combination function + -> MIRExp PTX aenv e -- ^ seed element, if this is an exclusive scan + -> MIRDelayed PTX aenv (Array (sh, Int) e) -- ^ input data + -> CodeGen PTX (IROpenAcc PTX aenv (Array (sh, Int) e)) +mkScanDim dir uid aenv repr@(ArrayR (ShapeRsnoc shr) tp) combine mseed marr = do + dev <- liftCodeGen $ asks ptxDeviceProperties + -- + let + (arrOut, paramOut) = mutableArray repr "out" + (arrIn, paramIn) = delayedArray "in" marr + paramEnv = envParam aenv + -- + config = launchConfig dev (CUDA.incWarp dev) (scanSMemSize dev tp) const [|| const ||] + -- + makeOpenAccWith config uid "scan" (paramOut ++ paramIn ++ paramEnv) $ do + + -- The first and last threads of the block need to communicate the + -- block-wide aggregate as a carry-in value across iterations. + -- + -- TODO: we could optimise this a bit if we can get access to the shared + -- memory area used by 'scanBlockSMem', and from there directly read the + -- value computed by the last thread. + carry <- staticSharedMem tp 1 + + -- Size of the input array + sz <- indexHead <$> delayedExtent arrIn + + -- Thread blocks iterate over the outer dimensions. Threads in a block + -- cooperatively scan along one dimension, but thread blocks do not + -- communicate with each other. + -- + bid <- int =<< blockIdx + gd <- int =<< gridDim + end <- shapeSize shr (indexTail (irArrayShape arrOut)) + + -- Iterate over the outer dimensions (all but the innermost dimension). + -- Within this loop we perform a scan over a row (innermost dimension) of + -- the input. + -- + -- Since 'bid', 'gd' and 'end' are uniform, the control flow within this + -- loop is also uniform. We can thus perform __syncthreads in the loop. + imapFromStepTo bid gd end $ \seg -> do + + -- Make sure all threads have finished previous iterations, + -- so we can reuse (and overwrite) shared memory. + __syncthreads + + -- Index this thread reads from + tid <- threadIdx + tid' <- int tid + i0 <- case dir of + LeftToRight -> do x <- A.mul numType seg sz + y <- A.add numType x tid' + return y + + RightToLeft -> do x <- A.add numType seg (liftInt 1) + y <- A.mul numType x sz + z <- A.sub numType y tid' + w <- A.sub numType z (liftInt 1) + return w + + -- Index this thread writes to + j0 <- case mseed of + Nothing -> return i0 + Just{} -> do szp1 <- return $ indexHead (irArrayShape arrOut) + case dir of + LeftToRight -> do x <- A.mul numType seg szp1 + y <- A.add numType x tid' + return y + + RightToLeft -> do x <- A.add numType seg (liftInt 1) + y <- A.mul numType x szp1 + z <- A.sub numType y tid' + w <- A.sub numType z (liftInt 1) + return w + + -- Stride indices by block dimension + bd <- blockDim + bd' <- int bd + let next ix = case dir of + LeftToRight -> A.add numType ix bd' + RightToLeft -> A.sub numType ix bd' + + -- Initialise this scan segment + -- + -- If this is an exclusive scan then the first thread just evaluates the + -- seed element and stores this value into the carry-in slot. All threads + -- shift their write-to index (j) by one, to make space for this element. + -- + -- If this is an inclusive scan then do a block-wide scan. The last thread + -- in the block writes the carry-in value. + -- + r <- + case mseed of + Just seed -> do + when (A.eq singleType tid (liftInt32 0)) $ do + z <- seed + writeArray TypeInt arrOut j0 z + writeArray TypeInt32 carry (liftInt32 0) z + j1 <- case dir of + LeftToRight -> A.add numType j0 (liftInt 1) + RightToLeft -> A.sub numType j0 (liftInt 1) + return $ A.trip sz i0 j1 + + Nothing -> do + -- We cannot call scanBlock under non-uniform control flow. + -- Instead, we conditionally read the input, and then + -- unconditionally call scanBlock. + x0 <- if (tp, A.lt singleType tid' sz) + then app1 (delayedLinearIndex arrIn) i0 + else return $ tupUndef tp + n' <- i32 sz + + r0 <- if (tp, A.gte singleType sz bd') + then scanBlock dir dev tp combine Nothing x0 + else scanBlock dir dev tp combine (Just n') x0 + + when (A.lt singleType tid' sz) $ do + writeArray TypeInt arrOut j0 r0 + + ll <- A.sub numType bd (liftInt32 1) + when (A.eq singleType tid ll) $ + writeArray TypeInt32 carry (liftInt32 0) r0 + + n1 <- A.sub numType sz bd' + i1 <- next i0 + j1 <- next j0 + return $ A.trip n1 i1 j1 + + -- Iterate over the remaining elements in this segment + -- The loop condition uses the first triple of the state, 'n'. + -- This variable is uniform (the same for all threads in the thread + -- block), since it is initialized as 'sz' or 'sz - bd', and lowered by + -- 'bd' each iteration. Hence the control flow in this loop is uniform, + -- and we can thus call __syncthreads within the loop. + void $ while + (TupRunit `TupRpair` TupRsingle scalarTypeInt `TupRpair` TupRsingle scalarTypeInt `TupRpair` TupRsingle scalarTypeInt) + (\(A.fst3 -> n) -> A.gt singleType n (liftInt 0)) + (\(A.untrip -> (n,i,j)) -> do + + -- Wait for the carry-in value from the previous iteration to be updated + __syncthreads + + -- Compute and store the next element of the scan + -- + -- NOTE: As with 'foldSeg' we require all threads to participate in + -- every iteration of the loop otherwise they will die prematurely. + -- Out-of-bounds threads return 'undef' at this point, which is really + -- unfortunate ): + -- + x <- if (tp, A.lt singleType tid' n) + then app1 (delayedLinearIndex arrIn) i + else return $ tupUndef tp + + -- Thread zero incorporates the carry-in element + y <- if (tp, A.eq singleType tid (liftInt32 0)) + then do + c <- readArray TypeInt32 carry (liftInt32 0) + case dir of + LeftToRight -> app2 combine c x + RightToLeft -> app2 combine x c + else + return x + + -- Perform the scan and write the result to memory + m <- i32 n + z <- if (tp, A.gte singleType n bd') + then scanBlock dir dev tp combine Nothing y + else scanBlock dir dev tp combine (Just m) y + + when (A.lt singleType tid' n) $ do + writeArray TypeInt arrOut j z + + -- The last thread of the block writes its result as the carry-out + -- value. If this thread is not active then we are on the last + -- iteration of the loop and it will not be needed. + w <- A.sub numType bd (liftInt32 1) + when (A.eq singleType tid w) $ + writeArray TypeInt32 carry (liftInt32 0) z + + -- Update indices for the next iteration + n' <- A.sub numType n bd' + i' <- next i + j' <- next j + return $ A.trip n' i' j') + r + + return_ + + +-- Multidimensional scan' along the innermost dimension +-- +-- A thread block individually computes along each innermost dimension. This is +-- a single-pass operation. +-- +-- * We can assume that the array is non-empty; exclusive scans with empty +-- innermost dimension will be instead filled with the seed element via +-- 'mkScan'Fill'. +-- +-- * Small but non-empty innermost dimension arrays (size << thread +-- block size) will have many threads which do no work. +-- +mkScan'Dim + :: forall aenv sh e. + Direction + -> UID + -> Gamma aenv -- ^ array environment + -> ArrayR (Array (sh, Int) e) + -> IRFun2 PTX aenv (e -> e -> e) -- ^ combination function + -> IRExp PTX aenv e -- ^ seed element + -> MIRDelayed PTX aenv (Array (sh, Int) e) -- ^ input data + -> CodeGen PTX (IROpenAcc PTX aenv (Array (sh, Int) e, Array sh e)) +mkScan'Dim dir uid aenv repr@(ArrayR (ShapeRsnoc shr) tp) combine seed marr = do + dev <- liftCodeGen $ asks ptxDeviceProperties + -- + let + (arrSum, paramSum) = mutableArray (reduceRank repr) "sum" + (arrOut, paramOut) = mutableArray repr "out" + (arrIn, paramIn) = delayedArray "in" marr + paramEnv = envParam aenv + -- + config = launchConfig dev (CUDA.incWarp dev) (scanSMemSize dev tp) const [|| const ||] + -- + makeOpenAccWith config uid "scan" (paramOut ++ paramSum ++ paramIn ++ paramEnv) $ do + + -- The first and last threads of the block need to communicate the + -- block-wide aggregate as a carry-in value across iterations. + -- + -- TODO: we could optimise this a bit if we can get access to the shared + -- memory area used by 'scanBlockSMem', and from there directly read the + -- value computed by the last thread. + carry <- staticSharedMem tp 1 + + -- Size of the input array + sz <- indexHead <$> delayedExtent arrIn + + -- If the innermost dimension is smaller than the number of threads in the + -- block, those threads will never contribute to the output. + tid <- threadIdx + tid' <- int tid + when (A.lte singleType tid' sz) $ do + + -- Thread blocks iterate over the outer dimensions, each thread block + -- cooperatively scanning along each outermost index. + bid <- int =<< blockIdx + gd <- int =<< gridDim + end <- shapeSize shr (irArrayShape arrSum) + + imapFromStepTo bid gd end $ \seg -> do + + -- Not necessary to wait for threads to catch up before starting this segment + -- __syncthreads + + -- Linear index bounds for this segment + inf <- A.mul numType seg sz + sup <- A.add numType inf sz + + -- Index that this thread will read from. Recall that the supremum index + -- is exclusive. + i0 <- case dir of + LeftToRight -> A.add numType inf tid' + RightToLeft -> do x <- A.sub numType sup tid' + y <- A.sub numType x (liftInt 1) + return y + + -- The index that this thread will write to. This is just shifted along + -- by one to make room for the initial element. + j0 <- case dir of + LeftToRight -> A.add numType i0 (liftInt 1) + RightToLeft -> A.sub numType i0 (liftInt 1) + + -- Evaluate the initial element. Store it into the carry-in slot as well + -- as to the array as the first element. This is always valid because if + -- the input array is empty then we will be evaluating via mkScan'Fill. + when (A.eq singleType tid (liftInt32 0)) $ do + z <- seed + writeArray TypeInt arrOut i0 z + writeArray TypeInt32 carry (liftInt32 0) z + + bd <- blockDim + bd' <- int bd + let next ix = case dir of + LeftToRight -> A.add numType ix bd' + RightToLeft -> A.sub numType ix bd' + + -- Now, threads iterate over the elements along the innermost dimension. + -- At each iteration the first thread incorporates the carry-in value + -- from the previous step. + -- + -- The index tracks how many elements remain for the thread block, since + -- indices i* and j* are local to each thread + n0 <- A.sub numType sup inf + void $ while + (TupRunit `TupRpair` TupRsingle scalarTypeInt `TupRpair` TupRsingle scalarTypeInt `TupRpair` TupRsingle scalarTypeInt) + (\(A.fst3 -> n) -> A.gt singleType n (liftInt 0)) + (\(A.untrip -> (n,i,j)) -> do + + -- Wait for threads to catch up to ensure the carry-in value from + -- the last iteration has been updated + __syncthreads + + -- If all threads in the block will participate this round we can + -- avoid (almost) all bounds checks. + _ <- if (TupRunit, A.gte singleType n bd') + -- All threads participate. No bounds checks required but + -- the last thread needs to update the carry-in value. + then do + x <- app1 (delayedLinearIndex arrIn) i + y <- if (tp, A.eq singleType tid (liftInt32 0)) + then do + c <- readArray TypeInt32 carry (liftInt32 0) + case dir of + LeftToRight -> app2 combine c x + RightToLeft -> app2 combine x c + else + return x + z <- scanBlock dir dev tp combine Nothing y + + -- Write results to the output array. Note that if we + -- align directly on the boundary of the array this is not + -- valid for the last thread. + case dir of + LeftToRight -> when (A.lt singleType j sup) $ writeArray TypeInt arrOut j z + RightToLeft -> when (A.gte singleType j inf) $ writeArray TypeInt arrOut j z + + -- Last thread of the block also saves its result as the + -- carry-in value + bd1 <- A.sub numType bd (liftInt32 1) + when (A.eq singleType tid bd1) $ + writeArray TypeInt32 carry (liftInt32 0) z + + return (lift TupRunit ()) + + -- Only threads that are in bounds can participate. This is + -- the last iteration of the loop. The last active thread + -- still needs to store its value into the carry-in slot. + -- + -- Note that all threads must call the block-wide scan. + -- SEE: [Synchronisation problems with SM_70 and greater] + else do + x <- if (tp, A.lt singleType tid' n) + then do + x <- app1 (delayedLinearIndex arrIn) i + y <- if (tp, A.eq singleType tid (liftInt32 0)) + then do + c <- readArray TypeInt32 carry (liftInt32 0) + case dir of + LeftToRight -> app2 combine c x + RightToLeft -> app2 combine x c + else + return x + return y + else + return $ tupUndef tp + + l <- i32 n + y <- scanBlock dir dev tp combine (Just l) x + + m <- A.sub numType l (liftInt32 1) + when (A.lt singleType tid m) $ writeArray TypeInt arrOut j y + when (A.eq singleType tid m) $ writeArray TypeInt32 carry (liftInt32 0) y + + return (lift TupRunit ()) + + A.trip <$> A.sub numType n bd' <*> next i <*> next j) + (A.trip n0 i0 j0) + + -- Wait for the carry-in value to be updated + __syncthreads + + -- Store the carry-in value to the separate final results array + when (A.eq singleType tid (liftInt32 0)) $ + writeArray TypeInt arrSum seg =<< readArray TypeInt32 carry (liftInt32 0) + + return_ + + + +-- Parallel scan, auxiliary +-- +-- If this is an exclusive scan of an empty array, we just fill the result with +-- the seed element. +-- +mkScanFill + :: UID + -> Gamma aenv + -> ArrayR (Array sh e) + -> IRExp PTX aenv e + -> CodeGen PTX (IROpenAcc PTX aenv (Array sh e)) +mkScanFill uid aenv repr seed = + mkGenerate uid aenv repr (IRFun1 (const seed)) + +mkScan'Fill + :: UID + -> Gamma aenv + -> ArrayR (Array (sh, Int) e) + -> IRExp PTX aenv e + -> CodeGen PTX (IROpenAcc PTX aenv (Array (sh, Int) e, Array sh e)) +mkScan'Fill uid aenv repr seed = + Safe.coerce <$> mkGenerate uid aenv (reduceRank repr) (IRFun1 (const seed)) + +scanSMemSize :: DeviceProperties -> TypeR e -> Int -> Int +scanSMemSize dev tp n = sharedMemorySizeAdd tp warps 0 + where + ws = CUDA.warpSize dev + warps = n `P.quot` ws + +-- Block wide scan +-- --------------- + +-- Efficient block-wide (inclusive) scan using the specified operator. +-- +-- Each block requires (#warps * (1 + 1.5*warp size)) elements of dynamically +-- allocated shared memory. +-- +-- Example: https://github.com/NVlabs/cub/blob/1.5.4/cub/block/specializations/block_scan_warp_scans.cuh +-- +-- Must be called under uniform control flow within a thread block +-- (as this function may use __syncthreads) +scanBlock + :: forall aenv e. + Direction + -> DeviceProperties -- ^ properties of the target device + -> TypeR e + -> IRFun2 PTX aenv (e -> e -> e) -- ^ combination function + -> Maybe (Operands Int32) -- ^ number of valid elements (may be less than block size) + -> Operands e -- ^ calling thread's input element + -> CodeGen PTX (Operands e) +scanBlock dir dev tp combine nelem = warpScan >=> warpPrefix + where + int32 :: Integral a => a -> Operands Int32 + int32 = liftInt32 . P.fromIntegral + + -- Temporary storage required for each warp + -- warp_smem_elems = CUDA.warpSize dev + (CUDA.warpSize dev `P.quot` 2) + -- warp_smem_bytes = warp_smem_elems * bytesElt tp + + -- Step 1: Scan in every warp + warpScan :: Operands e -> CodeGen PTX (Operands e) + warpScan = scanWarp dir dev tp combine + + -- Step 2: Collect the aggregate results of each warp to compute the prefix + -- values for each warp and combine with the partial result to compute each + -- thread's final value. + warpPrefix :: Operands e -> CodeGen PTX (Operands e) + warpPrefix input = do + -- Allocate #warps elements of shared memory + bd <- blockDim + warps <- A.quot integralType bd (int32 (CUDA.warpSize dev)) + smem <- dynamicSharedMem tp TypeInt32 warps (liftInt32 0) + + -- Share warp aggregates + wid <- warpId + lane <- laneId + when (A.eq singleType lane (int32 (CUDA.warpSize dev - 1))) $ do + writeArray TypeInt32 smem wid input + + -- Wait for each warp to finish its local scan and share the aggregate + __syncthreads + + -- Compute the prefix value for this warp and add to the partial result. + -- This step is not required for the first warp, which has no carry-in. + if (tp, A.eq singleType wid (liftInt32 0)) + then return input + else do + -- Every thread sequentially scans the warp aggregates to compute + -- their prefix value. We do this sequentially, but could also have + -- warp 0 do it cooperatively if we limit thread block sizes to + -- (warp size ^ 2). + steps <- case nelem of + Nothing -> return wid + Just n -> A.min singleType wid =<< A.quot integralType n (int32 (CUDA.warpSize dev)) + + p0 <- readArray TypeInt32 smem (liftInt32 0) + prefix <- iterFromStepTo tp (liftInt32 1) (liftInt32 1) steps p0 $ \step x -> do + y <- readArray TypeInt32 smem step + case dir of + LeftToRight -> app2 combine x y + RightToLeft -> app2 combine y x + + case dir of + LeftToRight -> app2 combine prefix input + RightToLeft -> app2 combine input prefix + + +-- Warp-wide scan +-- -------------- + +-- Efficient warp-wide (inclusive) scan using the specified operator. +-- +-- Each warp requires 48 (1.5 x warp size) elements of shared memory. The +-- routine assumes that it is allocated individually per-warp (i.e. can be +-- indexed in the range [0, warp size)). +-- +-- Example: https://github.com/NVlabs/cub/blob/1.5.4/cub/warp/specializations/warp_scan_smem.cuh +-- +scanWarp + :: forall aenv e. + Direction + -> DeviceProperties -- ^ properties of the target device + -> TypeR e + -> IRFun2 PTX aenv (e -> e -> e) -- ^ combination function + -> Operands e -- ^ calling thread's input element + -> CodeGen PTX (Operands e) +scanWarp dir dev tp combine = scan 0 + where + log2 :: Double -> Double + log2 = P.logBase 2 + + -- Number of steps required to scan warp + steps = P.floor (log2 (P.fromIntegral (CUDA.warpSize dev))) + + -- Unfold the scan as a recursive code generation function + scan :: Int -> Operands e -> CodeGen PTX (Operands e) + scan step x + | step >= steps = return x + | otherwise = do + let offset = 1 `P.shiftL` step + + -- share partial result through shared memory buffer + y <- __shfl_up tp x (liftWord32 offset) + lane <- laneId + + -- update partial result if in range + x' <- if (tp, A.gte singleType lane (liftInt32 . P.fromIntegral $ offset)) + then do + case dir of + LeftToRight -> app2 combine y x + RightToLeft -> app2 combine x y + + else + return x + + scan (step+1) x' + +tupUndef :: TypeR a -> Operands a +tupUndef TupRunit = OP_Unit +tupUndef (TupRpair a b) = OP_Pair (tupUndef a) (tupUndef b) +tupUndef (TupRsingle t) = ir t (undef t) + +-- Utilities +-- --------- + +i32 :: Operands Int -> CodeGen PTX (Operands Int32) +i32 = A.fromIntegral integralType numType + +int :: Operands Int32 -> CodeGen PTX (Operands Int) +int = A.fromIntegral integralType numType + diff --git a/src/Data/Array/Accelerate/LLVM/PTX/CodeGen/Stencil.hs b/src/Data/Array/Accelerate/LLVM/PTX/CodeGen/Stencil.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/PTX/CodeGen/Stencil.hs @@ -0,0 +1,190 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.PTX.CodeGen.Stencil +-- Copyright : [2018..2020] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.PTX.CodeGen.Stencil ( + + mkStencil1, + mkStencil2, + +) where + +import Data.Array.Accelerate.Representation.Array +import Data.Array.Accelerate.Representation.Shape +import Data.Array.Accelerate.Representation.Stencil +import Data.Array.Accelerate.Representation.Type +import Data.Array.Accelerate.Type + +import Data.Array.Accelerate.LLVM.CodeGen.Arithmetic +import Data.Array.Accelerate.LLVM.CodeGen.Array +import Data.Array.Accelerate.LLVM.CodeGen.Base +import Data.Array.Accelerate.LLVM.CodeGen.Environment +import Data.Array.Accelerate.LLVM.CodeGen.Exp +import Data.Array.Accelerate.LLVM.CodeGen.IR +import Data.Array.Accelerate.LLVM.CodeGen.Monad +import Data.Array.Accelerate.LLVM.CodeGen.Stencil +import Data.Array.Accelerate.LLVM.CodeGen.Sugar +import Data.Array.Accelerate.LLVM.Compile.Cache + +import Data.Array.Accelerate.LLVM.PTX.CodeGen.Base +import Data.Array.Accelerate.LLVM.PTX.CodeGen.Loop +import Data.Array.Accelerate.LLVM.PTX.Target ( PTX ) + +import qualified Data.Array.Accelerate.LLVM.Internal.LLVMPretty.AST as LP + +import Control.Monad + + +-- The stencil function is similar to a map, but has access to surrounding +-- elements as specified by the stencil pattern. +-- +-- This generates two functions: +-- +-- * stencil_inside: does not apply boundary conditions, assumes all element +-- accesses are valid +-- +-- * stencil_border: applies boundary condition check to each array access +-- +mkStencil1 + :: UID + -> Gamma aenv + -> StencilR sh a stencil + -> TypeR b + -> IRFun1 PTX aenv (stencil -> b) + -> IRBoundary PTX aenv (Array sh a) + -> MIRDelayed PTX aenv (Array sh a) + -> CodeGen PTX (IROpenAcc PTX aenv (Array sh b)) +mkStencil1 uid aenv stencil tp fun bnd marr = + let repr = ArrayR shr tp + (shr, halo) = stencilHalo stencil + (arrIn, paramIn) = delayedArray "in" marr + in + (+++) <$> mkInside uid aenv repr halo (IRFun1 $ app1 fun <=< stencilAccess stencil Nothing arrIn) paramIn + <*> mkBorder uid aenv repr (IRFun1 $ app1 fun <=< stencilAccess stencil (Just bnd) arrIn) paramIn + + +mkStencil2 + :: UID + -> Gamma aenv + -> StencilR sh a stencil1 + -> StencilR sh b stencil2 + -> TypeR c + -> IRFun2 PTX aenv (stencil1 -> stencil2 -> c) + -> IRBoundary PTX aenv (Array sh a) + -> MIRDelayed PTX aenv (Array sh a) + -> IRBoundary PTX aenv (Array sh b) + -> MIRDelayed PTX aenv (Array sh b) + -> CodeGen PTX (IROpenAcc PTX aenv (Array sh c)) +mkStencil2 uid aenv stencil1 stencil2 tp f bnd1 marr1 bnd2 marr2 = + let + repr = ArrayR shr tp + (arrIn1, paramIn1) = delayedArray "in1" marr1 + (arrIn2, paramIn2) = delayedArray "in2" marr2 + + inside = IRFun1 $ \ix -> do + s1 <- stencilAccess stencil1 Nothing arrIn1 ix + s2 <- stencilAccess stencil2 Nothing arrIn2 ix + app2 f s1 s2 + -- + border = IRFun1 $ \ix -> do + s1 <- stencilAccess stencil1 (Just bnd1) arrIn1 ix + s2 <- stencilAccess stencil2 (Just bnd2) arrIn2 ix + app2 f s1 s2 + + (shr, halo1) = stencilHalo stencil1 + (_, halo2) = stencilHalo stencil2 + halo = union shr halo1 halo2 + in + (+++) <$> mkInside uid aenv repr halo inside (paramIn1 ++ paramIn2) + <*> mkBorder uid aenv repr border (paramIn1 ++ paramIn2) + + +mkInside + :: UID + -> Gamma aenv + -> ArrayR (Array sh e) + -> sh + -> IRFun1 PTX aenv (sh -> e) + -> [LP.Typed LP.Ident] + -> CodeGen PTX (IROpenAcc PTX aenv (Array sh e)) +mkInside uid aenv repr@(ArrayR shr _) halo apply paramIn = + let + (arrOut, paramOut) = mutableArray repr "out" + paramInside = parameter (shapeType shr) "shInside" + shInside = local (shapeType shr) "shInside" + shOut = irArrayShape arrOut + paramEnv = envParam aenv + in + makeOpenAcc uid "stencil_inside" (paramInside ++ paramOut ++ paramIn ++ paramEnv) $ do + + start <- return (liftInt 0) + end <- shapeSize shr shInside + + -- iterate over the inside region as a linear index space + -- + imapFromTo start end $ \i -> do + + ixIn <- indexOfInt shr shInside i -- convert to multidimensional index of inside region + ixOut <- offset shr ixIn (lift (shapeType shr) halo) -- shift to multidimensional index of outside region + r <- app1 apply ixOut -- apply generator function + j <- intOfIndex shr shOut ixOut + writeArray TypeInt arrOut j r + + return_ + + +mkBorder + :: UID + -> Gamma aenv + -> ArrayR (Array sh e) + -> IRFun1 PTX aenv (sh -> e) + -> [LP.Typed LP.Ident] + -> CodeGen PTX (IROpenAcc PTX aenv (Array sh e)) +mkBorder uid aenv repr@(ArrayR shr _) apply paramIn = + let + (arrOut, paramOut) = mutableArray repr "out" + paramFrom = parameter (shapeType shr) "shFrom" + shFrom = local (shapeType shr) "shFrom" + paramInside = parameter (shapeType shr) "shInside" + shInside = local (shapeType shr) "shInside" + shOut = irArrayShape arrOut + paramEnv = envParam aenv + in + makeOpenAcc uid "stencil_border" (paramFrom ++ paramInside ++ paramOut ++ paramIn ++ paramEnv) $ do + + start <- return (liftInt 0) + end <- shapeSize shr shInside + + imapFromTo start end $ \i -> do + + ixIn <- indexOfInt shr shInside i -- convert to multidimensional index of inside region + ixOut <- offset shr ixIn shFrom -- shift to multidimensional index of outside region + r <- app1 apply ixOut -- apply generator function + j <- intOfIndex shr shOut ixOut + writeArray TypeInt arrOut j r + + return_ + + +offset :: ShapeR sh -> Operands sh -> Operands sh -> CodeGen PTX (Operands sh) +offset shr sh1 sh2 = go shr sh1 sh2 + where + go :: ShapeR t -> Operands t -> Operands t -> CodeGen PTX (Operands t) + go ShapeRz OP_Unit OP_Unit + = return OP_Unit + + go (ShapeRsnoc t) (OP_Pair sa1 sb1) (OP_Pair sa2 sb2) + = do x <- add (numType :: NumType Int) sb1 sb2 + OP_Pair <$> go t sa1 sa2 <*> return x + diff --git a/src/Data/Array/Accelerate/LLVM/PTX/CodeGen/Transform.hs b/src/Data/Array/Accelerate/LLVM/PTX/CodeGen/Transform.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/PTX/CodeGen/Transform.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.PTX.CodeGen.Transform +-- Copyright : [2014..2020] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.PTX.CodeGen.Transform + where + +-- accelerate +import Data.Array.Accelerate.Representation.Array +import Data.Array.Accelerate.Type + +import Data.Array.Accelerate.LLVM.CodeGen.Arithmetic +import Data.Array.Accelerate.LLVM.CodeGen.Array +import Data.Array.Accelerate.LLVM.CodeGen.Base +import Data.Array.Accelerate.LLVM.CodeGen.Environment +import Data.Array.Accelerate.LLVM.CodeGen.Exp +import Data.Array.Accelerate.LLVM.CodeGen.Monad +import Data.Array.Accelerate.LLVM.CodeGen.Sugar +import Data.Array.Accelerate.LLVM.Compile.Cache + +import Data.Array.Accelerate.LLVM.PTX.CodeGen.Base +import Data.Array.Accelerate.LLVM.PTX.CodeGen.Loop +import Data.Array.Accelerate.LLVM.PTX.Target ( PTX ) + + +-- Apply a unary function to each element of an array. Each thread processes +-- multiple elements, striding the array by the grid size. +-- +mkTransform + :: UID + -> Gamma aenv + -> ArrayR (Array sh a) + -> ArrayR (Array sh' b) + -> IRFun1 PTX aenv (sh' -> sh) + -> IRFun1 PTX aenv (a -> b) + -> CodeGen PTX (IROpenAcc PTX aenv (Array sh' b)) +mkTransform uid aenv repr@(ArrayR shr _) repr'@(ArrayR shr' _) p f = + let + (arrOut, paramOut) = mutableArray repr' "out" + (arrIn, paramIn) = mutableArray repr "in" + paramEnv = envParam aenv + in + makeOpenAcc uid "transform" (paramOut ++ paramIn ++ paramEnv) $ do + + let start = liftInt 0 + end <- shapeSize shr' (irArrayShape arrOut) + + imapFromTo start end $ \i' -> do + ix' <- indexOfInt shr' (irArrayShape arrOut) i' + ix <- app1 p ix' + i <- intOfIndex shr (irArrayShape arrIn) ix + a <- readArray TypeInt arrIn i + b <- app1 f a + writeArray TypeInt arrOut i' b + + return_ + diff --git a/src/Data/Array/Accelerate/LLVM/PTX/Compile.hs b/src/Data/Array/Accelerate/LLVM/PTX/Compile.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/PTX/Compile.hs @@ -0,0 +1,283 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-orphans #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.PTX.Compile +-- Copyright : [2014..2020] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.PTX.Compile ( + + module Data.Array.Accelerate.LLVM.Compile, + ObjectR(..), + +) where + +import Data.Array.Accelerate.AST ( PreOpenAcc ) +import Data.Array.Accelerate.Error +import Data.Array.Accelerate.Trafo.Delayed + +import Data.Array.Accelerate.LLVM.CodeGen ( llvmOfPreOpenAcc ) +import Data.Array.Accelerate.LLVM.CodeGen.Environment ( Gamma ) +import Data.Array.Accelerate.LLVM.CodeGen.Module ( Module(..) ) +import Data.Array.Accelerate.LLVM.Compile +import Data.Array.Accelerate.LLVM.State +import Data.Array.Accelerate.LLVM.Target.ClangInfo ( hostLLVMVersion, llvmverFromTuple, clangExePath, clangExePathEnvironment ) + +import Data.Array.Accelerate.LLVM.PTX.Analysis.Launch +import Data.Array.Accelerate.LLVM.PTX.CodeGen +import Data.Array.Accelerate.LLVM.PTX.Compile.Cache +import Data.Array.Accelerate.LLVM.PTX.Compile.Libdevice.Load +import Data.Array.Accelerate.LLVM.PTX.Foreign ( ) +import Data.Array.Accelerate.LLVM.PTX.Target +import qualified Data.Array.Accelerate.LLVM.PTX.Debug as Debug + +import Foreign.CUDA.Path ( cudaInstallPath ) +import qualified Foreign.CUDA.Analysis as CUDA + +import qualified LLVM.AST.Type.Name as LLVM + +import qualified Data.Array.Accelerate.LLVM.Internal.LLVMPretty as LP +import qualified Data.Array.Accelerate.LLVM.Internal.LLVMPretty.PP as LP +import qualified Text.PrettyPrint as Pretty + +import Control.Monad ( when ) +import Control.Monad.Reader +import Data.ByteString.Short ( ShortByteString ) +import Data.List ( intercalate ) +import qualified Data.List.NonEmpty as NE +import Data.Foldable ( toList ) +import GHC.IO.Exception ( IOErrorType(OtherError) ) +import Formatting +import System.Directory +import System.Exit ( ExitCode(..) ) +import System.IO ( hPutStrLn, stderr ) +import System.IO.Error ( mkIOError ) +import System.IO.Unsafe +import System.Process +import Text.Printf ( printf ) +import qualified Data.ByteString.Short.Char8 as SBS8 +import qualified Data.Map.Strict as Map + + +instance Compile PTX where + data ObjectR PTX = ObjectR { objId :: {-# UNPACK #-} !UID + , -- | Config for each exported kernel (symbol) + ptxConfig :: ![(ShortByteString, LaunchConfig)] + , objPath :: {- LAZY -} FilePath + } + compileForTarget = compile + + +-- | Compile an Accelerate expression to object code. +-- +-- This generates the target code together with a list of each kernel function +-- defined in the module paired with its occupancy information. +-- +compile :: HasCallStack => PreOpenAcc DelayedOpenAcc aenv a -> Gamma aenv -> LLVM PTX (ObjectR PTX) +compile pacc aenv = do + + -- Generate code for this Acc operation + -- + dev <- asks ptxDeviceProperties + let CUDA.Compute m n = CUDA.computeCapability dev + let arch = printf "sm_%d%d" m n + (uid, cacheFile) <- cacheOfPreOpenAcc pacc + Module ast md <- llvmOfPreOpenAcc uid pacc aenv + let config = [ (SBS8.pack f, x) | (LP.Symbol f, KM_PTX x) <- Map.toList md ] + + libdevice_bc <- liftIO libdeviceBitcodePath + + case isDeviceSupported (CUDA.computeCapability dev) of + Nothing -> return () -- all fine + Just err -> internalError string err + + -- Lower the generated LLVM into a CUBIN object code. + -- + -- The 'objData' field is lazily evaluated since the object code might have + -- already been loaded into the current context from a different function, in + -- which case it will be found by the linker cache. + -- + cubin <- liftIO . unsafeInterleaveIO $ do + exists <- doesFileExist cacheFile + recomp <- if Debug.debuggingIsEnabled then Debug.getFlag Debug.force_recomp else return False + if exists && not recomp + then do + Debug.traceM Debug.dump_cc ("cc: found cached object code " % shown) uid + + else do + -- Detect LLVM version + -- Note: this LLVM version is incorporated in the cache path, so we're safe detecting it at runtime. + let prettyHostLLVMVersion = intercalate "." (map show (toList hostLLVMVersion)) + llvmver <- case llvmverFromTuple hostLLVMVersion of + Just llvmver -> return llvmver + Nothing -> internalError ("accelerate-llvm-ptx: Unsupported LLVM version: " % string) + prettyHostLLVMVersion + Debug.traceM Debug.dump_cc ("Using Clang at " % string % " version " % shown) clangExePath prettyHostLLVMVersion + + when (NE.head hostLLVMVersion < 16) $ + case clangExePathEnvironment of + Nothing -> do + hPutStrLn stderr $ + "[accelerate-llvm-ptx] Clang version 16 or newer is required for the Nvidia PTX " ++ + "backend, but version " ++ prettyHostLLVMVersion ++ " was found at '" ++ + clangExePath ++ "'. To override this choice, set the ACCELERATE_LLVM_CLANG_PATH " ++ + "environment variable to point to the desired clang executable." + -- not an IOError because we're in unsafePerformIO, somewhere up the call chain + errorWithoutStackTrace $ + "accelerate-llvm-ptx: Clang version " ++ prettyHostLLVMVersion ++ + " found but >=16 required (set ACCELERATE_LLVM_CLANG_PATH to override)" + Just{} -> -- If an explicit path was given, let's just continue and see what happens. + return () + + -- Convert module to llvm-pretty format so that we can print it + let unoptimisedText = Pretty.renderStyle + Pretty.style { Pretty.lineLength = maxBound `div` 2 } + (LP.ppLLVM llvmver (LP.ppModule ast)) + ++ "\n\n" ++ accPreludePTX + Debug.when Debug.verbose $ do + Debug.traceM Debug.dump_cc ("Unoptimised LLVM IR:\n" % string) unoptimisedText + + isVerboseFlagSet <- Debug.getFlag Debug.verbose + let clangArgs = ["-O3", "--target=nvptx64-nvidia-cuda", "-march=" ++ arch + ,"-o", cacheFile + ,"-Wno-override-module" + ,"--cuda-path=" ++ cudaInstallPath + ,"-x", "ir", "-" + -- See Note [Internalizing Libdevice] + -- TODO: only link in libdevice if we're actually using __nv_ functions! + ,"-Xclang", "-mlink-builtin-bitcode", "-Xclang", libdevice_bc] + ++ (if isVerboseFlagSet then ["-v"] else []) + + Debug.traceM Debug.dump_cc ("Arguments to clang: " % shown) clangArgs + + -- Remove some diagnostics from clang (and subprocesses) output that we + -- know are fine. See filterClangStderr. Unfortunately, System.Process + -- does not have a combinator for "give me stdout and stderr but throw + -- exception on ExitFailure", so we do it manually. + (clangEC, clangOut, clangErr) <- readProcessWithExitCode clangExePath clangArgs unoptimisedText + putStr clangOut + putStr (filterClangStderr clangErr) + case clangEC of + ExitSuccess -> return () + ExitFailure code -> do + let msg = "clang returned non-zero exit code: " ++ show code ++ + " (invocation: " ++ show (clangExePath : clangArgs) ++ ")" + ioError $ mkIOError OtherError msg Nothing Nothing + + Debug.traceM Debug.dump_cc ("Written PTX to: " % string) cacheFile + + return cacheFile + + return $! ObjectR uid config cubin + + +{- Note [Internalizing Libdevice] + +"Libdevice" refers to $CUDAPATH/nvvm/libdevice/libdevice.XX.bc, an LLVM bitcode +file that (reportedly) contains definitions of various math functions for use +in NVIDIA PTX. Most interesting primitive arithmetic operations on +floating-point numbers get compiled to calls to functions from libdevice, so it +is essential that we link it into any kernel that we create (or at least, any +kernel that references functions from libdevice). + +However, libdevice is quite large; it is 473 KB of LLVM bitcode for cuda 12.6 +on my machine, and clang takes >1 second to compile it on my (5 GHz Intel) +machine. Indeed, the LLVM NVPTX usage guide [1] recommends _internalizing_ the +symbols from libdevice after linking it with the kernel module; more precisely, +it recommends to first link the kernel module with libdevice, and subsequently +internalize all functions that we don't explicitly want exported (the public +kernel functions). + +Clang doesn't have a command-line option to internalize symbols. Indeed, it +would be somewhat ambiguous when in the compilation process to do said +internalization. The LLVM command-line tool that _can_ do internalization is +`llvm-link`, the tool for linking LLVM modules together (and doing little +else). So translating the recommended [1] strategy to command-line tools +(because linking with LLVM through bindings is a version nightmare -- been +there, done that, not again), we get the following sensible procedure: + +$ llvm-link --internalize kernel.ll libdevice.bc -o kernel-linked.bc +$ clang --target=... kernel-linked.bc -o kernel.sass + +However, llvm-link is not clang, and we'd very much like to depend _only_ on +clang, not on the full LLVM suite of tools. Especially not for this vexingly +small bit of functionality! But clang is huge, and surely it can do +internalization somehow? + +It turns out it can, but they did their absolute best to hide it. (All +references in this paragraph are to LLVM HEAD on 2024-12-04: 7954a0514ba7de.) +The workhorse function, called from `llvm-link`, is internalizeModule(). This +function is also called from clang in BackendConsumer::LinkInModules() in +clang/lib/CodeGen/CodeGenAction.cpp, but only if .Internalize is set on the +CodeGenAction::LinkModule in question. In CompilerInvocation::ParseCodeGenArgs +(clang/lib/Frontend/CompilerInvocation.cpp), we see that _some_ field called +"Internalize" is set on _something_ (not a LinkModule, but whatever?) if the +OPT_mlink_builtin_bitcode flag is set. Of course, no documentation anywhere +explains what this option does; the only mention I could find anywhere is here +[2], as well as some mailing list posts / issue tracker comments mentioning it. +How do we use the option? Well, it's not a clang option, it's actually a (I +think!) cc1 option, so you have to do: + +$ clang -Xclang -mlink-builtin-bitcode -Xclang libdevice.bc + +This makes clang internalize everything in that module that is not globally +exported (I think), which is what we want. + +[1]: https://releases.llvm.org/19.1.0/docs/NVPTXUsage.html#linking-with-libdevice +[2]: https://clang.llvm.org/docs/OffloadingDesign.html#offload-device-compilation +-} + +filterClangStderr :: String -> String +filterClangStderr = unlines . filter (not . isShflSyncWarn) . lines + where + -- ptxas warns about use of shfl instructions without the .sync suffix on + -- CC 6.0, because such non-sync shuffles are deprecated (and indeed + -- removed in CC 7.0). We still use them in CC 6.0 (and not any more in CC + -- 7.0) because the shfl.sync in CC 6.0 has restrictions: + -- + -- > For .target `sm_6x` or below, all threads in `membermask` must execute + -- > the same `shfl.sync` instruction in convergence, and only threads + -- > belonging to some `membermask` can be active when the `shfl.sync` + -- > instruction is executed. Otherwise, the behavior is undefined. + -- (https://docs.nvidia.com/cuda/parallel-thread-execution/index.html#data-movement-and-conversion-instructions-shfl-sync) + -- + -- Perhaps we do use the shuffles in convergence, but we don't want to risk + -- it. Hence in CC 6.0, we still use non-sync shuffles. + -- + -- The ptxas warning cannot be turned off, however, and is **incredibly** + -- noisy (there's a warning for every single shfl instruction). Hence we + -- filter them out here. + -- + -- > ptxas /tmp/--f8a421.s, line 119; warning : Instruction 'shfl' without '.sync' is deprecated since PTX ISA version 6.0 and will be discontinued in a future PTX ISA version + isShflSyncWarn line = + let (presemi, postsemi) = break (== ';') line + in takeWhile (/= ' ') presemi == "ptxas" && + postsemi == "; warning : Instruction 'shfl' without '.sync' is deprecated since " ++ + "PTX ISA version 6.0 and will be discontinued in a future PTX ISA version" + +-- | Returns a human-readable error message in case the device is unsupported, +-- and Nothing if everything is alright. +isDeviceSupported :: CUDA.Compute -> Maybe String +isDeviceSupported cc@(CUDA.Compute m _) + -- We require shfl instructions which are available only from CC 3.0. + | m >= 3 = Nothing + | otherwise = Just $ + "Your GPU has compute capability " ++ show cc ++ ", but only >= 3.0 is supported." + +accPreludePTX :: String +accPreludePTX = unlines + -- see Data.Array.Accelerate.LLVM.PTX.CodeGen.Base.nanosleep for why this is a hand-written function + ["define private void @" ++ name_nanosleep ++ "(i32 noundef %0) alwaysinline convergent nounwind {" + ," tail call void asm sideeffect \"nanosleep.u32 $0;\", \"r\"(i32 %0)" + ," ret void" + ,"}"] + where + name_nanosleep = let LLVM.Label name = LLVM.makeAccPreludeLabel "nanosleep" in SBS8.unpack name diff --git a/src/Data/Array/Accelerate/LLVM/PTX/Compile/Cache.hs b/src/Data/Array/Accelerate/LLVM/PTX/Compile/Cache.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/PTX/Compile/Cache.hs @@ -0,0 +1,42 @@ +{-# OPTIONS_GHC -Wno-orphans #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.PTX.Compile.Cache +-- Copyright : [2017..2020] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.PTX.Compile.Cache ( + + module Data.Array.Accelerate.LLVM.Compile.Cache + +) where + +import Data.Array.Accelerate.LLVM.Compile.Cache +import Data.Array.Accelerate.LLVM.PTX.Target +import Data.Array.Accelerate.LLVM.Target.ClangInfo ( hostLLVMVersion ) + +import Control.Monad.Reader +import Data.Foldable ( toList ) +import Data.List ( intercalate ) +import Data.Version +import Foreign.CUDA.Analysis +import System.FilePath +import Text.Printf +import qualified Data.ByteString.Short.Char8 as S8 + +import Paths_accelerate_llvm_ptx + + +instance Persistent PTX where + targetCacheTemplate = do + Compute m n <- asks (computeCapability . ptxDeviceProperties) + return $ "accelerate-llvm-ptx-" ++ showVersion version + "llvmpr-" ++ intercalate "." (map show (toList hostLLVMVersion)) + S8.unpack ptxTargetTriple + printf "sm%d%d" m n + "morp.sass" + diff --git a/src/Data/Array/Accelerate/LLVM/PTX/Compile/Libdevice/Load.hs b/src/Data/Array/Accelerate/LLVM/PTX/Compile/Libdevice/Load.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/PTX/Compile/Libdevice/Load.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Data.Array.Accelerate.LLVM.PTX.Compile.Libdevice.Load +-- Copyright : [2014..2020] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.PTX.Compile.Libdevice.Load ( + + libdeviceBitcodePath, + +) where + +import Data.Array.Accelerate.Error +import Data.Array.Accelerate.LLVM.PTX.Execute.Event ( ) -- GHC#1012 +import Data.Array.Accelerate.LLVM.PTX.Execute.Stream ( ) -- GHC#1012 + +import qualified Foreign.CUDA.Driver as CUDA + +import Foreign.CUDA.Path + +import Data.List ( isPrefixOf, sortBy ) +import System.Directory +import System.FilePath + + +-- libdevice +-- --------- + +-- Compatible version of libdevice for a given compute capability should be +-- listed here: +-- +-- https://github.com/llvm/llvm-project/blob/master/lib/Target/NVPTX/NVPTX.td + +-- | Find the libdevice bitcode file for the given compute architecture. The name +-- of the bitcode file follows the format @libdevice.XX.bc@, where XX +-- represents a version(?). We search the libdevice path for all files of the +-- appropriate compute capability and load the "most recent" (by sort order). +libdeviceBitcodePath :: HasCallStack => IO FilePath +libdeviceBitcodePath + | CUDA.libraryVersion < 9000 = + -- There is some support code for cuda < 9 in an earlier version of these + -- files; in particular, look at commit + -- 2b5d69448557e89002c0179ea1aaf59bb757a6e3 (2023-08-22) + -- for original llvm-hs code. + internalError "Cuda < 9 is unsupported." + | otherwise = do + let nvvm = cudaInstallPath "nvvm" "libdevice" + + files <- getDirectoryContents nvvm + + let matches f = "libdevice" `isPrefixOf` f && takeExtension f == ".bc" + return $ case sortBy (flip compare) (filter matches files) of + name : _ -> nvvm name + [] -> internalError "not found: libdevice.XX.bc" diff --git a/src/Data/Array/Accelerate/LLVM/PTX/Context.hs b/src/Data/Array/Accelerate/LLVM/PTX/Context.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/PTX/Context.hs @@ -0,0 +1,269 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.PTX.Context +-- Copyright : [2014..2020] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.PTX.Context ( + + Context(..), + new, raw, withContext, + contextFinalizeResource, + +) where + +import Data.Array.Accelerate.Lifetime +import Data.Array.Accelerate.LLVM.PTX.Analysis.Device +import qualified Data.Array.Accelerate.LLVM.PTX.Debug as Debug + +import qualified Foreign.CUDA.Driver.Device as CUDA +import qualified Foreign.CUDA.Driver.Context as CUDA + +import Control.Concurrent +import Control.Exception +import Control.Monad +import Data.Char +import Data.Hashable +import Data.Int +import Data.IORef +import Data.Primitive.ByteArray +import Data.Text.Lazy.Builder +import Data.Word +import Formatting +import Prettyprinter +import Prettyprinter.Internal +import Prettyprinter.Render.Util.Panic +import Text.Printf +import qualified Data.Text.Lazy.Builder as TLB +import Prelude hiding ( (<>) ) + +import GHC.Base ( Int(..), addr2Int#, ) +import GHC.Ptr ( Ptr(..) ) + + +-- | An execution context, which is tied to a specific device and CUDA execution +-- context. +-- +data Context = Context { + deviceProperties :: {-# UNPACK #-} !CUDA.DeviceProperties -- information on hardware resources + , deviceName :: {-# UNPACK #-} !ByteArray -- device name, used for profiling + , deviceContext :: {-# UNPACK #-} !(Lifetime CUDA.Context) -- device execution context + + -- | The number of finalizers currently using the context to free resources, + -- plus 1 if the Context finalizer does not yet want to destroy the context + -- itself. See Note: [Finalizing a CUDA Context]. + , deviceFinalizerRefcount :: {-# UNPACK #-} !(IORef Int) + } + +instance Eq Context where + c1 == c2 = deviceContext c1 == deviceContext c2 + +instance Hashable Context where + hashWithSalt salt = + let + ptrToInt :: Ptr a -> Int + ptrToInt (Ptr addr#) = I# (addr2Int# addr#) + in + hashWithSalt salt . ptrToInt . CUDA.useContext . unsafeGetValue . deviceContext + + +-- | Create a new CUDA execution context +-- +new :: CUDA.Device + -> CUDA.DeviceProperties + -> [CUDA.ContextFlag] + -> IO Context +new dev prp flags = do + ctx <- raw dev prp =<< CUDA.create dev flags + _ <- CUDA.pop + return ctx + +-- | Wrap a raw CUDA execution context +-- +raw :: CUDA.Device + -> CUDA.DeviceProperties + -> CUDA.Context + -> IO Context +raw dev prp ctx = do + refcountVar <- newIORef 1 -- there is one user of the context: the context itself + + -- The kernels don't use much shared memory, so for devices that support it + -- prefer using those memory banks as an L1 cache. + -- + -- TLM: Is this a good idea? For example, external libraries such as cuBLAS + -- rely heavily on shared memory and thus this could adversely affect + -- performance. Perhaps we should use 'setCacheConfigFun' for individual + -- functions which might benefit from this. + -- + when (CUDA.computeCapability prp >= CUDA.Compute 2 0) + (CUDA.setCache CUDA.PreferL1) + + -- Generate the context name + let str = printf "[%d] %s\0" (fromIntegral (CUDA.useDevice dev) :: Int) (CUDA.deviceName prp) + mba <- newPinnedByteArray (length str) + + let go !_ [] = unsafeFreezeByteArray mba + go !i (x:xs) = do + writeByteArray mba i (fromIntegral (ord x) :: Word8) + go (i+1) xs + + nm <- go 0 str + + -- Display information about the selected device + Debug.traceM Debug.dump_phases builder (deviceInfo dev prp) + + lft <- newLifetime ctx -- on the CUDA context + let !result = Context prp nm lft refcountVar + addFinalizer lft $ decrementContext result + + return result + + +-- | Push the context onto the CPUs thread stack of current contexts and execute +-- some operation. +-- +{-# INLINE withContext #-} +withContext :: Context -> IO a -> IO a +withContext Context{..} action + = runInBoundThread + $ withLifetime deviceContext $ \ctx -> + bracket_ (push ctx) pop action + +{-# INLINE push #-} +push :: CUDA.Context -> IO () +push ctx = do + message ("push context: " % formatContext) ctx + CUDA.push ctx + +{-# INLINE pop #-} +pop :: IO () +pop = do + ctx <- CUDA.pop + message ("pop context: " % formatContext) ctx + +decrementContext :: Context -> IO () +decrementContext ctx = do + newCount <- atomicModifyIORef' (deviceFinalizerRefcount ctx) (\i -> (i - 1, i - 1)) + message ("decrement context " % formatContext % " to " % shown) (unsafeGetValue (deviceContext ctx)) newCount + when (newCount == 0) $ CUDA.destroy (unsafeGetValue (deviceContext ctx)) + +-- | If the underlying CUDA context is already slated for destruction entirely +-- (or has already been destroyed) by its finalizer, this function does +-- nothing. If the CUDA context will live on (for now), the passed @IO@ action +-- is invoked with a lock held so that the CUDA context will not be destroyed +-- while your action runs. Use this in finalizers of CUDA resources such as +-- arrays and linked modules. +-- +-- The context is not automatically pushed in the action; if you need to +-- 'withContext', do it yourself. +contextFinalizeResource :: Context -> IO () -> IO () +contextFinalizeResource ctx action = + -- See Note: [Finalizing a CUDA Context] + bracket + (do newCount <- atomicModifyIORef' (deviceFinalizerRefcount ctx) $ \i -> + if i == 0 then (0, 0) else (i + 1, i + 1) + message ("increment context " % formatContext % " to " % shown) (unsafeGetValue (deviceContext ctx)) newCount + return (newCount > 0)) + (\contextStillLive -> + when contextStillLive (decrementContext ctx)) + (\contextStillLive -> + when contextStillLive action) + + +-- 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 -> Builder +deviceInfo dev prp = go $ layoutPretty defaultLayoutOptions $ + devID <> colon <+> name <+> parens compute + <> comma <+> processors <+> at <+> pretty clock <+> parens cores + <> comma <+> memory + where + name = pretty (CUDA.deviceName prp) + compute = "compute capability" <+> unsafeViaShow (CUDA.computeCapability prp) + devID = "device" <+> unsafeViaShow (CUDA.useDevice dev) + processors = pretty (CUDA.multiProcessorCount prp) <+> "multiprocessors" + cores = pretty (CUDA.multiProcessorCount prp * coresPerMultiProcessor prp) <+> "cores" + memory = pretty mem <+> "global memory" + ---- + clock = toLazyText $ Debug.showFFloatSIBase (Just 2) 1000 (fromIntegral $ CUDA.clockRate prp * 1000 :: Double) "Hz" + mem = toLazyText $ Debug.showFFloatSIBase (Just 0) 1024 (fromIntegral $ CUDA.totalGlobalMem prp :: Double) "B" + at = pretty '@' + + go = \case + SFail -> panicUncaughtFail + SEmpty -> mempty + SChar c rest -> TLB.singleton c <> go rest + SText _l t rest -> TLB.fromText t <> go rest + SLine i rest -> TLB.singleton '\n' <> (TLB.fromText (textSpaces i) <> go rest) + SAnnPush _ann rest -> go rest + SAnnPop rest -> go rest + + +{-# INLINE message #-} +message :: Format (IO ()) a -> a +message fmt = Debug.traceM Debug.dump_gc ("gc: " % fmt) + +{-# INLINE formatContext #-} +formatContext :: Format r (CUDA.Context -> r) +formatContext = later $ \(CUDA.Context c) -> bformat shown c + + +-- Note: [Finalizing a CUDA Context] +-- +-- Both a CUDA context and the resources we allocate within such a context +-- (currently, arrays, executable modules and events) are freed with +-- finalizers; these are invoked by the GC when it detects (after a GC pass) +-- that the Haskell heap objects are no longer reachable. +-- +-- In our case, finalizers are attached to 'Lifetime' objects. The problem is +-- that even if a finalizer for Lifetime 1 refers to Lifetime 2, the GC does +-- not guarantee that the finalizer for Lifetime 1 runs to completion before the +-- finalizer of Lifetime 2 starts. (See the documentation for 'touchForeignPtr' +-- in base.) This is a problem for us because we are in this situation: to free +-- a resource within a CUDA context, we need a reference to that context and +-- the context needs to be alive. Thus finalizers for e.g. arrays reference the +-- Lifetime for the CUDA context. +-- +-- If we just leave GHC to do finalization as it wishes, this means that a CUDA +-- context may well be destroyed before the resourcees in it are finalized, +-- leading to use-after-free errors and segfaults. We have two choices here: +-- 1. either we let the finalizer for a Context wait until the other finalizers +-- have run, or +-- 2. we free the Context when first we can, and let resource finalizers that +-- come later, do nothing. +-- We choose option 2 because destroying a CUDA context already frees the +-- resources in it, so there is no need to do meticulous manual cleanup here. +-- +-- To accomplish this, we use reference counting. The context itself being +-- alive (precisely: its finalizer not yet having run) counts for one "use"; +-- the only other "uses" are the finalizers for the CUDA resources in the +-- context. (There is no need to track anything before we start finalizing, so +-- this is enough.) The Context finalizer does nothing more than a decrement on +-- the refcount to release the "use" of the CUDA context by the Context object +-- itself. +-- +-- To complete the picture: +-- - When decrementing, if we decremented to zero, we destroy the CUDA context. +-- - When incrementing, we are apparently in a resource finalizer, because that +-- is the only place where we increment. If here we see that the refcount is +-- already zero, we simply do nothing (and *skip* the resource finalizer +-- entirely): the CUDA context has already been destroyed, taking this +-- resource with it, so nothing more needs to be done. +-- +-- The resource finalizers use 'contextFinalizeResource' to access this +-- functionality. + diff --git a/src/Data/Array/Accelerate/LLVM/PTX/Debug.hs b/src/Data/Array/Accelerate/LLVM/PTX/Debug.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/PTX/Debug.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.PTX.Debug +-- Copyright : [2014..2020] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.PTX.Debug ( + + module Data.Array.Accelerate.Debug.Internal, + module Data.Array.Accelerate.LLVM.PTX.Debug, + +) where + +import Data.Array.Accelerate.Debug.Internal hiding ( timed, elapsed ) +import qualified Data.Array.Accelerate.Debug.Internal as D + +import Foreign.CUDA.Driver.Stream ( Stream ) +import qualified Foreign.CUDA.Driver.Event as Event + +import Control.Concurrent +import Control.Monad.Trans +import Data.Text.Lazy.Builder +import Formatting +import System.CPUTime + +import GHC.Float + + +-- | Execute an action and time the results. The second argument specifies how +-- to format the output string given elapsed GPU and CPU time respectively +-- +timed + :: MonadIO m + => Flag + -> (Double -> Double -> Double -> IO ()) + -> Maybe Stream + -> m a + -> m a +{-# INLINE timed #-} +timed f fmt = + monitorProcTime (getFlag f) fmt + +monitorProcTime + :: MonadIO m + => IO Bool + -> (Double -> Double -> Double -> IO ()) + -> Maybe Stream + -> m a + -> m a +{-# INLINE monitorProcTime #-} +monitorProcTime enabled display stream action = do + yes <- if debuggingIsEnabled then liftIO enabled else return False + if yes + then do + gpuBegin <- liftIO $ Event.create [] + gpuEnd <- liftIO $ Event.create [] + wallBegin <- liftIO $ getMonotonicTime + cpuBegin <- liftIO $ getCPUTime + _ <- liftIO $ Event.record gpuBegin stream + result <- action + _ <- liftIO $ Event.record gpuEnd stream + cpuEnd <- liftIO $ getCPUTime + wallEnd <- liftIO $ getMonotonicTime + + -- 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. + -- + _ <- liftIO . forkIO $ do + Event.block gpuEnd + diff <- Event.elapsedTime gpuBegin gpuEnd + let gpuTime = float2Double $ diff * 1E-3 -- milliseconds + cpuTime = fromIntegral (cpuEnd - cpuBegin) * 1E-12 -- picoseconds + wallTime = wallEnd - wallBegin -- seconds + + Event.destroy gpuBegin + Event.destroy gpuEnd + -- + display wallTime cpuTime gpuTime + -- + return result + + else + action + + +{-# INLINE elapsed #-} +elapsed :: Format r (Double -> Double -> Double -> r) +elapsed = formatSIBase (Just 3) 1000 % "s (wall), " + % formatSIBase (Just 3) 1000 % "s (cpu), " + % formatSIBase (Just 3) 1000 % "s (gpu)" + +-- accelerate/cbits/clock.c +foreign import ccall unsafe "clock_gettime_monotonic_seconds" getMonotonicTime :: IO Double + +data Phase = Compile | Link | Execute + +buildPhase :: Phase -> Builder +buildPhase = \case + Compile -> "compile" + Link -> "link" + Execute -> "execute" + +phase :: MonadIO m => Phase -> m a -> m a +phase p = D.timed dump_phases (now ("phase " <> buildPhase p <> ": ") % D.elapsed) + diff --git a/src/Data/Array/Accelerate/LLVM/PTX/Embed.hs b/src/Data/Array/Accelerate/LLVM/PTX/Embed.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/PTX/Embed.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-orphans #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.PTX.Embed +-- Copyright : [2017..2020] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.PTX.Embed ( + + module Data.Array.Accelerate.LLVM.Embed, + +) where + +import Data.ByteString.Short.Extra as BS + +import Data.Array.Accelerate.Lifetime + +import Data.Array.Accelerate.LLVM.Compile +import Data.Array.Accelerate.LLVM.Embed + +import Data.Array.Accelerate.LLVM.PTX.Compile +import Data.Array.Accelerate.LLVM.PTX.Link +import Data.Array.Accelerate.LLVM.PTX.Target +import Data.Array.Accelerate.LLVM.PTX.Context + +import qualified Foreign.CUDA.Driver as CUDA + +import Control.Monad.IO.Class ( liftIO ) +import Foreign.Ptr +import GHC.Ptr ( Ptr(..) ) +import Data.Array.Accelerate.TH.Compat ( CodeQ ) +import System.IO.Unsafe +import qualified Data.ByteString as B +import qualified Data.ByteString.Unsafe as B +import qualified Data.Array.Accelerate.TH.Compat as TH + + +instance Embed PTX where + embedForTarget = embed + +-- Embed the given object code and set up to be reloaded at execution time. +-- +embed :: PTX -> ObjectR PTX -> CodeQ (ExecutableR PTX) +embed target (ObjectR _ cfg objFname) = do + -- Generate the embedded kernel executable. This will load the embedded object + -- code into the current (at execution time) context. + loadQ `TH.bindCode` \kmd -> + [|| unsafePerformIO $ do + jit <- CUDA.loadDataFromPtrEx + $$( liftIO (B.readFile objFname) `TH.bindCode` \obj -> + TH.unsafeCodeCoerce [| Ptr $(TH.litE (TH.StringPrimL (B.unpack obj))) |] ) + [] + fun <- newLifetime (FunctionTable $$(listE (map (linkQ 'jit) kmd))) + return $ PTXR fun + ||] + where + -- Load the module to recover information such as number of registers + -- and bytes of shared memory. It may be possible to do this without + -- requiring an active CUDA context. + loadQ :: TH.Q [(Kernel, CodeQ (Int -> Int))] + loadQ = TH.runIO $ withContext (ptxContext target) $ do + obj <- B.readFile objFname + jit <- B.unsafeUseAsCString obj $ \p -> CUDA.loadDataFromPtrEx (castPtr p) [] + ks <- mapM (uncurry (linkFunctionQ (CUDA.jitModule jit))) cfg + CUDA.unload (CUDA.jitModule jit) + return ks + + linkQ :: TH.Name -> (Kernel, CodeQ (Int -> Int)) -> CodeQ Kernel + linkQ jit (Kernel name _ dsmem cta _, grid) = + [|| unsafePerformIO $ do + f <- CUDA.getFun (CUDA.jitModule $$(TH.unsafeCodeCoerce (TH.varE jit))) $$(liftSBS name) + return $ Kernel $$(liftSBS name) f dsmem cta $$grid + ||] + + listE :: [CodeQ a] -> CodeQ [a] + listE xs = TH.unsafeCodeCoerce (TH.listE (map TH.unTypeCode xs)) + diff --git a/src/Data/Array/Accelerate/LLVM/PTX/Execute.hs b/src/Data/Array/Accelerate/LLVM/PTX/Execute.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/PTX/Execute.hs @@ -0,0 +1,882 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-orphans #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.PTX.Execute +-- Copyright : [2014..2020] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.PTX.Execute ( + + executeAcc, + executeOpenAcc, + +) where + +import Data.Array.Accelerate.Analysis.Match +import Data.Array.Accelerate.Error +import Data.Array.Accelerate.Lifetime +import Data.Array.Accelerate.Representation.Array +import Data.Array.Accelerate.Representation.Shape +import Data.Array.Accelerate.Representation.Type +import Data.Array.Accelerate.Type + +import Data.Array.Accelerate.LLVM.Execute + +import Data.Array.Accelerate.LLVM.PTX.Analysis.Launch ( multipleOf ) +import Data.Array.Accelerate.LLVM.PTX.Array.Data +import Data.Array.Accelerate.LLVM.PTX.Array.Prim ( memsetArrayAsync ) +import Data.Array.Accelerate.LLVM.PTX.Execute.Async +import Data.Array.Accelerate.LLVM.PTX.Execute.Environment +import Data.Array.Accelerate.LLVM.PTX.Execute.Marshal +import Data.Array.Accelerate.LLVM.PTX.Execute.Stream ( Stream ) +import Data.Array.Accelerate.LLVM.PTX.Link +import Data.Array.Accelerate.LLVM.PTX.Target +import qualified Data.Array.Accelerate.LLVM.PTX.Debug as Debug +import qualified Data.Array.Accelerate.LLVM.PTX.Execute.Event as Event + +import qualified Foreign.CUDA.Driver as CUDA + +import Control.Monad ( forM_ ) +import Control.Monad.State ( liftIO ) +import Data.ByteString.Short.Char8 ( ShortByteString, unpack ) +import Data.List ( find ) +import Data.Maybe ( fromMaybe ) +import Formatting +import Prelude hiding ( exp, map, sum, scanl, scanr ) +import qualified Data.ByteString.Short as S +import qualified Data.ByteString.Short.Extra as SE +import qualified Data.DList as DL + + +{-# SPECIALISE INLINE executeAcc :: ExecAcc PTX a -> Par PTX (FutureArraysR PTX a) #-} +{-# SPECIALISE INLINE executeOpenAcc :: ExecOpenAcc PTX aenv a -> Val aenv -> Par PTX (FutureArraysR PTX a) #-} + +-- 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, we return a reference to the array data. The data +-- will already have been copied to the device during compilation of the +-- kernels. +-- +-- 2. If it is a non-skeleton node, such as a let binding or shape conversion, +-- then execute directly by updating the environment or similar. +-- +-- 3. If it is a skeleton node, then we need to execute the generated LLVM +-- code. +-- +instance Execute PTX where + {-# INLINE map #-} + {-# INLINE generate #-} + {-# INLINE transform #-} + {-# INLINE backpermute #-} + {-# INLINE fold #-} + {-# INLINE foldSeg #-} + {-# INLINE scan #-} + {-# INLINE scan' #-} + {-# INLINE permute #-} + {-# INLINE stencil1 #-} + {-# INLINE stencil2 #-} + {-# INLINE aforeign #-} + map = mapOp + generate = generateOp + transform = transformOp + backpermute = backpermuteOp + fold True = foldOp + fold False = fold1Op + foldSeg i _ = foldSegOp i + scan _ True = scanOp + scan _ False = scan1Op + scan' _ = scan'Op + permute = permuteOp + stencil1 = stencil1Op + stencil2 = stencil2Op + aforeign = aforeignOp + + +-- Skeleton implementation +-- ----------------------- + +-- Simple kernels just need to know the shape of the output array +-- +{-# INLINE simpleOp #-} +simpleOp + :: HasCallStack + => ShortByteString + -> ArrayR (Array sh e) + -> ExecutableR PTX + -> Gamma aenv + -> Val aenv + -> sh + -> Par PTX (Future (Array sh e)) +simpleOp name repr exe gamma aenv sh = + withExecutable exe $ \ptxExecutable -> do + future <- new + result <- allocateRemote repr sh + -- + let paramR = TupRsingle $ ParamRarray repr + cleanup <- executeOp (ptxExecutable !# name) gamma aenv (arrayRshape repr) sh paramR result + putCleanup future cleanup result + return future + +-- Mapping over an array can ignore the dimensionality of the array and +-- treat it as its underlying linear representation. +-- +{-# INLINE mapOp #-} +mapOp + :: HasCallStack + => Maybe (a :~: b) + -> ArrayR (Array sh a) + -> TypeR b + -> ExecutableR PTX + -> Gamma aenv + -> Val aenv + -> Array sh a + -> Par PTX (Future (Array sh b)) +mapOp inplace repr tp exe gamma aenv input@(shape -> sh) = + withExecutable exe $ \ptxExecutable -> do + let reprOut = ArrayR (arrayRshape repr) tp + future <- new + result <- case inplace of + Just Refl -> return input + Nothing -> allocateRemote reprOut sh + -- + let paramsR = TupRsingle (ParamRarray reprOut) `TupRpair` TupRsingle (ParamRarray repr) + cleanup <- executeOp (ptxExecutable !# "map") gamma aenv (arrayRshape repr) sh paramsR (result, input) + putCleanup future cleanup result + return future + +{-# INLINE generateOp #-} +generateOp + :: HasCallStack + => ArrayR (Array sh e) + -> ExecutableR PTX + -> Gamma aenv + -> Val aenv + -> sh + -> Par PTX (Future (Array sh e)) +generateOp = simpleOp "generate" + +{-# INLINE transformOp #-} +transformOp + :: HasCallStack + => ArrayR (Array sh a) + -> ArrayR (Array sh' b) + -> ExecutableR PTX + -> Gamma aenv + -> Val aenv + -> sh' + -> Array sh a + -> Par PTX (Future (Array sh' b)) +transformOp repr repr' exe gamma aenv sh' input = + withExecutable exe $ \ptxExecutable -> do + future <- new + result <- allocateRemote repr' sh' + let paramsR = TupRsingle (ParamRarray repr') `TupRpair` TupRsingle (ParamRarray repr) + cleanup <- executeOp (ptxExecutable !# "transform") gamma aenv (arrayRshape repr') sh' paramsR (result, input) + putCleanup future cleanup result + return future + +{-# INLINE backpermuteOp #-} +backpermuteOp + :: HasCallStack + => ArrayR (Array sh e) + -> ShapeR sh' + -> ExecutableR PTX + -> Gamma aenv + -> Val aenv + -> sh' + -> Array sh e + -> Par PTX (Future (Array sh' e)) +backpermuteOp (ArrayR shr tp) shr' = transformOp (ArrayR shr tp) (ArrayR shr' tp) + +-- There are two flavours of fold operation: +-- +-- 1. If we are collapsing to a single value, then multiple thread blocks are +-- working together. Since thread blocks synchronise with each other via +-- kernel launches, each block computes a partial sum and the kernel is +-- launched recursively until the final value is reached. +-- +-- 2. If this is a multidimensional reduction, then each inner dimension is +-- handled by a single thread block, so no global communication is +-- necessary. Furthermore are two kernel flavours: each innermost dimension +-- can be cooperatively reduced by (a) a thread warp; or (b) a thread +-- block. Currently we always use the first, but require benchmarking to +-- determine when to select each. +-- +{-# INLINE fold1Op #-} +fold1Op + :: HasCallStack + => ArrayR (Array sh e) + -> ExecutableR PTX + -> Gamma aenv + -> Val aenv + -> Delayed (Array (sh, Int) e) + -> Par PTX (Future (Array sh e)) +fold1Op repr exe gamma aenv arr@(delayedShape -> sh@(sx, sz)) + = boundsCheck "empty array" (sz > 0) + $ case size (ShapeRsnoc $ arrayRshape repr) sh of + 0 -> newFull =<< allocateRemote repr sx -- empty, but possibly with one or more non-zero dimensions + _ -> foldCore repr exe gamma aenv arr + +{-# INLINE foldOp #-} +foldOp + :: HasCallStack + => ArrayR (Array sh e) + -> ExecutableR PTX + -> Gamma aenv + -> Val aenv + -> Delayed (Array (sh, Int) e) + -> Par PTX (Future (Array sh e)) +foldOp repr exe gamma aenv arr@(delayedShape -> sh@(sx, _)) + = case size (ShapeRsnoc $ arrayRshape repr) sh of + 0 -> generateOp repr exe gamma aenv sx + _ -> foldCore repr exe gamma aenv arr + +{-# INLINE foldCore #-} +foldCore + :: HasCallStack + => ArrayR (Array sh e) + -> ExecutableR PTX + -> Gamma aenv + -> Val aenv + -> Delayed (Array (sh, Int) e) + -> Par PTX (Future (Array sh e)) +foldCore repr exe gamma aenv arr + | ArrayR ShapeRz tp <- repr + = foldAllOp tp exe gamma aenv arr + -- + | otherwise + = foldDimOp repr exe gamma aenv arr + +{-# INLINE foldAllOp #-} +foldAllOp + :: forall aenv e. HasCallStack + => TypeR e + -> ExecutableR PTX + -> Gamma aenv + -> Val aenv + -> Delayed (Vector e) + -> Par PTX (Future (Scalar e)) +foldAllOp tp exe gamma aenv input = + withExecutable exe $ \ptxExecutable -> do + future <- new + let + ks = ptxExecutable !# "foldAllS" + km1 = ptxExecutable !# "foldAllM1" + km2 = ptxExecutable !# "foldAllM2" + sh@((), n) = delayedShape input + paramsRinput = TupRsingle $ ParamRmaybe $ ParamRarray $ ArrayR dim1 tp + paramsRdim0 = TupRsingle $ ParamRarray $ ArrayR dim0 tp + paramsRdim1 = TupRsingle $ ParamRarray $ ArrayR dim1 tp + -- + if kernelThreadBlocks ks n == 1 + then do + -- The array is small enough that we can compute it in a single step + result <- allocateRemote (ArrayR dim0 tp) () + let paramsR = paramsRdim0 `TupRpair` paramsRinput + cleanup <- executeOp ks gamma aenv dim1 sh paramsR (result, manifest input) + putCleanup future cleanup result + + else do + -- Multi-kernel reduction to a single element. The first kernel integrates + -- any delayed elements, and the second is called recursively until + -- reaching a single element. + -- The cleanup function is accumulated. + let + rec :: Vector e -> IO () -> Par PTX () + rec tmp@(Array ((),m) adata) cleanup + | m <= 1 = putCleanup future cleanup (Array () adata) + | otherwise = do + let sh' = ((), m `multipleOf` kernelThreadBlockSize km2) + out <- allocateRemote (ArrayR dim1 tp) sh' + let paramsR2 = paramsRdim1 `TupRpair` paramsRdim1 + cleanup2 <- executeOp km2 gamma aenv dim1 sh' paramsR2 (tmp, out) + rec out (cleanup >> cleanup2) + -- + let sh' = ((), n `multipleOf` kernelThreadBlockSize km1) + tmp <- allocateRemote (ArrayR dim1 tp) sh' + let paramsR1 = paramsRdim1 `TupRpair` paramsRinput + cleanup <- executeOp km1 gamma aenv dim1 sh' paramsR1 (tmp, manifest input) + rec tmp cleanup + -- + return future + + +{-# INLINE foldDimOp #-} +foldDimOp + :: HasCallStack + => ArrayR (Array sh e) + -> ExecutableR PTX + -> Gamma aenv + -> Val aenv + -> Delayed (Array (sh, Int) e) + -> Par PTX (Future (Array sh e)) +foldDimOp repr@(ArrayR shr tp) exe gamma aenv input@(delayedShape -> (sh, sz)) + | sz == 0 = generateOp repr exe gamma aenv sh + | otherwise = + withExecutable exe $ \ptxExecutable -> do + future <- new + result <- allocateRemote repr sh + -- + let paramsR = TupRsingle (ParamRarray repr) `TupRpair` TupRsingle (ParamRmaybe $ ParamRarray $ ArrayR (ShapeRsnoc shr) tp) + cleanup <- executeOp (ptxExecutable !# "fold") gamma aenv shr sh paramsR (result, manifest input) + putCleanup future cleanup result + return future + + +{-# INLINE foldSegOp #-} +foldSegOp + :: HasCallStack + => IntegralType i + -> ArrayR (Array (sh, Int) e) + -> ExecutableR PTX + -> Gamma aenv + -> Val aenv + -> Delayed (Array (sh, Int) e) + -> Delayed (Segments i) + -> Par PTX (Future (Array (sh, Int) e)) +foldSegOp intTp repr exe gamma aenv input@(delayedShape -> (sh, sz)) segments@(delayedShape -> ((), ss)) = + withExecutable exe $ \ptxExecutable -> do + let + ArrayR (ShapeRsnoc shr') _ = repr + reprSeg = ArrayR dim1 $ TupRsingle $ SingleScalarType $ NumSingleType $ IntegralNumType intTp + n = ss - 1 -- segments array has been 'scanl (+) 0'`ed + m = size shr' sh * n + foldseg = if (sz`quot`ss) < (2 * kernelThreadBlockSize foldseg_cta) + then foldseg_warp + else foldseg_cta + -- + foldseg_cta = ptxExecutable !# "foldSeg_block" + foldseg_warp = ptxExecutable !# "foldSeg_warp" + -- qinit = ptxExecutable !# "qinit" + -- + future <- new + result <- allocateRemote repr (sh, n) + let paramsR = TupRsingle (ParamRarray repr) `TupRpair` TupRsingle (ParamRmaybe $ ParamRarray repr) `TupRpair` TupRsingle (ParamRmaybe $ ParamRarray reprSeg) + cleanup <- executeOp foldseg gamma aenv dim1 ((), m) paramsR ((result, manifest input), manifest segments) + putCleanup future cleanup result + return future + + +{-# INLINE scanOp #-} +scanOp + :: HasCallStack + => ArrayR (Array (sh, Int) e) + -> ExecutableR PTX + -> Gamma aenv + -> Val aenv + -> Delayed (Array (sh, Int) e) + -> Par PTX (Future (Array (sh, Int) e)) +scanOp repr exe gamma aenv input@(delayedShape -> (sz, n)) = + case n of + 0 -> generateOp repr exe gamma aenv (sz, 1) + _ -> scanCore repr exe gamma aenv (n+1) input + +{-# INLINE scan1Op #-} +scan1Op + :: HasCallStack + => ArrayR (Array (sh, Int) e) + -> ExecutableR PTX + -> Gamma aenv + -> Val aenv + -> Delayed (Array (sh, Int) e) + -> Par PTX (Future (Array (sh, Int) e)) +scan1Op repr exe gamma aenv input@(delayedShape -> sh@(_, n)) = + case n of + 0 -> newFull =<< allocateRemote repr sh + _ -> scanCore repr exe gamma aenv n input + +{-# INLINE scanCore #-} +scanCore + :: HasCallStack + => ArrayR (Array (sh, Int) e) + -> ExecutableR PTX + -> Gamma aenv + -> Val aenv + -> Int -- output size of innermost dimension + -> Delayed (Array (sh, Int) e) + -> Par PTX (Future (Array (sh, Int) e)) +scanCore repr exe gamma aenv m input + | ArrayR (ShapeRsnoc ShapeRz) tp <- repr + = scanAllOp tp exe gamma aenv m input + -- + | otherwise + = scanDimOp repr exe gamma aenv m input + +{-# INLINE scanAllOp #-} +scanAllOp + :: HasCallStack + => TypeR e + -> ExecutableR PTX + -> Gamma aenv + -> Val aenv + -> Int -- output size + -> Delayed (Vector e) + -> Par PTX (Future (Vector e)) +scanAllOp tp exe gamma aenv m input@(delayedShape -> ((), n)) = + withExecutable exe $ \ptxExecutable -> do + let + k1 = ptxExecutable !# "scanP1" + k2 = ptxExecutable !# "scanP2" + k3 = ptxExecutable !# "scanP3" + -- + c = kernelThreadBlockSize k1 + s = n `multipleOf` c + -- + repr = ArrayR dim1 tp + paramR = TupRsingle $ ParamRarray repr + paramsR1 = paramR `TupRpair` paramR `TupRpair` TupRsingle (ParamRmaybe $ ParamRarray repr) + paramsR3 = paramR `TupRpair` paramR `TupRpair` TupRsingle ParamRint + -- + future <- new + result <- allocateRemote repr ((), m) + + -- Step 1: Independent thread-block-wide scans of the input. Small arrays + -- which can be computed by a single thread block will require no + -- additional work. + tmp <- allocateRemote repr ((), s) + cleanup1 <- executeOp k1 gamma aenv dim1 ((), s) paramsR1 ((tmp, result), manifest input) + + -- Step 2: Multi-block reductions need to compute the per-block prefix, + -- then apply those values to the partial results. + cleanup2 <- + if s > 1 + then do + cleanup2a <- executeOp k2 gamma aenv dim1 ((), s) paramR tmp + cleanup2b <- executeOp k3 gamma aenv dim1 ((), s-1) paramsR3 ((tmp, result), c) + return (cleanup2a >> cleanup2b) + else + return (return ()) + + putCleanup future (cleanup1 >> cleanup2) result + return future + +{-# INLINE scanDimOp #-} +scanDimOp + :: HasCallStack + => ArrayR (Array (sh, Int) e) + -> ExecutableR PTX + -> Gamma aenv + -> Val aenv + -> Int + -> Delayed (Array (sh, Int) e) + -> Par PTX (Future (Array (sh, Int) e)) +scanDimOp repr exe gamma aenv m input@(delayedShape -> (sz, _)) = + withExecutable exe $ \ptxExecutable -> do + let ArrayR (ShapeRsnoc shr') _ = repr + future <- new + result <- allocateRemote repr (sz, m) + let paramsR = TupRsingle (ParamRarray repr) `TupRpair` TupRsingle (ParamRmaybe $ ParamRarray repr) + cleanup <- executeOp (ptxExecutable !# "scan") gamma aenv dim1 ((), size shr' sz) paramsR (result, manifest input) + putCleanup future cleanup result + return future + + +{-# INLINE scan'Op #-} +scan'Op + :: HasCallStack + => ArrayR (Array (sh, Int) e) + -> ExecutableR PTX + -> Gamma aenv + -> Val aenv + -> Delayed (Array (sh, Int) e) + -> Par PTX (Future (Array (sh, Int) e, Array sh e)) +scan'Op repr exe gamma aenv input@(delayedShape -> (sz, n)) = + case n of + 0 -> do + future <- new + result <- allocateRemote repr (sz, 0) + sums <- generateOp (reduceRank repr) exe gamma aenv sz + fork $ do sums' <- get sums + put future (result, sums') + return future + -- + _ -> scan'Core repr exe gamma aenv input + +{-# INLINE scan'Core #-} +scan'Core + :: HasCallStack + => ArrayR (Array (sh, Int) e) + -> ExecutableR PTX + -> Gamma aenv + -> Val aenv + -> Delayed (Array (sh, Int) e) + -> Par PTX (Future (Array (sh, Int) e, Array sh e)) +scan'Core repr exe gamma aenv input + | ArrayR (ShapeRsnoc ShapeRz) tp <- repr + = scan'AllOp tp exe gamma aenv input + -- + | otherwise + = scan'DimOp repr exe gamma aenv input + +{-# INLINE scan'AllOp #-} +scan'AllOp + :: HasCallStack + => TypeR e + -> ExecutableR PTX + -> Gamma aenv + -> Val aenv + -> Delayed (Vector e) + -> Par PTX (Future (Vector e, Scalar e)) +scan'AllOp tp exe gamma aenv input@(delayedShape -> ((), n)) = + withExecutable exe $ \ptxExecutable -> do + let + repr = ArrayR dim1 tp + paramRdim0 = TupRsingle $ ParamRarray $ ArrayR dim0 tp + paramRdim1 = TupRsingle $ ParamRarray repr + k1 = ptxExecutable !# "scanP1" + k2 = ptxExecutable !# "scanP2" + k3 = ptxExecutable !# "scanP3" + -- + c = kernelThreadBlockSize k1 + s = n `multipleOf` c + -- + future <- new + result <- allocateRemote repr ((), n) + tmp <- allocateRemote repr ((), s) + + -- Step 1: independent thread-block-wide scans. Each block stores its partial + -- sum to a temporary array. + let paramsR1 = paramRdim1 `TupRpair` paramRdim1 `TupRpair` TupRsingle (ParamRmaybe $ ParamRarray repr) + cleanup1 <- executeOp k1 gamma aenv dim1 ((), s) paramsR1 ((tmp, result), manifest input) + + -- If this was a small array that was processed by a single thread block then + -- we are done, otherwise compute the per-block prefix and apply those values + -- to the partial results. + if s == 1 + then + case tmp of + Array _ ad -> putCleanup future cleanup1 (result, Array () ad) + + else do + sums <- allocateRemote (ArrayR dim0 tp) () + let paramsR2 = paramRdim1 `TupRpair` paramRdim0 + let paramsR3 = paramRdim1 `TupRpair` paramRdim1 `TupRpair` TupRsingle ParamRint + cleanup2 <- executeOp k2 gamma aenv dim1 ((), s) paramsR2 (tmp, sums) + cleanup3 <- executeOp k3 gamma aenv dim1 ((), s-1) paramsR3 ((tmp, result), c) + putCleanup future (cleanup1 >> cleanup2 >> cleanup3) (result, sums) + -- + return future + +{-# INLINE scan'DimOp #-} +scan'DimOp + :: HasCallStack + => ArrayR (Array (sh, Int) e) + -> ExecutableR PTX + -> Gamma aenv + -> Val aenv + -> Delayed (Array (sh, Int) e) + -> Par PTX (Future (Array (sh, Int) e, Array sh e)) +scan'DimOp repr@(ArrayR (ShapeRsnoc shr') _) exe gamma aenv input@(delayedShape -> sh@(sz, _)) = + withExecutable exe $ \ptxExecutable -> do + future <- new + result <- allocateRemote repr sh + sums <- allocateRemote (reduceRank repr) sz + let paramsR = TupRsingle (ParamRarray repr) `TupRpair` TupRsingle (ParamRarray $ reduceRank repr) `TupRpair` TupRsingle (ParamRmaybe $ ParamRarray repr) + cleanup <- executeOp (ptxExecutable !# "scan") gamma aenv dim1 ((), size shr' sz) paramsR ((result, sums), manifest input) + putCleanup future cleanup (result, sums) + return future + + +{-# INLINE permuteOp #-} +permuteOp + :: HasCallStack + => Bool + -> ArrayR (Array sh e) + -> ShapeR sh' + -> ExecutableR PTX + -> Gamma aenv + -> Val aenv + -> Array sh' e + -> Delayed (Array sh e) + -> Par PTX (Future (Array sh' e)) +permuteOp inplace repr@(ArrayR shr tp) shr' exe gamma aenv defaults@(shape -> shOut) input@(delayedShape -> shIn) = + withExecutable exe $ \ptxExecutable -> do + let + n = size shr shIn + m = size shr' shOut + repr' = ArrayR shr' tp + reprLock = ArrayR dim1 $ TupRsingle $ scalarTypeWord32 + paramR = TupRsingle $ ParamRmaybe $ ParamRarray repr + paramR' = TupRsingle $ ParamRarray repr' + kernel = case functionTable ptxExecutable of + k:_ -> k + _ -> internalError "no kernels found" + -- + future <- new + result <- if inplace + then Debug.trace Debug.dump_exec "exec: permute/inplace" $ return defaults + else Debug.trace Debug.dump_exec "exec: permute/clone" $ get =<< cloneArrayAsync repr' defaults + -- + let kernelName' = + let kn = kernelName kernel + in SE.take (S.length kn - 65) kn + cleanup <- case kernelName' of + -- execute directly using atomic operations + "permute_rmw" -> + let paramsR = paramR' `TupRpair` paramR + in executeOp kernel gamma aenv dim1 ((), n) paramsR (result, manifest input) + + -- a temporary array is required for spin-locks around the critical section + "permute_mutex" -> do + barrier <- new :: Par PTX (Future (Vector Word32)) + Array _ ad <- allocateRemote reprLock ((), m) + fork $ do fill <- memsetArrayAsync (NumSingleType $ IntegralNumType TypeWord32) m 0 ad + put barrier . Array ((), m) =<< get fill + -- + let paramsR = paramR' `TupRpair` TupRsingle (ParamRfuture $ ParamRarray reprLock) `TupRpair` paramR + executeOp kernel gamma aenv dim1 ((), n) paramsR ((result, barrier), manifest input) + + _ -> internalError "unexpected kernel image" + -- + putCleanup future cleanup result + return future + + +{-# INLINE stencil1Op #-} +stencil1Op + :: HasCallStack + => TypeR a + -> ArrayR (Array sh b) + -> sh + -> ExecutableR PTX + -> Gamma aenv + -> Val aenv + -> Delayed (Array sh a) + -> Par PTX (Future (Array sh b)) +stencil1Op tp repr@(ArrayR shr _) halo exe gamma aenv input@(delayedShape -> sh) = + stencilCore repr exe gamma aenv halo sh paramsR (manifest input) + where paramsR = TupRsingle $ ParamRmaybe $ ParamRarray $ ArrayR shr tp + +-- Using the defaulting instances for stencil operations (for now). +-- +{-# INLINE stencil2Op #-} +stencil2Op + :: HasCallStack + => TypeR a + -> TypeR b + -> ArrayR (Array sh c) + -> sh + -> ExecutableR PTX + -> Gamma aenv + -> Val aenv + -> Delayed (Array sh a) + -> Delayed (Array sh b) + -> Par PTX (Future (Array sh c)) +stencil2Op tpA tpB repr@(ArrayR shr _) halo exe gamma aenv input1@(delayedShape -> sh1) input2@(delayedShape -> sh2) = + stencilCore repr exe gamma aenv halo (intersect (arrayRshape repr) sh1 sh2) paramsR (manifest input1, manifest input2) + where paramsR = TupRsingle (ParamRmaybe $ ParamRarray $ ArrayR shr tpA) `TupRpair` TupRsingle (ParamRmaybe $ ParamRarray $ ArrayR shr tpB) + +{-# INLINE stencilCore #-} +stencilCore + :: forall aenv sh e params. HasCallStack + => ArrayR (Array sh e) + -> ExecutableR PTX + -> Gamma aenv + -> Val aenv + -> sh -- border dimensions (i.e. index of first interior element) + -> sh -- output array size + -> ParamsR PTX params + -> params + -> Par PTX (Future (Array sh e)) +stencilCore repr@(ArrayR shr _) exe gamma aenv halo shOut paramsR params = + withExecutable exe $ \ptxExecutable -> do + let + inside = ptxExecutable !# "stencil_inside" + border = ptxExecutable !# "stencil_border" + + shIn :: sh + shIn = trav (\x y -> x - 2*y) shOut halo + + trav :: (Int -> Int -> Int) -> sh -> sh -> sh + trav f a b = go (arrayRshape repr) a b + where + go :: ShapeR t -> t -> t -> t + go ShapeRz () () = () + go (ShapeRsnoc shr') (xa,xb) (ya,yb) = (go shr' xa ya, f xb yb) + -- + future <- new + result <- allocateRemote repr shOut + parent <- asksParState ptxStream + parentStartPoint <- liftPar (Event.waypoint parent) + + -- interior (no bounds checking) + let paramsRinside = TupRsingle (ParamRshape shr) `TupRpair` TupRsingle (ParamRarray repr) `TupRpair` paramsR + cleanup1 <- executeOp inside gamma aenv shr shIn paramsRinside ((shIn, result), params) + + -- halo regions (bounds checking) + -- executed in separate streams so that they might overlap the main stencil + -- and each other, as individually they will not saturate the device + forM_ (stencilBorders (arrayRshape repr) shOut halo) $ \(u, v) -> + fork $ do + -- synchronise with start of stencil computation, so that the arguments + -- are available + child <- asksParState ptxStream + liftIO (Event.after parentStartPoint child) + + -- launch in a separate stream + let sh = trav (-) v u + let paramsRborder = TupRsingle (ParamRshape shr) `TupRpair` TupRsingle (ParamRshape shr) + `TupRpair` TupRsingle (ParamRarray repr) + `TupRpair` paramsR + cleanup2 <- executeOp border gamma aenv shr sh paramsRborder (((u, sh), result), params) + addCleanup future cleanup2 + + -- make remainder of the parent stream depend on the border results + event <- liftPar (Event.waypoint child) + ready <- liftIO (Event.query event) + if ready then return () + else liftIO (Event.after event parent) + + putCleanup future cleanup1 result + return future + +-- Compute the stencil border regions, where we may need to evaluate the +-- boundary conditions. +-- +{-# INLINE stencilBorders #-} +stencilBorders + :: forall sh. HasCallStack + => ShapeR sh + -> sh + -> sh + -> [(sh, sh)] +stencilBorders shr sh halo = [ face i | i <- [0 .. (2 * rank shr - 1)] ] + where + face :: Int -> (sh, sh) + face n = go n shr sh halo + + go :: Int -> ShapeR t -> t -> t -> (t, t) + go _ ShapeRz () () = ((), ()) + go n (ShapeRsnoc shr') (sha, sza) (shb, szb) + = let + (sha', shb') = go (n-2) shr' sha shb + (sza', szb') + | n < 0 = (0, sza) + | n == 0 = (0, szb) + | n == 1 = (sza-szb, sza) + | otherwise = (szb, sza-szb) + in + ((sha', sza'), (shb', szb')) + + +-- Foreign functions +-- +{-# INLINE aforeignOp #-} +aforeignOp + :: HasCallStack + => String + -> ArraysR as + -> ArraysR bs + -> (as -> Par PTX (Future bs)) + -> as + -> Par PTX (Future bs) +aforeignOp name _ _ asm arr = do + stream <- asksParState ptxStream + Debug.monitorProcTime query msg (Just (unsafeGetValue stream)) (asm arr) + where + msg = Debug.traceM Debug.dump_exec ("exec: " % string % " " % Debug.elapsed) name + query = if Debug.debuggingIsEnabled + then return True + else liftIO $ Debug.getFlag Debug.dump_exec + + + +-- Skeleton execution +-- ------------------ + +-- | Retrieve the named kernel +-- +(!#) :: HasCallStack => FunctionTable -> ShortByteString -> Kernel +(!#) exe name + = fromMaybe (internalError ("function not found: " % string) (unpack name)) + $ lookupKernel name exe + +lookupKernel :: ShortByteString -> FunctionTable -> Maybe Kernel +lookupKernel name ptxExecutable = + find (\k -> let n = kernelName k in SE.take (S.length n - 65) n == name) (functionTable ptxExecutable) + +delayedShape :: Delayed (Array sh e) -> sh +delayedShape (Delayed sh) = sh +delayedShape (Manifest a) = shape a + +manifest :: Delayed (Array sh e) -> Maybe (Array sh e) +manifest (Manifest a) = Just a +manifest Delayed{} = Nothing + +-- | Execute some operation with the supplied executable functions +-- +withExecutable :: HasCallStack => ExecutableR PTX -> (FunctionTable -> Par PTX b) -> Par PTX b +withExecutable PTXR{..} f = + localParState (\(s,_) -> (s,Just ptxExecutable)) $ do + r <- f (unsafeGetValue ptxExecutable) + liftIO $ touchLifetime ptxExecutable + return r + + +-- Execute the function implementing this kernel. +-- +executeOp + :: HasCallStack + => Kernel + -> Gamma aenv + -> Val aenv + -> ShapeR sh + -> sh + -> ParamsR PTX params + -> params + -> Par PTX (IO ()) +executeOp kernel gamma aenv shr sh paramsR params = + let n = size shr sh + in if n > 0 + then do + stream <- asksParState ptxStream + (argv, cleanup) <- marshalParams' @PTX (paramsR `TupRpair` TupRsingle (ParamRenv gamma)) (params, aenv) + liftIO $ launch kernel stream n $ DL.toList argv + return cleanup + else + return (return ()) + + +-- Execute a device function with the given thread configuration and function +-- parameters. +-- +launch :: HasCallStack => Kernel -> Stream -> Int -> [CUDA.FunParam] -> IO () +launch Kernel{..} stream n args = + withLifetime stream $ \st -> + Debug.monitorProcTime query msg (Just st) $ + CUDA.launchKernel kernelFun grid cta smem (Just st) args + where + cta = (kernelThreadBlockSize, 1, 1) + grid = (kernelThreadBlocks n, 1, 1) + smem = kernelSharedMemBytes + + -- Debugging/monitoring support + query = if Debug.debuggingIsEnabled + then return True + else Debug.getFlag Debug.dump_exec + + fst3 (x,_,_) = x + msg wall cpu gpu = do + verbose <- Debug.getFlag Debug.verbose + let kernelName' | verbose = kernelName + | otherwise = SE.take (S.length kernelName - 65) kernelName + Debug.traceM Debug.dump_exec ("exec: " % string % " <<< " % int % ", " % int % ", " % int % " >>> " % Debug.elapsed) + (unpack kernelName') (fst3 grid) (fst3 cta) smem wall cpu gpu + diff --git a/src/Data/Array/Accelerate/LLVM/PTX/Execute/Async.hs b/src/Data/Array/Accelerate/LLVM/PTX/Execute/Async.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/PTX/Execute/Async.hs @@ -0,0 +1,197 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.PTX.Execute.Async +-- Copyright : [2014..2020] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.PTX.Execute.Async ( + + module Data.Array.Accelerate.LLVM.Execute.Async, + module Data.Array.Accelerate.LLVM.PTX.Execute.Async, + +) where + +import Data.Array.Accelerate.Error +import Data.Array.Accelerate.Lifetime + +import Data.Array.Accelerate.LLVM.Execute.Async +import Data.Array.Accelerate.LLVM.State + +import Data.Array.Accelerate.LLVM.PTX.Target +import Data.Array.Accelerate.LLVM.PTX.Execute.Event ( Event ) +import Data.Array.Accelerate.LLVM.PTX.Execute.Stream ( Stream ) +import Data.Array.Accelerate.LLVM.PTX.Link.Object ( FunctionTable ) +import qualified Data.Array.Accelerate.LLVM.PTX.Execute.Event as Event +import qualified Data.Array.Accelerate.LLVM.PTX.Execute.Stream as Stream + +import Control.Monad.Reader +import Data.IORef + + +-- | Evaluate a parallel computation +-- +{-# INLINE evalPar #-} +evalPar :: Par PTX a -> LLVM PTX a +evalPar p = do + s <- Stream.create + r <- runReaderT (runPar p) (s, Nothing) + return r + + +type ParState = (Stream, Maybe (Lifetime FunctionTable)) + +ptxStream :: ParState -> Stream +ptxStream = fst + +ptxKernel :: ParState -> Maybe (Lifetime FunctionTable) +ptxKernel = snd + + +-- Implementation +-- -------------- + +data Future a = Future {-# UNPACK #-} !(IORef (IVar a)) + +data IVar a + = Full !a + | Pending {-# UNPACK #-} !Event !(IO ()) !a + | Empty !(IO ()) + + +askParState :: Par PTX ParState +askParState = Par ask + +asksParState :: (ParState -> a) -> Par PTX a +asksParState f = Par (asks f) + +localParState :: (ParState -> ParState) -> Par PTX a -> Par PTX a +localParState f (Par m) = Par (local f m) + +instance MonadReader PTX (Par PTX) where + ask = Par (lift ask) + local f (Par (ReaderT g)) = Par (ReaderT (\parstate -> local f (g parstate))) + +instance Async PTX where + type FutureR PTX = Future + + newtype Par PTX a = Par { runPar :: ReaderT ParState (LLVM PTX) a } + deriving ( Functor, Applicative, Monad, MonadIO ) + + {-# INLINEABLE new #-} + {-# INLINEABLE newFull #-} + new = Future <$> liftIO (newIORef (Empty (return ()))) + newFull v = Future <$> liftIO (newIORef (Full v)) + + {-# INLINEABLE spawn #-} + spawn m = do + s' <- liftPar Stream.create + r <- localParState (const (s', Nothing)) m + liftIO (Stream.destroy s') + return r + + {-# INLINEABLE fork #-} + fork m = do + s' <- liftPar (Stream.create) + () <- localParState (const (s', Nothing)) m + liftIO (Stream.destroy s') + + -- When we call 'put' the actual work may not have been evaluated yet; get + -- a new event in the current execution stream and once that is filled we can + -- transition the IVar to Full. + -- + {-# INLINEABLE put #-} + put (Future ref) v = do + stream <- asksParState ptxStream + kernel <- asksParState ptxKernel + event <- liftPar (Event.waypoint stream) + ready <- liftIO (Event.query event) + let cleanupK = case kernel of + Just k -> touchLifetime k + Nothing -> return () + liftIO . atomicModifyIORef' ref $ \case + Empty cleanup -> if ready then (Full v, ()) + else (Pending event (cleanup >> cleanupK) v, ()) + _ -> internalError "multiple put" + + -- Get the value of Future. Since the actual cross-stream synchronisation + -- happens on the device, we should never have to block/reschedule the main + -- thread waiting on a value; if we get an empty IVar at this point, something + -- has gone wrong. + -- + {-# INLINEABLE get #-} + get (Future ref) = do + stream <- asksParState ptxStream + liftIO $ do + ivar <- readIORef ref + case ivar of + Full v -> return v + Pending event cleanup v -> do + ready <- Event.query event + if ready + then do + writeIORef ref (Full v) + cleanup + else + Event.after event stream + return v + Empty _ -> internalError "blocked on an IVar" + + {-# INLINEABLE block #-} + block = liftIO . wait + + {-# INLINE liftPar #-} + liftPar = Par . lift + + +-- | Block the calling _host_ thread until the value offered by the future is +-- available. +-- +{-# INLINEABLE wait #-} +wait :: Future a -> IO a +wait (Future ref) = do + ivar <- readIORef ref + case ivar of + Full v -> return v + Pending event cleanup v -> do + Event.block event + writeIORef ref (Full v) + cleanup + return v + Empty _ -> internalError "blocked on an IVar" + +{-# INLINEABLE putCleanup #-} +putCleanup :: HasCallStack => FutureR PTX a -> IO () -> a -> Par PTX () +putCleanup (Future ref) cleanup v = do + stream <- asksParState ptxStream + kernel <- asksParState ptxKernel + event <- liftPar (Event.waypoint stream) + ready <- liftIO (Event.query event) + let cleanupK = case kernel of + Just k -> touchLifetime k + Nothing -> return () + liftIO . atomicModifyIORef' ref $ \case + Empty cleanup2 -> if ready then (Full v, ()) + else (Pending event (cleanup2 >> cleanup >> cleanupK) v, ()) + _ -> internalError "multiple put" + +{-# INLINEABLE addCleanup #-} +addCleanup :: HasCallStack => FutureR PTX a -> IO () -> Par PTX () +addCleanup (Future ref) cleanup = liftIO $ do + toRunNow <- atomicModifyIORef' ref $ \case + Full v -> (Full v, cleanup) + Pending event cleanup2 v -> (Pending event (cleanup2 >> cleanup) v, return ()) + Empty cleanup2 -> (Empty (cleanup2 >> cleanup), return ()) + toRunNow + diff --git a/src/Data/Array/Accelerate/LLVM/PTX/Execute/Environment.hs b/src/Data/Array/Accelerate/LLVM/PTX/Execute/Environment.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/PTX/Execute/Environment.hs @@ -0,0 +1,22 @@ +-- | +-- Module : Data.Array.Accelerate.LLVM.PTX.Execute.Environment +-- Copyright : [2014..2020] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.PTX.Execute.Environment ( + + module Data.Array.Accelerate.LLVM.Execute.Environment, + module Data.Array.Accelerate.LLVM.PTX.Execute.Environment, + +) where + +import Data.Array.Accelerate.LLVM.PTX.Target +import Data.Array.Accelerate.LLVM.Execute.Environment + +type Val = ValR PTX + diff --git a/src/Data/Array/Accelerate/LLVM/PTX/Execute/Event.hs b/src/Data/Array/Accelerate/LLVM/PTX/Execute/Event.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/PTX/Execute/Event.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.PTX.Execute.Event +-- Copyright : [2014..2020] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.PTX.Execute.Event ( + + Event, + create, destroy, query, waypoint, after, block, + +) where + +import Data.Array.Accelerate.Lifetime +import qualified Data.Array.Accelerate.Array.Remote.LRU as Remote + +import Data.Array.Accelerate.LLVM.PTX.Array.Remote ( ) +import qualified Data.Array.Accelerate.LLVM.PTX.Context as Context +import Data.Array.Accelerate.LLVM.PTX.Target ( PTX(..) ) +import Data.Array.Accelerate.LLVM.State +import qualified Data.Array.Accelerate.LLVM.PTX.Debug as Debug +import {-# SOURCE #-} Data.Array.Accelerate.LLVM.PTX.Execute.Stream + +import Foreign.CUDA.Driver.Error +import qualified Foreign.CUDA.Driver.Event as Event +import qualified Foreign.CUDA.Driver.Stream as Stream + +import Control.Exception +import Control.Monad +import Control.Monad.Reader +import Data.Text.Lazy.Builder +import Formatting + + +-- | Events can be used for efficient device-side synchronisation between +-- execution streams and between the host. +-- +type Event = Lifetime Event.Event + + +-- | Create a new event. It will not be automatically garbage collected, and is +-- not suitable for timing purposes. +-- +{-# INLINEABLE create #-} +create :: LLVM PTX Event +create = do + ctx <- asks ptxContext + e <- create' + event <- liftIO $ newLifetime e + liftIO $ addFinalizer event $ do + message ("destroy " % formatEvent) e + Context.contextFinalizeResource ctx $ + Event.destroy e + return event + +create' :: LLVM PTX Event.Event +create' = do + PTX{ptxMemoryTable} <- asks llvmTarget + me <- attempt "create/new" (liftIO . catchOOM $ Event.create [Event.DisableTiming]) + `orElse` do + Remote.reclaim ptxMemoryTable + liftIO $ do + message "create/new: failed (purging)" + catchOOM $ Event.create [Event.DisableTiming] + case me of + Just e -> return e + Nothing -> liftIO $ do + message "create/new: failed (non-recoverable)" + throwIO (ExitCode OutOfMemory) + + where + catchOOM :: IO a -> IO (Maybe a) + catchOOM it = + liftM Just it `catch` \e -> case e of + ExitCode OutOfMemory -> return Nothing + _ -> throwIO e + + attempt :: MonadIO m => Builder -> m (Maybe a) -> m (Maybe a) + attempt msg ea = do + ma <- ea + case ma of + Nothing -> return Nothing + Just a -> do message builder msg + return (Just a) + + orElse :: MonadIO m => m (Maybe a) -> m (Maybe a) -> m (Maybe a) + orElse ea eb = do + ma <- ea + case ma of + Just a -> return (Just a) + Nothing -> eb + + +-- | Delete an event +-- +{-# INLINEABLE destroy #-} +destroy :: Event -> IO () +destroy = finalize + +-- | Create a new event marker that will be filled once execution in the +-- specified stream has completed all previously submitted work. +-- +{-# INLINEABLE waypoint #-} +waypoint :: Stream -> LLVM PTX Event +waypoint stream = do + event <- create + liftIO $ + withLifetime stream $ \s -> do + withLifetime event $ \e -> do + message ("add waypoint " % formatEvent % " in stream " % formatStream) e s + Event.record e (Just s) + return event + +-- | Make all future work submitted to the given stream wait until the event +-- reports completion before beginning execution. +-- +{-# INLINEABLE after #-} +after :: Event -> Stream -> IO () +after event stream = + withLifetime stream $ \s -> + withLifetime event $ \e -> do + message ("after " % formatEvent % " in stream " % formatStream) e s + Event.wait e (Just s) [] + +-- | Block the calling thread until the event is recorded +-- +{-# INLINEABLE block #-} +block :: Event -> IO () +block event = + withLifetime event $ \e -> do + message ("blocked on event " % formatEvent) e + Event.block e + +-- | Test whether an event has completed +-- +{-# INLINEABLE query #-} +query :: Event -> IO Bool +query event = withLifetime event Event.query + + +-- Debug +-- ----- + +{-# INLINE message #-} +message :: MonadIO m => Format (m ()) a -> a +message fmt = Debug.traceM Debug.dump_sched ("event: " % fmt) + +{-# INLINE formatEvent #-} +formatEvent :: Format r (Event.Event -> r) +formatEvent = later $ \(Event.Event e) -> bformat shown e + +{-# INLINE formatStream #-} +formatStream :: Format r (Stream.Stream -> r) +formatStream = later $ \(Stream.Stream s) -> bformat shown s + diff --git a/src/Data/Array/Accelerate/LLVM/PTX/Execute/Event.hs-boot b/src/Data/Array/Accelerate/LLVM/PTX/Execute/Event.hs-boot new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/PTX/Execute/Event.hs-boot @@ -0,0 +1,26 @@ +-- | +-- Module : Data.Array.Accelerate.LLVM.PTX.Execute.Event-boot +-- Copyright : [2016..2020] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.PTX.Execute.Event ( + + Event, + query, block + +) where + +import Data.Array.Accelerate.Lifetime +import qualified Foreign.CUDA.Driver.Event as Event + + +type Event = Lifetime Event.Event + +query :: Event -> IO Bool +block :: Event -> IO () + diff --git a/src/Data/Array/Accelerate/LLVM/PTX/Execute/Marshal.hs b/src/Data/Array/Accelerate/LLVM/PTX/Execute/Marshal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/PTX/Execute/Marshal.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.PTX.Execute.Marshal +-- Copyright : [2014..2020] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.PTX.Execute.Marshal ( + + module Data.Array.Accelerate.LLVM.Execute.Marshal + +) where + +import Data.Array.Accelerate.LLVM.State +import Data.Array.Accelerate.LLVM.Execute.Marshal + +import Data.Array.Accelerate.LLVM.PTX.Target +import Data.Array.Accelerate.LLVM.PTX.Execute.Async +import qualified Data.Array.Accelerate.LLVM.PTX.Array.Prim as Prim + +import Data.Array.Accelerate.Type +import Data.Array.Accelerate.Array.Data + +import qualified Foreign.CUDA.Driver as CUDA + +import Control.Concurrent +import Control.Monad.IO.Class (liftIO) +import qualified Data.DList as DL + + +instance Marshal PTX where + type ArgR PTX = CUDA.FunParam + type MarshalCleanup PTX = IO () + + marshalInt = CUDA.VArg + marshalScalarData' t + | SingleArrayDict <- singleArrayDict t + = liftPar . fmap (\(ptr, cleanup) -> (DL.singleton (CUDA.VArg ptr), cleanup)) . getCudaDevicePtr t + +-- | Return the CUDA device pointer corresponding to the given array, as well +-- as a cleanup IO action that __MUST__ be run once you are done with the +-- pointer (i.e. the GPU kernel has completed). Not calling the cleanup action +-- will result in leaked memory and resources. Calling the action twice will +-- block indefinitely on an MVar. +-- +-- This function is a hack. Prim.withDevicePtr is intended to be a wrapping +-- function that retains the resource while the callback is running and +-- releases it when the callback returns. This is all nice, but since the PTX +-- Accelerate runtime is asynchronous, uses of withDevicePtr would not all be +-- neatly nested: the actual array lifetimes are haphazard intervals during +-- program execution. +-- +-- Originally, this function just gave up and extracted the DevicePtr by +-- calling withDevicePtr with a trivial body that simply leaks p; this is +-- unsound (which was acknowledged by a 'fixme' comment...) and appears to have +-- been the cause of silent incorrect results (!) on a GTX 1050 Ti on the +-- adbench-gmmgrad test in accelerate-tests [1]. +-- +-- [1]: https://github.com/tomsmeding/accelerate-tests/blob/master/src/Data/Array/Accelerate/Tests/Prog/ADBenchGMMGrad.hs +-- +-- Fortunately, it turns out that the MemoryTable implementation underlying +-- withDevicePtr does not in fact assume lexical nesting of array usages. Thus +-- we can use a hack to let the callback of withDevicePtr live for the correct +-- amount of time without needing to rearchitect the entire PTX backend: let +-- the call run in a forkIO thread and use MVars to communicate when it should +-- return. This means that we now have the possibility to return a +-- self-contained "cleanup" handler from getCudaDevicePtr that does nothing but +-- signal to the withDevicePtr callback that the array's lifetime has ended and +-- the scope can close. All this is possible because the 'LLVM' monad is just a +-- reader monad over IO, so we can unlift it into IO. +-- +-- As a final, questionable improvement, we let the "cleanup" handler wait +-- until withDevicePtr has properly returned so that we know the array's +-- refcount has been properly decremented and memory has been released if +-- possible. +getCudaDevicePtr + :: SingleType e + -> ArrayData e + -> LLVM PTX (CUDA.DevicePtr (ScalarArrayDataR e), IO ()) +getCudaDevicePtr !t !ad = do + ptrVar <- liftIO newEmptyMVar + doneVar <- liftIO newEmptyMVar + releasedVar <- liftIO newEmptyMVar + + _ <- unliftIOLLVM $ \inLLVM -> forkIO $ inLLVM $ do + Prim.withDevicePtr t ad $ \p -> liftIO $ do + putMVar ptrVar p + takeMVar doneVar + return (Nothing, ()) + liftIO $ putMVar releasedVar () + + ptr <- liftIO $ readMVar ptrVar + return (ptr, putMVar doneVar () >> readMVar releasedVar) + diff --git a/src/Data/Array/Accelerate/LLVM/PTX/Execute/Stream.hs b/src/Data/Array/Accelerate/LLVM/PTX/Execute/Stream.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/PTX/Execute/Stream.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.PTX.Execute.Stream +-- Copyright : [2014..2020] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.PTX.Execute.Stream ( + + Reservoir, new, + Stream, create, destroy, streaming, + +) where + +import Data.Array.Accelerate.Lifetime +import qualified Data.Array.Accelerate.Array.Remote.LRU as Remote + +import Data.Array.Accelerate.LLVM.PTX.Array.Remote ( ) +import Data.Array.Accelerate.LLVM.PTX.Execute.Event ( Event ) +import Data.Array.Accelerate.LLVM.PTX.Target ( PTX(..) ) +import Data.Array.Accelerate.LLVM.State +import qualified Data.Array.Accelerate.LLVM.PTX.Debug as Debug +import qualified Data.Array.Accelerate.LLVM.PTX.Execute.Event as Event +import Data.Array.Accelerate.LLVM.PTX.Execute.Stream.Reservoir as RSV + +import Foreign.CUDA.Driver.Error +import qualified Foreign.CUDA.Driver.Stream as Stream + +import Control.Exception +import Control.Monad +import Control.Monad.Reader +import Data.Text.Lazy.Builder +import Formatting + + +-- | A 'Stream' represents an independent sequence of computations executed on +-- the GPU. Operations in different streams may be executed concurrently with +-- each other, but operations in the same stream can never overlap. +-- 'Data.Array.Accelerate.LLVM.PTX.Execute.Event.Event's can be used for +-- efficient cross-stream synchronisation. +-- +type Stream = Lifetime Stream.Stream + + +-- Executing operations in streams +-- ------------------------------- + +-- | Execute an operation in a unique execution stream. The (asynchronous) +-- result is passed to a second operation together with an event that will be +-- signalled once the operation is complete. The stream and event are released +-- after the second operation completes. +-- +{-# INLINEABLE streaming #-} +streaming + :: (Stream -> LLVM PTX a) + -> (Event -> a -> LLVM PTX b) + -> LLVM PTX b +streaming !action !after = do + stream <- create + first <- action stream + end <- Event.waypoint stream + final <- after end first + liftIO $ do + destroy stream + Event.destroy end + return final + + +-- Primitive operations +-- -------------------- + +{-- +-- | Delete all execution streams from the reservoir +-- +{-# INLINEABLE flush #-} +flush :: Context -> Reservoir -> IO () +flush !Context{..} !ref = do + mc <- deRefWeak weakContext + case mc of + Nothing -> message "delete reservoir/dead context" + Just ctx -> do + message "flush reservoir" + old <- swapMVar ref Seq.empty + bracket_ (CUDA.push ctx) CUDA.pop $ Seq.mapM_ Stream.destroy old +--} + + +-- | Create a CUDA execution stream. If an inactive stream is available for use, +-- use that, otherwise generate a fresh stream. +-- +-- Note: [Finalising execution streams] +-- +-- We don't actually ensure that the stream has executed all of its operations +-- to completion before attempting to return it to the reservoir for reuse. +-- Doing so increases overhead of the LLVM RTS due to 'forkIO', and consumes CPU +-- time as 'Stream.block' busy-waits for the stream to complete. It is quicker +-- to optimistically return the streams to the end of the reservoir immediately, +-- and just check whether the stream is done before reusing it. +-- +-- > void . forkIO $ do +-- > Stream.block stream +-- > modifyMVar_ ref $ \rsv -> return (rsv Seq.|> stream) +-- +{-# INLINEABLE create #-} +create :: LLVM PTX Stream +create = do + PTX{..} <- asks llvmTarget + s <- create' + stream <- liftIO $ newLifetime s + liftIO $ addFinalizer stream (RSV.insert ptxStreamReservoir s) + return stream + +create' :: LLVM PTX Stream.Stream +create' = do + PTX{..} <- asks llvmTarget + ms <- attempt "create/reservoir" (liftIO $ RSV.malloc ptxStreamReservoir) + `orElse` + attempt "create/new" (liftIO . catchOOM $ Stream.create []) + `orElse` do + Remote.reclaim ptxMemoryTable + liftIO $ do + message "create/new: failed (purging)" + catchOOM $ Stream.create [] + case ms of + Just s -> return s + Nothing -> liftIO $ do + message "create/new: failed (non-recoverable)" + throwIO (ExitCode OutOfMemory) + + where + catchOOM :: IO a -> IO (Maybe a) + catchOOM it = + liftM Just it `catch` \e -> case e of + ExitCode OutOfMemory -> return Nothing + _ -> throwIO e + + attempt :: MonadIO m => Builder -> m (Maybe a) -> m (Maybe a) + attempt msg ea = do + ma <- ea + case ma of + Nothing -> return Nothing + Just a -> do message builder msg + return (Just a) + + orElse :: MonadIO m => m (Maybe a) -> m (Maybe a) -> m (Maybe a) + orElse ea eb = do + ma <- ea + case ma of + Just a -> return (Just a) + Nothing -> eb + + +-- | Merge a stream back into the reservoir. This must only be done once all +-- pending operations in the stream have completed. +-- +{-# INLINEABLE destroy #-} +destroy :: Stream -> IO () +destroy = finalize + + +-- Debug +-- ----- + +{-# INLINE message #-} +message :: MonadIO m => Format (m ()) a -> a +message fmt = Debug.traceM Debug.dump_sched ("stream: " % fmt) + diff --git a/src/Data/Array/Accelerate/LLVM/PTX/Execute/Stream.hs-boot b/src/Data/Array/Accelerate/LLVM/PTX/Execute/Stream.hs-boot new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/PTX/Execute/Stream.hs-boot @@ -0,0 +1,32 @@ +-- | +-- Module : Data.Array.Accelerate.LLVM.PTX.Execute.Stream-boot +-- Copyright : [2016..2020] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.PTX.Execute.Stream ( + + Stream, + streaming, + +) where + +import Data.Array.Accelerate.Lifetime ( Lifetime ) +import Data.Array.Accelerate.LLVM.State ( LLVM ) +import Data.Array.Accelerate.LLVM.PTX.Target ( PTX ) +import {-# SOURCE #-} Data.Array.Accelerate.LLVM.PTX.Execute.Event + +import qualified Foreign.CUDA.Driver.Stream as Stream + + +type Stream = Lifetime Stream.Stream + +streaming + :: (Stream -> LLVM PTX a) + -> (Event -> a -> LLVM PTX b) + -> LLVM PTX b + diff --git a/src/Data/Array/Accelerate/LLVM/PTX/Execute/Stream/Reservoir.hs b/src/Data/Array/Accelerate/LLVM/PTX/Execute/Stream/Reservoir.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/PTX/Execute/Stream/Reservoir.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.PTX.Execute.Stream.Reservoir +-- Copyright : [2016..2020] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.PTX.Execute.Stream.Reservoir ( + + Reservoir, + new, malloc, insert, + +) where + +import Data.Array.Accelerate.LLVM.PTX.Context ( Context ) +import qualified Data.Array.Accelerate.LLVM.PTX.Debug as Debug + +import Control.Concurrent.MVar +import Data.Sequence ( Seq ) +import Formatting +import qualified Data.Sequence as Seq +import qualified Foreign.CUDA.Driver.Stream as Stream + + +-- | The reservoir is a place to store CUDA execution streams that are currently +-- inactive. When a new stream is requested one is provided from the reservoir +-- if available, otherwise a fresh execution stream is created. +-- +type Reservoir = MVar (Seq Stream.Stream) + + +-- | Generate a new empty reservoir. It is not necessary to pre-populate it with +-- any streams because stream creation does not cause a device synchronisation. +-- +-- Additionally, we do not need to finalise any of the streams. A reservoir is +-- tied to a specific execution context, so when the reservoir dies it is +-- because the PTX state and contained CUDA context have died, so there is +-- nothing more to do. +-- +{-# INLINEABLE new #-} +new :: Context -> IO Reservoir +new _ctx = newMVar Seq.empty + + +-- | Retrieve an execution stream from the reservoir, if one is available. +-- +-- Since we put streams back onto the reservoir once we have finished adding +-- work to them, not once they have completed execution of the tasks, we must +-- check for one which has actually completed. +-- +-- See note: [Finalising execution streams] +-- +{-# INLINEABLE malloc #-} +malloc :: Reservoir -> IO (Maybe Stream.Stream) +malloc !ref = + modifyMVar ref (search Seq.empty) + where + -- scan through the streams in the reservoir looking for the first inactive + -- one. Optimistically adding the streams to the end of the reservoir as + -- soon as we stop assigning new work to them (c.f. async), and just + -- checking they have completed before reusing them, is quicker than having + -- a finaliser thread block until completion before retiring them. + -- + search !acc !rsv = + case Seq.viewl rsv of + Seq.EmptyL -> return (acc, Nothing) + s Seq.:< ss -> do + done <- Stream.finished s + case done of + True -> return (acc Seq.>< ss, Just s) + False -> search (acc Seq.|> s) ss + + +-- | Add a stream to the reservoir +-- +{-# INLINEABLE insert #-} +insert :: Reservoir -> Stream.Stream -> IO () +insert !ref !stream = do + message ("stash stream " % formatStream) stream + modifyMVar_ ref $ \rsv -> return (rsv Seq.|> stream) + + +-- Debug +-- ----- + +{-# INLINE message #-} +message :: Format (IO ()) a -> a +message fmt = Debug.traceM Debug.dump_sched ("stream: " % fmt) + +{-# INLINE formatStream #-} +formatStream :: Format r (Stream.Stream -> r) +formatStream = later $ \(Stream.Stream s) -> bformat shown s + diff --git a/src/Data/Array/Accelerate/LLVM/PTX/Foreign.hs b/src/Data/Array/Accelerate/LLVM/PTX/Foreign.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/PTX/Foreign.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.PTX.Foreign +-- Copyright : [2016..2020] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.PTX.Foreign ( + + -- Foreign functions + ForeignAcc(..), + ForeignExp(..), + + -- useful re-exports + LLVM, + PTX(..), + Context(..), + liftIO, + withDevicePtr, + module Data.Array.Accelerate.LLVM.PTX.Array.Data, + module Data.Array.Accelerate.LLVM.PTX.Execute.Async, + module Data.Array.Accelerate.LLVM.PTX.Execute.Event, + module Data.Array.Accelerate.LLVM.PTX.Execute.Stream, + +) where + +import qualified Data.Array.Accelerate.Sugar.Foreign as S + +import Data.Array.Accelerate.LLVM.State +import Data.Array.Accelerate.LLVM.CodeGen.Sugar + +import Data.Array.Accelerate.LLVM.Foreign +import Data.Array.Accelerate.LLVM.PTX.Array.Data +import Data.Array.Accelerate.LLVM.PTX.Array.Prim +import Data.Array.Accelerate.LLVM.PTX.Context +import Data.Array.Accelerate.LLVM.PTX.Execute.Async +import Data.Array.Accelerate.LLVM.PTX.Target +import Data.Array.Accelerate.LLVM.PTX.Execute.Stream ( Stream ) +import Data.Array.Accelerate.LLVM.PTX.Execute.Event ( Event, waypoint, query ) + +import Control.Monad.State +import Data.Typeable + + +instance Foreign PTX where + foreignAcc (ff :: asm (a -> b)) + | Just Refl <- eqT @asm @ForeignAcc + , ForeignAcc _ asm <- ff = Just asm + | otherwise = Nothing + + foreignExp (ff :: asm (x -> y)) + | Just Refl <- eqT @asm @ForeignExp + , ForeignExp _ asm <- ff = Just asm + | otherwise = Nothing + +instance S.Foreign ForeignAcc where + strForeign (ForeignAcc s _) = s + +instance S.Foreign ForeignExp where + strForeign (ForeignExp s _) = s + + +-- Foreign functions in the PTX backend. +-- +data ForeignAcc f where + ForeignAcc :: String + -> (a -> Par PTX (Future b)) + -> ForeignAcc (a -> b) + +-- Foreign expressions in the PTX backend. +-- +data ForeignExp f where + ForeignExp :: String + -> IRFun1 PTX () (x -> y) + -> ForeignExp (x -> y) + +deriving instance Typeable ForeignAcc +deriving instance Typeable ForeignExp + diff --git a/src/Data/Array/Accelerate/LLVM/PTX/Link.hs b/src/Data/Array/Accelerate/LLVM/PTX/Link.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/PTX/Link.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-orphans #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.PTX.Link +-- Copyright : [2017..2020] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.PTX.Link ( + + module Data.Array.Accelerate.LLVM.Link, + ExecutableR(..), FunctionTable(..), Kernel(..), ObjectCode, + linkFunctionQ, + +) where + +import Data.Array.Accelerate.Lifetime + +import Data.Array.Accelerate.LLVM.Link +import Data.Array.Accelerate.LLVM.State + +import Data.Array.Accelerate.LLVM.PTX.Analysis.Launch +import Data.Array.Accelerate.LLVM.PTX.Compile +import Data.Array.Accelerate.LLVM.PTX.Context +import Data.Array.Accelerate.LLVM.PTX.Link.Cache +import Data.Array.Accelerate.LLVM.PTX.Link.Object +import Data.Array.Accelerate.LLVM.PTX.Target +import qualified Data.Array.Accelerate.LLVM.PTX.Debug as Debug + +import qualified Foreign.CUDA.Analysis as CUDA +import qualified Foreign.CUDA.Driver as CUDA + +import Control.Monad.Reader +import Data.ByteString.Short.Char8 ( ShortByteString, unpack ) +import Formatting +import Foreign.Ptr +import Data.Array.Accelerate.TH.Compat +import qualified Data.ByteString as B +import qualified Data.ByteString.Unsafe as B +import Prelude as P hiding ( lookup ) + + +instance Link PTX where + data ExecutableR PTX = PTXR { ptxExecutable :: {-# UNPACK #-} !(Lifetime FunctionTable) + } + linkForTarget = link + + +-- | Load the generated object code into the current CUDA context. +-- +link :: ObjectR PTX -> LLVM PTX (ExecutableR PTX) +link (ObjectR uid cfg objFname) = do + target <- asks llvmTarget + cache <- asks ptxKernelTable + funs <- liftIO $ dlsym uid cache $ do + -- Load the SASS object code into the current CUDA context + obj <- B.readFile objFname + jit <- B.unsafeUseAsCString obj $ \p -> CUDA.loadDataFromPtrEx (castPtr p) [] + let mdl = CUDA.jitModule jit + + -- Extract the kernel functions + nm <- FunctionTable `fmap` mapM (uncurry (linkFunction mdl)) cfg + oc <- newLifetime mdl + + -- Finalise the module by unloading it from the CUDA context + addFinalizer oc $ do + Debug.traceM Debug.dump_ld ("ld: unload module: " % formatFunctionTable) nm + contextFinalizeResource (ptxContext target) $ + withContext (ptxContext target) (CUDA.unload mdl) + + return (nm, oc) + -- + return $! PTXR funs + + +-- | Extract the named function from the module and package into a Kernel +-- object, which includes meta-information on resource usage. +-- +-- If we are in debug mode, print statistics on kernel resource usage, etc. +-- +linkFunction + :: CUDA.Module -- the compiled module + -> ShortByteString -- __global__ entry function name + -> LaunchConfig -- launch configuration for this global function + -> IO Kernel +linkFunction mdl name configure = + fst `fmap` linkFunctionQ mdl name configure + +linkFunctionQ + :: CUDA.Module + -> ShortByteString + -> LaunchConfig + -> IO (Kernel, CodeQ (Int -> Int)) +linkFunctionQ mdl name configure = do + f <- CUDA.getFun mdl name + regs <- CUDA.requires f CUDA.NumRegs + ssmem <- CUDA.requires f CUDA.SharedSizeBytes + cmem <- CUDA.requires f CUDA.ConstSizeBytes + lmem <- CUDA.requires f CUDA.LocalSizeBytes + maxt <- CUDA.requires f CUDA.MaxKernelThreadsPerBlock + + let + (occ, cta, grid, dsmem, gridQ) = configure maxt regs ssmem + + msg1 = bformat ("kernel function " % squoted string % " used " % int % " registers, " % int % " bytes smem, " % int % " bytes lmem, " % int % " bytes cmem") + (unpack name) regs (ssmem + dsmem) lmem cmem + + msg2 = bformat ("multiprocessor occupancy " % fixed 1 % "% : " % int % " threads over " % int % " warps in " % int % " blocks") + (CUDA.occupancy100 occ) + (CUDA.activeThreads occ) + (CUDA.activeWarps occ) + (CUDA.activeThreadBlocks occ) + + Debug.traceM Debug.dump_cc ("cc: " % builder % "\n " % builder) msg1 msg2 + return (Kernel name f dsmem cta grid, gridQ) + + +{-- +-- | Extract the names of the function definitions from the module. +-- +-- Note: [Extracting global function names] +-- +-- It is important to run this on the module given to us by code generation. +-- After combining modules with 'libdevice', extra function definitions, +-- corresponding to basic maths operations, will be added to the module. These +-- functions will not be callable as __global__ functions. +-- +-- The list of names will be exported in the order that they appear in the +-- module. +-- +globalFunctions :: [Definition] -> [String] +globalFunctions defs = + [ n | GlobalDefinition Function{..} <- defs + , not (null basicBlocks) + , let Name n = name + ] +--} + diff --git a/src/Data/Array/Accelerate/LLVM/PTX/Link/Cache.hs b/src/Data/Array/Accelerate/LLVM/PTX/Link/Cache.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/PTX/Link/Cache.hs @@ -0,0 +1,22 @@ +-- | +-- Module : Data.Array.Accelerate.LLVM.PTX.Link.Cache +-- Copyright : [2017..2020] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.PTX.Link.Cache ( + + KernelTable, + LC.new, LC.dlsym, + +) where + +import Data.Array.Accelerate.LLVM.PTX.Link.Object +import qualified Data.Array.Accelerate.LLVM.Link.Cache as LC + +type KernelTable = LC.LinkCache FunctionTable ObjectCode + diff --git a/src/Data/Array/Accelerate/LLVM/PTX/Link/Object.hs b/src/Data/Array/Accelerate/LLVM/PTX/Link/Object.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/PTX/Link/Object.hs @@ -0,0 +1,46 @@ +-- | +-- Module : Data.Array.Accelerate.LLVM.PTX.Link.Object +-- Copyright : [2017..2020] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.PTX.Link.Object + where + +import Data.Array.Accelerate.Lifetime +import Data.ByteString.Short.Char8 ( ShortByteString, unpack ) +import Data.List +import Formatting +import qualified Foreign.CUDA.Driver as CUDA + + +-- | The kernel function table is a list of the kernels implemented by a given +-- CUDA device module +-- +data FunctionTable = FunctionTable { functionTable :: [Kernel] } +data Kernel = Kernel + { kernelName :: {-# UNPACK #-} !ShortByteString + , kernelFun :: {-# UNPACK #-} !CUDA.Fun + , kernelSharedMemBytes :: {-# UNPACK #-} !Int + , kernelThreadBlockSize :: {-# UNPACK #-} !Int + , kernelThreadBlocks :: (Int -> Int) + } + +instance Show FunctionTable where + showsPrec _ f + = showString "<<" + . showString (intercalate "," [ unpack (kernelName k) | k <- functionTable f ]) + . showString ">>" + +formatFunctionTable :: Format r (FunctionTable -> r) +formatFunctionTable = later $ \f -> + bformat (angled (angled (commaSep string))) [ unpack (kernelName k) | k <- functionTable f ] + +-- | Object code consists of executable code in the device address space +-- +type ObjectCode = Lifetime CUDA.Module + diff --git a/src/Data/Array/Accelerate/LLVM/PTX/Pool.hs b/src/Data/Array/Accelerate/LLVM/PTX/Pool.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/PTX/Pool.hs @@ -0,0 +1,193 @@ +{-# LANGUAGE ScopedTypeVariables #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.PTX.Pool +-- Copyright : [2017..2020] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.PTX.Pool ( + + Pool, + create, with, take, put, + unsafeWith, + +) where + +import Control.Concurrent.MVar +import Control.Exception +import Data.Maybe +import System.IO.Unsafe +import Prelude hiding ( take ) + +import Data.Sequence ( Seq ) +import qualified Data.Sequence as Seq + + +-- | An item pool +-- +-- Based on 'Control.Concurrent.QSem' +-- +data Pool a = Pool {-# UNPACK #-} !(MVar ([a], Seq (MVar a))) + +-- The semaphore state (as, bs): +-- +-- * as the currently available resources +-- +-- * bs is the queue of blocked threads, stored in FIFO order. New threads are +-- queued onto the right, and threads are woken up from the left. +-- +-- A blocked thread is represented by an empty (MVar a). To unblock the thread, +-- we give it a resource via its MVar. +-- +-- A thread can deque itself by also putting () into the MVar, which it must do +-- if it receives an exception while blocked in 'take'. This means that when +-- unblocking a thread in 'put' we must first check whether the MVar is already +-- full; the MVar lock on the semaphore itself resolves race conditions between +-- put and a thread attempting to deque itself. +-- + +-- | Build a new pool with the supplied initial quantity. +-- +create :: [a] -> IO (Pool a) +create initial = + Pool <$> newMVar (initial, Seq.empty) + +-- | Wait for a unit of the resource to become available, and run the supplied +-- action given that resource. +-- +with :: Pool a -> (a -> IO b) -> IO b +with pool action = + bracket (take pool) (put pool) action + +unsafeWith :: Pool a -> (a -> b) -> b +unsafeWith pool action = + unsafePerformIO $ with pool (evaluate . action) + + +-- | Wait for an item from the pool to become available. +-- +take :: Pool a -> IO a +take (Pool ref) = + mask_ $ do + (r, bs) <- takeMVar ref + case r of + [] -> do + b <- newEmptyMVar + putMVar ref (r, bs Seq.|> b) + wait b + + (a:as) -> do + putMVar ref (as, bs) + return a + where + wait b = + takeMVar b `catch` \(e :: SomeException) -> + uninterruptibleMask_ $ do -- Note [signal interruptible] + r <- takeMVar ref + ma <- tryTakeMVar b + r' <- case ma of + Just a -> signal a r -- make sure we don't lose the resource + Nothing -> do putMVar b (throw e) -- unblock the thread?? + return r + putMVar ref r' + throwIO e + + +-- | Return a unit of the resource to the pool. +-- +put :: Pool a -> a -> IO () +put (Pool ref) a = + uninterruptibleMask_ $ do -- Note [signal interruptible] + r <- takeMVar ref + r' <- signal a r + putMVar ref r' + + +-- Note [signal interruptible] +-- +-- If we have: +-- +-- > bracket take put (...) +-- +-- and an exception arrives at the put, then we must not lose the resource. The +-- put is masked by bracket, but taking the MVar might block, and so it would be +-- interruptible. Hence we need an uninterruptibleMask here. +-- +signal :: a -> ([a], Seq (MVar a)) -> IO ([a], Seq (MVar a)) +signal a (as, blocked) = + if null as + then loop blocked -- there may be waiting threads; wake one up + else return (a:as, blocked) -- nobody waiting + where + loop blocked' = + case Seq.viewl blocked' of + Seq.EmptyL -> return ([a], Seq.empty) + b Seq.:< bs -> do + r <- tryPutMVar b a + if r then return ([], bs) -- we woke up a thread + else loop bs -- already unblocked; drop from the queue + +{-- +-- | An item pool +-- +data Pool a = Pool {-# UNPACK #-} !(MVar (NonEmpty a)) + + +-- | Create a new pooled resource containing the given items +-- +create :: [a] -> IO (Pool a) +create [] = Pool <$> newEmptyMVar +create (x:xs) = Pool <$> newMVar (x :| xs) + + +-- | Execute an operation using an item from the pool. Like 'take', the function +-- blocks until one becomes available. +-- +with :: Pool a -> (a -> IO b) -> IO b +with pool action = + bracket (take pool) (put pool) action + +unsafeWith :: Pool a -> (a -> b) -> b +unsafeWith pool action = + unsafePerformIO $ with pool (pure . action) + + +-- | Take an item from the pool. This will block until one is available. +-- +take :: Pool a -> IO a +take (Pool ref) = do + x :| xs <- takeMVar ref -- blocking + case xs of + [] -> return () -- leave the pool empty; subsequent 'take's will block + (a:as) -> mask_ $ do r <- tryTakeMVar ref + case r of + Nothing -> putMVar ref (a :| as) + Just (b :| bs) -> putMVar ref (a :| b : bs ++ as) + return x + + +-- | Return an item back to the pool for later reuse. This should be +-- a non-blocking operation. +-- +put :: Pool a -> a -> IO () +put (Pool ref) a = + mask_ $ do + it <- tryTakeMVar ref + case it of + Just (b :| bs) -> putMVar ref (a :| b : bs) + Nothing -> putMVar ref (a :| []) + + +#if __GLASGOW_HASKELL__ < 800 +-- | Non-empty (and non-strict) list type. +-- +infixr 5 :| +data NonEmpty a = a :| [a] + deriving ( Eq, Ord, Show, Read ) +#endif +--} + diff --git a/src/Data/Array/Accelerate/LLVM/PTX/State.hs b/src/Data/Array/Accelerate/LLVM/PTX/State.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/PTX/State.hs @@ -0,0 +1,176 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.PTX.State +-- Copyright : [2014..2020] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.PTX.State ( + + evalPTX, + createTargetForDevice, createTargetFromContext, + + Pool(..), + withPool, unsafeWithPool, + defaultTarget, + defaultTargetPool, + +) where + +import Data.Array.Accelerate.Error + +import Data.Array.Accelerate.LLVM.State +import Data.Array.Accelerate.LLVM.PTX.Target +import qualified Data.Array.Accelerate.LLVM.PTX.Array.Table as MT +import qualified Data.Array.Accelerate.LLVM.PTX.Context as CT +import qualified Data.Array.Accelerate.LLVM.PTX.Debug as Debug +import qualified Data.Array.Accelerate.LLVM.PTX.Execute.Stream as ST +import qualified Data.Array.Accelerate.LLVM.PTX.Link.Cache as LC +import qualified Data.Array.Accelerate.LLVM.PTX.Pool as Pool + +import Foreign.CUDA.Driver.Error +import qualified Foreign.CUDA.Driver as CUDA +import qualified Foreign.CUDA.Driver.Context as Context + +import Control.Concurrent +import Control.Exception ( try, catch ) +import Data.Maybe ( fromMaybe, catMaybes ) +import Formatting +import System.Environment ( lookupEnv ) +import System.IO.Unsafe ( unsafePerformIO, unsafeInterleaveIO ) +import Text.Read ( readMaybe ) + + +-- | Execute a PTX computation +-- +evalPTX :: PTX -> LLVM PTX a -> IO a +evalPTX ptx acc = + CT.withContext (ptxContext ptx) (evalLLVM ptx acc) + `catch` + \e -> internalError shown (e :: CUDAException) + + +-- | Create a new PTX execution target for the given device +-- +createTargetForDevice + :: CUDA.Device + -> CUDA.DeviceProperties + -> [CUDA.ContextFlag] + -> IO PTX +createTargetForDevice dev prp flags = do + raw <- CUDA.create dev flags + ptx <- createTarget dev prp raw + _ <- CUDA.pop + return ptx + + +-- | Create a PTX execute target for the given device context +-- +createTargetFromContext + :: CUDA.Context + -> IO PTX +createTargetFromContext raw = do + dev <- Context.device + prp <- CUDA.props dev + createTarget dev prp raw + + +-- | Create a PTX execution target +-- +createTarget + :: CUDA.Device + -> CUDA.DeviceProperties + -> CUDA.Context + -> IO PTX +createTarget dev prp raw = do + ctx <- CT.raw dev prp raw + mt <- MT.new ctx + lc <- LC.new + st <- ST.new ctx + return $! PTX ctx mt lc st + + +-- Shared execution contexts +-- ------------------------- + +-- In order to implement runN, we need to keep track of all available contexts, +-- as well as the managed resource pool. +-- +data Pool a = Pool + { managed :: {-# UNPACK #-} !(Pool.Pool a) + , unmanaged :: [a] + } + +-- Evaluate a thing given an execution context from the default pool +-- +withPool :: Pool a -> (a -> IO b) -> IO b +withPool p = Pool.with (managed p) + +unsafeWithPool :: Pool a -> (a -> b) -> b +unsafeWithPool p = Pool.unsafeWith (managed p) + + +-- Top-level mutable state +-- ----------------------- +-- +-- It is important to keep some information alive for the entire run of the +-- program, not just a single execution. These tokens use 'unsafePerformIO' to +-- ensure they are executed only once, and reused for subsequent invocations. +-- + +-- | Select a device from the default pool. +-- +{-# NOINLINE defaultTarget #-} +defaultTarget :: PTX +defaultTarget = case unmanaged defaultTargetPool of + ptx : _ -> ptx + _ -> error "impossible" -- ensured by defaultTargetPool + +-- | Create a shared resource pool of the available CUDA devices. +-- +-- This globally shared resource pool is auto-initialised on startup. It will +-- consist of every currently available device, or those specified by the value +-- of the environment variable @ACCELERATE_LLVM_PTX_DEVICES@ (as a list of +-- device ordinals). +-- +{-# NOINLINE defaultTargetPool #-} +defaultTargetPool :: Pool PTX +defaultTargetPool = unsafePerformIO $! do + Debug.traceM Debug.dump_gc "gc: initialise default PTX pool" + CUDA.initialise [] + + -- Figure out which GPUs we should put into the execution pool + -- + ngpu <- CUDA.count + menv <- (readMaybe =<<) <$> lookupEnv "ACCELERATE_LLVM_PTX_DEVICES" + + let ids = fromMaybe [0..ngpu-1] menv + + -- Spin up the GPU at the given ordinal. + -- + boot :: Int -> IO (Maybe PTX) + boot i = unsafeInterleaveIO $ runInBoundThread $ do + dev <- CUDA.device i + prp <- CUDA.props dev + r <- try $ createTargetForDevice dev prp [CUDA.SchedAuto] + case r of + Right ptx -> return (Just ptx) + Left (e::CUDAException) -> do + Debug.traceM Debug.dump_gc ("gc: failed to initialise device " % int % ": " % shown) i e + return Nothing + + -- Create the pool from the available devices, which get spun-up lazily as + -- required (due to the implementation of the Pool, we will look ahead by one + -- each time one device is requested). + -- + devices <- catMaybes <$> mapM boot ids + if null devices + then error "No CUDA-capable devices are available" + else Pool <$> Pool.create devices + <*> return devices + diff --git a/src/Data/Array/Accelerate/LLVM/PTX/Target.hs b/src/Data/Array/Accelerate/LLVM/PTX/Target.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/PTX/Target.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +-- | +-- Module : Data.Array.Accelerate.LLVM.PTX.Target +-- Copyright : [2014..2020] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.LLVM.PTX.Target ( + + module Data.Array.Accelerate.LLVM.Target, + module Data.Array.Accelerate.LLVM.PTX.Target, + +) where + +-- accelerate +import Data.Array.Accelerate.Error + +import Data.Array.Accelerate.LLVM.Extra +import Data.Array.Accelerate.LLVM.Target + +import Data.Array.Accelerate.LLVM.PTX.Array.Table ( MemoryTable ) +import Data.Array.Accelerate.LLVM.PTX.Context ( Context, deviceProperties, deviceName ) +import Data.Array.Accelerate.LLVM.PTX.Execute.Stream.Reservoir ( Reservoir ) +import Data.Array.Accelerate.LLVM.PTX.Link.Cache ( KernelTable ) + +-- CUDA +import Foreign.CUDA.Analysis.Device ( DeviceProperties ) + +-- standard library +import Data.ByteString.Short ( ShortByteString ) +import Data.Primitive.ByteArray +import Foreign.C.String +import Foreign.Ptr + + +-- | The PTX execution target for NVIDIA GPUs. +-- +-- The execution target carries state specific for the current execution +-- context. The data here --- device memory and execution streams --- are +-- implicitly tied to this CUDA execution context. +-- +-- Don't store anything here that is independent of the context, for example +-- state related to [persistent] kernel caching should _not_ go here. +-- +data PTX = PTX { + ptxContext :: {-# UNPACK #-} !Context + , ptxMemoryTable :: {-# UNPACK #-} !MemoryTable + , ptxKernelTable :: {-# UNPACK #-} !KernelTable + , ptxStreamReservoir :: {-# UNPACK #-} !Reservoir + } + +instance Target PTX where + targetTriple = Just ptxTargetTriple + targetDataLayout = Nothing + + +-- | Extract the properties of the device the current PTX execution state is +-- executing on. +-- +ptxDeviceProperties :: PTX -> DeviceProperties +ptxDeviceProperties = deviceProperties . ptxContext + +-- | Extract the name of the device of the current execution context +-- +ptxDeviceName :: PTX -> CString +ptxDeviceName = castPtr . byteArrayContents . deviceName . ptxContext + + +-- | String that describes the target host. +-- +ptxTargetTriple :: HasCallStack => ShortByteString +ptxTargetTriple = + case bitSize (undefined::Int) of + 32 -> "nvptx-nvidia-cuda" + 64 -> "nvptx64-nvidia-cuda" + _ -> internalError "I don't know what architecture I am" diff --git a/src/GHC/Heap/NormalForm.hs b/src/GHC/Heap/NormalForm.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Heap/NormalForm.hs @@ -0,0 +1,93 @@ +-- | +-- Module : GHC.Heap.NormalForm +-- Copyright : [2020] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- +-- https://github.com/input-output-hk/cardano-prelude/blob/96e8dcb29dc3c29eee99c0d020152fad6071af6d/src/Cardano/Prelude/GHC/Heap/NormalForm.hs +-- +-- This code has been adapted from the module "GHC.AssertNF" of the package +-- +-- () authored by +-- Joachim Breitner. +-- +-- To avoid space leaks and unwanted evaluation behaviour, the programmer +-- might want his data to be fully evaluated at certain positions in the +-- code. This can be enforced, for example, by ample use of +-- "Control.DeepSeq", but this comes at a cost. +-- +-- Experienced users hence use 'Control.DeepSeq.deepseq' only to find out +-- about the existence of space leaks and optimize their code to not create +-- the thunks in the first place, until the code no longer shows better +-- performance with 'deepseq'. +-- + +module GHC.Heap.NormalForm ( + + isHeadNormalForm, + isNormalForm, + +) where + +import GHC.Exts.Heap + +-- Everything is in normal form, unless it is a thunk explicitly marked as +-- such. Indirection are also considered to be in HNF. +-- +isHeadNormalForm :: Closure -> IO Bool +isHeadNormalForm c = do + case c of + ThunkClosure{} -> return False + APClosure{} -> return False + SelectorClosure{} -> return False + BCOClosure{} -> return False + _ -> return True + +-- | The function 'isNormalForm' checks whether its argument is fully evaluated +-- and deeply evaluated. +-- +-- NOTE 1: If you want to override the behaviour of 'isNormalForm' for specific +-- types (in particular, for specific types that may be /nested/ somewhere +-- inside the @a@), consider using +-- 'Cardano.Prelude.GHC.Heap.NormalForm.Classy.noUnexpectedThunks' instead. +-- +-- NOTE 2: The normal form check can be quite brittle, especially with @-O0@. +-- For example, writing something like +-- +-- > let !(Value x) = ... in .... +-- +-- might translate to +-- +-- > let !.. = ... in ... (case ... of Value x -> x) +-- +-- which would trivially be @False@. In general, 'isNormalForm' should probably +-- only be used with @-O1@, but even then the answer may still depend on +-- internal decisions made by ghc during compilation. +-- +isNormalForm :: a -> IO Bool +isNormalForm x = isNormalFormBoxed (asBox x) + +isNormalFormBoxed :: Box -> IO Bool +isNormalFormBoxed b = do + c <- getBoxedClosureData b + nf <- isHeadNormalForm c + if nf + then do + c' <- getBoxedClosureData b + allM isNormalFormBoxed (allClosures c') + else do + return False + +-- From Control.Monad.Loops in monad-loops +-- +allM :: Monad m => (a -> m Bool) -> [a] -> m Bool +allM _ [] = return True +allM p (x : xs) = do + q <- p x + if q + then allM p xs + else return False + diff --git a/src/System/Process/Extra.hs b/src/System/Process/Extra.hs new file mode 100644 --- /dev/null +++ b/src/System/Process/Extra.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE RecordWildCards #-} +-- | +-- Module : System.Process.Extra +-- Copyright : [2017..2020] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module System.Process.Extra + where + +-- standard library +import Control.Concurrent +import Control.Exception +import Foreign.C ( Errno(..), ePIPE ) +import GHC.IO.Exception ( IOErrorType(..), IOException(..) ) + + +-- | Fork a thread while doing something else, but kill it if there's an +-- exception. +-- +-- This is important because we want to kill the thread that is holding the +-- Handle lock, because when we clean up the process we try to close that +-- handle, which could otherwise deadlock. +-- +-- Stolen from the 'process' package. +-- +withForkWait :: IO () -> (IO () -> IO a) -> IO a +withForkWait async body = do + waitVar <- newEmptyMVar :: IO (MVar (Either SomeException ())) + mask $ \restore -> do + tid <- forkIO $ try (restore async) >>= putMVar waitVar + let wait = takeMVar waitVar >>= either throwIO return + restore (body wait) `onException` killThread tid + +ignoreSIGPIPE :: IO () -> IO () +ignoreSIGPIPE = + handle $ \e -> + case e of + IOError{..} | ResourceVanished <- ioe_type + , Just ioe <- ioe_errno + , Errno ioe == ePIPE + -> return () + _ -> throwIO e + diff --git a/test/nofib/Data/Array/Accelerate/LLVM/PTX/NoFib/RunQ.hs b/test/nofib/Data/Array/Accelerate/LLVM/PTX/NoFib/RunQ.hs new file mode 100644 --- /dev/null +++ b/test/nofib/Data/Array/Accelerate/LLVM/PTX/NoFib/RunQ.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TemplateHaskell #-} +module Data.Array.Accelerate.LLVM.PTX.NoFib.RunQ where + +import qualified Data.Array.Accelerate as A +import qualified Data.Array.Accelerate.LLVM.PTX as GPU + +import Test.Tasty +import Test.Tasty.HUnit + + +-- WARNING: This module is duplicated (apart from Native/PTX) between the +-- accelerate-llvm-native and accelerate-llvm-ptx backends. This code is not +-- included in the main Accelerate nofib testsuite because of staging issues: +-- the test can only be defined after runQ is known, and runQ is only built +-- after the 'accelerate' package has already finished building. It would be +-- possible to deduplicate the little Accelerate program in there, but that was +-- not deemed worth the effort. + + +test_runq :: TestTree +test_runq = + testGroup "runQ" + [ testCase "simple" test_simple ] + +test_simple :: Assertion +test_simple = do + let prog :: A.Vector Int -> A.Scalar Int + !prog = $(GPU.runQ $ \a -> A.sum (A.map (+1) (a :: A.Acc (A.Vector Int)))) + let n = 10000 + prog (A.fromList (A.Z A.:. 10000) [1..]) @=? A.fromList A.Z [n * (n + 1) `div` 2 + n] diff --git a/test/nofib/Main.hs b/test/nofib/Main.hs new file mode 100644 --- /dev/null +++ b/test/nofib/Main.hs @@ -0,0 +1,19 @@ +-- | +-- Module : nofib-llvm-ptx +-- Copyright : [2017..2020] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Main where + +import Data.Array.Accelerate.Test.NoFib +import Data.Array.Accelerate.LLVM.PTX +import Data.Array.Accelerate.LLVM.PTX.NoFib.RunQ + +main :: IO () +main = nofib runN test_runq +