accelerate-llvm-ptx 1.1.0.1 → 1.2.0.0
raw patch · 87 files changed
+9017/−8607 lines, 87 filesdep +accelerate-llvm-ptxdep −fclabelsdep ~acceleratedep ~accelerate-llvmdep ~base
Dependencies added: accelerate-llvm-ptx
Dependencies removed: fclabels
Dependency ranges changed: accelerate, accelerate-llvm, base, cuda, llvm-hs, llvm-hs-pure, nvvm
Files
- CHANGELOG.md +28/−3
- Data/Array/Accelerate/LLVM/PTX.hs +0/−458
- Data/Array/Accelerate/LLVM/PTX/Analysis/Device.hs +0/−50
- Data/Array/Accelerate/LLVM/PTX/Analysis/Launch.hs +0/−75
- Data/Array/Accelerate/LLVM/PTX/Array/Data.hs +0/−213
- Data/Array/Accelerate/LLVM/PTX/Array/Prim.hs +0/−508
- Data/Array/Accelerate/LLVM/PTX/Array/Remote.hs +0/−163
- Data/Array/Accelerate/LLVM/PTX/Array/Table.hs +0/−60
- Data/Array/Accelerate/LLVM/PTX/CodeGen.hs +0/−47
- Data/Array/Accelerate/LLVM/PTX/CodeGen/Base.hs +0/−408
- Data/Array/Accelerate/LLVM/PTX/CodeGen/Fold.hs +0/−628
- Data/Array/Accelerate/LLVM/PTX/CodeGen/FoldSeg.hs +0/−464
- Data/Array/Accelerate/LLVM/PTX/CodeGen/Generate.hs +0/−60
- Data/Array/Accelerate/LLVM/PTX/CodeGen/Intrinsic.hs +0/−359
- Data/Array/Accelerate/LLVM/PTX/CodeGen/Loop.hs +0/−47
- Data/Array/Accelerate/LLVM/PTX/CodeGen/Map.hs +0/−60
- Data/Array/Accelerate/LLVM/PTX/CodeGen/Permute.hs +0/−366
- Data/Array/Accelerate/LLVM/PTX/CodeGen/Queue.hs +0/−118
- Data/Array/Accelerate/LLVM/PTX/CodeGen/Scan.hs +0/−1335
- Data/Array/Accelerate/LLVM/PTX/Compile.hs +0/−322
- Data/Array/Accelerate/LLVM/PTX/Compile/Cache.hs +0/−40
- Data/Array/Accelerate/LLVM/PTX/Compile/Libdevice.hs +0/−177
- Data/Array/Accelerate/LLVM/PTX/Compile/Libdevice/Load.hs +0/−143
- Data/Array/Accelerate/LLVM/PTX/Compile/Libdevice/TH.hs +0/−188
- Data/Array/Accelerate/LLVM/PTX/Context.hs +0/−147
- Data/Array/Accelerate/LLVM/PTX/Debug.hs +0/−101
- Data/Array/Accelerate/LLVM/PTX/Embed.hs +0/−86
- Data/Array/Accelerate/LLVM/PTX/Execute.hs +0/−595
- Data/Array/Accelerate/LLVM/PTX/Execute/Async.hs +0/−63
- Data/Array/Accelerate/LLVM/PTX/Execute/Environment.hs +0/−22
- Data/Array/Accelerate/LLVM/PTX/Execute/Event.hs +0/−162
- Data/Array/Accelerate/LLVM/PTX/Execute/Event.hs-boot +0/−26
- Data/Array/Accelerate/LLVM/PTX/Execute/Marshal.hs +0/−147
- Data/Array/Accelerate/LLVM/PTX/Execute/Stream.hs +0/−181
- Data/Array/Accelerate/LLVM/PTX/Execute/Stream.hs-boot +0/−32
- Data/Array/Accelerate/LLVM/PTX/Execute/Stream/Reservoir.hs +0/−102
- Data/Array/Accelerate/LLVM/PTX/Foreign.hs +0/−81
- Data/Array/Accelerate/LLVM/PTX/Link.hs +0/−153
- Data/Array/Accelerate/LLVM/PTX/Link/Cache.hs +0/−22
- Data/Array/Accelerate/LLVM/PTX/Link/Object.hs +0/−41
- Data/Array/Accelerate/LLVM/PTX/State.hs +0/−111
- Data/Array/Accelerate/LLVM/PTX/Target.hs +0/−182
- README.md +18/−14
- accelerate-llvm-ptx.cabal +50/−47
- src/Data/Array/Accelerate/LLVM/PTX.hs +532/−0
- src/Data/Array/Accelerate/LLVM/PTX/Analysis/Device.hs +80/−0
- src/Data/Array/Accelerate/LLVM/PTX/Analysis/Launch.hs +75/−0
- src/Data/Array/Accelerate/LLVM/PTX/Array/Data.hs +226/−0
- src/Data/Array/Accelerate/LLVM/PTX/Array/Prim.hs +506/−0
- src/Data/Array/Accelerate/LLVM/PTX/Array/Remote.hs +163/−0
- src/Data/Array/Accelerate/LLVM/PTX/Array/Table.hs +60/−0
- src/Data/Array/Accelerate/LLVM/PTX/CodeGen.hs +47/−0
- src/Data/Array/Accelerate/LLVM/PTX/CodeGen/Base.hs +409/−0
- src/Data/Array/Accelerate/LLVM/PTX/CodeGen/Fold.hs +637/−0
- src/Data/Array/Accelerate/LLVM/PTX/CodeGen/FoldSeg.hs +473/−0
- src/Data/Array/Accelerate/LLVM/PTX/CodeGen/Generate.hs +57/−0
- src/Data/Array/Accelerate/LLVM/PTX/CodeGen/Intrinsic.hs +360/−0
- src/Data/Array/Accelerate/LLVM/PTX/CodeGen/Loop.hs +47/−0
- src/Data/Array/Accelerate/LLVM/PTX/CodeGen/Map.hs +57/−0
- src/Data/Array/Accelerate/LLVM/PTX/CodeGen/Permute.hs +369/−0
- src/Data/Array/Accelerate/LLVM/PTX/CodeGen/Scan.hs +1364/−0
- src/Data/Array/Accelerate/LLVM/PTX/Compile.hs +290/−0
- src/Data/Array/Accelerate/LLVM/PTX/Compile/Cache.hs +42/−0
- src/Data/Array/Accelerate/LLVM/PTX/Compile/Libdevice.hs +177/−0
- src/Data/Array/Accelerate/LLVM/PTX/Compile/Libdevice/Load.hs +143/−0
- src/Data/Array/Accelerate/LLVM/PTX/Compile/Libdevice/TH.hs +188/−0
- src/Data/Array/Accelerate/LLVM/PTX/Context.hs +161/−0
- src/Data/Array/Accelerate/LLVM/PTX/Debug.hs +97/−0
- src/Data/Array/Accelerate/LLVM/PTX/Embed.hs +86/−0
- src/Data/Array/Accelerate/LLVM/PTX/Execute.hs +603/−0
- src/Data/Array/Accelerate/LLVM/PTX/Execute/Async.hs +63/−0
- src/Data/Array/Accelerate/LLVM/PTX/Execute/Environment.hs +22/−0
- src/Data/Array/Accelerate/LLVM/PTX/Execute/Event.hs +162/−0
- src/Data/Array/Accelerate/LLVM/PTX/Execute/Event.hs-boot +26/−0
- src/Data/Array/Accelerate/LLVM/PTX/Execute/Marshal.hs +155/−0
- src/Data/Array/Accelerate/LLVM/PTX/Execute/Stream.hs +181/−0
- src/Data/Array/Accelerate/LLVM/PTX/Execute/Stream.hs-boot +32/−0
- src/Data/Array/Accelerate/LLVM/PTX/Execute/Stream/Reservoir.hs +102/−0
- src/Data/Array/Accelerate/LLVM/PTX/Foreign.hs +81/−0
- src/Data/Array/Accelerate/LLVM/PTX/Link.hs +153/−0
- src/Data/Array/Accelerate/LLVM/PTX/Link/Cache.hs +22/−0
- src/Data/Array/Accelerate/LLVM/PTX/Link/Object.hs +41/−0
- src/Data/Array/Accelerate/LLVM/PTX/Pool.hs +193/−0
- src/Data/Array/Accelerate/LLVM/PTX/State.hs +188/−0
- src/Data/Array/Accelerate/LLVM/PTX/Target.hs +182/−0
- src/System/Process/Extra.hs +48/−0
- test/nofib/Main.hs +21/−0
CHANGELOG.md view
@@ -6,11 +6,33 @@ project adheres to the [Haskell Package Versioning Policy (PVP)](https://pvp.haskell.org) +## [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 + ## [1.1.0.0] - 2017-09-21 ### Added * support for GHC-8.2@@ -22,22 +44,25 @@ ### Fixed * 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+ * initial release +[1.2.0.0]: https://github.com/AccelerateHS/accelerate-llvm/compare/1.1.0.1-ptx...v1.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 [accelerate-llvm#17]: https://github.com/AccelerateHS/accelerate-llvm/issues/17
− Data/Array/Accelerate/LLVM/PTX.hs
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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 <https://github.com/tmcdonell/lulesh-accelerate lulesh-accelerate>--- project for an example.------ [/Note:/]------ Due to <https://ghc.haskell.org/trac/ghc/ticket/13587 GHC#13587>, 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-
− Data/Array/Accelerate/LLVM/PTX/Analysis/Device.hs
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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-
− Data/Array/Accelerate/LLVM/PTX/Analysis/Launch.hs
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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 ||]-
− Data/Array/Accelerate/LLVM/PTX/Array/Data.hs
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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-
− Data/Array/Accelerate/LLVM/PTX/Array/Prim.hs
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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)-
− Data/Array/Accelerate/LLVM/PTX/Array/Remote.hs
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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-
− Data/Array/Accelerate/LLVM/PTX/Array/Table.hs
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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 ()--
− Data/Array/Accelerate/LLVM/PTX/CodeGen.hs
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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-
− Data/Array/Accelerate/LLVM/PTX/CodeGen/Base.hs
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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------ <https://github.com/llvm-mirror/llvm/blob/master/include/llvm/IR/IntrinsicsNVVM.td>----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.------ <http://docs.nvidia.com/cuda/cuda-c-programming-guide/index.html#synchronization-functions>----__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.------ <http://docs.nvidia.com/cuda/cuda-c-programming-guide/index.html#memory-fence-functions>----__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.------ <https://github.com/AccelerateHS/accelerate/issues/363>----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- }- }-
− Data/Array/Accelerate/LLVM/PTX/CodeGen/Fold.hs
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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-
− Data/Array/Accelerate/LLVM/PTX/CodeGen/FoldSeg.hs
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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-
− Data/Array/Accelerate/LLVM/PTX/CodeGen/Generate.hs
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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_--
− Data/Array/Accelerate/LLVM/PTX/CodeGen/Intrinsic.hs
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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"- ]-
− Data/Array/Accelerate/LLVM/PTX/CodeGen/Loop.hs
@@ -1,47 +0,0 @@--- |--- Module : Data.Array.Accelerate.LLVM.PTX.CodeGen.Loop--- Copyright : [2015..2017] Trevor L. McDonell--- License : BSD3------ Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>--- Stability : experimental--- Portability : non-portable (GHC extensions)-----module Data.Array.Accelerate.LLVM.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-
− Data/Array/Accelerate/LLVM/PTX/CodeGen/Map.hs
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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_-
− Data/Array/Accelerate/LLVM/PTX/CodeGen/Permute.hs
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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.- -- <https://github.com/AccelerateHS/accelerate/issues/363>- -- 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))-
− Data/Array/Accelerate/LLVM/PTX/CodeGen/Queue.hs
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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_-
− Data/Array/Accelerate/LLVM/PTX/CodeGen/Scan.hs
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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'-
− Data/Array/Accelerate/LLVM/PTX/Compile.hs
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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)-
− Data/Array/Accelerate/LLVM/PTX/Compile/Cache.hs
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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"-
− Data/Array/Accelerate/LLVM/PTX/Compile/Libdevice.hs
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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, .. }-
− Data/Array/Accelerate/LLVM/PTX/Compile/Libdevice/Load.hs
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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-
− Data/Array/Accelerate/LLVM/PTX/Compile/Libdevice/TH.hs
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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 )-
− Data/Array/Accelerate/LLVM/PTX/Context.hs
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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-
− Data/Array/Accelerate/LLVM/PTX/Debug.hs
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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")-
− Data/Array/Accelerate/LLVM/PTX/Embed.hs
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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 ||]-
− Data/Array/Accelerate/LLVM/PTX/Execute.hs
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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)-
− Data/Array/Accelerate/LLVM/PTX/Execute/Async.hs
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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-
− Data/Array/Accelerate/LLVM/PTX/Execute/Environment.hs
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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-
− Data/Array/Accelerate/LLVM/PTX/Execute/Event.hs
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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-
− Data/Array/Accelerate/LLVM/PTX/Execute/Event.hs-boot
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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 ()-
− Data/Array/Accelerate/LLVM/PTX/Execute/Marshal.hs
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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))-
− Data/Array/Accelerate/LLVM/PTX/Execute/Stream.hs
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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 ()-
− Data/Array/Accelerate/LLVM/PTX/Execute/Stream.hs-boot
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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-
− Data/Array/Accelerate/LLVM/PTX/Execute/Stream/Reservoir.hs
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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-
− Data/Array/Accelerate/LLVM/PTX/Foreign.hs
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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-
− Data/Array/Accelerate/LLVM/PTX/Link.hs
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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- ]---}-
− Data/Array/Accelerate/LLVM/PTX/Link/Cache.hs
@@ -1,22 +0,0 @@--- |--- Module : Data.Array.Accelerate.LLVM.PTX.Link.Cache--- Copyright : [2017] Trevor L. McDonell--- License : BSD3------ Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>--- Stability : experimental--- Portability : non-portable (GHC extensions)-----module Data.Array.Accelerate.LLVM.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-
− Data/Array/Accelerate/LLVM/PTX/Link/Object.hs
@@ -1,41 +0,0 @@--- |--- Module : Data.Array.Accelerate.LLVM.PTX.Link.Object--- Copyright : [2017] Trevor L. McDonell--- License : BSD3------ Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>--- Stability : experimental--- Portability : non-portable (GHC extensions)-----module Data.Array.Accelerate.LLVM.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-
− Data/Array/Accelerate/LLVM/PTX/State.hs
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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]-
− Data/Array/Accelerate/LLVM/PTX/Target.hs
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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-
README.md view
@@ -1,7 +1,10 @@ An LLVM backend for the Accelerate Array Language ================================================= -[](https://travis-ci.org/AccelerateHS/accelerate-llvm)+[](https://travis-ci.org/AccelerateHS/accelerate-llvm)+[](https://ci.appveyor.com/project/tmcdonell/accelerate-llvm)+[](https://stackage.org/lts/package/accelerate-llvm)+[](https://stackage.org/nightly/package/accelerate-llvm) [](https://hackage.haskell.org/package/accelerate-llvm) [](https://hub.docker.com/r/tmcdonell/accelerate-llvm/) [](https://microbadger.com/images/tmcdonell/accelerate-llvm)@@ -64,7 +67,7 @@ Example using [Homebrew](http://brew.sh) on macOS: ```sh-$ brew install llvm-hs/homebrew-llvm/llvm-4.0+$ brew install llvm-hs/homebrew-llvm/llvm-6.0 ``` ## Debian/Ubuntu@@ -75,17 +78,17 @@ then: ```sh-$ apt-get install llvm-4.0-dev+$ apt-get install llvm-6.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).+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/6.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+ 1. Download and unpack the [LLVM-6.0 source code](http://releases.llvm.org/6.0.0/llvm-6.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)+ such as the Clang compiler or Polly loop optimiser. See the [LLVM releases](http://releases.llvm.org/download.html#6.0.0) page for the complete list. 2. Create a temporary build directory and `cd` into it, for example:@@ -113,7 +116,7 @@ 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+ ln -s libLLVM.dylib libLLVM-6.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@@ -128,13 +131,13 @@ 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+$ ln -s stack-8.2.yaml stack.yaml $ stack setup $ stack install ``` Note that the version of [`llvm-hs`](https://hackage.haskell.org/package/llvm-hs)-used must match the installed version of LLVM, which is currently 4.0.+used must match the installed version of LLVM, which is currently 6.0. ## libNVVM@@ -152,11 +155,12 @@ on the version of the CUDA toolkit you have installed. The following table shows some combinations: -| | LLVM-3.3 | LLVM-3.4 | LLVM-3.5 | LLVM-3.8 | LLVM-3.9 | LLVM-4.0 |-|:------------:|:--------:|:--------:|:--------:|:--------:|:--------:|:--------:|-| **CUDA-7.0** | ⭕ | ❌ | | | | |-| **CUDA-7.5** | | ⭕ | ⭕ | ❌ | | |-| **CUDA-8.0** | | | ⭕ | ⭕ | ❌ | ❌ |+| | LLVM-3.3 | LLVM-3.4 | LLVM-3.5 | LLVM-3.8 | LLVM-3.9 | LLVM-4.0 | LLVM-5.0 |+|:------------:|:--------:|:--------:|:--------:|:--------:|:--------:|:--------:|:--------:|+| **CUDA-7.0** | ⭕ | ❌ | | | | | |+| **CUDA-7.5** | | ⭕ | ⭕ | ❌ | | | |+| **CUDA-8.0** | | | ⭕ | ⭕ | ❌ | ❌ | |+| **CUDA-9.0** | | | | | | ❌ | ❌ | Where ⭕ = Works, and ❌ = Does not work.
accelerate-llvm-ptx.cabal view
@@ -1,5 +1,5 @@ name: accelerate-llvm-ptx-version: 1.1.0.1+version: 1.2.0.0 cabal-version: >= 1.10 tested-with: GHC >= 7.10 build-type: Simple@@ -26,7 +26,7 @@ . Example using Homebrew on macOS: .- > brew install llvm-hs/homebrew-llvm/llvm-5.0+ > brew install llvm-hs/homebrew-llvm/llvm-6.0 . /Debian & Ubuntu/ .@@ -35,13 +35,13 @@ instructions for adding the correct package database for your OS version, and then: .- > apt-get install llvm-5.0-dev+ > apt-get install llvm-6.0-dev . /Building from source/ . If your OS does not have an appropriate LLVM distribution available, you can also build from source. Detailed build instructions are available on- <http://releases.llvm.org/5.0.0/docs/CMake.html LLVM.org>. Make sure to+ <http://releases.llvm.org/6.0.0/docs/CMake.html LLVM.org>. Make sure to include the cmake build options @-DLLVM_BUILD_LLVM_DYLIB=ON -DLLVM_LINK_LLVM_DYLIB=ON@ so that the @libLLVM@ shared library will be built. Also ensure that the @LLVM_TARGETS_TO_BUILD@@@ -83,26 +83,6 @@ 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 +100,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,7 +121,7 @@ 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.Queue Data.Array.Accelerate.LLVM.PTX.CodeGen.Scan Data.Array.Accelerate.LLVM.PTX.Compile@@ -152,28 +136,25 @@ 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 Paths_accelerate_llvm_ptx build-depends:- base >= 4.7 && < 4.11- , accelerate == 1.1.*- , accelerate-llvm == 1.1.*+ base >= 4.7 && < 4.12+ , accelerate == 1.2.*+ , accelerate-llvm == 1.2.* , bytestring >= 0.10.4 , containers >= 0.5 && <0.6 , cuda >= 0.9 , deepseq >= 1.3 , directory >= 1.0 , dlist >= 0.6- , fclabels >= 2.0 , file-embed >= 0.0.8 , filepath >= 1.0 , hashable >= 1.2- , llvm-hs >= 4.1 && < 5.2- , llvm-hs-pure >= 4.1 && < 5.2+ , llvm-hs >= 4.1 && < 6.1+ , llvm-hs-pure >= 4.1 && < 6.1 , mtl >= 2.2.1 , nvvm >= 0.7.5 , pretty >= 1.1@@ -182,37 +163,59 @@ , time >= 1.4 , unordered-containers >= 0.2 + hs-source-dirs:+ src+ default-language:- Haskell2010+ Haskell2010 - ghc-options: -O2 -Wall -fwarn-tabs+ ghc-options:+ -O2+ -Wall+ -fwarn-tabs + ghc-prof-options:+ -caf-all+ -auto-all+ if impl(ghc >= 8.0)- ghc-options: -Wmissed-specialisations+ ghc-options:+ -Wmissed-specialisations if flag(nvvm)- cpp-options: -DACCELERATE_USE_NVVM+ cpp-options:+ -DACCELERATE_USE_NVVM - 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 - if flag(unsafe-checks)- cpp-options: -DACCELERATE_UNSAFE_CHECKS+ build-depends:+ base >= 4.7+ , accelerate+ , accelerate-llvm-ptx - if flag(internal-checks)- cpp-options: -DACCELERATE_INTERNAL_CHECKS+ default-language:+ Haskell2010 + ghc-options:+ -Wall+ -O2+ -threaded+ -rtsopts+ -with-rtsopts=-A128M+ -with-rtsopts=-n4M + 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: 1.2.0.0 location: https://github.com/AccelerateHS/accelerate-llvm.git -- vim: nospell
+ src/Data/Array/Accelerate/LLVM/PTX.hs view
@@ -0,0 +1,532 @@+{-# 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 <tmcdonell@cse.unsw.edu.au>+-- 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,+ 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++-- 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 Control.Exception+import Control.Monad.Trans+import Data.Maybe+import Data.Typeable+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.+--+-- 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+ $ wait =<< runAsync 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+ $ 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'.+--+-- 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 execute+ where+ !acc = convertAccWith config a+ execute = do+ dumpGraph acc+ withPool defaultTargetPool $ \target ->+ evalPTX target $ do+ build <- phase "compile" (compileAcc acc) >>= dumpStats+ exec <- phase "link" (linkAcc build)+ res <- phase "execute" (executeAcc exec >>= AD.copyToHostLazy)+ return res++-- | 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+ build <- phase "compile" (compileAcc acc) >>= dumpStats+ 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 = 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 :: Afunction f => f -> AfunctionR f+runN f = exec+ where+ !acc = convertAfunWith config 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' target acc)+++-- | 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+ !exec = runNWith' target acc++runNWith' :: PTX -> DelayedAfun f -> f+runNWith' 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 = 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 = 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, AfunctionR f ~ RunAsyncR r) => f -> r+runNAsync f = exec+ where+ !acc = convertAfunWith config 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, AfunctionR f ~ RunAsyncR r) => PTX -> f -> r+runNAsyncWith target f = exec+ where+ !acc = convertAfunWith config f+ !exec = runNAsyncWith' target acc++runNAsyncWith' :: RunAsync f => PTX -> DelayedAfun (RunAsyncR f) -> f+runNAsyncWith' target acc = runAsync' target afun (return Aempty)+ where+ !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 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 <https://github.com/tmcdonell/lulesh-accelerate lulesh-accelerate>+-- project for an example.+--+-- [/Note:/]+--+-- Due to <https://ghc.haskell.org/trac/ghc/ticket/13587 GHC#13587>, 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' [| async |]++-- | 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' [| async |] (TH.varE target) f)+++runQ' :: Afunction f => TH.ExpQ -> f -> TH.ExpQ+runQ' using = runQ'_main using (\go -> [| withPool defaultTargetPool $ \target -> evalPTX target $go |])++runQWith' :: Afunction f => TH.ExpQ -> TH.ExpQ -> f -> TH.ExpQ+runQWith' using target = runQ'_main using (TH.appE [| evalPTX $target |])++-- 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'_main :: Afunction f => TH.ExpQ -> (TH.ExpQ -> TH.ExpQ) -> f -> TH.ExpQ+runQ'_main using k 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.bangP (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) (TH.appE using [| phase "execute" $(k (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+++-- | 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 :: 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+
+ src/Data/Array/Accelerate/LLVM/PTX/Analysis/Device.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE ScopedTypeVariables #-}+-- |+-- 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 <tmcdonell@cse.unsw.edu.au>+-- 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+
+ src/Data/Array/Accelerate/LLVM/PTX/Analysis/Launch.hs view
@@ -0,0 +1,75 @@+{-# 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 <tmcdonell@cse.unsw.edu.au>+-- 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 ||]+
+ src/Data/Array/Accelerate/LLVM/PTX/Array/Data.hs view
@@ -0,0 +1,226 @@+{-# 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 <tmcdonell@cse.unsw.edu.au>+-- 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+ let !n = size sh+ arr <- liftIO $ allocateArray sh+ runArray arr (\m ad -> Prim.mallocArray (n*m) 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 !n !mst !ad = do+ case mst of+ Nothing -> Prim.pokeArrayR from n ad+ Just st -> Prim.pokeArrayAsyncR st from n ad++ {-# INLINEABLE copyToHostR #-}+ copyToHostR !from !n !mst !ad = do+ case mst of+ Nothing -> Prim.peekArrayR from n ad+ Just st -> Prim.peekArrayAsyncR st from n ad++ {-# INLINEABLE copyToPeerR #-}+ copyToPeerR !from !n !dst !mst !ad = do+ case mst of+ Nothing -> Prim.copyArrayPeerR (ptxContext dst) (ptxMemoryTable dst) from n ad+ Just st -> Prim.copyArrayPeerAsyncR (ptxContext dst) (ptxMemoryTable dst) st from n 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+ peekR :: (ArrayElt e, ArrayPtrs e ~ Ptr a, Storable a, Typeable a, Typeable e)+ => ArrayData e+ -> UniqueArray a+ -> Int+ -> IO (UniqueArray a)+ peekR ad (UniqueArray uid (Lifetime ref weak fp)) n = 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 -> Int -> IO (ArrayData e)+ runR ArrayEltRunit AD_Unit _ = return AD_Unit+ runR (ArrayEltRpair aeR2 aeR1) (AD_Pair ad2 ad1) n = AD_Pair <$> runR aeR2 ad2 n <*> runR aeR1 ad1 n+ runR (ArrayEltRvec2 aeR) (AD_V2 ad) n = AD_V2 <$> runR aeR ad (n*2)+ runR (ArrayEltRvec3 aeR) (AD_V3 ad) n = AD_V3 <$> runR aeR ad (n*3)+ runR (ArrayEltRvec4 aeR) (AD_V4 ad) n = AD_V4 <$> runR aeR ad (n*4)+ runR (ArrayEltRvec8 aeR) (AD_V8 ad) n = AD_V8 <$> runR aeR ad (n*8)+ runR (ArrayEltRvec16 aeR) (AD_V16 ad) n = AD_V16 <$> runR aeR ad (n*16)+ --+ runR ArrayEltRint ad@(AD_Int ua) n = AD_Int <$> peekR ad ua n+ runR ArrayEltRint8 ad@(AD_Int8 ua) n = AD_Int8 <$> peekR ad ua n+ runR ArrayEltRint16 ad@(AD_Int16 ua) n = AD_Int16 <$> peekR ad ua n+ runR ArrayEltRint32 ad@(AD_Int32 ua) n = AD_Int32 <$> peekR ad ua n+ runR ArrayEltRint64 ad@(AD_Int64 ua) n = AD_Int64 <$> peekR ad ua n+ runR ArrayEltRword ad@(AD_Word ua) n = AD_Word <$> peekR ad ua n+ runR ArrayEltRword8 ad@(AD_Word8 ua) n = AD_Word8 <$> peekR ad ua n+ runR ArrayEltRword16 ad@(AD_Word16 ua) n = AD_Word16 <$> peekR ad ua n+ runR ArrayEltRword32 ad@(AD_Word32 ua) n = AD_Word32 <$> peekR ad ua n+ runR ArrayEltRword64 ad@(AD_Word64 ua) n = AD_Word64 <$> peekR ad ua n+ runR ArrayEltRcshort ad@(AD_CShort ua) n = AD_CShort <$> peekR ad ua n+ runR ArrayEltRcushort ad@(AD_CUShort ua) n = AD_CUShort <$> peekR ad ua n+ runR ArrayEltRcint ad@(AD_CInt ua) n = AD_CInt <$> peekR ad ua n+ runR ArrayEltRcuint ad@(AD_CUInt ua) n = AD_CUInt <$> peekR ad ua n+ runR ArrayEltRclong ad@(AD_CLong ua) n = AD_CLong <$> peekR ad ua n+ runR ArrayEltRculong ad@(AD_CULong ua) n = AD_CULong <$> peekR ad ua n+ runR ArrayEltRcllong ad@(AD_CLLong ua) n = AD_CLLong <$> peekR ad ua n+ runR ArrayEltRcullong ad@(AD_CULLong ua) n = AD_CULLong <$> peekR ad ua n+ runR ArrayEltRhalf ad@(AD_Half ua) n = AD_Half <$> peekR ad ua n+ runR ArrayEltRfloat ad@(AD_Float ua) n = AD_Float <$> peekR ad ua n+ runR ArrayEltRdouble ad@(AD_Double ua) n = AD_Double <$> peekR ad ua n+ runR ArrayEltRcfloat ad@(AD_CFloat ua) n = AD_CFloat <$> peekR ad ua n+ runR ArrayEltRcdouble ad@(AD_CDouble ua) n = AD_CDouble <$> peekR ad ua n+ runR ArrayEltRbool ad@(AD_Bool ua) n = AD_Bool <$> peekR ad ua n+ runR ArrayEltRchar ad@(AD_Char ua) n = AD_Char <$> peekR ad ua n+ runR ArrayEltRcchar ad@(AD_CChar ua) n = AD_CChar <$> peekR ad ua n+ runR ArrayEltRcschar ad@(AD_CSChar ua) n = AD_CSChar <$> peekR ad ua n+ runR ArrayEltRcuchar ad@(AD_CUChar ua) n = AD_CUChar <$> peekR ad ua n+ in+ Array sh <$> runR arrayElt adata (R.size sh)+++-- | 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 (size sh)+ return out+ where+ sh = shape arr++ copyR :: ArrayEltR e -> ArrayData e -> ArrayData e -> Int -> LLVM PTX ()+ copyR ArrayEltRunit _ _ _ = return ()+ copyR (ArrayEltRpair aeR1 aeR2) ad1 ad2 n = copyR aeR1 (fstArrayData ad1) (fstArrayData ad2) n >>+ copyR aeR2 (sndArrayData ad1) (sndArrayData ad2) n+ --+ copyR (ArrayEltRvec2 aeR) (AD_V2 ad1) (AD_V2 ad2) n = copyR aeR ad1 ad2 (n*2)+ copyR (ArrayEltRvec3 aeR) (AD_V3 ad1) (AD_V3 ad2) n = copyR aeR ad1 ad2 (n*3)+ copyR (ArrayEltRvec4 aeR) (AD_V4 ad1) (AD_V4 ad2) n = copyR aeR ad1 ad2 (n*4)+ copyR (ArrayEltRvec8 aeR) (AD_V8 ad1) (AD_V8 ad2) n = copyR aeR ad1 ad2 (n*8)+ copyR (ArrayEltRvec16 aeR) (AD_V16 ad1) (AD_V16 ad2) n = copyR aeR ad1 ad2 (n*16)+ --+ copyR ArrayEltRint ad1 ad2 n = copyPrim ad1 ad2 n+ copyR ArrayEltRint8 ad1 ad2 n = copyPrim ad1 ad2 n+ copyR ArrayEltRint16 ad1 ad2 n = copyPrim ad1 ad2 n+ copyR ArrayEltRint32 ad1 ad2 n = copyPrim ad1 ad2 n+ copyR ArrayEltRint64 ad1 ad2 n = copyPrim ad1 ad2 n+ copyR ArrayEltRword ad1 ad2 n = copyPrim ad1 ad2 n+ copyR ArrayEltRword8 ad1 ad2 n = copyPrim ad1 ad2 n+ copyR ArrayEltRword16 ad1 ad2 n = copyPrim ad1 ad2 n+ copyR ArrayEltRword32 ad1 ad2 n = copyPrim ad1 ad2 n+ copyR ArrayEltRword64 ad1 ad2 n = copyPrim ad1 ad2 n+ copyR ArrayEltRhalf ad1 ad2 n = copyPrim ad1 ad2 n+ copyR ArrayEltRfloat ad1 ad2 n = copyPrim ad1 ad2 n+ copyR ArrayEltRdouble ad1 ad2 n = copyPrim ad1 ad2 n+ copyR ArrayEltRbool ad1 ad2 n = copyPrim ad1 ad2 n+ copyR ArrayEltRchar ad1 ad2 n = copyPrim ad1 ad2 n+ copyR ArrayEltRcshort ad1 ad2 n = copyPrim ad1 ad2 n+ copyR ArrayEltRcushort ad1 ad2 n = copyPrim ad1 ad2 n+ copyR ArrayEltRcint ad1 ad2 n = copyPrim ad1 ad2 n+ copyR ArrayEltRcuint ad1 ad2 n = copyPrim ad1 ad2 n+ copyR ArrayEltRclong ad1 ad2 n = copyPrim ad1 ad2 n+ copyR ArrayEltRculong ad1 ad2 n = copyPrim ad1 ad2 n+ copyR ArrayEltRcllong ad1 ad2 n = copyPrim ad1 ad2 n+ copyR ArrayEltRcullong ad1 ad2 n = copyPrim ad1 ad2 n+ copyR ArrayEltRcfloat ad1 ad2 n = copyPrim ad1 ad2 n+ copyR ArrayEltRcdouble ad1 ad2 n = copyPrim ad1 ad2 n+ copyR ArrayEltRcchar ad1 ad2 n = copyPrim ad1 ad2 n+ copyR ArrayEltRcschar ad1 ad2 n = copyPrim ad1 ad2 n+ copyR ArrayEltRcuchar ad1 ad2 n = copyPrim ad1 ad2 n++ copyPrim+ :: (ArrayElt e, ArrayPtrs e ~ Ptr a, Typeable e, Storable a, Typeable a)+ => ArrayData e+ -> ArrayData e+ -> Int+ -> LLVM PTX ()+ copyPrim !a1 !a2 !m = Prim.copyArrayAsync stream m a1 a2+
+ src/Data/Array/Accelerate/LLVM/PTX/Array/Prim.hs view
@@ -0,0 +1,506 @@+{-# 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 <tmcdonell@cse.unsw.edu.au>+-- 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 !n !ad =+ blocking $ \st -> pokeArrayAsyncR st from n 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 !n !ad = do+ let !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 elements from an array at the 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+ !bytes = sizeOf (undefined::a)+ --+ message $ "indexArray: " ++ showBytes bytes+ Debug.didCopyBytesFromRemote (fromIntegral bytes)+ 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 !n !ad =+ blocking $ \st -> peekArrayAsyncR st from n 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 !n !ad = do+ let !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 !n !src !dst =+ blocking $ \st -> copyArrayAsyncR st from n 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 !n !ad_src !ad_dst = do+ let !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 !n !ad =+ blocking $ \st -> copyArrayPeerAsyncR ctx2 mt2 st from n 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 !n !ad = do+ let !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)+
+ src/Data/Array/Accelerate/LLVM/PTX/Array/Remote.hs view
@@ -0,0 +1,163 @@+{-# 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 <tmcdonell@cse.unsw.edu.au>+-- 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+
+ src/Data/Array/Accelerate/LLVM/PTX/Array/Table.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE BangPatterns #-}+-- |+-- Module : Data.Array.Accelerate.LLVM.PTX.Array.Table+-- Copyright : [2014..2017] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.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 ()++
+ src/Data/Array/Accelerate/LLVM/PTX/CodeGen.hs view
@@ -0,0 +1,47 @@+{-# 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 <tmcdonell@cse.unsw.edu.au>+-- 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+
+ src/Data/Array/Accelerate/LLVM/PTX/CodeGen/Base.hs view
@@ -0,0 +1,409 @@+{-# 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 <tmcdonell@cse.unsw.edu.au>+-- 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+--+-- <https://github.com/llvm-mirror/llvm/blob/master/include/llvm/IR/IntrinsicsNVVM.td>+--+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 Int, IR Int, [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.+--+-- <http://docs.nvidia.com/cuda/cuda-c-programming-guide/index.html#synchronization-functions>+--+__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.+--+-- <http://docs.nvidia.com/cuda/cuda-c-programming-guide/index.html#memory-fence-functions>+--+__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.+--+-- <https://github.com/AccelerateHS/accelerate/issues/363>+--+atomicAdd_f :: FloatingType a -> Operand (Ptr a) -> Operand a -> CodeGen ()+atomicAdd_f t addr val =+ let+ width :: Int+ width =+ case t of+ TypeHalf{} -> 16+ 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 TypeRunit = return OP_Unit+ go (TypeRpair t1 t2) = OP_Pair <$> go t1 <*> go t2+ go tt@(TypeRscalar 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 (ArrayPrimType 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 (ArrayPrimType 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 TypeRunit i = return (i, OP_Unit)+ go (TypeRpair t2 t1) i0 = do+ (i1, p1) <- go t1 i0+ (i2, p2) <- go t2 i1+ return $ (i2, OP_Pair p2 p1)+ go (TypeRscalar 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 (TypeRscalar 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+ }+ }+
+ src/Data/Array/Accelerate/LLVM/PTX/CodeGen/Fold.hs view
@@ -0,0 +1,637 @@+{-# 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 <tmcdonell@cse.unsw.edu.au>+-- 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+ start' <- i32 start+ 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 =<< int i0+ r0 <- if A.eq singleType sz bd+ then reduceBlockSMem dev combine Nothing x0+ else reduceBlockSMem dev combine (Just sz) x0++ when (A.eq singleType 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 <- int =<< blockDim+ sz <- 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 singleType sz step++ -- Threads cooperatively reduce this stripe+ reduceFromTo dev from to combine+ (app1 delayedLinearIndex)+ (when (A.eq singleType 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+ gd <- gridDim+ bd <- int =<< blockDim+ sz <- return $ 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 singleType sz step++ -- Threads cooperatively reduce this stripe+ reduceFromTo dev from to combine (readArray arrTmp) $ \r ->+ when (A.eq singleType tid (lift 0)) $+ writeArray arrOut seg =<<+ case mseed of+ Nothing -> return r+ Just z -> if A.eq singleType 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 <- indexHead <$> delayedExtent+ sz' <- i32 sz++ when (A.lt singleType 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 =<< int tid+ x0 <- app1 delayedLinearIndex i0+ bd <- blockDim+ r0 <- if A.gte singleType sz' bd+ then reduceBlockSMem dev combine Nothing x0+ else reduceBlockSMem dev combine (Just sz') x0++ -- Step 2: keep walking over the input+ bd' <- int bd+ 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 =<< int tid+ v' <- A.sub numType to offset+ r' <- if A.gte singleType v' bd'+ -- All threads of the block are valid, so we can avoid+ -- bounds checks.+ then do+ x <- app1 delayedLinearIndex 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 singleType i to+ then app1 delayedLinearIndex i+ else return r+ v <- i32 v'+ y <- reduceBlockSMem dev combine (Just v) x+ return y++ if A.eq singleType 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 singleType 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 singleType 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 singleType 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 singleType 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 singleType 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 Int -- ^ starting index+ -> IR Int -- ^ final index (exclusive)+ -> (IRFun2 PTX aenv (a -> a -> a)) -- ^ combination function+ -> (IR Int -> 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 <- int =<< threadIdx+ bd <- int =<< blockDim++ valid <- A.sub numType to from+ i <- A.add numType from tid++ _ <- if 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 <- 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 singleType i to) $ do+ x <- get i+ v <- i32 valid+ r <- reduceBlockSMem dev combine (Just v) x+ set r++ return (IR OP_Unit :: IR ())++ return ()++++-- Utilities+-- ---------++i32 :: IR Int -> CodeGen (IR Int32)+i32 = A.fromIntegral integralType numType++int :: IR Int32 -> CodeGen (IR Int)+int = A.fromIntegral integralType numType++imapFromTo+ :: IR Int+ -> IR Int+ -> (IR Int -> CodeGen ())+ -> CodeGen ()+imapFromTo start end body = do+ bid <- int =<< blockIdx+ gd <- int =<< gridDim+ i0 <- A.add numType start bid+ imapFromStepTo i0 gd end body+
+ src/Data/Array/Accelerate/LLVM/PTX/CodeGen/FoldSeg.hs view
@@ -0,0 +1,473 @@+{-# 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 <tmcdonell@cse.unsw.edu.au>+-- 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 <- indexHead <$> delayedExtent arr+ ss <- do n <- 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 singleType 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 singleType tid (lift 2)) $ do+ i <- case rank (undefined::sh) of+ 0 -> return s+ _ -> A.rem integralType s ss+ j <- A.add numType i =<< int tid+ v <- app1 (delayedLinearIndex seg) j+ writeArray smem tid =<< int 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 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 (IR OP_Unit :: IR ())+ Just z -> do+ when (A.eq singleType 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.+ --+ i0 <- A.add numType inf =<< int tid+ x0 <- if A.lt singleType i0 sup+ then app1 (delayedLinearIndex arr) i0+ else let+ go :: TupleType a -> Operands a+ go TypeRunit = OP_Unit+ go (TypeRpair a b) = OP_Pair (go a) (go b)+ go (TypeRscalar t) = ir' t (undef t)+ in+ return . IR $ go (eltType (undefined::e))++ bd <- int =<< blockDim+ v0 <- A.sub numType sup inf+ v0' <- i32 v0+ r0 <- if A.gte singleType 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 =<< int tid+ v' <- A.sub numType sup offset+ r' <- if A.gte singleType v' bd+ -- All threads in the block are in bounds, so we+ -- can avoid bounds checks.+ then do+ x <- app1 (delayedLinearIndex arr) 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 singleType i' sup+ then app1 (delayedLinearIndex arr) i'+ else return r+ z <- i32 v'+ y <- reduceBlockSMem dev combine (Just z) x+ return y++ -- first thread incorporates the result from the previous+ -- iteration+ if A.eq singleType 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 singleType 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 <- indexHead <$> delayedExtent arr+ ss <- do a <- indexHead <$> delayedExtent seg+ b <- A.sub numType a (lift 1)+ return b++ -- Each thread reduces a segment independently+ s0 <- A.add numType start =<< int gwid+ gd <- int =<< gridDim+ wpb' <- int wpb+ 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 singleType lane (lift 2)) $ do+ a <- case rank (undefined::sh) of+ 0 -> return s+ _ -> A.rem integralType s ss+ b <- A.add numType a =<< int lane+ c <- app1 (delayedLinearIndex seg) b+ writeArray lim lane =<< int 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 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 (IR OP_Unit :: IR ())+ Just z -> do+ when (A.eq singleType 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 =<< int lane+ x0 <- if A.lt singleType i0 sup+ then app1 (delayedLinearIndex arr) i0+ else let+ go :: TupleType a -> Operands a+ go TypeRunit = OP_Unit+ go (TypeRpair a b) = OP_Pair (go a) (go b)+ go (TypeRscalar t) = ir' t (undef t)+ in+ return . IR $ go (eltType (undefined::e))++ v0 <- A.sub numType sup inf+ v0' <- i32 v0+ r0 <- if A.gte singleType v0 (lift 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 (lift ws)+ r <- iterFromStepTo nx (lift ws) sup r0 $ \offset r -> do++ -- TLM: Similarly, I think this is unnecessary...+ __syncthreads++ i' <- A.add numType offset =<< int lane+ v' <- A.sub numType sup offset+ r' <- if A.gte singleType v' (lift ws)+ then do+ -- All lanes are in bounds, so avoid bounds checks+ x <- app1 (delayedLinearIndex arr) i'+ y <- reduceWarpSMem dev combine smem Nothing x+ return y++ else do+ x <- if A.lt singleType i' sup+ then app1 (delayedLinearIndex arr) i'+ else return r+ z <- i32 v'+ y <- reduceWarpSMem dev combine smem (Just z) x+ return y++ -- The first lane incorporates the result from the previous+ -- iteration+ if A.eq singleType 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 singleType 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 i => IR i -> CodeGen (IR Int32)+i32 = A.fromIntegral integralType numType++int :: IsIntegral i => IR i -> CodeGen (IR Int)+int = A.fromIntegral integralType numType+
+ src/Data/Array/Accelerate/LLVM/PTX/CodeGen/Generate.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+-- |+-- Module : Data.Array.Accelerate.LLVM.PTX.CodeGen.Generate+-- Copyright : [2014..2017] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.PTX.CodeGen.Generate+ where++import Prelude hiding ( fromIntegral )++-- accelerate+import Data.Array.Accelerate.Array.Sugar ( Array, Shape, Elt )++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+ ix <- indexOfInt (irArrayShape arrOut) i -- convert to multidimensional index+ r <- app1 apply ix -- apply generator function+ writeArray arrOut i r -- store result++ return_++
+ src/Data/Array/Accelerate/LLVM/PTX/CodeGen/Intrinsic.hs view
@@ -0,0 +1,360 @@+{-# 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 <tmcdonell@cse.unsw.edu.au>+-- 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"+ ]+
+ src/Data/Array/Accelerate/LLVM/PTX/CodeGen/Loop.hs view
@@ -0,0 +1,47 @@+-- |+-- Module : Data.Array.Accelerate.LLVM.PTX.CodeGen.Loop+-- Copyright : [2015..2017] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.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+++-- | 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 :: IR Int -> IR Int -> (IR Int -> CodeGen ()) -> CodeGen ()+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+
+ src/Data/Array/Accelerate/LLVM/PTX/CodeGen/Map.hs view
@@ -0,0 +1,57 @@+{-# 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 <tmcdonell@cse.unsw.edu.au>+-- 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.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+ xs <- app1 delayedLinearIndex i+ ys <- app1 apply xs+ writeArray arrOut i ys++ return_+
+ src/Data/Array/Accelerate/LLVM/PTX/CodeGen/Permute.hs view
@@ -0,0 +1,369 @@+{-# LANGUAGE CPP #-}+{-# 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 <tmcdonell@cse.unsw.edu.au>+-- 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++ 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+ --+ _ | TypeRscalar (SingleScalarType 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' = 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 ()+ 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' = NumSingleType n+ primAdd = bytes == 4+ -- Available directly in LLVM-6 and later;+ -- earlier versions could use inline assembly+#if MIN_VERSION_llvm_hs_pure(6,0,0)+ || compute >= compute60+#endif++ 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+ NumSingleType (IntegralNumType t) -> rmw_integral t addr (op t r')+ NumSingleType (FloatingNumType t) -> rmw_floating t addr (op t r')+ NonNumSingleType 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++ 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 singleType 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 TypeRunit () OP_Unit = return (lift True)+ go (TypeRpair tsh tsz) (ish, isz) (OP_Pair sh sz) = do x <- go tsh ish sh+ y <- go tsz isz sz+ land' x y+ go (TypeRscalar s) ig sz = case s of+ SingleScalarType t -> A.eq t (ir t (single t ig)) (ir t (op' t sz))+ VectorScalarType{} -> $internalError "ignore" "unexpected shape type"+
+ src/Data/Array/Accelerate/LLVM/PTX/CodeGen/Scan.hs view
@@ -0,0 +1,1364 @@+{-# 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 <tmcdonell@cse.unsw.edu.au>+-- 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 <- 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+ gd' <- int gd+ s0 <- A.add numType start =<< int bid++ -- iterating over thread-block-wide segments+ imapFromStepTo s0 gd' end $ \chunk -> do++ 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+ 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 singleType i sz+ R -> A.gte singleType i (lift 0)++ when (valid i0) $ do+ x0 <- app1 delayedLinearIndex i0+ x1 <- case mseed of+ Nothing -> return x0+ Just seed ->+ if A.eq singleType tid (lift 0) `A.land` A.eq singleType 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+ n' <- i32 n+ x2 <- if A.gte singleType 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 singleType gd (lift 1) `land` A.eq singleType 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+ 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+ 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 singleType i end+ R -> A.gte singleType i start++ when (valid i0) $ do++ __syncthreads++ x0 <- readArray arrTmp i0+ x1 <- if A.gt singleType offset (lift 0) `land` A.eq singleType 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+ n' <- i32 n+ x2 <- if A.gte singleType 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 singleType 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 Int)+ paramStride = scalarParameter scalarType ("ix.stride" :: Name Int)+ --+ config = launchConfig dev (CUDA.incWarp dev) (const 0) const [|| const ||]+ in+ makeOpenAccWith config "scanP3" (paramGang ++ 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+ 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 singleType d sz+ return (c,e)+ Nothing -> do+ c <- A.add numType b stride+ d <- A.min singleType 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 singleType e (lift 0)+ return (f,d)+ Nothing -> do+ d <- A.sub numType c stride+ e <- A.max singleType 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 <- int =<< 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 <- indexHead <$> delayedExtent++ -- 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+ s0 <- A.add numType start bid++ -- iterate over thread-block wide segments+ imapFromStepTo s0 gd end $ \seg -> do++ 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+ 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 singleType i sz+ R -> A.gte singleType i (lift 0)++ when (valid i0) $ do+ x0 <- app1 delayedLinearIndex i0++ -- Thread 0 of the first segment must also evaluate and store the+ -- initial element+ ti <- threadIdx+ x1 <- if A.eq singleType ti (lift 0) `A.land` A.eq singleType 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+ n' <- i32 n+ x2 <- if A.gte singleType 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 singleType j0 sz) $ writeArray arrOut j0 x2+ R -> when (A.gte singleType 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 singleType n bd+ y <- A.sub numType x (lift 1)+ return y+ when (A.eq singleType 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+ tid' <- int tid+ bd <- int =<< 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 singleType i end+ R -> A.gte singleType i start++ when (valid i0) $ do++ -- wait for the carry-in value to be updated+ __syncthreads++ x0 <- readArray arrTmp i0+ x1 <- if A.gt singleType offset (lift 0) `A.land` A.eq singleType 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+ n' <- i32 n+ x2 <- if A.gte singleType 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 singleType bd n+ y <- A.sub numType x (lift 1)+ z <- i32 y+ return z+ when (A.eq singleType 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 singleType 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 Int)+ paramStride = scalarParameter scalarType ("ix.stride" :: Name Int)+ --+ config = launchConfig dev (CUDA.incWarp dev) (const 0) const [|| const ||]+ in+ makeOpenAccWith config "scanP3" (paramGang ++ 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+ 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 singleType 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 singleType 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 <- int =<< 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 <- 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 <- int =<< blockIdx+ gd <- int =<< gridDim+ s0 <- A.add numType start bid+ imapFromStepTo s0 gd end $ \seg -> do++ -- Index this thread reads from+ tid <- threadIdx+ tid' <- int tid+ 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 <- return $ 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+ bd' <- int bd+ 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 singleType 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 singleType tid' sz) $ do+ n' <- i32 sz+ x0 <- app1 delayedLinearIndex i0+ r0 <- if A.gte singleType sz bd'+ then scanBlockSMem dir dev combine Nothing x0+ else scanBlockSMem dir dev combine (Just n') x0+ writeArray arrOut j0 r0++ ll <- A.sub numType bd (lift 1)+ when (A.eq singleType 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 singleType 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 singleType tid' n+ then app1 delayedLinearIndex i+ else let+ go :: TupleType a -> Operands a+ go TypeRunit = OP_Unit+ go (TypeRpair a b) = OP_Pair (go a) (go b)+ go (TypeRscalar t) = ir' t (undef t)+ in+ return . IR $ go (eltType (undefined::e))++ -- Thread zero incorporates the carry-in element+ y <- if A.eq singleType 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+ m <- i32 n+ z <- if A.gte singleType n bd'+ then scanBlockSMem dir dev combine Nothing y+ else scanBlockSMem dir dev combine (Just m) y++ when (A.lt singleType 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 singleType 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 <- 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+ 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+ 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 singleType tid (lift 0)) $ do+ z <- seed+ writeArray arrOut i0 z+ writeArray carry (lift 0 :: IR Int32) z++ bd <- blockDim+ bd' <- int bd+ 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 singleType 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 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 i+ y <- if A.eq singleType 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 singleType j sup) $ writeArray arrOut j z+ R -> when (A.gte singleType 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 singleType 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 singleType tid' n) $ do+ x <- app1 delayedLinearIndex i+ y <- if A.eq singleType 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+ l <- i32 n+ z <- scanBlockSMem dir dev combine (Just l) y++ m <- A.sub numType n (lift 1)+ _ <- if A.lt singleType 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 singleType 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 singleType 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 singleType 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 singleType 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 singleType 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'+++-- Utilities+-- ---------++i32 :: IR Int -> CodeGen (IR Int32)+i32 = A.fromIntegral integralType numType++int :: IR Int32 -> CodeGen (IR Int)+int = A.fromIntegral integralType numType+
+ src/Data/Array/Accelerate/LLVM/PTX/Compile.hs view
@@ -0,0 +1,290 @@+{-# 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 <tmcdonell@cse.unsw.edu.au>+-- 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+import qualified LLVM.Analysis as LLVM++-- 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.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.ForeignPtr+import Foreign.Ptr+import Foreign.Storable+import System.Directory+import System.Exit+import System.FilePath+import System.IO+import System.IO.Unsafe+import System.Process+import System.Process.Extra+import Text.Printf ( printf )+import qualified Data.Map as Map+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as B8+import qualified Data.ByteString.Internal as B+import qualified Data.ByteString.Short.Char8 as S8+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 <- if Debug.debuggingIsEnabled then Debug.getFlag Debug.force_recomp else return False+ if exists && not recomp+ then do+ Debug.traceIO Debug.dump_cc (printf "cc: found cached object code %s" (show 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 <- if Debug.debuggingIsEnabled then Debug.getFlag Debug.verbose else return False+ _debug <- if Debug.debuggingIsEnabled then Debug.getFlag Debug.debug else return False+ --+ 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 to compile the generated PTX into SASS (GPU+ -- object code). 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+++-- 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 -> ShortByteString -> [(String, ByteString)] -> LLVM.Module -> IO ByteString+compileModuleNVVM dev name libdevice mdl = do+ _debug <- if Debug.debuggingIsEnabled then Debug.getFlag Debug.debug else return False+ --+ 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) : (S8.unpack 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++ when Debug.internalChecksAreEnabled $ LLVM.verify mdl++ -- Run the standard optimisation pass+ --+ let pss = LLVM.defaultCuratedPassSetSpec { LLVM.optLevel = Just 3 }+ LLVM.withPassManager pss $ \pm -> do++ 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)+
+ src/Data/Array/Accelerate/LLVM/PTX/Compile/Cache.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- |+-- Module : Data.Array.Accelerate.LLVM.PTX.Compile.Cache+-- Copyright : [2017] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.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+ </> "llvm-hs-" ++ VERSION_llvm_hs+ </> S8.unpack ptxTargetTriple+ </> B8.unpack (ptxISAVersion m n)+ </> "morp.sass"+
+ src/Data/Array/Accelerate/LLVM/PTX/Compile/Libdevice.hs view
@@ -0,0 +1,177 @@+{-# 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 <tmcdonell@cse.unsw.edu.au>+-- 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, .. }+
+ src/Data/Array/Accelerate/LLVM/PTX/Compile/Libdevice/Load.hs view
@@ -0,0 +1,143 @@+{-# 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 <tmcdonell@cse.unsw.edu.au>+-- 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+
+ src/Data/Array/Accelerate/LLVM/PTX/Compile/Libdevice/TH.hs view
@@ -0,0 +1,188 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+-- |+-- Module : Data.Array.Accelerate.LLVM.PTX.Compile.Libdevice.TH+-- Copyright : [2017] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.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 )+
+ src/Data/Array/Accelerate/LLVM/PTX/Context.hs view
@@ -0,0 +1,161 @@+{-# LANGUAGE MagicHash #-}+{-# 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 <tmcdonell@cse.unsw.edu.au>+-- 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 qualified Foreign.CUDA.Driver.Context as CUDA++import Control.Exception+import Control.Monad+import Data.Hashable+import Text.PrettyPrint+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+ , deviceContext :: {-# UNPACK #-} !(Lifetime CUDA.Context) -- device execution context+ }++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+ 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.dump_phases (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 $+ devID <> colon <+> name <+> parens compute+ <> comma <+> processors <+> at <+> text clock <+> parens cores+ <> comma <+> memory+ where+ name = text (CUDA.deviceName prp)+ compute = text "compute capability" <+> text (show $ CUDA.computeCapability prp)+ devID = text "device" <+> int (fromIntegral $ CUDA.useDevice dev)+ 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+
+ src/Data/Array/Accelerate/LLVM/PTX/Debug.hs view
@@ -0,0 +1,97 @@+-- |+-- 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 <tmcdonell@cse.unsw.edu.au>+-- 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.Monad.Trans+import Control.Concurrent+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+ :: Flag+ -> (Double -> Double -> Double -> String)+ -> Maybe Stream+ -> IO ()+ -> IO ()+{-# INLINE timed #-}+timed f msg =+ monitorProcTime (getFlag f) (\t1 t2 t3 -> traceIO f (msg t1 t2 t3))++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 $ getCurrentTime+ cpuBegin <- liftIO $ getCPUTime+ _ <- liftIO $ Event.record gpuBegin stream+ result <- action+ _ <- liftIO $ Event.record gpuEnd stream+ cpuEnd <- liftIO $ getCPUTime+ wallEnd <- liftIO $ 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.+ --+ _ <- 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 = realToFrac (diffUTCTime wallEnd wallBegin)++ Event.destroy gpuBegin+ Event.destroy gpuEnd+ --+ display wallTime cpuTime gpuTime+ --+ return result++ else+ action+++{-# 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")+
+ src/Data/Array/Accelerate/LLVM/PTX/Embed.hs view
@@ -0,0 +1,86 @@+{-# 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 <tmcdonell@cse.unsw.edu.au>+-- 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 ||]+
+ src/Data/Array/Accelerate/LLVM/PTX/Execute.hs view
@@ -0,0 +1,603 @@+{-# 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 <tmcdonell@cse.unsw.edu.au>+-- 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(..) )+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.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 = simpleOp+ stencil2 = stencil2Op+ aforeign = aforeignOp+++-- 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 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, 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, 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).+--+stencil2Op+ :: (Shape sh, Elt e)+ => ExecutableR PTX+ -> Gamma aenv+ -> Aval aenv+ -> Stream+ -> sh+ -> sh+ -> LLVM PTX (Array sh e)+stencil2Op exe gamma aenv stream sh1 sh2 =+ simpleOp exe gamma aenv stream (sh1 `intersect` sh2)+++-- Foreign functions+--+aforeignOp+ :: (Arrays as, Arrays bs)+ => String+ -> (Stream -> as -> LLVM PTX bs)+ -> Stream+ -> as+ -> LLVM PTX bs+aforeignOp name asm stream arr =+ Debug.monitorProcTime query msg (Just (unsafeGetValue stream)) $+ asm stream arr+ where+ query = if Debug.monitoringIsEnabled+ then return True+ else liftIO $ Debug.getFlag Debug.dump_exec++ msg wall cpu gpu = do+ Debug.addProcessorTime Debug.PTX gpu+ Debug.traceIO Debug.dump_exec $+ printf "exec: %s %s" name (Debug.elapsed wall cpu gpu)+++-- 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++-- | 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 (start, 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.getFlag 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)+
+ src/Data/Array/Accelerate/LLVM/PTX/Execute/Async.hs view
@@ -0,0 +1,63 @@+{-# 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 <tmcdonell@cse.unsw.edu.au>+-- 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+
+ src/Data/Array/Accelerate/LLVM/PTX/Execute/Environment.hs view
@@ -0,0 +1,22 @@+-- |+-- 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 <tmcdonell@cse.unsw.edu.au>+-- 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+
+ src/Data/Array/Accelerate/LLVM/PTX/Execute/Event.hs view
@@ -0,0 +1,162 @@+{-# 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 <tmcdonell@cse.unsw.edu.au>+-- 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+
+ src/Data/Array/Accelerate/LLVM/PTX/Execute/Event.hs-boot view
@@ -0,0 +1,26 @@+-- |+-- Module : Data.Array.Accelerate.LLVM.PTX.Execute.Event-boot+-- Copyright : [2016..2017] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.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 ()+
+ src/Data/Array/Accelerate/LLVM/PTX/Execute/Marshal.hs view
@@ -0,0 +1,155 @@+{-# 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 <tmcdonell@cse.unsw.edu.au>+-- 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 (ArrayEltRvec2 aeR) (AD_V2 ad) = marshalR aeR ad+ marshalR (ArrayEltRvec3 aeR) (AD_V3 ad) = marshalR aeR ad+ marshalR (ArrayEltRvec4 aeR) (AD_V4 ad) = marshalR aeR ad+ marshalR (ArrayEltRvec8 aeR) (AD_V8 ad) = marshalR aeR ad+ marshalR (ArrayEltRvec16 aeR) (AD_V16 ad) = marshalR aeR 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 ArrayEltRhalf 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))+
+ src/Data/Array/Accelerate/LLVM/PTX/Execute/Stream.hs view
@@ -0,0 +1,181 @@+{-# 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 <tmcdonell@cse.unsw.edu.au>+-- 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 ()+
+ src/Data/Array/Accelerate/LLVM/PTX/Execute/Stream.hs-boot view
@@ -0,0 +1,32 @@+-- |+-- Module : Data.Array.Accelerate.LLVM.PTX.Execute.Stream-boot+-- Copyright : [2016..2017] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.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+
+ src/Data/Array/Accelerate/LLVM/PTX/Execute/Stream/Reservoir.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE BangPatterns #-}+-- |+-- Module : Data.Array.Accelerate.LLVM.PTX.Execute.Stream.Reservoir+-- Copyright : [2016..2017] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.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+
+ src/Data/Array/Accelerate/LLVM/PTX/Foreign.hs view
@@ -0,0 +1,81 @@+{-# 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 <tmcdonell@cse.unsw.edu.au>+-- 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+
+ src/Data/Array/Accelerate/LLVM/PTX/Link.hs view
@@ -0,0 +1,153 @@+{-# 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 <tmcdonell@cse.unsw.edu.au>+-- 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+ ]+--}+
+ src/Data/Array/Accelerate/LLVM/PTX/Link/Cache.hs view
@@ -0,0 +1,22 @@+-- |+-- Module : Data.Array.Accelerate.LLVM.PTX.Link.Cache+-- Copyright : [2017] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.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+
+ src/Data/Array/Accelerate/LLVM/PTX/Link/Object.hs view
@@ -0,0 +1,41 @@+-- |+-- Module : Data.Array.Accelerate.LLVM.PTX.Link.Object+-- Copyright : [2017] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.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+
+ src/Data/Array/Accelerate/LLVM/PTX/Pool.hs view
@@ -0,0 +1,193 @@+{-# LANGUAGE ScopedTypeVariables #-}+-- |+-- Module : Data.Array.Accelerate.LLVM.PTX.Pool+-- Copyright : [2017] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.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+--}+
+ src/Data/Array/Accelerate/LLVM/PTX/State.hs view
@@ -0,0 +1,188 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# 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 <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.PTX.State (++ evalPTX,+ createTargetForDevice, createTargetFromContext,++ Pool(..),+ withPool, unsafeWithPool,+ defaultTarget,+ defaultTargetPool,++) where++-- accelerate+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 Data.Range ( Range(..) )+import Control.Parallel.Meta ( Executable(..) )++-- standard library+import Control.Concurrent ( runInBoundThread )+import Control.Exception ( try, catch )+import Data.Maybe ( fromMaybe, catMaybes )+import System.Environment ( lookupEnv )+import System.IO.Unsafe ( unsafePerformIO )+import Text.Printf ( printf )+import Text.Read ( readMaybe )+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+ 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 simpleIO+++{-# INLINE simpleIO #-}+simpleIO :: Executable+simpleIO = Executable $ \_name _ppt range action ->+ case range of+ Empty -> return ()+ IE u v -> action u v 0+++-- 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 = head (unmanaged 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.traceIO 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 = 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.traceIO Debug.dump_gc (printf "gc: failed to initialise device %d: %s" i (show 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+
+ src/Data/Array/Accelerate/LLVM/PTX/Target.hs view
@@ -0,0 +1,182 @@+{-# 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 <tmcdonell@cse.unsw.edu.au>+-- 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+
+ src/System/Process/Extra.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE RecordWildCards #-}+-- |+-- Module : System.Process.Extra+-- Copyright : [2017] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module 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+
+ test/nofib/Main.hs view
@@ -0,0 +1,21 @@+-- |+-- Module : nofib-llvm-ptx+-- Copyright : [2017] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- 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.Debug++main :: IO ()+main = do+ beginMonitoring+ nofib runN+