packages feed

accelerate-llvm-ptx 1.1.0.1 → 1.4.0.0

raw patch · 91 files changed

Files

CHANGELOG.md view
@@ -7,37 +7,113 @@ Policy (PVP)](https://pvp.haskell.org)  +## [1.4.0.0] - ?+### Changed+  * Support for LLVM-16 to 22.+  * Use shuffle instructions for faster warp-level folds and scans.+  * Support new compute capabilities.++### Fixed+  * Device memory was deallocated too early or overwritten [accelerate-llvm#111]+  * CUDA Context double free [accelerate-llvm#113]+  * Execution of stencil boundaries were not properly synchronised+  * Scans sometimes gave incorrect results+  * Various other small correctness issues++### Contributors++Special thanks to those who contributed patches as part of this release:++  * Trevor L. McDonell (@tmcdonell)+  * Tom Smeding (@tomsmeding)+  * David van Balen (@dpvanbalen)+  * Ivo Gabe de Wolff (@ivogabe)+  * Michael Swam (@michael-swan)+  * Travis Whitaker (@TravisWhitaker)+  * Noah Williams (@noahmartinwilliams)+  * Robbert van der Helm (@robbert-vdh)+  * Jann Müller (@j-mueller)++## [1.3.0.0] - 2018-08-27+### Changed+  * Code generation improvements for stencil operations++### Fixed+  * Segmented folds crash or give inconsistent results ([accelerate#423])+  * Synchronisation problems on SM7+ [#436] ++### Contributors++Special thanks to those who contributed patches as part of this release:++  * Trevor L. McDonell (@tmcdonell)+  * Josh Meredith (@JoshMeredith)+  * Ivo Gabe de Wolff (@ivogabe)+  * Lars van den Haak (@sakehl)+  * Joshua Meredith (@JoshMeredith)+++## [1.2.0.0] - 2018-04-03+### Changed+  * `run` variants which do not take an explicit execution context now execute on+    the first available device in an exclusive fashion. Multi-GPU systems can+    specify the default set of GPUs to use with environment variable+    `ACCELERATE_LLVM_PTX_DEVICES` as a list of device ordinals.++### Added+  * support for half-precision floats+  * support for struct-of-array-of-struct representations+  * support 64-bit atomic-add instruction in forward permutations ([#363])+  * support for LLVM-6.0+  * support for GHC-8.4++### Contributors++Special thanks to those who contributed patches as part of this release:++  * Trevor L. McDonell (@tmcdonell)+  * Moritz Kiefer (@cocreature)++ ## [1.1.0.1] - 2018-01-08 ### Fixed- * add support for building with CUDA-9.x+  * add support for building with CUDA-9.x + ## [1.1.0.0] - 2017-09-21 ### Added- * support for GHC-8.2- * caching of compilation results ([accelerate-llvm#17])- * support for ahead-of-time compilation (`runQ` and `runQAsync`)+  * support for GHC-8.2+  * caching of compilation results ([accelerate-llvm#17])+  * support for ahead-of-time compilation (`runQ` and `runQAsync`)  ### Changed- * generalise `run1*` to polyvariadic `runN*`+  * generalise `run1*` to polyvariadic `runN*`  ### Fixed- * Fixed synchronisation bug in multidimensional reduction- +  * Fixed synchronisation bug in multidimensional reduction + ## [1.0.0.1] - 2017-05-25 ### Fixed-  * [#386] (partial fix)+  * device kernel image is invalid ([#386]) + ## [1.0.0.0] - 2017-03-31   * initial release  +[1.3.0.0]:              https://github.com/AccelerateHS/accelerate-llvm/compare/1.2.0.0...v1.3.0.0+[1.2.0.0]:              https://github.com/AccelerateHS/accelerate-llvm/compare/1.1.0.1-ptx...1.2.0.0 [1.1.0.1]:              https://github.com/AccelerateHS/accelerate-llvm/compare/1.1.0.0...1.1.0.1-ptx [1.1.0.0]:              https://github.com/AccelerateHS/accelerate-llvm/compare/1.0.0.0...1.1.0.0 [1.0.0.1]:              https://github.com/AccelerateHS/accelerate-llvm/compare/1.0.0.0...1.0.0.1 [1.0.0.0]:              https://github.com/AccelerateHS/accelerate-llvm/compare/be7f91295f77434b2103c70aa1cabb6a4f2b09a8...1.0.0.0  [#386]:                 https://github.com/AccelerateHS/accelerate/issues/386+[#363]:                 https://github.com/AccelerateHS/accelerate/issues/363 +[#436]:                 https://github.com/AccelerateHS/accelerate/issues/436 [accelerate-llvm#17]:   https://github.com/AccelerateHS/accelerate-llvm/issues/17-+[accelerate#423]:       https://github.com/AccelerateHS/accelerate/issues/423+[accelerate-llvm#111]:  https://github.com/AccelerateHS/accelerate-llvm/pull/111+[accelerate-llvm#113]:  https://github.com/AccelerateHS/accelerate-llvm/pull/113
− 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-
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) [2014..2017] The Accelerate Team.  All rights reserved.+Copyright (c) [2014..2020] The Accelerate Team.  All rights reserved.  Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
README.md view
@@ -1,14 +1,18 @@-An LLVM backend for the Accelerate Array Language-=================================================+<div align="center">+<img width="450" src="https://github.com/AccelerateHS/accelerate/raw/master/images/accelerate-logo-text-v.png?raw=true" alt="henlo, my name is Theia"/> -[![Build Status](https://travis-ci.org/AccelerateHS/accelerate-llvm.svg)](https://travis-ci.org/AccelerateHS/accelerate-llvm)+# LLVM backends for the Accelerate array language++[![CI](https://github.com/AccelerateHS/accelerate-llvm/actions/workflows/ci.yml/badge.svg)](https://github.com/AccelerateHS/accelerate-llvm/actions/workflows/ci.yml)+[![Gitter](https://img.shields.io/gitter/room/nwjs/nw.js.svg)](https://gitter.im/AccelerateHS/Lobby) [![Hackage](https://img.shields.io/hackage/v/accelerate-llvm.svg)](https://hackage.haskell.org/package/accelerate-llvm)-[![Docker Automated build](https://img.shields.io/docker/automated/tmcdonell/accelerate-llvm.svg)](https://hub.docker.com/r/tmcdonell/accelerate-llvm/)-[![Docker status](https://images.microbadger.com/badges/image/tmcdonell/accelerate-llvm.svg)](https://microbadger.com/images/tmcdonell/accelerate-llvm) +</div>+ This package compiles Accelerate code to LLVM IR, and executes that code on-multicore CPUs as well as NVIDIA GPUs. This avoids the need to go through `nvcc`-or `clang`. For details on Accelerate, refer to the [main repository][GitHub].+multicore CPUs as well as NVIDIA GPUs. This avoids the need to go through+`nvcc` or write C++ code. For details on Accelerate, refer to the [main+repository][GitHub].  We love all kinds of contributions, so feel free to open issues for missing features as well as report (or fix!) bugs on the [issue tracker][Issues].@@ -18,171 +22,143 @@    * [Dependencies](#dependencies)- * [Docker](#docker)- * [Installing LLVM](#installing-llvm)-   * [Homebrew](#homebrew)+   * [macOS](#macos)    * [Debian/Ubuntu](#debianubuntu)-   * [Building from source](#building-from-source)- * [Installing Accelerate-LLVM](#installing-accelerate-llvm)-   * [libNVVM](#libNVVM)+   * [Arch Linux](#archlinux)+   * [Windows](#windows)   Dependencies ------------ -Haskell dependencies are available from Hackage, but there are several external+Haskell dependencies are available from Hackage, but there are some external library dependencies that you will need to install as well: - * [`LLVM`](http://llvm.org)- * [`libFFI`](http://sourceware.org/libffi/) (if using the `accelerate-llvm-native` backend for multicore CPUs)- * [`CUDA`](https://developer.nvidia.com/cuda-downloads) (if using the `accelerate-llvm-ptx` backend for NVIDIA GPUs)---Docker---------A [docker](https://www.docker.com) container is provided with this package-preinstalled (via stack) at `/opt/accelerate-llvm`. Note that if you wish to use-the `accelerate-llvm-ptx` GPU backend, you will need to install the [NVIDIA-docker](https://github.com/NVIDIA/nvidia-docker) plugin; see that page for more-information.--```sh-$ docker run -it tmcdonell/accelerate-llvm-```---Installing LLVM------------------When installing LLVM, make sure that it includes the `libLLVM` shared library.-If you want to use the GPU targeting `accelerate-llvm-ptx` backend, make sure-you install (or build) LLVM with the 'nvptx' target.+- if using `accelerate-llvm-native` for multicore CPU:+  [`libFFI`](http://sourceware.org/libffi/)+- if using `accelerate-llvm-ptx` for GPU:+  [`CUDA`](https://developer.nvidia.com/cuda-downloads);+  [Note that not all versions of CUDA support all NVIDIA GPUs](https://en.wikipedia.org/wiki/CUDA#GPUs_supported)+- [`clang`](https://clang.llvm.org/) (if using `accelerate-llvm-ptx`: version+  16 or higher, built with support for the `nvptx` backend). `accelerate-llvm`+  uses the command-line tool as a way to be compatible with many different LLVM+  versions, not to compile C code. (Accelerate passes LLVM IR to `clang`.) -## Homebrew+Below are some OS-specific instructions. If anything here is wrong or out of+date, please file an issue. -Example using [Homebrew](http://brew.sh) on macOS:+## macOS -```sh-$ brew install llvm-hs/homebrew-llvm/llvm-4.0-```+To get `libFFI`, run `brew install libffi`. `clang` is already provided with+macOS (you may need to `xcode-select --install`), and CUDA is not supported on+macOS.  ## Debian/Ubuntu -For Debian/Ubuntu based Linux distributions, the LLVM.org website provides-binary distribution packages. Check [apt.llvm.org](http://apt.llvm.org) for-instructions for adding the correct package database for your OS version, and-then:--```sh-$ apt-get install llvm-4.0-dev-```--## Building from source--If your OS does not have an appropriate LLVM distribution available, you can also build from source. Detailed build instructions are available on the [LLVM.org website](http://releases.llvm.org/4.0.0/docs/CMake.html). Note that you will require at least [CMake 3.4.3](http://www.cmake.org/cmake/resources/software.html) and a recent C++ compiler; at least Clang 3.1, GCC 4.8, or Visual Studio 2015 (update 3).--  1. Download and unpack the [LLVM-4.0 source code](http://releases.llvm.org/4.0.0/llvm-4.0.0.src.tar.xz). We'll refer to-     the path that the source tree was unpacked to as `LLVM_SRC`. Only the main-     LLVM source tree is required, but you can optionally add other components-     such as the Clang compiler or Polly loop optimiser. See the [LLVM releases](http://releases.llvm.org/download.html#4.0.0)-     page for the complete list.--  2. Create a temporary build directory and `cd` into it, for example:-     ```sh-     $ mkdir /tmp/build-     $ cd /tmp/build-     ```--  3. Execute the following to configure the build. Here `INSTALL_PREFIX` is-     where LLVM is to be installed, for example `/usr/local` or-     `$HOME/opt/llvm`:-     ```sh-     $ cmake $LLVM_SRC -DCMAKE_INSTALL_PREFIX=$INSTALL_PREFIX -DCMAKE_BUILD_TYPE=Release -DLLVM_ENABLE_ASSERTIONS=ON -DLLVM_BUILD_LLVM_DYLIB=ON -DLLVM_LINK_LLVM_DYLIB=ON-     ```-     See [options and variables](http://llvm.org/docs/CMake.html#options-and-variables)-     for a list of additional build parameters you can specify.--  4. Build and install:-     ```sh-     $ cmake --build .-     $ cmake --build . --target install-     ```--  5. For macOS only, some additional steps are useful to work around issues related-     to [System Integrity Protection](https://en.wikipedia.org/wiki/System_Integrity_Protection):-     ```sh-     cd $INSTALL_PREFIX/lib-     ln -s libLLVM.dylib libLLVM-4.0.dylib-     install_name_tool -id $PWD/libLTO.dylib libLTO.dylib-     install_name_tool -id $PWD/libLLVM.dylib libLLVM.dylib-     install_name_tool -change '@rpath/libLLVM.dylib' $PWD/libLLVM.dylib libLTO.dylib-     ```+For `clang`:+- On Ubuntu 24.04 (noble) / Debian trixie or higher: `sudo apt install clang`.+- Otherwise, if you need only the CPU backend (`accelerate-llvm-native`):+  `sudo apt install clang` will give you an old version of `clang`, but the CPU+   backend is likely to work fine.+- If you are on an older distro and need the GPU backend+  (`accelerate-llvm-ptx`): `clang` version 16 or higher is required.+  Add the apt source from [apt.llvm.org](https://apt.llvm.org/). The neatest+  way to do this is to create a file `/etc/apt/sources.list.d/llvm.list` (the+  precise file name does not matter) and put in it, for Ubuntu (change "jammy"+  as appropriate): +      deb http://apt.llvm.org/jammy/ llvm-toolchain-jammy main+      deb-src http://apt.llvm.org/jammy/ llvm-toolchain-jammy main -Installing Accelerate-LLVM---------------------------+  or for Debian (change "bookworm" as appropriate): -Once the dependencies are installed, we are ready to install `accelerate-llvm`.+      deb http://apt.llvm.org/bookworm/ llvm-toolchain-bookworm main+      deb-src http://apt.llvm.org/bookworm/ llvm-toolchain-bookworm main -For example, installation using [`stack`](http://docs.haskellstack.org/en/stable/README.html)-just requires you to point it to the appropriate configuration file:-```sh-$ ln -s stack-8.0.yaml stack.yaml-$ stack setup-$ stack install-```+  and `sudo apt update; sudo apt install clang`. This gets you the latest+  version of `clang`; different sources are also available for specific+  versions (see [apt.llvm.org](https://apt.llvm.org)). -Note that the version of [`llvm-hs`](https://hackage.haskell.org/package/llvm-hs)-used must match the installed version of LLVM, which is currently 4.0.+To use the CPU backend (`accelerate-llvm-native`), install `libFFI` using+`sudo apt install libffi-dev`. +To use the GPU backend (`accelerate-llvm-ptx`), install CUDA from+[here](https://developer.nvidia.com/cuda-downloads?target_os=Linux)+("deb (network)" is smoother than the "deb (local)" option). -## libNVVM+## Arch Linux -The `accelerate-llvm-ptx` backend can optionally be compiled to generate GPU-code using the `libNVVM` library, rather than LLVM's inbuilt NVPTX code-generator. `libNVVM` is a closed-source library distributed as part of the-NVIDIA CUDA toolkit, and is what the `nvcc` compiler itself uses internally when-compiling CUDA C code.+Run `sudo pacman -S clang`. To use the CPU backend (`accelerate-llvm-native`),+additionally run `sudo pacman -S libffi`. To use the GPU backend+(`accelerate-llvm-ptx`), additionally run `sudo pacman -S cuda`. -Using `libNVVM` _may_ improve GPU performance compared to the code generator-built in to LLVM. One difficulty with using it however is that since `libNVVM`-is also based on LLVM, and typically lags LLVM by several releases, you must-install `accelerate-llvm` with a "compatible" version of LLVM, which will depend-on the version of the CUDA toolkit you have installed. The following table shows-some combinations:+## Windows -|              | LLVM-3.3 | LLVM-3.4 | LLVM-3.5 | LLVM-3.8 | LLVM-3.9 | LLVM-4.0 |-|:------------:|:--------:|:--------:|:--------:|:--------:|:--------:|:--------:|-| **CUDA-7.0** |     ⭕    |     ❌    |          |          |          |          |-| **CUDA-7.5** |          |     ⭕    |     ⭕    |     ❌    |          |          |-| **CUDA-8.0** |          |          |     ⭕    |     ⭕    |     ❌    |     ❌    |+We recommend WSL2 (not WSL1, WSL2!) and following the Ubuntu instructions+above. The remainder of this text attemps to give you a working system on+Windows native. -Where ⭕ = Works, and ❌ = Does not work.+Install `clang`; you have two options:+1. Using+   [WinGet](https://learn.microsoft.com/en-us/windows/package-manager/winget/):+   `winget install LLVM.LLVM`+2. By downloading the installer directly (WinGet just runs the same installer)+   from [here](https://github.com/llvm/llvm-project/releases) (choose+   "LLVM-&lt;version>-win64.exe" from the latest release; you may need to click+   "Show all 57 assets").+This will also give you `libFFI`. -Note that the above restrictions on CUDA and LLVM version exist _only_ if you-want to use the NVVM component. Otherwise, you should be free to use any-combination of CUDA and LLVM.+<details><summary>Optionally, add <code>clang</code> (and more) to your system path. Click to see how.</summary> -Also note that `accelerate-llvm-ptx` itself currently requires at least LLVM-3.5.+Accelerate should be able to find `clang` automatically even if you do not do+this. However, for easy access to `clang` and all other LLVM executables, add+`C:\Program Files\LLVM\bin` to the system path as follows:+1. Search for "environment variables" in the start menu+2. Click "Edit the system environment variables"+3. Click on "Environment Variables..."+4. Double-click on the user variable called "Path"+5. And add a new entry containing `C:\Program Files\LLVM\bin`. -Using `stack`, either edit the `stack.yaml` and add the following section:+Note that if you add an entry here manually, it is a good idea to clean it up+again if you uninstall LLVM/clang. (Leaving it there is not very harmful,+however.) -```yaml-flags:-  accelerate-llvm-ptx:-    nvvm: true-```+You may find that the LLVM/clang installer has already added the Path entry+automatically (it did not for us); if so, no need to add a second entry. -Or install using the following option on the command line:+&mdash;&mdash;+</details> -```sh-$ stack install accelerate-llvm-ptx --flag accelerate-llvm-ptx:nvvm-```+You may additionally need the VS Build Tools, if you have not yet installed and+set up Visual Studio otherwise. You need this if `clang` complains that it is+`unable to find a Visual Studio installation; try running Clang from a developer command prompt`. -If installing via `cabal`:+1. If you already have the Visual Studio Installer on your system, open it and+   check if you already have Visual Studio (Community) installed. Note that+   this is completely unrelated to VS _Code_.+   - If you already have VS (Community): inside the Visual Studio Installer,+     click on "Modify" in the VS (Community) box. This should get you a screen+     with "workloads" you can select.+   - If you do not yet have VS (Community), install the VS Build Tools: go to+     https://visualstudio.microsoft.com/downloads, scroll down to "All+     Downloads", open "Tools for Visual Studio", and select "Build Tools for+     Visual Studio". If you run the installer, you should get a screen with+     "workloads" you can select.+2. Under the Workloads tab, choose the "Desktop development with C++" workload.+   If you want to save a bit of disk space (not much), keep only the following+   two options selected:+   - "MSVC v143 - VE 2022 C++ x64/x86 build tools (Latest)"+   - "Windows 11 SDK (…)" (choose the latest option). The attentive reader may+     note that the wizard also offers Clang; we recommend a separate Clang+     install for Accelerate because the one from VS somehow doesn’t seem to+     work properly with Accelerate. If you find out why, please let us know.+3. Install that. This takes a while. -```sh-$ cabal install accelerate-llvm-ptx -fnvvm-```+It turns out that having both Visual Studio and the Build Tools installed+results in Clang getting confused between the two (it appears that Visual+Studio is 64-bit (x64) and the Build Tools are 32-bit (x86)). If Clang+complains about the bit-ness of your system libraries, double-check that you+haven’t installed both simultaneously. +The GPU backend (`accelerate-llvm-ptx`) probably doesn't work on Windows; in+any case, it is untested.
− Setup.hs 
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
accelerate-llvm-ptx.cabal view
@@ -1,108 +1,39 @@+cabal-version:          2.2+ name:                   accelerate-llvm-ptx-version:                1.1.0.1-cabal-version:          >= 1.10-tested-with:            GHC >= 7.10+version:                1.4.0.0+tested-with:            GHC >= 9.4 build-type:             Simple  synopsis:               Accelerate backend for NVIDIA GPUs description:     This library implements a backend for the /Accelerate/ language which-    generates LLVM-IR targeting CUDA capable GPUs. For further information,+    generates LLVM IR targeting CUDA capable GPUs. For further information,     refer to the main <http://hackage.haskell.org/package/accelerate accelerate>     package.     .     [/Dependencies/]     .     Haskell dependencies are available from Hackage. The following external-    libraries are alse required:-    .-      * <http://llvm.org LLVM>-    .-      * <https://developer.nvidia.com/cuda-downloads CUDA>-    .-    [/Installing LLVM/]-    .-    /Homebrew/-    .-    Example using Homebrew on macOS:-    .-    > brew install llvm-hs/homebrew-llvm/llvm-5.0-    .-    /Debian & Ubuntu/-    .-    For Debian/Ubuntu based Linux distributions, the LLVM.org website provides-    binary distribution packages. Check <http://apt.llvm.org apt.llvm.org> for-    instructions for adding the correct package database for your OS version,-    and then:-    .-    > apt-get install llvm-5.0-dev-    .-    /Building from source/-    .-    If your OS does not have an appropriate LLVM distribution available, you can-    also build from source. Detailed build instructions are available on-    <http://releases.llvm.org/5.0.0/docs/CMake.html LLVM.org>. Make sure to-    include the cmake build options-    @-DLLVM_BUILD_LLVM_DYLIB=ON -DLLVM_LINK_LLVM_DYLIB=ON@ so that the @libLLVM@-    shared library will be built. Also ensure that the @LLVM_TARGETS_TO_BUILD@-    option includes the @NVPTX@ target (if not specified all targets are built).-    .-    [/Installing accelerate-llvm/]-    .-    To use @accelerate-llvm@ it is important that the @llvm-hs@ package is-    installed against the @libLLVM@ shared library, rather than statically-    linked, so that we can use LLVM from GHCi and Template Haskell. This is the-    default configuration, but you can also enforce this explicitly by adding-    the following to your @stack.yaml@ file:-    .-    > flags:-    >   llvm-hs:-    >     shared-llvm: true-    .-    Or by specifying the @shared-llvm@ flag to cabal:+    dependencies are also required:     .-    > cabal install llvm-hs -fshared-llvm+    * <https://clang.llvm.org/ clang> (not used to compile C code, but to compile generated LLVM IR via a mostly LLVM-version-independent interface)+    * <https://developer.nvidia.com/cuda-downloads CUDA>     .+    For installation instructions, see the <https://github.com/AccelerateHS/accelerate-llvm#readme README>. -license:                BSD3+license:                BSD-3-Clause license-file:           LICENSE author:                 Trevor L. McDonell-maintainer:             Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+maintainer:             Trevor L. McDonell <trevor.mcdonell@gmail.com> bug-reports:            https://github.com/AccelerateHS/accelerate/issues-category:               Compilers/Interpreters, Concurrency, Data, Parallelism+category:               Accelerate, Compilers/Interpreters, Concurrency, Data, Parallelism -extra-source-files:+extra-doc-files:     CHANGELOG.md     README.md  --- Configuration flags--- ---------------------Flag nvvm-  Default:              False-  Description:          Use the NVVM library to generate optimised PTX--Flag debug-  Default:              False-  Description:-    Enable debug tracing message flags. Note that 'debug' must be enabled in the-    base 'accelerate' package as well. See the 'accelerate' package for usage-    and available options.--Flag bounds-checks-  Default:              True-  Description:          Enable bounds checking--Flag unsafe-checks-  Default:              False-  Description:          Enable bounds checking in unsafe operations--Flag internal-checks-  Default:              False-  Description:          Enable internal consistency checks-- -- Build configuration -- ------------------- @@ -120,11 +51,15 @@     Data.Array.Accelerate.LLVM.PTX.Array.Table     Data.Array.Accelerate.LLVM.PTX.Context     Data.Array.Accelerate.LLVM.PTX.Debug+    Data.Array.Accelerate.LLVM.PTX.Pool     Data.Array.Accelerate.LLVM.PTX.State     Data.Array.Accelerate.LLVM.PTX.Target      Data.Array.Accelerate.LLVM.PTX.Execute     Data.Array.Accelerate.LLVM.PTX.Execute.Async+    Data.Array.Accelerate.LLVM.PTX.Execute.Environment+    Data.Array.Accelerate.LLVM.PTX.Execute.Event+    Data.Array.Accelerate.LLVM.PTX.Execute.Marshal     Data.Array.Accelerate.LLVM.PTX.Execute.Stream     Data.Array.Accelerate.LLVM.PTX.Execute.Stream.Reservoir @@ -137,14 +72,13 @@     Data.Array.Accelerate.LLVM.PTX.CodeGen.Loop     Data.Array.Accelerate.LLVM.PTX.CodeGen.Map     Data.Array.Accelerate.LLVM.PTX.CodeGen.Permute-    Data.Array.Accelerate.LLVM.PTX.CodeGen.Queue     Data.Array.Accelerate.LLVM.PTX.CodeGen.Scan+    Data.Array.Accelerate.LLVM.PTX.CodeGen.Stencil+    Data.Array.Accelerate.LLVM.PTX.CodeGen.Transform      Data.Array.Accelerate.LLVM.PTX.Compile     Data.Array.Accelerate.LLVM.PTX.Compile.Cache-    Data.Array.Accelerate.LLVM.PTX.Compile.Libdevice     Data.Array.Accelerate.LLVM.PTX.Compile.Libdevice.Load-    Data.Array.Accelerate.LLVM.PTX.Compile.Libdevice.TH      Data.Array.Accelerate.LLVM.PTX.Link     Data.Array.Accelerate.LLVM.PTX.Link.Cache@@ -152,67 +86,93 @@      Data.Array.Accelerate.LLVM.PTX.Embed -    Data.Array.Accelerate.LLVM.PTX.Execute.Environment-    Data.Array.Accelerate.LLVM.PTX.Execute.Event-    Data.Array.Accelerate.LLVM.PTX.Execute.Marshal+    System.Process.Extra+    GHC.Heap.NormalForm      Paths_accelerate_llvm_ptx +  autogen-modules:+    Paths_accelerate_llvm_ptx+   build-depends:-          base                          >= 4.7 && < 4.11-        , accelerate                    == 1.1.*-        , accelerate-llvm               == 1.1.*+          base                          >= 4.10 && < 5+        , accelerate                    == 1.4.*+        , accelerate-llvm               == 1.4.*         , bytestring                    >= 0.10.4-        , containers                    >= 0.5 && <0.6-        , cuda                          >= 0.9+        , containers                    >= 0.5 && < 0.9+        , cuda                          >= 0.10         , deepseq                       >= 1.3         , directory                     >= 1.0         , dlist                         >= 0.6-        , fclabels                      >= 2.0         , file-embed                    >= 0.0.8         , filepath                      >= 1.0+        , formatting                    >= 7.0         , hashable                      >= 1.2-        , llvm-hs                       >= 4.1 && < 5.2-        , llvm-hs-pure                  >= 4.1 && < 5.2+        -- , llvm-pretty                   >= 0.12         , mtl                           >= 2.2.1-        , nvvm                          >= 0.7.5-        , pretty                        >= 1.1+          -- only used to render llvm-pretty output+        , pretty+        , prettyprinter                 >= 1.7+        , primitive                     >= 0.7         , process                       >= 1.4.3         , template-haskell-        , time                          >= 1.4+        , text                          >= 1.2         , unordered-containers          >= 0.2 -  default-language:-    Haskell2010+  if impl(ghc >= 8.6)+    build-depends:+          ghc-heap+  else+    build-depends:+          ghc+        , ghci -  ghc-options:                  -O2 -Wall -fwarn-tabs+  hs-source-dirs:+        src -  if impl(ghc >= 8.0)-    ghc-options:                -Wmissed-specialisations+  default-language:+        Haskell2010 -  if flag(nvvm)-    cpp-options:                -DACCELERATE_USE_NVVM+  ghc-options:+        -O2+        -Wall+        -fwarn-tabs -  if flag(debug)-    cpp-options:                -DACCELERATE_DEBUG -  if flag(bounds-checks)-    cpp-options:                -DACCELERATE_BOUNDS_CHECKS+test-suite nofib-llvm-ptx+  type:                 exitcode-stdio-1.0+  hs-source-dirs:       test/nofib+  main-is:              Main.hs+  other-modules:+    Data.Array.Accelerate.LLVM.PTX.NoFib.RunQ -  if flag(unsafe-checks)-    cpp-options:                -DACCELERATE_UNSAFE_CHECKS+  build-depends:+          base                          >= 4.10+        , accelerate+        , accelerate-llvm-ptx+        , tasty+        , tasty-hunit -  if flag(internal-checks)-    cpp-options:                -DACCELERATE_INTERNAL_CHECKS+  default-language:+        Haskell2010 +  ghc-options:+        -Wall+        -O2+        -threaded+        -rtsopts+        -with-rtsopts=-A128M+        -with-rtsopts=-n4M+        -- -with-rtsopts=-N + source-repository head   type:                 git   location:             https://github.com/AccelerateHS/accelerate-llvm.git  source-repository this   type:                 git-  tag:                  1.1.0.1-ptx+  tag:                  v1.4.0.0   location:             https://github.com/AccelerateHS/accelerate-llvm.git  -- vim: nospell
+ src/Data/Array/Accelerate/LLVM/PTX.hs view
@@ -0,0 +1,561 @@+{-# LANGUAGE AllowAmbiguousTypes  #-}+{-# LANGUAGE BangPatterns         #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE GADTs                #-}+{-# LANGUAGE OverloadedStrings    #-}+{-# LANGUAGE RankNTypes           #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE TemplateHaskell      #-}+{-# LANGUAGE TypeApplications     #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE TypeOperators        #-}+{-# LANGUAGE TypeSynonymInstances #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.PTX+-- Copyright   : [2014..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--+-- This module implements a backend for the /Accelerate/ language targeting+-- NVPTX for execution on NVIDIA GPUs. Expressions are on-line translated into+-- LLVM code, which is just-in-time executed in parallel on the GPU.+--+-- * Concurrent kernel execution+--+-- Accelerate enables copies to and from device memory to occur concurrently+-- with kernel execution. However, in order for kernels to be executed+-- concurrently, you must create your own 'PTX' execution target and pass it to+-- the 'runWith'-style functions. For example:+--+-- > import Data.Array.Accelerate                    as A+-- > import qualified Data.Array.Accelerate.LLVM.PTX as PTX+-- > import qualified Foreign.CUDA.Driver            as C+-- >+-- > dotp :: Acc (Vector Float) -> Acc (Vector Float) -> Acc (Scalar Float)+-- > dotp xs ys = A.fold (+) 0 (A.zipWith (*) xs ys)+-- >+-- > runDotP = do+-- >     C.initialise []+-- >     -- Assuming just one CUDA device+-- >     dev0 <- C.device 0+-- >     dev0Props <- C.props dev0+-- >     ptx <- PTX.createTargetForDevice dev0 dev0Props []+-- >     -- Using runAsyncWith+-- >     let xs = fromList (Z:.10) [0..]   :: Vector Float+-- >         ys = fromList (Z:.10) [1,3..] :: Vector Float+-- >     asyncDotP <- PTX.runAsyncWith ptx (dotp (use+-- >     ...+-- >     dotP <- PTX.wait asyncDotP+--+-- The CUDA scheduler will only execute kernels concurrently if there are+-- sufficient resources available. Concurrency is limited by the number of+-- available threads, blocks, warps and registers; a kernel occupancy of \(n\)+-- does not always imply that \(1-n\) device resources are available.++module Data.Array.Accelerate.LLVM.PTX (++  Acc, Arrays,+  Afunction, AfunctionR,++  -- * Synchronous execution+  run, runWith,+  run1, run1With,+  runN, runNWith,+  stream, streamWith,++  -- * Asynchronous execution+  Async,+  wait, poll, cancel,++  runAsync, runAsyncWith,+  run1Async, run1AsyncWith,+  runNAsync, runNAsyncWith,++  -- * Ahead-of-time compilation+  runQ, runQWith,+  runQAsync, runQAsyncWith,++  -- * Execution targets+  PTX, createTargetForDevice, createTargetFromContext,++  -- * Controlling host-side allocation+  registerPinnedAllocatorWith,++) where++import Data.Array.Accelerate.AST                                    ( PreOpenAfun(..), arraysR, liftALeftHandSide )+import Data.Array.Accelerate.AST.LeftHandSide                       ( lhsToTupR )+import Data.Array.Accelerate.Array.Data+import Data.Array.Accelerate.Async                                  ( Async, asyncBound, wait, poll, cancel )+import Data.Array.Accelerate.Error+import Data.Array.Accelerate.Representation.Array                   ( liftArraysR )+import Data.Array.Accelerate.Smart                                  ( Acc )+import Data.Array.Accelerate.Sugar.Array                            ( Arrays, toArr, fromArr, ArraysR )+import Data.Array.Accelerate.Trafo+import Data.Array.Accelerate.Trafo.Delayed+import Data.Array.Accelerate.Trafo.Sharing                          ( Afunction(..), AfunctionRepr(..), afunctionRepr )+import qualified Data.Array.Accelerate.Sugar.Array                  as Sugar++import Data.Array.Accelerate.LLVM.PTX.Array.Data+import Data.Array.Accelerate.LLVM.PTX.Compile+import Data.Array.Accelerate.LLVM.PTX.Context+import Data.Array.Accelerate.LLVM.PTX.Debug+import Data.Array.Accelerate.LLVM.PTX.Embed+import Data.Array.Accelerate.LLVM.PTX.Execute+import Data.Array.Accelerate.LLVM.PTX.Execute.Async                 ( Par, evalPar, getArrays )+import Data.Array.Accelerate.LLVM.PTX.Execute.Environment+import Data.Array.Accelerate.LLVM.PTX.Link+import Data.Array.Accelerate.LLVM.PTX.State+import Data.Array.Accelerate.LLVM.PTX.Target++import Foreign.CUDA.Driver                                          as CUDA ( CUDAException, mallocHostForeignPtr )++import Control.Exception+import Control.Monad.Trans+import Data.Maybe+import Formatting                                                   ( shown )+import System.IO.Unsafe+import qualified Data.Array.Accelerate.TH.Compat                    as TH+++-- Accelerate: LLVM backend for NVIDIA GPUs+-- ----------------------------------------++-- | Compile and run a complete embedded array program.+--+-- This will execute using the first available CUDA device. If you wish to run+-- on a specific device, use 'runWith'.+--+-- The result is copied back to the host only once the arrays are demanded (or+-- the result is forced to normal form). For results consisting of multiple+-- components (a tuple of arrays or array of tuples) this applies per primitive+-- array. Evaluating the result of 'run' to WHNF will initiate the computation,+-- but does not copy the results back from the device.+--+-- /NOTE:/ it is recommended to use 'runN' or 'runQ' whenever possible.+--+run :: Arrays a => Acc a -> a+run a = unsafePerformIO (runIO a)++-- | As 'run', but execute using the specified target rather than using the+-- default, automatically selected device.+--+runWith :: Arrays a => PTX -> Acc a -> a+runWith target a = unsafePerformIO (runWithIO target a)++-- | As 'run', but run the computation asynchronously and return immediately+-- without waiting for the result. The status of the computation can be queried+-- using 'wait', 'poll', and 'cancel'.+--+-- This will run on the first available CUDA device. If you wish to run on+-- a specific device, use 'runAsyncWith'.+--+runAsync :: Arrays a => Acc a -> IO (Async a)+runAsync a = asyncBound (runIO a)++-- | As 'runWith', but execute asynchronously. Be sure not to destroy the context,+-- or attempt to attach it to a different host thread, before all outstanding+-- operations have completed.+--+runAsyncWith :: Arrays a => PTX -> Acc a -> IO (Async a)+runAsyncWith target a = asyncBound (runWithIO target a)+++runIO :: Arrays a => Acc a -> IO a+runIO a = withPool defaultTargetPool (\target -> runWithIO target a)++runWithIO :: forall a. Arrays a => PTX -> Acc a -> IO a+runWithIO target a = execute+  where+    !acc    = convertAcc a+    execute = do+      dumpGraph acc+      evalPTX target $ do+        build <- phase Compile (compileAcc acc) >>= dumpStats+        exec  <- phase Link    (linkAcc build)+        res   <- phase Execute (evalPar (executeAcc exec >>= copyToHostLazy (Sugar.arraysR @a)))+        return $ toArr res+++-- | This is 'runN', specialised to an array program of one argument.+--+run1 :: (Arrays a, Arrays b) => (Acc a -> Acc b) -> a -> b+run1 = runN++-- | As 'run1', but execute using the specified target rather than using the+-- default, automatically selected device.+--+run1With :: (Arrays a, Arrays b) => PTX -> (Acc a -> Acc b) -> a -> b+run1With = runNWith+++-- | Prepare and execute an embedded array program.+--+-- This function can be used to improve performance in cases where the array+-- program is constant between invocations, because it enables us to bypass+-- front-end conversion stages and move directly to the execution phase. If you+-- have a computation applied repeatedly to different input data, use this,+-- specifying any changing aspects of the computation via the input parameters.+-- If the function is only evaluated once, this is equivalent to 'run'.+--+-- In order to use 'runN' you must express your Accelerate program as a function+-- of array terms:+--+-- > f :: (Arrays a, Arrays b, ... Arrays c) => Acc a -> Acc b -> ... -> Acc c+--+-- This function then returns the compiled version of 'f':+--+-- > runN f :: (Arrays a, Arrays b, ... Arrays c) => a -> b -> ... -> c+--+-- At an example, rather than:+--+-- > step :: Acc (Vector a) -> Acc (Vector b)+-- > step = ...+-- >+-- > simulate :: Vector a -> Vector b+-- > simulate xs = run $ step (use xs)+--+-- Instead write:+--+-- > simulate = runN step+--+-- You can use the debugging options to check whether this is working+-- successfully. For example, running with the @-ddump-phases@ flag should show+-- that the compilation steps only happen once, not on the second and subsequent+-- invocations of 'simulate'. Note that this typically relies on GHC knowing+-- that it can lift out the function returned by 'runN' and reuse it.+--+-- As with 'run', the resulting array(s) are only copied back to the host once+-- they are actually demanded (forced to normal form). Thus, splitting a program+-- into multiple 'runN' steps does not imply transferring intermediate+-- computations back and forth between host and device. However note that+-- Accelerate is not able to optimise (fuse) across separate 'runN' invocations.+--+-- See the programs in the 'accelerate-examples' package for examples.+--+-- See also 'runQ', which compiles the Accelerate program at _Haskell_ compile+-- time, thus eliminating the runtime overhead altogether.+--+runN :: forall f. Afunction f => f -> AfunctionR f+runN f = exec+  where+    !acc  = convertAfun f+    !exec = unsafeWithPool defaultTargetPool+          $ \target -> fromJust (lookup (ptxContext target) afun)++    -- Lazily cache the compiled function linked for each execution context.+    -- This includes specialisation for different compute capabilities and+    -- device-side memory management.+    --+    -- Perhaps this implicit version of 'runN' is not a good idea then, because+    -- we might need to migrate data between devices between iterations+    -- depending on which GPU gets scheduled.+    --+    !afun = flip map (unmanaged defaultTargetPool)+          $ \target -> (ptxContext target, runNWith' @f target acc)+++-- | As 'runN', but execute using the specified target device.+--+runNWith :: forall f. Afunction f => PTX -> f -> AfunctionR f+runNWith target f = exec+  where+    !acc  = convertAfun f+    !exec = runNWith' @f target acc++runNWith' :: forall f. Afunction f => PTX -> DelayedAfun (ArraysFunctionR f) -> AfunctionR f+runNWith' target acc = go (afunctionRepr @f) afun (return Empty)+  where+    !afun = unsafePerformIO $ do+              dumpGraph acc+              evalPTX target $ do+                build <- phase Compile (compileAfun acc) >>= dumpStats+                link  <- phase Link    (linkAfun build)+                return link++    go :: forall aenv t r trepr.+          AfunctionRepr t r trepr+       -> ExecOpenAfun PTX aenv trepr+       -> Par PTX (Val aenv)+       -> r+    go (AfunctionReprLam repr) (Alam lhs l) k = \ !arrs ->+      let k' = do aenv <- k+                  a    <- useRemoteAsync (lhsToTupR lhs) $ fromArr arrs+                  return (aenv `push` (lhs, a))+      in go repr l k'+    go AfunctionReprBody (Abody b) k = unsafePerformIO . phase Execute . evalPTX target . evalPar $ do+      aenv <- k+      fut  <- executeOpenAcc b aenv+      toArr <$> copyToHostLazy (Sugar.arraysR @r) fut+    go _ _ _ = error "But that's not right, oh, no, what's the story?"+++-- | As 'run1', but the computation is executed asynchronously.+--+run1Async :: (Arrays a, Arrays b) => (Acc a -> Acc b) -> a -> IO (Async b)+run1Async = runNAsync++-- | As 'run1With', but execute asynchronously.+--+run1AsyncWith :: (Arrays a, Arrays b) => PTX -> (Acc a -> Acc b) -> a -> IO (Async b)+run1AsyncWith = runNAsyncWith+++-- | As 'runN', but execute asynchronously.+--+runNAsync :: (Afunction f, RunAsync r, ArraysFunctionR f ~ RunAsyncR r) => f -> r+runNAsync f = exec+  where+    !acc  = convertAfun f+    !exec = unsafeWithPool defaultTargetPool+          $ \target -> fromJust (lookup (ptxContext target) afun)++    !afun = flip map (unmanaged defaultTargetPool)+          $ \target -> (ptxContext target, runNAsyncWith' target acc)+++-- | As 'runNWith', but execute asynchronously.+--+runNAsyncWith :: (Afunction f, RunAsync r, ArraysFunctionR f ~ RunAsyncR r) => PTX -> f -> r+runNAsyncWith target f = exec+  where+    !acc  = convertAfun f+    !exec = runNAsyncWith' target acc++runNAsyncWith' :: RunAsync f => PTX -> DelayedAfun (RunAsyncR f) -> f+runNAsyncWith' target acc = exec+  where+    !afun = unsafePerformIO $ do+              dumpGraph acc+              evalPTX target $ do+                build <- phase Compile (compileAfun acc) >>= dumpStats+                link  <- phase Link    (linkAfun build)+                return link+    !exec = runAsync' target afun (return Empty)++class RunAsync f where+  type RunAsyncR f+  runAsync' :: PTX -> ExecOpenAfun PTX aenv (RunAsyncR f) -> Par PTX (Val aenv) -> f++instance (Arrays a, RunAsync b) => RunAsync (a -> b) where+  type RunAsyncR (a -> b) = ArraysR a -> RunAsyncR b+  runAsync' _      Abody{}  _ _     = error "runAsync: function oversaturated"+  runAsync' target (Alam lhs l) k !arrs =+    let k' = do aenv  <- k+                a     <- useRemoteAsync (Sugar.arraysR @a) $ fromArr arrs+                return (aenv `push` (lhs, a))+    in runAsync' target l k'++instance Arrays b => RunAsync (IO (Async b)) where+  type RunAsyncR (IO (Async b)) = ArraysR b+  runAsync' _      Alam{}    _ = error "runAsync: function not fully applied"+  runAsync' target (Abody b) k = asyncBound . phase Execute . evalPTX target . evalPar $ do+    aenv <- k+    ans  <- executeOpenAcc b aenv+    arrs <- getArrays (arraysR b) ans+    return $ toArr arrs+++-- | Stream a lazily read list of input arrays through the given program,+-- collecting results as we go.+--+stream :: (Arrays a, Arrays b) => (Acc a -> Acc b) -> [a] -> [b]+stream f arrs = map go arrs+  where+    !go = run1 f++-- | As 'stream', but execute using the specified target.+--+streamWith :: (Arrays a, Arrays b) => PTX -> (Acc a -> Acc b) -> [a] -> [b]+streamWith target f arrs = map go arrs+  where+    !go = run1With target f+++-- | Ahead-of-time compilation for an embedded array program.+--+-- This function will generate, compile, and link into the final executable,+-- code to execute the given Accelerate computation /at Haskell compile time/.+-- This eliminates any runtime overhead associated with the other @run*@+-- operations. The generated code will be compiled for the current (default) GPU+-- architecture.+--+-- Since the Accelerate program will be generated at Haskell compile time,+-- construction of the Accelerate program, in particular via meta-programming,+-- will be limited to operations available to that phase. Also note that any+-- arrays which are embedded into the program via 'Data.Array.Accelerate.use'+-- will be stored as part of the final executable.+--+-- Usage of this function in your program is similar to that of 'runN'. First,+-- express your Accelerate program as a function of array terms:+--+-- > f :: (Arrays a, Arrays b, ... Arrays c) => Acc a -> Acc b -> ... -> Acc c+--+-- This function then returns a compiled version of @f@ as a Template Haskell+-- splice, to be added into your program at Haskell compile time:+--+-- > {-# LANGUAGE TemplateHaskell #-}+-- >+-- > f' :: a -> b -> ... -> c+-- > f' = $( runQ f )+--+-- Note that at the splice point the usage of @f@ must monomorphic; i.e. the+-- types @a@, @b@ and @c@ must be at some known concrete type.+--+-- See the <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' [| asyncBound |]++-- | Ahead-of-time analogue of 'runNAsyncWith'. See 'runQWith' for more information.+--+-- The correct type of this function is:+--+-- > runQAsyncWith :: (Afunction f, RunAsync r, AfunctionR f ~ RunAsyncR r) => f -> Q (TExp (PTX -> r))+--+-- @since 1.1.0.0+--+runQAsyncWith :: Afunction f => f -> TH.ExpQ+runQAsyncWith f = do+  target <- TH.newName "target"+  TH.lamE [TH.varP target] (runQWith' [| asyncBound |] (TH.varE target) f)+++runQ' :: Afunction f => TH.ExpQ -> f -> TH.ExpQ+runQ' using = runQ'_ using (\go -> [| withPool defaultTargetPool (\target -> evalPTX target (evalPar $go)) |])++runQWith' :: Afunction f => TH.ExpQ -> TH.ExpQ -> f -> TH.ExpQ+runQWith' using target = runQ'_ using (\go -> [| evalPTX $target (evalPar $go) |])++-- Generate a template haskell expression for the given function to be embedded+-- into the current program. The supplied continuation specifies how to execute+-- the given body expression (e.g. using 'evalPTX')+--+-- NOTE:+--+--  * Can we do this without requiring an active GPU context? This should be+--    possible with only the DeviceProperties, but we would have to be a little+--    careful if we pass invalid values for the other state components. If we+--    attempt this, at minimum we need to parse the generated .sass to extract+--    resource usage information, rather than loading the module and probing+--    directly.+--+--  * What happens if we execute this code on a different architecture revision?+--    With runN this will automatically be recompiled for each new architecture+--    (at runtime).+--+runQ'_ :: Afunction f => TH.ExpQ -> (TH.ExpQ -> TH.ExpQ) -> f -> TH.ExpQ+runQ'_ using k f = do+  afun  <- let acc = convertAfun f+           in  TH.runIO $ do+                 dumpGraph acc+                 evalPTX defaultTarget $+                   phase Compile (compileAfun acc) >>= dumpStats+  let+      go :: CompiledOpenAfun PTX aenv t -> [TH.PatQ] -> [TH.ExpQ] -> [TH.StmtQ] -> TH.ExpQ+      go (Alam lhs l) xs as stmts = do+        x <- TH.newName "x" -- lambda bound variable+        a <- TH.newName "a" -- local array name+        s <- TH.bindS (TH.varP a) [| useRemoteAsync $(TH.unTypeCode $ liftArraysR (lhsToTupR lhs)) (fromArr $(TH.varE x)) |]+        go l (TH.bangP (TH.varP x) : xs) ([| ($(TH.unTypeCode $ liftALeftHandSide lhs), $(TH.varE a)) |] : as) (return s : stmts)++      go (Abody b) xs as stmts = do+        r <- TH.newName "r" -- result+        s <- TH.newName "s"+        let+            aenv  = foldr (\a gamma -> [| $gamma `push` $a |] ) [| Empty |] as+            body  = embedOpenAcc defaultTarget b+        --+        TH.lamE (reverse xs)+                [| $using (phase Execute $(k (+                     TH.doE ( reverse stmts +++                            [ TH.bindS (TH.varP r) [| executeOpenAcc $(TH.unTypeCode body) $aenv |]+                            , TH.bindS (TH.varP s) [| copyToHostLazy $(TH.unTypeCode (liftArraysR (arraysR b))) $(TH.varE r) |]+                            , TH.noBindS [| return $ toArr $(TH.varE s) |]+                            ]))))+                 |]+  --+  go afun [] [] []+++-- Controlling host-side allocation+-- --------------------------------++-- | Configure the default execution target to allocate all future host-side+-- arrays using (CUDA) pinned memory. Any newly allocated arrays will be+-- page-locked and directly accessible from the device, enabling high-speed+-- (asynchronous) DMA.+--+-- Note that since the amount of available pageable memory will be reduced,+-- overall system performance can suffer.+--+-- registerPinnedAllocator :: IO ()+-- registerPinnedAllocator = registerPinnedAllocatorWith defaultTarget+++-- | All future array allocations will use pinned memory associated with the+-- given execution context. These arrays will be directly accessible from the+-- device, enabling high-speed asynchronous DMA.+--+-- Note that since the amount of available pageable memory will be reduced,+-- overall system performance can suffer.+--+registerPinnedAllocatorWith :: HasCallStack => PTX -> IO ()+registerPinnedAllocatorWith target =+  registerForeignPtrAllocator $ \bytes ->+    withContext (ptxContext target) (CUDA.mallocHostForeignPtr [] bytes)+    `catch`+    \e -> internalError shown (e :: CUDAException)+++-- Debugging+-- =========++dumpStats :: MonadIO m => a -> m a+dumpStats x = liftIO dumpSimplStats >> return x+
+ src/Data/Array/Accelerate/LLVM/PTX/Analysis/Device.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE ScopedTypeVariables #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.PTX.Analysis.Device+-- Copyright   : [2008..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- 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,74 @@+{-# LANGUAGE QuasiQuotes     #-}+{-# LANGUAGE TemplateHaskell #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.PTX.Analysis.Launch+-- Copyright   : [2008..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.PTX.Analysis.Launch (++  DeviceProperties, Occupancy, LaunchConfig,+  simpleLaunchConfig, launchConfig,+  multipleOf, multipleOfQ,++) where++import Foreign.CUDA.Analysis                            as CUDA+import Data.Array.Accelerate.TH.Compat+++-- | Given information about the resource usage of the compiled kernel,+-- determine the optimum launch parameters.+--+type LaunchConfig+  =  Int                            -- maximum #threads per block+  -> Int                            -- #registers per thread+  -> Int                            -- #bytes of static shared memory+  -> ( Occupancy+     , Int                          -- thread block size+     , Int -> Int                   -- grid size required to process the given input size+     , Int                          -- #bytes dynamic shared memory+     , CodeQ (Int -> Int)+     )++-- | Analytics for a simple kernel which requires no additional shared memory or+-- have other constraints on launch configuration. The smallest thread block+-- size, in increments of a single warp, with the highest occupancy is used.+--+simpleLaunchConfig :: DeviceProperties -> LaunchConfig+simpleLaunchConfig dev = launchConfig dev (decWarp dev) (const 0) multipleOf multipleOfQ+++-- | Determine the optimal kernel launch configuration for a kernel.+--+launchConfig+    :: DeviceProperties             -- ^ Device architecture to optimise for+    -> [Int]                        -- ^ Thread block sizes to consider+    -> (Int -> Int)                 -- ^ Shared memory (#bytes) as a function of thread block size+    -> (Int -> Int -> Int)          -- ^ Determine grid size for input size 'n' (first arg) over thread blocks of size 'm' (second arg)+    -> CodeQ (Int -> Int -> Int)+    -> LaunchConfig+launchConfig dev candidates dynamic_smem grid_size grid_sizeQ maxThreads registers static_smem =+  let+      (cta, occ)  = optimalBlockSizeOf dev (filter (<= maxThreads) candidates) (const registers) smem+      maxGrid     = multiProcessorCount dev * activeThreadBlocks occ+      grid n      = maxGrid `min` grid_size n cta+      smem n      = static_smem + dynamic_smem n+      gridQ       = [|| \n -> (maxGrid::Int) `min` $$grid_sizeQ (n::Int) (cta::Int) ||]+  in+  ( occ, cta, grid, dynamic_smem cta, gridQ )+++-- | The next highest multiple of 'y' from 'x'.+--+multipleOf :: Int -> Int -> Int+multipleOf x y = ((x + y - 1) `quot` y)++multipleOfQ :: CodeQ (Int -> Int -> Int)+multipleOfQ = [|| multipleOf ||]+
+ src/Data/Array/Accelerate/LLVM/PTX/Array/Data.hs view
@@ -0,0 +1,205 @@+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE MagicHash           #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell     #-}+{-# LANGUAGE UnboxedTuples       #-}+{-# OPTIONS_GHC -Wno-orphans #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.PTX.Array.Data+-- Copyright   : [2014..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.PTX.Array.Data (++  module Data.Array.Accelerate.LLVM.Array.Data,+  module Data.Array.Accelerate.LLVM.PTX.Array.Data,++) where++import Data.Array.Accelerate.Array.Data+import Data.Array.Accelerate.Array.Unique+import Data.Array.Accelerate.Error+import Data.Array.Accelerate.Lifetime+import Data.Array.Accelerate.Representation.Array+import Data.Array.Accelerate.Representation.Shape+import Data.Array.Accelerate.Representation.Type+import Data.Array.Accelerate.Type++import Data.Array.Accelerate.LLVM.Array.Data+import Data.Array.Accelerate.LLVM.State++import Data.Array.Accelerate.LLVM.PTX.State+import Data.Array.Accelerate.LLVM.PTX.Target+import Data.Array.Accelerate.LLVM.PTX.Execute.Async+import qualified Data.Array.Accelerate.LLVM.PTX.Array.Prim          as Prim++import Control.Applicative+import Control.Monad+import Control.Monad.IO.Class                                       ( liftIO )+import Control.Monad.Reader                                         ( asks )+import System.IO.Unsafe+import Prelude++import GHC.Heap.NormalForm+++-- | Remote memory management for the PTX target. Data can be copied+-- asynchronously using multiple execution engines whenever possible.+--+instance Remote PTX where+  {-# INLINEABLE allocateRemote   #-}+  {-# INLINEABLE indexRemoteAsync #-}+  {-# INLINEABLE useRemoteR       #-}+  {-# INLINEABLE copyToHostR      #-}+  {-# INLINEABLE copyToRemoteR    #-}+  allocateRemote repr@(ArrayR shr tp) !sh = do+    let !n = size shr sh+    arr    <- liftIO $ allocateArray repr sh  -- shadow array on the host+    liftPar $ runArray tp arr (\m t ad -> Prim.mallocArray t (n*m) ad >> return ad)++  indexRemoteAsync  = runIndexArrayAsync Prim.indexArrayAsync+  useRemoteR        = Prim.useArrayAsync+  copyToHostR       = Prim.peekArrayAsync+  copyToRemoteR     = Prim.pokeArrayAsync+  copyToPeerR       = internalError "not supported yet"+++-- | Copy an array from the remote device to the host. Although the Accelerate+-- program is hyper-strict and will evaluate the computation as soon as any part+-- of it is demanded, the individual array payloads are copied back to the host+-- _only_ as they are demanded by the Haskell program. This has several+-- consequences:+--+--   1. If the device has multiple memcpy engines, only one will be used. The+--      transfers are however associated with a non-default stream.+--+--   2. Using 'seq' to force an Array to head-normal form will initiate the+--      computation, but not transfer the results back to the host. Requesting+--      an array element or using 'deepseq' to force to normal form is required+--      to actually transfer the data.+--+{-# INLINEABLE copyToHostLazy #-}+copyToHostLazy+    :: HasCallStack+    => ArraysR arrs+    -> FutureArraysR PTX arrs+    -> Par PTX arrs+copyToHostLazy TupRunit         ()       = return ()+copyToHostLazy (TupRpair r1 r2) (f1, f2) = do+  a1 <- copyToHostLazy r1 f1+  a2 <- copyToHostLazy r2 f2+  return (a1, a2)+copyToHostLazy (TupRsingle (ArrayR shr tp)) future = do+  ptx <- asks llvmTarget+  liftIO $ do+    Array sh adata <- wait future++    -- Note: [Lazy device-host transfers]+    --+    -- This needs must be non-strict at the leaves of the datatype (that+    -- is, the UniqueArray pointers). This means we can traverse the+    -- ArrayData constructors (in particular, the spine defined by Unit+    -- and Pair) until we reach the array we care about, without forcing+    -- the other fields.+    --+    -- https://github.com/AccelerateHS/accelerate/issues/437+    --+    -- Furthermore, we only want to transfer the data if the host pointer+    -- is currently unevaluated. This situation can occur for example if+    -- the argument to 'use' or 'unit' is returned as part of the result+    -- of a 'run'. Peek at GHC's underlying closure representation and+    -- check whether the pointer is a thunk, and only initiate the+    -- transfer if so.+    --+    let+      peekR :: SingleType e+            -> ArrayData e+            -> Int+            -> IO (ArrayData e)+      peekR t ad m+        | SingleArrayDict                        <- singleArrayDict t+        , UniqueArray uid (Lifetime lft weak fp) <- ad+        = unsafeInterleaveIO $ do+          yes <- isNormalForm fp+          fp' <- if yes+                    then return fp+                    else unsafeInterleaveIO . evalPTX ptx . evalPar $ do+                          !_ <- block =<< Prim.peekArrayAsync t m ad+                          return fp+          --+          return $ UniqueArray uid (Lifetime lft weak fp')++      n = size shr sh++      runR :: TypeR e -> ArrayData e -> IO (ArrayData e)+      runR TupRunit           !()          = return ()+      runR (TupRpair !t1 !t2) (!ad1, !ad2) = (,) <$> runR t1 ad1 <*> runR t2 ad2+      runR (TupRsingle !t)    !ad          =+        case t of+          SingleScalarType s                       -> peekR s ad n+          VectorScalarType (VectorType w s)+            | SingleArrayDict <- singleArrayDict s -> peekR s ad (n * w)++    Array sh <$> runR tp adata++-- | Clone an array into a newly allocated array on the device.+--+cloneArrayAsync+    :: ArrayR (Array sh e)+    -> Array sh e+    -> Par PTX (Future (Array sh e))+cloneArrayAsync repr@(ArrayR shr tp) arr@(Array _ src) = do+  Array _ dst <- allocateRemote repr sh+  Array sh `liftF` copyR tp src dst+  where+    sh = shape arr+    n  = size shr sh++    copyR :: TypeR s -> ArrayData s -> ArrayData s -> Par PTX (Future (ArrayData s))+    copyR TupRunit           !_          !_            = newFull ()+    copyR (TupRpair !t1 !t2) !(ad1, ad2) !(ad1', ad2') = liftF2 (,) (copyR t1 ad1 ad1') (copyR t2 ad2 ad2')+    copyR (TupRsingle !t)    !ad         !ad'          =+      case t of+        SingleScalarType s                       -> copyPrim s ad ad' n+        VectorScalarType (VectorType w s)+          | SingleArrayDict <- singleArrayDict s -> copyPrim s ad ad' (n * w)++    copyPrim+        :: SingleType s+        -> ArrayData s+        -> ArrayData s+        -> Int+        -> Par PTX (Future (ArrayData s))+    copyPrim !s !a1 !a2 !m = Prim.copyArrayAsync s m a1 a2++    liftF :: Async arch+          => (a -> b)+          -> Par arch (FutureR arch a)+          -> Par arch (FutureR arch b)+    liftF f x = do+      r  <- new+      x' <- x+      put r . f =<< get x'  -- don't create a new execution stream for this+      return r++    liftF2 :: Async arch+           => (a -> b -> c)+           -> Par arch (FutureR arch a)+           -> Par arch (FutureR arch b)+           -> Par arch (FutureR arch c)+    liftF2 f x y = do+      r  <- new+      x' <- spawn x+      y' <- spawn y+      fork $ put r =<< liftM2 f (get x') (get y')+      return r+
+ src/Data/Array/Accelerate/LLVM/PTX/Array/Prim.hs view
@@ -0,0 +1,391 @@+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE MagicHash           #-}+{-# LANGUAGE MagicHash           #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeOperators       #-}+{-# LANGUAGE UnboxedTuples       #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.PTX.Array.Prim+-- Copyright   : [2014..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.PTX.Array.Prim (++  mallocArray,+  useArrayAsync,+  indexArrayAsync,+  peekArrayAsync,+  pokeArrayAsync,+  copyArrayAsync,+  -- copyArrayPeerAsync,+  memsetArrayAsync,+  withDevicePtr,++) where++import Data.Array.Accelerate.Array.Data+import Data.Array.Accelerate.Array.Unique+import Data.Array.Accelerate.Error+import Data.Array.Accelerate.Lifetime                               hiding ( withLifetime )+import Data.Array.Accelerate.Representation.Elt+import Data.Array.Accelerate.Representation.Type+import Data.Array.Accelerate.Type++import Data.Array.Accelerate.LLVM.State++import Data.Array.Accelerate.LLVM.PTX.Target+import Data.Array.Accelerate.LLVM.PTX.Execute.Async+import Data.Array.Accelerate.LLVM.PTX.Execute.Event+import Data.Array.Accelerate.LLVM.PTX.Execute.Stream+import Data.Array.Accelerate.LLVM.PTX.Array.Remote                  as Remote+import qualified Data.Array.Accelerate.LLVM.PTX.Debug               as Debug++import qualified Foreign.CUDA.Driver                                as CUDA+import qualified Foreign.CUDA.Driver.Stream                         as CUDA++import Control.Monad+import Control.Monad.Reader+import Data.IORef+import Data.Text.Lazy.Builder+import Formatting                                                   hiding ( bytes )+import qualified Formatting                                         as F+import Prelude++import GHC.Base                                                     ( IO(..), Int(..), Double(..), touch#, int2Double# )+++-- | Allocate a device-side array associated with the given host array. If the+-- allocation fails due to a memory error, we attempt some last-ditch memory+-- cleanup before trying again. If it still fails; error.+--+{-# INLINEABLE mallocArray #-}+mallocArray+    :: HasCallStack+    => SingleType e+    -> Int+    -> ArrayData e+    -> LLVM PTX ()+mallocArray !t !n !ad = do+  message ("mallocArray: " % formatBytes) (n * bytesElt (TupRsingle (SingleScalarType t)))+  void $ Remote.malloc t ad n False+++-- | A combination of 'mallocArray' and 'pokeArray', that allocates remotes+-- memory and uploads an existing array. This is specialised because we tell the+-- allocator that the host-side array is frozen, and thus it is safe to evict+-- the remote memory and re-upload the data at any time.+--+{-# INLINEABLE useArrayAsync #-}+useArrayAsync+    :: HasCallStack+    => SingleType e+    -> Int+    -> ArrayData e+    -> Par PTX (Future (ArrayData e))+useArrayAsync !t !n !ad = do+  message ("useArrayAsync: " % formatBytes) (n * bytesElt (TupRsingle (SingleScalarType t)))+  alloc <- liftPar $ Remote.malloc t ad n True+  if alloc+    then pokeArrayAsync t n ad+    else newFull ad+++-- | Copy data from the host to an existing array on the device+--+{-# INLINEABLE pokeArrayAsync #-}+pokeArrayAsync+    :: HasCallStack+    => SingleType e+    -> Int+    -> ArrayData e+    -> Par PTX (Future (ArrayData e))+pokeArrayAsync !t !n !ad+  | SingleArrayDict <- singleArrayDict t+  , SingleDict      <- singleDict t+  = do+    let !src   = CUDA.HostPtr (unsafeUniqueArrayPtr ad)+        !bytes = n * bytesElt (TupRsingle (SingleScalarType t))+    --+    stream <- asksParState ptxStream+    result <- liftPar $+      withLifetime stream $ \st  ->+        withDevicePtr t ad $ \dst ->+          nonblocking stream $ do+            transfer "pokeArray" bytes (Just st) $ do+              CUDA.pokeArrayAsync n src dst (Just st)+              Debug.memcpy_to_remote bytes+            return ad+    --+    return result+++-- | Read an element from an array at the given row-major index.+--+-- This copies the data via a temporary array on the host, so that packed AoS+-- elements can be copied in a single transfer.+--+{-# INLINEABLE indexArrayAsync #-}+indexArrayAsync+    :: HasCallStack+    => Int              -- actual number of values per element (i.e. this is >1 for SIMD types)+    -> SingleType e+    -> ArrayData e+    -> Int              -- element index+    -> Par PTX (Future (ArrayData e))+indexArrayAsync !n !t !ad_src !i+  | SingleArrayDict <- singleArrayDict t+  , SingleDict      <- singleDict t+  = do+    ad_dst <- liftIO $ newArrayData (TupRsingle $ SingleScalarType t) n+    let !bytes = n * bytesElt (TupRsingle (SingleScalarType t))+        !dst   = CUDA.HostPtr (unsafeUniqueArrayPtr ad_dst)+    --+    stream <- asksParState ptxStream+    result <- liftPar $+      withLifetime stream  $ \st  ->+      withDevicePtr t ad_src $ \src ->+        nonblocking stream $ do+          transfer "indexArray" bytes (Just st) $ do+            CUDA.peekArrayAsync n (src `CUDA.advanceDevPtr` (i*n)) dst (Just st)+            Debug.memcpy_from_remote bytes+          return ad_dst+    --+    return result+++-- | Copy data from the device into the associated host-side Accelerate array+--+{-# INLINEABLE peekArrayAsync #-}+peekArrayAsync+    :: HasCallStack+    => SingleType e+    -> Int+    -> ArrayData e+    -> Par PTX (Future (ArrayData e))+peekArrayAsync !t !n !ad+  | SingleArrayDict <- singleArrayDict t+  , SingleDict      <- singleDict t+  = do+    let !bytes = n * bytesElt (TupRsingle (SingleScalarType t))+        !dst   = CUDA.HostPtr (unsafeUniqueArrayPtr ad)+    --+    stream <- asksParState ptxStream+    result <- liftPar $+      withLifetime stream $ \st  ->+        withDevicePtr t ad  $ \src ->+          nonblocking stream $ do+            transfer "peekArray" bytes (Just st) $ do+              CUDA.peekArrayAsync n src dst (Just st)+              Debug.memcpy_from_remote bytes+            return ad+    --+    return result+++-- | Copy data between arrays in the same context+--+{-# INLINEABLE copyArrayAsync #-}+copyArrayAsync+    :: HasCallStack+    => SingleType e+    -> Int+    -> ArrayData e+    -> ArrayData e+    -> Par PTX (Future (ArrayData e))+copyArrayAsync !t !n !ad_src !ad_dst+  | SingleArrayDict <- singleArrayDict t+  , SingleDict      <- singleDict t+  = do+    let !bytes = n * bytesElt (TupRsingle (SingleScalarType t))+    --+    stream <- asksParState ptxStream+    result <- liftPar $+      withLifetime stream        $ \st ->+        withDevicePtr t ad_src   $ \src ->+          withDevicePtr t ad_dst $ \dst -> do+            (e,r) <- nonblocking stream $ do+                      transfer "copyArray" bytes (Just st) $ CUDA.copyArrayAsync n src dst (Just st)+                      return ad_dst+            return (e, (e,r))+    --+    return result+++{--+-- | Copy data from one device context into a _new_ array on the second context.+-- It is an error if the destination array already exists.+--+{-# INLINEABLE copyArrayPeerAsync #-}+copyArrayPeerAsync+    :: SingleType e+    -> Context                            -- destination context+    -> MemoryTable                        -- destination memory table+    -> Stream+    -> Int+    -> ArrayData e+    -> LLVM PTX ()+copyArrayPeerAsync = error "copyArrayPeerAsync"+{--+copyArrayPeerAsync !t !ctx2 !mt2 !st !n !ad = do+  let !bytes    = n * sizeOfSingleType t+  src   <- devicePtr mt1 ad+  dst   <- mallocArray ctx2 mt2 n ad+  transfer "copyArrayPeer" bytes (Just st) $+    CUDA.copyArrayPeerAsync n src (deviceContext ctx1) dst (deviceContext ctx2) (Just st)+--}++-- | Copy part of an array from one device context to another. Both source and+-- destination arrays must exist.+--+{-# INLINEABLE copyArrayPeerAsyncR #-}+copyArrayPeerAsync+    :: SingleType e+    -> Context                            -- destination context+    -> MemoryTable                        -- destination memory table+    -> Stream+    -> Int+    -> Int+    -> ArrayData e+    -> LLVM PTX ()+copyArrayPeerAsync = error "copyArrayPeerAsyncR"+{--+copyArrayPeerAsyncR !t !ctx2 !mt2 !st !from !n !ad = do+  let !bytes    = n    * sizeOfSingleType t+      !offset   = from * sizeOfSingleType t+  src <- devicePtr mt1 ad       :: IO (CUDA.DevicePtr a)+  dst <- devicePtr mt2 ad       :: IO (CUDA.DevicePtr a)+  transfer "copyArrayPeer" bytes (Just st) $+    CUDA.copyArrayPeerAsync n (src `CUDA.plusDevPtr` offset) (deviceContext ctx1)+                              (dst `CUDA.plusDevPtr` offset) (deviceContext ctx2) (Just st)+--}+--}++-- | Set elements of the array to the specified value. Only 8-, 16-, and 32-bit+-- values are supported.+--+{-# INLINEABLE memsetArrayAsync #-}+memsetArrayAsync+    :: HasCallStack+    => SingleType e+    -> Int+    -> ScalarArrayDataR e+    -> ArrayData e+    -> Par PTX (Future (ArrayData e))+memsetArrayAsync !t !n !v !ad+  | SingleArrayDict <- singleArrayDict t+  , SingleDict      <- singleDict t+  = do+    let !bytes = n * bytesElt (TupRsingle (SingleScalarType t))+    --+    stream <- asksParState ptxStream+    result <- liftPar $+      withLifetime stream $ \st  ->+        withDevicePtr t ad  $ \ptr ->+          nonblocking stream $ do+            transfer "memset" bytes (Just st) $ CUDA.memsetAsync ptr n v (Just st)+            return ad+    --+    return result+++-- Auxiliary+-- ---------++-- | Lookup the device memory associated with a given host array and do+-- something with it.+--+{-# INLINEABLE withDevicePtr #-}+withDevicePtr+    :: HasCallStack+    => SingleType e+    -> ArrayData e+    -> (CUDA.DevicePtr (ScalarArrayDataR e) -> LLVM PTX (Maybe Event, r))+    -> LLVM PTX r+withDevicePtr !t !ad !f = do+  mr <- withRemote t ad f+  case mr of+    Nothing -> internalError "array does not exist on the device"+    Just r  -> return r++{--+-- | Lookup the device memory associated with a given host array+--+{-# INLINEABLE devicePtr #-}+devicePtr+    :: (ArrayElt e, ArrayPtrs e ~ Ptr a, Typeable a, Typeable b)+    => ArrayData e+    -> LLVM PTX (CUDA.DevicePtr b)+devicePtr !ad = do+  undefined+  {--+  mv <- Table.lookup mt ad+  case mv of+    Just v      -> return v+    Nothing     -> $internalError "devicePtr" "lost device memory"+  --}+--}++-- | Execute a (presumable asynchronous) operation and return the result+-- together with an event recorded immediately afterwards in the given stream.+--+{-# INLINE nonblocking #-}+nonblocking :: Stream -> LLVM PTX a -> LLVM PTX (Maybe Event, Future a)+nonblocking !stream !action = do+  result <- action+  event  <- waypoint stream+  ready  <- liftIO (query event)+  if ready+    then do+      future <- Future <$> liftIO (newIORef (Full result))+      return (Nothing, future)++    else do+      future <- Future <$> liftIO (newIORef (Pending event (return ()) result))+      return (Just event, future)++{-# INLINE withLifetime #-}+withLifetime :: MonadIO m => Lifetime a -> (a -> m b) -> m b+withLifetime (Lifetime ref _ a) f = do+  r <- f a+  liftIO (touchIORef ref)+  return r++{-# INLINE touchIORef #-}+touchIORef :: IORef a -> IO ()+touchIORef r = IO $ \s -> case touch# r s of s' -> (# s', () #)+++-- Debug+-- -----++{-# INLINE double #-}+double :: Int -> Double+double (I# i#) = D# (int2Double# i#)++{-# INLINE formatBytes #-}+formatBytes :: Format r (Int -> r)+formatBytes = F.bytes @Double shortest++{-# INLINE message #-}+message :: MonadIO m => Format (m ()) a -> a+message fmt = Debug.traceM Debug.dump_gc ("gc: " % fmt)++{-# INLINE transfer #-}+transfer :: MonadIO m => Builder -> Int -> Maybe CUDA.Stream -> IO () -> m ()+transfer name bytes stream action =+  let fmt wall cpu gpu =+        message (builder % ": " % F.bytes @Double shortest % " @ " % Debug.formatSIBase (Just 3) 1024 % "B/s, " % Debug.elapsed)+          name bytes (double bytes / wall) wall cpu gpu+  in+  liftIO (Debug.timed Debug.dump_gc fmt stream action)+
+ src/Data/Array/Accelerate/LLVM/PTX/Array/Remote.hs view
@@ -0,0 +1,167 @@+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE MagicHash           #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeFamilies        #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.PTX.Array.Remote+-- Copyright   : [2014..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.PTX.Array.Remote (++  withRemote, malloc,++) where++import Data.Array.Accelerate.LLVM.State+import Data.Array.Accelerate.LLVM.PTX.Target+import {-# SOURCE #-} Data.Array.Accelerate.LLVM.PTX.Execute.Event+import {-# SOURCE #-} Data.Array.Accelerate.LLVM.PTX.Execute.Stream++import Data.Array.Accelerate.Array.Data+import Data.Array.Accelerate.Array.Unique+import Data.Array.Accelerate.Lifetime+import Data.Array.Accelerate.Representation.Elt+import Data.Array.Accelerate.Representation.Type+import Data.Array.Accelerate.Type+import qualified Data.Array.Accelerate.Array.Remote                 as Remote+import qualified Data.Array.Accelerate.LLVM.PTX.Debug               as Debug++import Foreign.CUDA.Driver.Error+import qualified Foreign.CUDA.Ptr                                   as CUDA+import qualified Foreign.CUDA.Driver                                as CUDA+import qualified Foreign.CUDA.Driver.Stream                         as CUDA++import Control.Exception+import Control.Monad.Reader+import Data.Text.Lazy.Builder+import Formatting                                                   hiding ( bytes )+import qualified Formatting                                         as F++import GHC.Base                                                     ( Int(..), Double(..), int2Double# )+++-- Events signal once a computation has completed+--+instance Remote.Task (Maybe Event) where+  completed Nothing  = return True+  completed (Just e) = query e++instance Remote.RemoteMemory (LLVM PTX) where+  type RemotePtr (LLVM PTX) = CUDA.DevicePtr+  --+  mallocRemote n+    | n <= 0    = return (Just CUDA.nullDevPtr)+    | otherwise = do+        name <- asks ptxDeviceName+        liftIO $ do+          ep <- try (CUDA.mallocArray n)+          case ep of+            Right p                     -> do Debug.remote_memory_alloc name (CUDA.useDevicePtr p) n+                                              return (Just p)+            Left (ExitCode OutOfMemory) -> do return Nothing+            Left e                      -> do message ("malloc failed with error: " % shown) e+                                              throwIO e++  peekRemote t n src ad+    | SingleArrayDict <- singleArrayDict t+    , SingleDict      <- singleDict t+    = let bytes = n * bytesElt (TupRsingle (SingleScalarType t))+          dst   = CUDA.HostPtr (unsafeUniqueArrayPtr ad)+      in+      blocking            $ \stream ->+      withLifetime stream $ \st     -> do+        Debug.memcpy_from_remote bytes+        transfer "peekRemote" bytes (Just st) $ CUDA.peekArrayAsync n src dst (Just st)++  pokeRemote t n dst ad+    | SingleArrayDict <- singleArrayDict t+    , SingleDict      <- singleDict t+    = let bytes = n * bytesElt (TupRsingle (SingleScalarType t))+          src   = CUDA.HostPtr (unsafeUniqueArrayPtr ad)+      in+      blocking            $ \stream ->+      withLifetime stream $ \st     -> do+        Debug.memcpy_to_remote bytes+        transfer "pokeRemote" bytes (Just st) $ CUDA.pokeArrayAsync n src dst (Just st)++  castRemotePtr        = CUDA.castDevPtr+  availableRemoteMem   = liftIO $ fst `fmap` CUDA.getMemInfo+  totalRemoteMem       = liftIO $ snd `fmap` CUDA.getMemInfo+  remoteAllocationSize = return 4096++++-- | Allocate an array in the remote memory space sufficient to hold the given+-- number of elements, and associated with the given host side array. Space will+-- be freed from the remote device if necessary.+--+{-# INLINEABLE malloc #-}+malloc+    :: SingleType e+    -> ArrayData e+    -> Int+    -> Bool+    -> LLVM PTX Bool+malloc !tp !ad !n !frozen = do+  PTX{..} <- asks llvmTarget+  Remote.malloc ptxMemoryTable tp ad frozen n+++-- | Lookup up the remote array pointer for the given host-side array+--+{-# INLINEABLE withRemote #-}+withRemote+    :: SingleType e+    -> ArrayData e+    -> (CUDA.DevicePtr (ScalarArrayDataR e) -> LLVM PTX (Maybe Event, r))+    -> LLVM PTX (Maybe r)+withRemote !tp !ad !f = do+  PTX{..} <- asks llvmTarget+  Remote.withRemote ptxMemoryTable tp ad f+++-- Auxiliary+-- ---------++-- | Execute the given operation in a new stream, and wait for the operation to+-- complete before returning.+--+{-# INLINE blocking #-}+blocking :: (Stream -> IO a) -> LLVM PTX a+blocking !fun =+  streaming (liftIO . fun) $ \e r -> do+    liftIO $ block e+    return r++{-# INLINE double #-}+double :: Int -> Double+double (I# i#) = D# (int2Double# i#)+++-- Debugging+-- ---------++{-# INLINE message #-}+message :: Format (IO ()) a -> a+message fmt = Debug.traceM Debug.dump_gc ("gc: " % fmt)++{-# INLINE transfer #-}+transfer :: Builder -> Int -> Maybe CUDA.Stream -> IO () -> IO ()+transfer name bytes stream action =+  let fmt wall cpu gpu =+        message (builder % ": " % F.bytes @Double shortest % " @ " % Debug.formatSIBase (Just 3) 1024 % "B/s, " % Debug.elapsed)+          name bytes (double bytes / wall) wall cpu gpu+  in+  Debug.timed Debug.dump_gc fmt stream action+
+ src/Data/Array/Accelerate/LLVM/PTX/Array/Table.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE BangPatterns      #-}+{-# LANGUAGE OverloadedStrings #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.PTX.Array.Table+-- Copyright   : [2014..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.PTX.Array.Table (++  MemoryTable,+  new,++) where++import Data.Array.Accelerate.LLVM.PTX.Context                       ( Context, withContext )+import qualified Data.Array.Accelerate.LLVM.PTX.Context             as Context+import qualified Data.Array.Accelerate.Array.Remote                 as Remote+import qualified Data.Array.Accelerate.LLVM.PTX.Debug               as Debug+import {-# SOURCE #-} Data.Array.Accelerate.LLVM.PTX.Execute.Event++import qualified Foreign.CUDA.Ptr                                   as CUDA+import qualified Foreign.CUDA.Driver                                as CUDA++import Formatting+++-- Remote memory tables. This builds upon the LRU-cached memory tables provided+-- by the base Accelerate package.+--+type MemoryTable = Remote.MemoryTable CUDA.DevicePtr (Maybe Event)+++-- | Create a new PTX memory table. This is specific to a given PTX target, as+-- devices arrays are unique to a CUDA context.+--+{-# INLINEABLE new #-}+new :: Context -> IO MemoryTable+new !ctx = Remote.new freeRemote+  where+    freeRemote :: CUDA.DevicePtr a -> IO ()+    freeRemote !ptr = do+      message ("freeRemote " % shown) ptr+      Context.contextFinalizeResource ctx $+        withContext ctx (CUDA.free ptr)+++-- Debugging+-- ---------++{-# INLINE message #-}+message :: Format (IO ()) a -> a+message fmt = Debug.traceM Debug.dump_gc ("gc: " % fmt)+
+ src/Data/Array/Accelerate/LLVM/PTX/CodeGen.hs view
@@ -0,0 +1,45 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.PTX.CodeGen+-- Copyright   : [2014..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.PTX.CodeGen (++  KernelMetadata(..),++) where++-- accelerate+import Data.Array.Accelerate.LLVM.CodeGen++import Data.Array.Accelerate.LLVM.PTX.CodeGen.Base+import Data.Array.Accelerate.LLVM.PTX.CodeGen.Fold+import Data.Array.Accelerate.LLVM.PTX.CodeGen.FoldSeg+import Data.Array.Accelerate.LLVM.PTX.CodeGen.Generate+import Data.Array.Accelerate.LLVM.PTX.CodeGen.Intrinsic ()+import Data.Array.Accelerate.LLVM.PTX.CodeGen.Map+import Data.Array.Accelerate.LLVM.PTX.CodeGen.Permute+import Data.Array.Accelerate.LLVM.PTX.CodeGen.Scan+import Data.Array.Accelerate.LLVM.PTX.CodeGen.Stencil+import Data.Array.Accelerate.LLVM.PTX.CodeGen.Transform+import Data.Array.Accelerate.LLVM.PTX.Target+++instance Skeleton PTX where+  map         = mkMap+  generate    = mkGenerate+  transform   = mkTransform+  fold        = mkFold+  foldSeg     = mkFoldSeg+  scan        = mkScan+  scan'       = mkScan'+  permute     = mkPermute+  stencil1    = mkStencil1+  stencil2    = mkStencil2+
+ src/Data/Array/Accelerate/LLVM/PTX/CodeGen/Base.hs view
@@ -0,0 +1,825 @@+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE MultiWayIf          #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeFamilies        #-}+{-# LANGUAGE ViewPatterns        #-}+{-# OPTIONS_GHC -Wno-orphans     #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.PTX.CodeGen.Base+-- Copyright   : [2014..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.PTX.CodeGen.Base (++  -- Types+  DeviceProperties, KernelMetadata(..),++  -- Thread identifiers+  blockDim, gridDim, threadIdx, blockIdx, warpSize,+  gridSize, globalThreadIdx,++  -- Other intrinsics+  laneId, warpId,+  laneMask_eq, laneMask_lt, laneMask_le, laneMask_gt, laneMask_ge,+  atomicAdd_f,+  nanosleep,++  -- Barriers and synchronisation+  __syncthreads, __syncthreads_count, __syncthreads_and, __syncthreads_or,+  __syncwarp, __syncwarp_mask,+  __threadfence_block, __threadfence_grid,++  -- Warp shuffle instructions+  __shfl_up, __shfl_down, __shfl_idx, __broadcast,++  -- Shared memory+  staticSharedMem,+  sharedMemorySizeAdd,+  dynamicSharedMem,+  sharedMemAddrSpace, sharedMemVolatility,++  -- Kernel definitions+  (+++),+  makeOpenAcc, makeOpenAccWith,++) where++import Data.Primitive.Vec+import Data.Array.Accelerate.Error+import Data.Array.Accelerate.LLVM.CodeGen.Arithmetic                as A+import Data.Array.Accelerate.LLVM.CodeGen.Base+import Data.Array.Accelerate.LLVM.CodeGen.IR+import Data.Array.Accelerate.LLVM.CodeGen.Module+import Data.Array.Accelerate.LLVM.CodeGen.Monad+import Data.Array.Accelerate.LLVM.CodeGen.Ptr+import Data.Array.Accelerate.LLVM.CodeGen.Sugar+import Data.Array.Accelerate.LLVM.Compile.Cache+import Data.Array.Accelerate.LLVM.PTX.Analysis.Launch+import Data.Array.Accelerate.LLVM.PTX.Target+import Data.Array.Accelerate.Representation.Array+import Data.Array.Accelerate.Representation.Elt+import Data.Array.Accelerate.Representation.Shape+import Data.Array.Accelerate.Representation.Type+import qualified Data.Array.Accelerate.LLVM.CodeGen.Constant        as A++import Foreign.CUDA.Analysis                                        ( Compute(..), computeCapability )+import qualified Foreign.CUDA.Analysis                              as CUDA++import LLVM.AST.Type.Constant+import LLVM.AST.Type.Downcast+import LLVM.AST.Type.Function+import LLVM.AST.Type.GetElementPtr+import LLVM.AST.Type.Instruction+import LLVM.AST.Type.Instruction.Atomic+import qualified LLVM.AST.Type.Instruction.RMW                      as RMW+import LLVM.AST.Type.Instruction.Volatile+import LLVM.AST.Type.Metadata+import LLVM.AST.Type.Name+import LLVM.AST.Type.Operand+import LLVM.AST.Type.Representation+import qualified Data.Array.Accelerate.LLVM.Internal.LLVMPretty     as LP++import Control.Applicative+import Control.Monad                                                ( void )+import Control.Monad.Reader                                         ( asks )+import Data.Bits+import Data.Proxy+import Data.String+import Foreign.Storable+import Prelude                                                      as P++import GHC.TypeLits++++-- Thread identifiers+-- ------------------++-- | Read the builtin registers that store CUDA thread and grid identifiers+--+-- <https://github.com/llvm-mirror/llvm/blob/master/include/llvm/IR/IntrinsicsNVVM.td>+--+specialPTXReg :: Label -> CodeGen PTX (Operands Int32)+specialPTXReg f =+  call (Body type' (Just Tail) f) [NoUnwind, ReadNone]++blockDim, gridDim, threadIdx, blockIdx, warpSize :: CodeGen PTX (Operands Int32)+blockDim    = specialPTXReg "llvm.nvvm.read.ptx.sreg.ntid.x"+gridDim     = specialPTXReg "llvm.nvvm.read.ptx.sreg.nctaid.x"+threadIdx   = specialPTXReg "llvm.nvvm.read.ptx.sreg.tid.x"+blockIdx    = specialPTXReg "llvm.nvvm.read.ptx.sreg.ctaid.x"+warpSize    = specialPTXReg "llvm.nvvm.read.ptx.sreg.warpsize"++laneId :: CodeGen PTX (Operands Int32)+laneId      = specialPTXReg "llvm.nvvm.read.ptx.sreg.laneid"++laneMask_eq, laneMask_lt, laneMask_le, laneMask_gt, laneMask_ge :: CodeGen PTX (Operands Int32)+laneMask_eq = specialPTXReg "llvm.nvvm.read.ptx.sreg.lanemask.eq"+laneMask_lt = specialPTXReg "llvm.nvvm.read.ptx.sreg.lanemask.lt"+laneMask_le = specialPTXReg "llvm.nvvm.read.ptx.sreg.lanemask.le"+laneMask_gt = specialPTXReg "llvm.nvvm.read.ptx.sreg.lanemask.gt"+laneMask_ge = specialPTXReg "llvm.nvvm.read.ptx.sreg.lanemask.ge"+++-- | NOTE: The special register %warpid as volatile value and is not guaranteed+--         to be constant over the lifetime of a thread or thread block.+--+-- http://docs.nvidia.com/cuda/cuda-c-programming-guide/index.html#sm-id-and-warp-id+--+-- http://docs.nvidia.com/cuda/parallel-thread-execution/index.html#special-registers-warpid+--+warpId :: CodeGen PTX (Operands Int32)+warpId = do+  dev <- liftCodeGen $ asks ptxDeviceProperties+  tid <- threadIdx+  A.quot integralType tid (A.liftInt32 (P.fromIntegral (CUDA.warpSize dev)))++_warpId :: CodeGen PTX (Operands Int32)+_warpId = specialPTXReg "llvm.ptx.read.warpid"+++-- | The size of the thread grid+--+-- > gridDim.x * blockDim.x+--+gridSize :: CodeGen PTX (Operands Int32)+gridSize = do+  ncta  <- gridDim+  nt    <- blockDim+  mul numType ncta nt+++-- | The global thread index+--+-- > blockDim.x * blockIdx.x + threadIdx.x+--+globalThreadIdx :: CodeGen PTX (Operands Int32)+globalThreadIdx = do+  ntid  <- blockDim+  ctaid <- blockIdx+  tid   <- threadIdx+  --+  u     <- mul numType ntid ctaid+  v     <- add numType tid u+  return v+++{--+-- | Generate function parameters that will specify the first and last (linear)+-- index of the array this kernel should evaluate.+--+gangParam :: (Operands Int, Operands Int, [LLVM.Parameter])+gangParam =+  let start = "ix.start"+      end   = "ix.end"+  in+  (local start, local end, parameter start ++ parameter end )+--}+++-- Barriers and synchronisation+-- ----------------------------++-- | Call a built-in CUDA synchronisation intrinsic+--+barrier :: Label -> CodeGen PTX ()+barrier f = void $ call (Body VoidType (Just Tail) f) [NoUnwind, NoDuplicate, Convergent]++barrier_op :: Label -> Operands Int32 -> CodeGen PTX (Operands Int32)+barrier_op f x = call (Lam primType (op integralType x) (Body type' (Just Tail) f)) [NoUnwind, NoDuplicate, Convergent]+++-- | Wait until all threads in the thread block have reached this point, and all+-- global and shared memory accesses made by these threads prior to the+-- __syncthreads() are visible to all threads in the block.+--+-- <http://docs.nvidia.com/cuda/cuda-c-programming-guide/index.html#synchronization-functions>+--+__syncthreads :: CodeGen PTX ()+__syncthreads = barrier "llvm.nvvm.barrier0"++-- | Identical to __syncthreads() with the additional feature that it returns+-- the number of threads in the block for which the predicate evaluates to+-- non-zero.+--+__syncthreads_count :: Operands Int32 -> CodeGen PTX (Operands Int32)+__syncthreads_count = barrier_op "llvm.nvvm.barrier0.popc"++-- | Identical to __syncthreads() with the additional feature that it returns+-- non-zero iff the predicate evaluates to non-zero for all threads in the+-- block.+--+__syncthreads_and :: Operands Int32 -> CodeGen PTX (Operands Int32)+__syncthreads_and = barrier_op "llvm.nvvm.barrier0.and"++-- | Identical to __syncthreads() with the additional feature that it returns+-- non-zero iff the predicate evaluates to non-zero for any thread in the block.+--+__syncthreads_or :: Operands Int32 -> CodeGen PTX (Operands Int32)+__syncthreads_or = barrier_op "llvm.nvvm.barrier0.or"+++-- | Wait until all warp lanes have reached this point.+--+__syncwarp :: HasCallStack => CodeGen PTX ()+__syncwarp = __syncwarp_mask (liftWord32 0xffffffff)++-- | Wait until all warp lanes named in the mask have executed a __syncwarp()+-- with the same mask. All non-exited threads named in the mask must execute+-- a corresponding __syncwarp with the same mask, or the result is undefined.+--+-- This guarantees memory ordering among threads participating in the barrier.+--+-- Requires LLVM-6.0 or higher.+-- Only required for devices of SM7 and later.+--+__syncwarp_mask :: HasCallStack => Operands Word32 -> CodeGen PTX ()+__syncwarp_mask mask = do+  llvmver <- getLLVMversion+  dev <- liftCodeGen $ asks ptxDeviceProperties+  case (computeCapability dev >= Compute 7 0, llvmver >= 6) of+    (True, True) -> void $ call (Lam primType (op primType mask) (Body VoidType (Just Tail) "llvm.nvvm.bar.warp.sync")) [NoUnwind, NoDuplicate, Convergent]+    (True, False) -> internalError "LLVM-6.0 or above is required for Volta devices and later"+    (False, _) -> return ()+++-- | Ensure that all writes to shared and global memory before the call to+-- __threadfence_block() are observed by all threads in the *block* of the+-- calling thread as occurring before all writes to shared and global memory+-- made by the calling thread after the call.+--+-- <http://docs.nvidia.com/cuda/cuda-c-programming-guide/index.html#memory-fence-functions>+--+__threadfence_block :: CodeGen PTX ()+__threadfence_block = barrier "llvm.nvvm.membar.cta"+++-- | As __threadfence_block(), but the synchronisation is for *all* thread blocks.+-- In CUDA this is known simply as __threadfence().+--+__threadfence_grid :: CodeGen PTX ()+__threadfence_grid = barrier "llvm.nvvm.membar.gl"+++-- Atomic functions+-- ----------------++-- LLVM provides atomic instructions for integer arguments only. CUDA provides+-- additional support for atomic add on floating point types, which can be+-- accessed through the following intrinsics.+--+-- Double precision is supported on Compute 6.0 devices and later. Half+-- precision is supported on Compute 7.0 devices and later.+--+-- LLVM-4.0 currently lacks support for this intrinsic, however it is+-- accessible via inline assembly.+--+-- LLVM-9 integrated floating-point atomic operations into the AtomicRMW+-- instruction, but this functionality is missing from llvm-hs-9. We access+-- it via inline assembly..+--+-- <https://github.com/AccelerateHS/accelerate/issues/363>+--+atomicAdd_f :: HasCallStack => FloatingType a -> Operand (Ptr a) -> Operand a -> CodeGen PTX ()+atomicAdd_f t addr val = do+  llvmver <- getLLVMversion+  if | llvmver >= 10 ->+         void . instr' $ AtomicRMW (FloatingNumType t) NonVolatile RMW.Add addr val (CrossThread, AcquireRelease)++     | otherwise ->+         internalError "LLVM < 10 not supported"+++-- Warp shuffle functions+-- ----------------------+--+-- Exchange a variable between threads within a warp. Requires compute+-- capability 3.0 or higher.+--+-- <https://docs.nvidia.com/cuda/cuda-c-programming-guide/index.html#warp-shuffle-functions>+--+-- Each of the shfl primitives also exists in ".p" form. This version+-- returns, alongside the normal value, a boolean that returns whether the+-- source lane was in range. This could be useful when doing bounds checks+-- in folds and scans.+--++data ShuffleOp+  = Idx     -- ^ Direct copy from indexed lane+  | Up      -- ^ Copy from a lane with lower ID relative to the caller+  | Down    -- ^ Copy from a lane with higher ID relative to the caller+  | XOR     -- ^ Copy from a lane based on bitwise XOR of own lane ID++-- | Each thread gets the value provided by lower threads+--+__shfl_up :: TypeR a -> Operands a -> Operands Word32 -> CodeGen PTX (Operands a)+__shfl_up = shfl Up++-- | Each thread gets the value provided by higher threads+--+__shfl_down :: TypeR a -> Operands a -> Operands Word32 -> CodeGen PTX (Operands a)+__shfl_down  = shfl Down++-- | shfl_idx takes an argument representing the source lane index.+--+__shfl_idx :: TypeR a -> Operands a -> Operands Word32 -> CodeGen PTX (Operands a)+__shfl_idx = shfl Idx++-- | Distribute the value from lane 0 across the warp+--+__broadcast :: TypeR a -> Operands a -> CodeGen PTX (Operands a)+__broadcast aR a = __shfl_idx aR a (liftWord32 0)+++shfl :: ShuffleOp+     -> TypeR a+     -> Operands a+     -> Operands Word32+     -> CodeGen PTX (Operands a)+shfl sop tR val delta = go tR val+  where+    delta' :: Operand Word32+    delta' = op integralType delta++    go :: TypeR s -> Operands s -> CodeGen PTX (Operands s)+    go TupRunit         OP_Unit       = return OP_Unit+    go (TupRpair aR bR) (OP_Pair a b) = OP_Pair <$> go aR a <*> go bR b+    go (TupRsingle t)   a             = scalar t a++    scalar :: ScalarType s -> Operands s -> CodeGen PTX (Operands s)+    scalar (SingleScalarType t) = single t+    scalar (VectorScalarType t) = vector t++    single :: SingleType s -> Operands s -> CodeGen PTX (Operands s)+    single (NumSingleType t) = num t++    vector :: forall n s. VectorType (Vec n s) -> Operands (Vec n s) -> CodeGen PTX (Operands (Vec n s))+    vector v@(VectorType w t) a+      | SingleDict <- singleDict t+      = let bytes = sizeOf (undefined::s)+            (m,r) = P.quotRem (w * bytes) 4++            withSomeNat :: Int -> (forall m. KnownNat m => Proxy m -> b) -> b+            withSomeNat n k =+              case someNatVal (toInteger n) of+                Nothing          -> error "Welcome to overthinkers club. The first rule of overthinkers club is: yet to be decided."+                Just (SomeNat p) -> k p+         in+         if r == 0+            -- bitcast into a <m x i32> vector+            -- special case for a single element vector+            then+              if m == 1+                 then do+                   b <- A.bitcast (VectorScalarType v) (scalarType @Int32) a+                   c <- integral (integralType @Int32) b+                   d <- A.bitcast scalarType (VectorScalarType v) c+                   return d++                 else+                   let+                       vec :: forall m. KnownNat m => Proxy m -> CodeGen PTX (Operands (Vec n s))+                       vec _ = do+                         let v' = VectorType m (singleType @Int32)++                         b <- A.bitcast (VectorScalarType v) (VectorScalarType v') a++                         let c = op v' b++                             repack :: Int32 -> CodeGen PTX (Operands (Vec m Int32))+                             repack 0 = return $ ir v' (A.undef (VectorScalarType v'))+                             repack i = do+                               d <- instr $ ExtractElement (i-1) c+                               e <- integral integralType d+                               f <- repack (i-1)+                               g <- instr $ InsertElement (i-1) (op v' f) (op integralType e)+                               return g++                         h <- repack (P.fromIntegral m)+                         i <- A.bitcast (VectorScalarType v') (VectorScalarType v) h+                         return i+                   in+                   withSomeNat m vec++            -- Round up to the next multiple of 32:+            --+            --   1. bitcast to an integer of the same number of bits: e.g. bitcast <3 x i16> i48+            --   2. extend that to the next multiple of 32: e.g. zext i48 i64+            --   3. bitcast to <m+1 x i32>: e.g. bitcast i64 <2 x i32>+            --+            else+              let raw :: LP.Type -> LP.Instr -> CodeGen PTX (LP.Typed LP.Value)+                  raw ty ins = do+                    name <- freshLocalName+                    instr_ (LP.Result (nameToPrettyI name) ins [] [])+                    return (LP.Typed ty (LP.ValIdent (nameToPrettyI name)))++                  rawUp :: Type u -> LP.Instr -> CodeGen PTX (Operand u)+                  rawUp ty ins = do+                    name <- freshLocalName+                    instr_ (LP.Result (nameToPrettyI name) ins [] [])+                    return (LocalReference ty name)+++                  vec :: forall m. KnownNat m => Proxy m -> CodeGen PTX (Operands (Vec n s))+                  vec _ = do+                    let t0Up :: Type (Vec n s)+                        t0Up = PrimType (ScalarPrimType (VectorScalarType v))+                        t0 = downcast t0Up++                        t1 = LP.PrimType (LP.Integer (P.fromIntegral ((w*bytes) * 8)))+                        t2 = LP.PrimType (LP.Integer (P.fromIntegral ((m+1) * 4 * 8)))++                        v' :: VectorType (Vec m Int32)+                        v' = VectorType (m+1) (singleType @Int32)+                        t3Up :: Type (Vec m Int32)+                        t3Up = PrimType (ScalarPrimType (VectorScalarType v'))+                        t3 = downcast t3Up++                    b <- raw t1 (LP.Conv LP.BitCast (downcast (op v a)) t1)+                    c <- raw t2 (LP.Conv (LP.ZExt False) b t2)+                    d <- rawUp t3Up (LP.Conv LP.BitCast c t3)+                    e <- vector v' (ir v' d)+                    f <- raw t2 (LP.Conv LP.BitCast (downcast (op v' e)) t2)+                    g <- raw t1 (LP.Conv (LP.Trunc False False) f t1)+                    h <- rawUp t0Up (LP.Conv LP.BitCast g t0)+                    return (ir v h)+               in+               withSomeNat (m+1) vec++    num :: NumType s -> Operands s -> CodeGen PTX (Operands s)+    num (IntegralNumType t) = integral t+    num (FloatingNumType t) = floating t++    integral :: forall s. IntegralType s -> Operands s -> CodeGen PTX (Operands s)+    integral TypeInt32 a = shfl_op sop ShuffleInt32 delta' a+    integral t         a+      | IntegralDict <- integralDict t+      = case finiteBitSize (undefined::s) of+          64 -> do+            let ta = SingleScalarType (NumSingleType (IntegralNumType t))+                tb = scalarType @(Vec 2 Int32)+            --+            b <- A.bitcast ta tb a+            c <- vector (VectorType 2 singleType) b+            d <- A.bitcast tb ta c+            return d++          _  -> do+            b <- A.fromIntegral t (numType @Int32) a+            c <- integral integralType b+            d <- A.fromIntegral integralType (IntegralNumType t) c+            return d++    floating :: FloatingType s -> Operands s -> CodeGen PTX (Operands s)+    floating TypeFloat  a = shfl_op sop ShuffleFloat delta' a+    floating TypeDouble a = do+      b <- A.bitcast scalarType (scalarType @(Vec 2 Int32)) a+      c <- vector (VectorType 2 singleType) b+      d <- A.bitcast scalarType (scalarType @Double) c+      return d+    floating TypeHalf   a = do+      b <- A.bitcast scalarType (scalarType @Int16) a+      c <- integral integralType b+      d <- A.bitcast scalarType (scalarType @Half) c+      return d+++data ShuffleType a where+  ShuffleInt32 :: ShuffleType Int32+  ShuffleFloat :: ShuffleType Float++shfl_op+    :: forall a.+       ShuffleOp+    -> ShuffleType a+    -> Operand Word32               -- delta+    -> Operands a                   -- value to give+    -> CodeGen PTX (Operands a)     -- value received+shfl_op sop t delta val = do+  dev <- liftCodeGen $ asks ptxDeviceProperties++  let+      -- The CUDA __shfl* instruction take an optional final parameter+      -- which is the warp size. Setting this value to something (always+      -- a power-of-two) other than 32 emulates the shfl behaviour at that+      -- warp size. Behind the scenes, a bunch of instructions happen with+      -- this width parameter before they get passed into the actual shfl+      -- instruction. Here, we have to directly set them to the 'actual'+      -- width parameter. The formula that clang compiles to is in the+      -- comments+      --+      width :: Operand Int32+      width = case sop of+        Up   -> A.integral integralType 0  -- ((32 - warpSize) `shiftL` 8)+        Down -> A.integral integralType 31 -- ((32 - warpSize) `shiftL` 8) `or` 31+        Idx  -> A.integral integralType 31 -- ((32 - warpSize) `shiftL` 8) `or` 31+        XOR  -> A.integral integralType 31 -- ((32 - warpSize) `shiftL` 8) `or` 31++      -- Starting CUDA 9.0, the normal `shfl` primitives are deprecated in+      -- favour of the newer `shfl_sync` primitives. They behave the same+      -- way, except they start with a 'mask' argument specifying which+      -- threads participate in the shuffle.+      --+      mask :: Operand Int32+      mask  = A.integral integralType (-1) -- all threads participate++      useSyncShfl = CUDA.computeCapability dev >= Compute 7 0++      call' = if useSyncShfl+                 then call . Lam primType mask+                 else call++      sync  = if useSyncShfl then "sync." else ""+      asm   = "llvm.nvvm.shfl."+           <> sync+           <> case sop of+                Idx  -> "idx."+                Up   -> "up."+                Down -> "down."+                XOR  -> "bfly."+           <> case t of+                ShuffleInt32 -> "i32"+                ShuffleFloat -> "f32"++      t_val = case t of+                ShuffleInt32 -> primType :: PrimType Int32+                ShuffleFloat -> primType :: PrimType Float++  call' (Lam t_val (op t_val val) (Lam primType delta (Lam primType width (Body (PrimType t_val) (Just Tail) asm)))) [Convergent, NoUnwind, InaccessibleMemOnly]+++-- Shared memory+-- -------------++sharedMemAddrSpace :: AddrSpace+sharedMemAddrSpace = AddrSpace 3++sharedMemVolatility :: Volatility+sharedMemVolatility = Volatile+++-- Declare a new statically allocated array in the __shared__ memory address+-- space, with enough storage to contain the given number of elements.+--+-- Previously, like initialiseDynamicSharedMemory, this function declared an+-- external global, e.g. for 1 i64:+--   @sdata = external addrspace(3) global [1 x i64], align 8+-- This would correspond to the following CUDA source:+--   extern __shared__ int64_t sdata[1];+--+-- But this CUDA C++ is rejected by Clang. When LLVM is fed LLVM IR, however,+-- things are more subtle; in the old llvm-hs backend where we linked against+-- LLVM, with LLVM 15, the above IR (defining @0) was accepted. However,+-- passing this same IR to Clang 18 with the llvm-pretty backend (yes I'm aware+-- the clang version is also changing here), clang first calls ptxas and then+-- nvlink; nvlink complains:+--   Undefined reference to 'sdata' in '/tmp/test-409abe.cubin'+-- When linking against LLVM 15, nvlink is never invoked, but instead ptxas is+-- _not_ given the -c flag and it immediately produces a SASS file.+--+-- Because Clang doesn't even accept the corresponding C++ code, but does+-- accept this:+--   __shared__ int64_t sdata[1];+-- the global created in this function was changed to be of internal linkage+-- instead. The assigned value is 'undef', just like what Clang generates for+-- the internal sdata C++ declaration.+staticSharedMem+    :: TypeR e+    -> Word64+    -> CodeGen PTX (IRArray (Vector e))+staticSharedMem tp n = do+  ad    <- go tp+  return $ IRArray { irArrayRepr       = ArrayR dim1 tp+                   , irArrayShape      = OP_Pair OP_Unit $ OP_Int $ A.integral integralType $ P.fromIntegral n+                   , irArrayData       = ad+                   , irArrayAddrSpace  = sharedMemAddrSpace+                   , irArrayVolatility = sharedMemVolatility+                   }+  where+    go :: TypeR s -> CodeGen PTX (Operands s)+    go TupRunit          = return OP_Unit+    go (TupRpair t1 t2)  = OP_Pair <$> go t1 <*> go t2+    go tt@(TupRsingle t) = do+      -- Declare a new global reference for the statically allocated array+      -- located in the __shared__ memory space.+      nm <- freshGlobalName+      let arrt = ArrayPrimType n t+          ptrarrt = PrimType (PtrPrimType arrt sharedMemAddrSpace)+      sm <- return $ ConstantOperand $ GlobalReference ptrarrt nm+      declareGlobalVar $ LP.Global+        { LP.globalSym = nameToPrettyS nm+        , LP.globalAttrs = LP.GlobalAttrs+            { LP.gaLinkage = Just LP.Internal+            , LP.gaVisibility = Nothing+            , LP.gaAddrSpace = sharedMemAddrSpace+            , LP.gaConstant = False }+        , LP.globalType = LP.Array n (downcast t)+        , LP.globalValue = Just LP.ValUndef+        , LP.globalAlign = Just (4 `P.max` P.fromIntegral (bytesElt tt))+        , LP.globalMetadata = mempty+        }++      -- Return a pointer to the first element of the __shared__ memory array.+      -- We do this rather than just returning the global reference directly due+      -- to how __shared__ memory needs to be indexed with the GEP instruction.+      p <- instr' $ GetElementPtr (GEP (PrimType arrt) sm (A.num numType 0 :: Operand Int32)+                                       (GEPArray (A.num numType 0 :: Operand Int32) (GEPEmpty (ScalarPrimType t))))+      q <- instr' $ PtrCast (PtrPrimType (ScalarPrimType t) sharedMemAddrSpace) p++      return $ ir t (unPtr q)+++-- External declaration in shared memory address space. This must be declared in+-- order to access memory allocated dynamically by the CUDA driver. This results+-- in the following global declaration:+--+-- > @__shared__ = external addrspace(3) global [0 x i8]+--+initialiseDynamicSharedMemory :: CodeGen PTX (Operand (Ptr Int8))+initialiseDynamicSharedMemory = do+  declareGlobalVar $ LP.Global+    { LP.globalSym = LP.Symbol "__shared__"+    , LP.globalAttrs = LP.GlobalAttrs+        { LP.gaLinkage = Just LP.External+        , LP.gaVisibility = Nothing+        , LP.gaAddrSpace = sharedMemAddrSpace+        , LP.gaConstant = False }+    , LP.globalType = LP.Array 0 (LP.PrimType (LP.Integer 8))+    , LP.globalValue = Nothing+    , LP.globalAlign = Nothing+    , LP.globalMetadata = mempty+    }+  return $ ConstantOperand+    $ ConstantGetElementPtr (GEP (PrimType (ArrayPrimType 0 (scalarType @Int8)))+                                 (GlobalReference (PrimType (PtrPrimType (ArrayPrimType 0 scalarType) sharedMemAddrSpace)) "__shared__")+                                 (ScalarConstant (scalarType @Int32) 0)+                                 (GEPArray (ScalarConstant (scalarType @Int32) 0) (GEPEmpty primType)))++sharedMemorySizeAdd+  :: TypeR e+  -> Int -- number of array elements+  -> Int -- #bytes of shared memory the have already been allocated+  -> Int+sharedMemorySizeAdd tp n i = case tp of+  TupRunit -> i+  TupRpair t2 t1 ->+    -- First handle the second element of the tuple, then the first,+    -- to match the behaviour of dynamicSharedMem+    sharedMemorySizeAdd t2 n $ sharedMemorySizeAdd t1 n i+  TupRsingle t ->+    let+      bytes = bytesElt tp+      -- Align 'i' to the alignment of t+      aligned = alignTo (scalarAlignment t) i+    in+      aligned + bytes * n++-- Declare a new dynamically allocated array in the __shared__ memory space+-- with enough space to contain the given number of elements.+--+dynamicSharedMem+    :: forall e int.+       TypeR e+    -> IntegralType int+    -> Operands int                                 -- number of array elements+    -> Operands int                                 -- #bytes of shared memory that have already been allocated+    -> CodeGen PTX (IRArray (Vector e))+dynamicSharedMem tp int n@(op int -> m) (op int -> offset)+  | IntegralDict <- integralDict int = do+    smem         <- initialiseDynamicSharedMemory+    let+        numTp = IntegralNumType int++        go :: TypeR s -> Operand int -> CodeGen PTX (Operand int, Operands s)+        go TupRunit         i  = return (i, OP_Unit)+        go (TupRpair t2 t1) i0 = do+          (i1, p1) <- go t1 i0+          (i2, p2) <- go t2 i1+          return $ (i2, OP_Pair p2 p1)+        go (TupRsingle t)   i  = do+          let bytes = bytesElt (TupRsingle t)+          let align = scalarAlignment t+          i' <- instr' $ Add numTp i (A.integral int $ P.fromIntegral $ align - 1)+          aligned <- instr' $ BAnd int i' (A.integral int $ P.fromIntegral $ Data.Bits.complement $ align - 1)+          p <- instr' $ GetElementPtr (GEP1 scalarType smem aligned)+          q <- instr' $ PtrCast (PtrPrimType (ScalarPrimType t) sharedMemAddrSpace) p+          a <- instr' $ Mul numTp m (A.integral int (P.fromIntegral bytes))+          b <- instr' $ Add numTp aligned a+          return (b, ir t (unPtr q))+    --+    (_, ad) <- go tp offset+    sz      <- A.fromIntegral int (numType :: NumType Int) n+    return   $ IRArray { irArrayRepr       = ArrayR dim1 tp+                       , irArrayShape      = OP_Pair OP_Unit sz+                       , irArrayData       = ad+                       , irArrayAddrSpace  = sharedMemAddrSpace+                       , irArrayVolatility = sharedMemVolatility+                       }+++-- Other functions+-- ---------------++-- Sleep the thread for (approximately) the given number of nanoseconds.+-- Requires compute capability >= 7.0+--+nanosleep :: Operands Int32 -> CodeGen PTX ()+nanosleep ns = do+  -- This is an acc prelude function because it requires inline assembly, and+  -- llvm-pretty does not yet support caling inline assembly snippets. Thus we+  -- manually wrap the assembly in an inlineable function and call that.+  let label = makeAccPreludeLabel "nanosleep"+  void $ instr (Call (Lam primType (op integralType ns) (Body VoidType (Just Tail) (Right label))))+++-- Global kernel definitions+-- -------------------------++data instance KernelMetadata PTX = KM_PTX LaunchConfig++-- | Combine kernels into a single program+--+(+++) :: IROpenAcc PTX aenv a -> IROpenAcc PTX aenv a -> IROpenAcc PTX aenv a+IROpenAcc k1 +++ IROpenAcc k2 = IROpenAcc (k1 ++ k2)+++-- | Create a single kernel program with the default launch configuration.+--+makeOpenAcc+    :: UID+    -> Label+    -> [LP.Typed LP.Ident]+    -> CodeGen PTX ()+    -> CodeGen PTX (IROpenAcc PTX aenv a)+makeOpenAcc uid name param kernel = do+  dev <- liftCodeGen $ asks ptxDeviceProperties+  makeOpenAccWith (simpleLaunchConfig dev) uid name param kernel++-- | Create a single kernel program with the given launch analysis information.+--+makeOpenAccWith+    :: LaunchConfig+    -> UID+    -> Label+    -> [LP.Typed LP.Ident]+    -> CodeGen PTX ()+    -> CodeGen PTX (IROpenAcc PTX aenv a)+makeOpenAccWith config uid name param kernel = do+  body  <- makeKernel config (name <> fromString ('_' : show uid)) param kernel+  return $ IROpenAcc [body]++-- | Create a complete kernel function by running the code generation process+-- specified in the final parameter.+--+makeKernel+    :: LaunchConfig+    -> Label+    -> [LP.Typed LP.Ident]+    -> CodeGen PTX ()+    -> CodeGen PTX (Kernel PTX aenv a)+makeKernel config name param kernel = do+  _    <- kernel+  code <- createBlocks+  let define = LP.Define+        { LP.defLinkage    = Nothing+        , LP.defVisibility = Nothing+        , LP.defRetType    = LP.PrimType LP.Void+        , LP.defName       = labelToPrettyS name+        , LP.defArgs       = param+        , LP.defVarArgs    = False+        , LP.defAttrs      = []+        , LP.defSection    = Nothing+        , LP.defGC         = Nothing+        , LP.defBody       = code+        , LP.defMetadata   = mempty+        , LP.defComdat     = Nothing+        }+  addMetadata "nvvm.annotations"+    [ Just . MetadataConstantOperand+      $ LP.Typed (LP.defFunType define) (LP.ValSymbol (labelToPrettyS name))+    , Just . MetadataStringOperand   $ "kernel"+    , Just . MetadataConstantOperand $ LP.Typed (LP.PrimType (LP.Integer 32)) (LP.ValInteger 1)+    ]+  return $ Kernel+    { kernelMetadata = KM_PTX config+    , unKernel       = define+    }++scalarAlignment :: ScalarType t -> Int+scalarAlignment t@(SingleScalarType _) = bytesElt (TupRsingle t)+scalarAlignment (VectorScalarType (VectorType _ t)) = bytesElt (TupRsingle $ SingleScalarType t)++-- Align 'ptr' to the given alignment.+-- Assumes 'align' is a power of 2.+alignTo :: Int -> Int -> Int+alignTo align ptr = (ptr + align - 1) .&. Data.Bits.complement (align - 1)
+ src/Data/Array/Accelerate/LLVM/PTX/CodeGen/Fold.hs view
@@ -0,0 +1,616 @@+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE RebindableSyntax    #-}+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell     #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeOperators       #-}+{-# LANGUAGE ViewPatterns        #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.PTX.CodeGen.Fold+-- Copyright   : [2016..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.PTX.CodeGen.Fold+  where++import Data.Array.Accelerate.Representation.Array+import Data.Array.Accelerate.Representation.Shape                   hiding ( size )+import Data.Array.Accelerate.Representation.Type++import Data.Array.Accelerate.LLVM.CodeGen.Arithmetic                as A+import Data.Array.Accelerate.LLVM.CodeGen.Array+import Data.Array.Accelerate.LLVM.CodeGen.Base+import Data.Array.Accelerate.LLVM.CodeGen.Constant+import Data.Array.Accelerate.LLVM.CodeGen.Environment+import Data.Array.Accelerate.LLVM.CodeGen.Exp+import Data.Array.Accelerate.LLVM.CodeGen.IR+import Data.Array.Accelerate.LLVM.CodeGen.Loop                      as Loop+import Data.Array.Accelerate.LLVM.CodeGen.Monad+import Data.Array.Accelerate.LLVM.CodeGen.Sugar+import Data.Array.Accelerate.LLVM.Compile.Cache++import Data.Array.Accelerate.LLVM.PTX.Analysis.Launch+import Data.Array.Accelerate.LLVM.PTX.CodeGen.Base+import Data.Array.Accelerate.LLVM.PTX.CodeGen.Generate+import Data.Array.Accelerate.LLVM.PTX.Target++import LLVM.AST.Type.Representation++import qualified Foreign.CUDA.Analysis                              as CUDA++import Control.Monad                                                ( (>=>) )+import Control.Monad.Reader                                         ( asks )+import Data.String                                                  ( fromString )+import Data.Bits                                                    as P+import Prelude                                                      as P+++-- Reduce an array along the innermost dimension. The reduction function must be+-- associative to allow for an efficient parallel implementation, but the+-- initial element does /not/ need to be a neutral element of operator.+--+-- TODO: Specialise for commutative operations (such as (+)) and those with+--       a neutral element {(+), 0}+--+mkFold+    :: forall aenv sh e.+       UID+    -> Gamma            aenv+    -> ArrayR (Array sh e)+    -> IRFun2       PTX aenv (e -> e -> e)+    -> Maybe (IRExp PTX aenv e)+    -> MIRDelayed   PTX aenv (Array (sh, Int) e)+    -> CodeGen      PTX      (IROpenAcc PTX aenv (Array sh e))+mkFold uid aenv repr f z acc = case z of+  Just z' -> (+++) <$> codeFold <*> mkFoldFill uid aenv repr z'+  Nothing -> codeFold+  where+    codeFold = case repr of+      ArrayR ShapeRz tp -> mkFoldAll uid aenv tp   f z acc+      _                 -> mkFoldDim uid aenv repr f z acc+++-- Reduce an array to a single element.+--+-- Since reductions consume arrays that have been fused into them, parallel+-- reduction requires two separate kernels. At an example, take vector dot+-- product:+--+-- > dotp xs ys = fold (+) 0 (zipWith (*) xs ys)+--+-- 1. The first pass reads in the fused array data, in this case corresponding+--    to the function (\i -> (xs!i) * (ys!i)).+--+-- 2. The second pass reads in the manifest array data from the first step and+--    directly reduces the array. This can be done recursively in-place until+--    only a single element remains.+--+-- In both phases, thread blocks cooperatively reduce a stripe of the input (one+-- element per thread) to a single element, which is stored to the output array.+--+mkFoldAll+    :: forall aenv e.+       UID+    -> Gamma          aenv                      -- ^ array environment+    -> TypeR e+    -> IRFun2     PTX aenv (e -> e -> e)        -- ^ combination function+    -> MIRExp     PTX aenv e                    -- ^ (optional) initial element for exclusive reductions+    -> MIRDelayed PTX aenv (Vector e)           -- ^ input data+    -> CodeGen    PTX      (IROpenAcc PTX aenv (Scalar e))+mkFoldAll uid aenv tp combine mseed macc = do+  dev <- liftCodeGen $ asks ptxDeviceProperties+  foldr1 (+++) <$> sequence [ mkFoldAllS  uid dev aenv tp combine mseed macc+                            , mkFoldAllM1 uid dev aenv tp combine       macc+                            , mkFoldAllM2 uid dev aenv tp combine mseed+                            ]+++-- Reduction to an array to a single element, for small arrays which can be+-- processed by a single thread block.+--+mkFoldAllS+    :: forall aenv e.+       UID+    -> DeviceProperties                         -- ^ properties of the target GPU+    -> Gamma          aenv                      -- ^ array environment+    -> TypeR e+    -> IRFun2     PTX aenv (e -> e -> e)        -- ^ combination function+    -> MIRExp     PTX aenv e                    -- ^ (optional) initial element for exclusive reductions+    -> MIRDelayed PTX aenv (Vector e)           -- ^ input data+    -> CodeGen    PTX      (IROpenAcc PTX aenv (Scalar e))+mkFoldAllS uid dev aenv tp combine mseed marr =+  let+      (arrOut, paramOut)  = mutableArray (ArrayR dim0 tp) "out"+      (arrIn,  paramIn)   = delayedArray "in" marr+      paramEnv            = envParam aenv+      --+      config              = launchConfig dev (CUDA.incWarp dev) smem multipleOf multipleOfQ+      smem n              = sharedMemorySizeAdd tp warps 0+        where+          ws        = CUDA.warpSize dev+          warps     = n `P.quot` ws+  in+  makeOpenAccWith config uid "foldAllS" (paramOut ++ paramIn ++ paramEnv) $ do++    tid     <- threadIdx+    bd      <- blockDim++    sh      <- delayedExtent arrIn+    end     <- shapeSize dim1 sh++    -- We can assume that there is only a single thread block+    start'  <- return (liftInt32 0)+    end'    <- i32 end+    i0      <- A.add numType start' tid+    sz      <- A.sub numType end' start'+    when (A.lt singleType i0 sz) $ do++      -- Thread reads initial element and then participates in block-wide+      -- reduction.+      x0 <- app1 (delayedLinearIndex arrIn) =<< int i0+      r0 <- if (tp, A.eq singleType sz bd)+              then reduceBlock dev tp combine Nothing   x0+              else reduceBlock dev tp combine (Just sz) x0++      when (A.eq singleType tid (liftInt32 0)) $+        writeArray TypeInt32 arrOut tid =<<+          case mseed of+            Nothing -> return r0+            Just z  -> flip (app2 combine) r0 =<< z   -- Note: initial element on the left++    return_+++-- Reduction of an entire array to a single element. This kernel implements step+-- one for reducing large arrays which must be processed by multiple thread+-- blocks.+--+mkFoldAllM1+    :: forall aenv e.+       UID+    -> DeviceProperties                         -- ^ properties of the target GPU+    -> Gamma          aenv                      -- ^ array environment+    -> TypeR e+    -> IRFun2     PTX aenv (e -> e -> e)        -- ^ combination function+    -> MIRDelayed PTX aenv (Vector e)           -- ^ input data+    -> CodeGen    PTX      (IROpenAcc PTX aenv (Scalar e))+mkFoldAllM1 uid dev aenv tp combine marr =+  let+      (arrTmp, paramTmp)  = mutableArray (ArrayR dim1 tp) "tmp"+      (arrIn,  paramIn)   = delayedArray "in" marr+      paramEnv            = envParam aenv+      start               = liftInt 0+      --+      config              = launchConfig dev (CUDA.incWarp dev) smem const [|| const ||]+      smem n              = sharedMemorySizeAdd tp warps 0+        where+          ws        = CUDA.warpSize dev+          warps     = n `P.quot` ws+  in+  makeOpenAccWith config uid "foldAllM1" (paramTmp ++ paramIn ++ paramEnv) $ do++    -- Each thread block cooperatively reduces a stripe of the input and stores+    -- that value into a temporary array at a corresponding index. Since the+    -- order of operations remains fixed, this method supports non-commutative+    -- reductions.+    --+    tid   <- threadIdx+    bd    <- int =<< blockDim+    sz    <- indexHead <$> delayedExtent arrIn+    end   <- shapeSize dim1 (irArrayShape arrTmp)++    imapFromTo start end $ \seg -> do++      -- Wait for all threads to catch up before beginning the stripe+      __syncthreads++      -- Bounds of the input array we will reduce between+      from  <- A.mul numType    seg  bd+      step  <- A.add numType    from bd+      to    <- A.min singleType sz   step++      -- Threads cooperatively reduce this stripe+      reduceFromTo dev tp from to combine+        (app1 (delayedLinearIndex arrIn))+        (when (A.eq singleType tid (liftInt32 0)) . writeArray TypeInt arrTmp seg)++    return_+++-- Reduction of an array to a single element, (recursive) step 2 of multi-block+-- reduction algorithm.+--+mkFoldAllM2+    :: forall aenv e.+       UID+    -> DeviceProperties+    -> Gamma       aenv+    -> TypeR e+    -> IRFun2  PTX aenv (e -> e -> e)+    -> MIRExp  PTX aenv e+    -> CodeGen PTX      (IROpenAcc PTX aenv (Scalar e))+mkFoldAllM2 uid dev aenv tp combine mseed =+  let+      (arrTmp, paramTmp)  = mutableArray (ArrayR dim1 tp) "tmp"+      (arrOut, paramOut)  = mutableArray (ArrayR dim1 tp) "out"+      paramEnv            = envParam aenv+      start               = liftInt 0+      --+      config              = launchConfig dev (CUDA.incWarp dev) smem const [|| const ||]+      smem n              = sharedMemorySizeAdd tp warps 0+        where+          ws        = CUDA.warpSize dev+          warps     = n `P.quot` ws+  in+  makeOpenAccWith config uid "foldAllM2" (paramTmp ++ paramOut ++ paramEnv) $ do++    -- Threads cooperatively reduce a stripe of the input (temporary) array+    -- output from the first phase, storing the results into another temporary.+    -- When only a single thread block remains, we have reached the final+    -- reduction step and add the initial element (for exclusive reductions).+    --+    tid   <- threadIdx+    gd    <- gridDim+    bd    <- int =<< blockDim+    sz    <- return $ indexHead (irArrayShape arrTmp)+    end   <- shapeSize dim1 (irArrayShape arrOut)++    imapFromTo start end $ \seg -> do++      -- Wait for all threads to catch up before beginning the stripe+      __syncthreads++      -- Bounds of the input we will reduce between+      from  <- A.mul numType    seg  bd+      step  <- A.add numType    from bd+      to    <- A.min singleType sz   step++      -- Threads cooperatively reduce this stripe+      reduceFromTo dev tp from to combine (readArray TypeInt arrTmp) $ \r ->+        when (A.eq singleType tid (liftInt32 0)) $+          writeArray TypeInt arrOut seg =<<+            case mseed of+              Nothing -> return r+              Just z  -> if (tp, A.eq singleType gd (liftInt32 1))+                           then flip (app2 combine) r =<< z   -- Note: initial element on the left+                           else return r++    return_+++-- Reduce an array of arbitrary rank along the innermost dimension only.+--+-- For simplicity, each element of the output (reduction along an+-- innermost-dimension index) is computed by a single thread block, meaning we+-- don't have to worry about inter-block synchronisation. A more balanced method+-- would be a segmented reduction (specialised, since the length of each segment+-- is known a priori).+--+mkFoldDim+    :: forall aenv sh e.+       UID+    -> Gamma aenv                                     -- ^ array environment+    -> ArrayR (Array sh e)+    -> IRFun2     PTX aenv (e -> e -> e)              -- ^ combination function+    -> MIRExp     PTX aenv e                          -- ^ (optional) seed element, if this is an exclusive reduction+    -> MIRDelayed PTX aenv (Array (sh, Int) e)        -- ^ input data+    -> CodeGen    PTX      (IROpenAcc PTX aenv (Array sh e))+mkFoldDim uid aenv repr@(ArrayR shr tp) combine mseed marr = do+  dev <- liftCodeGen $ asks ptxDeviceProperties+  --+  let+      (arrOut, paramOut)  = mutableArray repr "out"+      (arrIn,  paramIn)   = delayedArray "in" marr+      paramEnv            = envParam aenv+      --+      config              = launchConfig dev (CUDA.incWarp dev) smem const [|| const ||]+      smem n              = sharedMemorySizeAdd tp warps 0+        where+          ws        = CUDA.warpSize dev+          warps     = n `P.quot` ws+  --+  makeOpenAccWith config uid "fold" (paramOut ++ paramIn ++ paramEnv) $ do++    -- If the innermost dimension is smaller than the number of threads in the+    -- block, those threads will never contribute to the output.+    tid   <- threadIdx+    sz    <- indexHead <$> delayedExtent arrIn+    sz'   <- i32 sz++    when (A.lt singleType tid sz') $ do++      start <- return (liftInt 0)+      end   <- shapeSize shr (irArrayShape arrOut)++      -- Thread blocks iterate over the outer dimensions, each thread block+      -- cooperatively reducing along each outermost index to a single value.+      --+      imapFromTo start end $ \seg -> do++        -- Wait for threads to catch up before starting this segment. We could+        -- also place this at the bottom of the loop, but here allows threads to+        -- exit quickly on the last iteration.+        __syncthreads++        -- Step 1: initialise local sums+        from  <- A.mul numType seg  sz          -- first linear index this block will reduce+        to    <- A.add numType from sz          -- last linear index this block will reduce (exclusive)++        i0    <- A.add numType from =<< int tid+        x0    <- app1 (delayedLinearIndex arrIn) i0+        bd    <- blockDim+        r0    <- if (tp, A.gte singleType sz' bd)+                   then reduceBlock dev tp combine Nothing    x0+                   else reduceBlock dev tp combine (Just sz') x0++        -- Step 2: keep walking over the input+        bd'   <- int bd+        next  <- A.add numType from bd'+        r     <- iterFromStepTo tp next bd' to r0 $ \offset r -> do++          -- Wait for all threads to catch up before starting the next stripe+          __syncthreads++          -- Threads cooperatively reduce this stripe of the input+          i   <- A.add numType offset =<< int tid+          v'  <- A.sub numType to offset+          r'  <- if (tp, A.gte singleType v' bd')+                   -- All threads of the block are valid, so we can avoid+                   -- bounds checks.+                   then do+                     x <- app1 (delayedLinearIndex arrIn) i+                     y <- reduceBlock dev tp combine Nothing x+                     return y++                   -- Otherwise, we require bounds checks when reading the input+                   -- and during the reduction. Note that even though only the+                   -- valid threads will contribute useful work in the+                   -- reduction, we must still have all threads enter the+                   -- reduction procedure to avoid synchronisation divergence.+                   else do+                     x <- if (tp, A.lt singleType i to)+                            then app1 (delayedLinearIndex arrIn) i+                            else let+                                     go :: TypeR a -> Operands a+                                     go TupRunit       = OP_Unit+                                     go (TupRpair a b) = OP_Pair (go a) (go b)+                                     go (TupRsingle t) = ir t (undef t)+                                 in+                                 return $ go tp++                     v <- i32 v'+                     y <- reduceBlock dev tp combine (Just v) x+                     return y++          if (tp, A.eq singleType tid (liftInt32 0))+            then app2 combine r r'+            else return r'++        -- Step 3: Thread 0 writes the aggregate reduction of this dimension to+        -- memory. If this is an exclusive fold, combine with the initial element.+        --+        when (A.eq singleType tid (liftInt32 0)) $+          writeArray TypeInt arrOut seg =<<+            case mseed of+              Nothing -> return r+              Just z  -> flip (app2 combine) r =<< z  -- Note: initial element on the left++    return_+++-- Exclusive reductions over empty arrays (of any dimension) fill the lower+-- dimensions with the initial element.+--+mkFoldFill+    :: UID+    -> Gamma       aenv+    -> ArrayR (Array sh e)+    -> IRExp   PTX aenv e+    -> CodeGen PTX      (IROpenAcc PTX aenv (Array sh e))+mkFoldFill uid aenv repr seed =+  mkGenerate uid aenv repr (IRFun1 (const seed))+++-- Efficient threadblock-wide reduction using the specified operator. The+-- aggregate reduction value is stored in thread zero. Supports non-commutative+-- operators.+--+-- Requires dynamically allocated memory: (#warps * (1 + 1.5 * warp size)).+--+-- Example: https://github.com/NVlabs/cub/blob/1.5.2/cub/block/specializations/block_reduce_warp_reductions.cuh+--+reduceBlock+    :: forall aenv e.+       DeviceProperties                         -- ^ properties of the target device+    -> TypeR e+    -> IRFun2 PTX aenv (e -> e -> e)            -- ^ combination function+    -> Maybe (Operands Int32)                   -- ^ number of valid elements (may be less than block size)+    -> Operands e                               -- ^ calling thread's input element+    -> CodeGen PTX (Operands e)                 -- ^ thread-block-wide reduction using the specified operator (lane 0 only)+reduceBlock dev tp combine size = warpReduce >=> warpAggregate+  where+    int32 :: Integral a => a -> Operands Int32+    int32 = liftInt32 . P.fromIntegral++    -- Step 1: Reduction in every warp+    --+    warpReduce :: Operands e -> CodeGen PTX (Operands e)+    warpReduce input = do+      wid   <- warpId+      -- Are we doing bounds checking for this warp?+      case size of+        -- The entire thread block is valid, so skip bounds checks.+        Nothing -> reduceWarp dev tp combine Nothing input++        -- Otherwise check how many elements are valid for this warp. If it is+        -- full then we can still skip bounds checks for it.+        Just n -> do+          offset <- A.mul numType wid (int32 (CUDA.warpSize dev))+          valid  <- A.sub numType n offset+          if (tp, A.gte singleType valid (int32 (CUDA.warpSize dev)))+            then reduceWarp dev tp combine Nothing      input+            else reduceWarp dev tp combine (Just valid) input++    -- Step 2: Aggregate per-warp reductions+    --+    warpAggregate :: Operands e -> CodeGen PTX (Operands e)+    warpAggregate input = do+      -- Allocate #warps elements of shared memory+      bd    <- blockDim+      warps <- A.quot integralType bd (int32 (CUDA.warpSize dev))+      smem  <- dynamicSharedMem tp TypeInt32 warps (liftInt32 0)++      -- Share the per-lane aggregates+      wid   <- warpId+      lane  <- laneId+      when (A.eq singleType lane (liftInt32 0)) $ do+        writeArray TypeInt32 smem wid input++      -- Wait for each warp to finish its local reduction+      __syncthreads++      -- -- Now, warp 0 will reduce all the warp-wide results.+      -- -- TODO: this means that the block can only consist of 32 warps,+      -- -- reducing 1024 elements total. Check if this gets handled by callers!+      -- if (tp, A.eq singleType wid (liftInt32 0))+      --   then warpReduce input+      --   else+      --     return input++      -- Update the total aggregate. Thread 0 just does this sequentially (as is+      -- done in CUB), but we could also do this cooperatively (better for+      -- larger thread blocks?)+      --+      tid   <- threadIdx+      if (tp, A.eq singleType tid (liftInt32 0))+        then do+          steps <- case size of+                     Nothing -> return warps+                     Just n  -> do+                       a <- A.add numType n (int32 (CUDA.warpSize dev - 1))+                       b <- A.quot integralType a (int32 (CUDA.warpSize dev))+                       return b+          iterFromStepTo tp (liftInt32 1) (liftInt32 1) steps input $ \step x ->+            app2 combine x =<< readArray TypeInt32 smem step+        else+          return input+++-- Efficient warp-wide reduction using shared memory. The aggregate reduction+-- value for the warp is stored in thread lane zero.+--+-- Each warp requires 48 (1.5 x warp size) elements of shared memory. The+-- routine assumes that is is allocated individually per-warp (i.e. can be+-- indexed in the range [0,warp size)).+--+-- Example: https://github.com/NVlabs/cub/blob/1.5.2/cub/warp/specializations/warp_reduce_smem.cuh#L128+--+reduceWarp+    :: forall e aenv. DeviceProperties+    -> TypeR e+    -> IRFun2 PTX aenv (e -> e -> e)                  -- ^ combination function+    -> Maybe (Operands Int32)                         -- ^ number of items that will be reduced by this warp, otherwise all lanes are valid+    -> Operands e                                     -- ^ this thread's input value+    -> CodeGen PTX (Operands e)                       -- ^ final result+reduceWarp dev typer combine size = reduce 0+  where+    log2 :: Double -> Double+    log2  = P.logBase 2++    -- Number steps required to reduce warp+    steps = P.floor . log2 . P.fromIntegral . CUDA.warpSize $ dev++    valid offset = do+      lane  <- laneId+      i     <- A.add numType lane (liftInt32 offset)+      case size of+        Nothing -> A.lt singleType i (liftInt32 (P.fromIntegral (CUDA.warpSize dev)))+        Just n  -> A.lt singleType i n++    -- Unfold the reduction as a recursive code generation function.+    reduce :: Int -> Operands e -> CodeGen PTX (Operands e)+    reduce step x+      | step > steps = return x+      | otherwise     = do+          let+              offset :: (Bits i, Integral i) => i+              offset = 1 `P.shiftL` step++          y  <- __shfl_down typer x (liftWord32 offset)+          x' <- if (typer, valid offset)+                  then app2 combine x y+                  else return x+          reduce (step + 1) x'++++-- Reduction loops+-- ---------------++reduceFromTo+    :: DeviceProperties+    -> TypeR a+    -> Operands Int                                   -- ^ starting index+    -> Operands Int                                   -- ^ final index (exclusive)+    -> (IRFun2 PTX aenv (a -> a -> a))                -- ^ combination function+    -> (Operands Int -> CodeGen PTX (Operands a))     -- ^ function to retrieve element at index+    -> (Operands a -> CodeGen PTX ())                 -- ^ what to do with the value+    -> CodeGen PTX ()+reduceFromTo dev tp from to combine get set = do++  tid   <- int =<< threadIdx+  bd    <- int =<< blockDim++  valid <- A.sub numType to from+  i     <- A.add numType from tid++  _     <- if (TupRunit, A.gte singleType valid bd)+             then do+               -- All threads in the block will participate in the reduction, so+               -- we can avoid bounds checks+               x <- get i+               r <- reduceBlock dev tp combine Nothing x+               set r++               return (lift TupRunit ())+             else do+               -- Only in-bounds threads can read their input and participate in+               -- the reduction+               when (A.lt singleType i to) $ do+                 x <- get i+                 v <- i32 valid+                 r <- reduceBlock dev tp combine (Just v) x+                 set r++               return (lift TupRunit ())++  return ()+++-- Utilities+-- ---------++i32 :: Operands Int -> CodeGen PTX (Operands Int32)+i32 = A.fromIntegral integralType numType++int :: Operands Int32 -> CodeGen PTX (Operands Int)+int = A.fromIntegral integralType numType++imapFromTo+    :: Operands Int+    -> Operands Int+    -> (Operands Int -> CodeGen PTX ())+    -> CodeGen PTX ()+imapFromTo start end body = do+  bid <- int =<< blockIdx+  gd  <- int =<< gridDim+  i0  <- A.add numType start bid+  imapFromStepTo i0 gd end body+
+ src/Data/Array/Accelerate/LLVM/PTX/CodeGen/FoldSeg.hs view
@@ -0,0 +1,476 @@+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE RebindableSyntax    #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell     #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeOperators       #-}+{-# LANGUAGE ViewPatterns        #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.PTX.CodeGen.FoldSeg+-- Copyright   : [2016..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.PTX.CodeGen.FoldSeg+  where++import Data.Array.Accelerate.Representation.Array+import Data.Array.Accelerate.Representation.Shape+import Data.Array.Accelerate.Representation.Type++import Data.Array.Accelerate.LLVM.CodeGen.Arithmetic                as A+import Data.Array.Accelerate.LLVM.CodeGen.Array+import Data.Array.Accelerate.LLVM.CodeGen.Base+import Data.Array.Accelerate.LLVM.CodeGen.Constant+import Data.Array.Accelerate.LLVM.CodeGen.Environment+import Data.Array.Accelerate.LLVM.CodeGen.Exp+import Data.Array.Accelerate.LLVM.CodeGen.IR+import Data.Array.Accelerate.LLVM.CodeGen.Loop                      as Loop+import Data.Array.Accelerate.LLVM.CodeGen.Monad+import Data.Array.Accelerate.LLVM.CodeGen.Sugar+import Data.Array.Accelerate.LLVM.Compile.Cache++import Data.Array.Accelerate.LLVM.PTX.Analysis.Launch+import Data.Array.Accelerate.LLVM.PTX.CodeGen.Base+import qualified Data.Array.Accelerate.LLVM.PTX.CodeGen.Fold        as Fold ( reduceBlock, reduceWarp, imapFromTo )+import Data.Array.Accelerate.LLVM.PTX.Target++import LLVM.AST.Type.Representation++import qualified Foreign.CUDA.Analysis                              as CUDA++import Control.Monad                                                ( void )+import Control.Monad.Reader                                         ( asks )+import Data.String                                                  ( fromString )+import Prelude                                                      as P+++-- Segmented reduction along the innermost dimension of an array. Performs one+-- reduction per segment of the source array.+--+mkFoldSeg+    :: forall aenv sh i e.+       UID+    -> Gamma            aenv+    -> ArrayR (Array (sh, Int) e)+    -> IntegralType i+    -> IRFun2       PTX aenv (e -> e -> e)+    -> Maybe (IRExp PTX aenv e)+    -> MIRDelayed   PTX aenv (Array (sh, Int) e)+    -> MIRDelayed   PTX aenv (Segments i)+    -> CodeGen      PTX      (IROpenAcc PTX aenv (Array (sh, Int) e))+mkFoldSeg uid aenv repr intTp combine seed arr seg =+  (+++) <$> mkFoldSegP_block uid aenv repr intTp combine seed arr seg+        <*> mkFoldSegP_warp  uid aenv repr intTp combine seed arr seg+++-- This implementation assumes that the segments array represents the offset+-- indices to the source array, rather than the lengths of each segment. The+-- segment-offset approach is required for parallel implementations.+--+-- Each segment is computed by a single thread block, meaning we don't have to+-- worry about inter-block synchronisation.+--+mkFoldSegP_block+    :: forall aenv sh i e.+       UID+    -> Gamma          aenv+    -> ArrayR (Array (sh, Int) e)+    -> IntegralType i+    -> IRFun2     PTX aenv (e -> e -> e)+    -> MIRExp     PTX aenv e+    -> MIRDelayed PTX aenv (Array (sh, Int) e)+    -> MIRDelayed PTX aenv (Segments i)+    -> CodeGen    PTX      (IROpenAcc PTX aenv (Array (sh, Int) e))+mkFoldSegP_block uid aenv repr@(ArrayR shr tp) intTp combine mseed marr mseg = do+  dev <- liftCodeGen $ asks ptxDeviceProperties+  --+  let+      (arrOut, paramOut)  = mutableArray repr "out"+      (arrIn,  paramIn)   = delayedArray "in"  marr+      (arrSeg, paramSeg)  = delayedArray "seg" mseg+      paramEnv            = envParam aenv+      --+      config              = launchConfig dev (CUDA.decWarp dev) dsmem const [|| const ||]+      dsmem n             = sharedMemorySizeAdd tp warps 0+        where+          ws        = CUDA.warpSize dev+          warps     = n `P.quot` ws+  --+  makeOpenAccWith config uid "foldSeg_block" (paramOut ++ paramIn ++ paramSeg ++ paramEnv) $ do++    -- We use a dynamically scheduled work queue in order to evenly distribute+    -- the uneven workload, due to the variable length of each segment, over the+    -- available thread blocks.+    -- queue <- globalWorkQueue++    -- All threads in the block need to know what the start and end indices of+    -- this segment are in order to participate in the reduction. We use+    -- variables in __shared__ memory to communicate these values between+    -- threads in the block. Furthermore, by using a 2-element array, we can+    -- have the first two threads of the block read the start and end indices as+    -- a single coalesced read, since they will be sequential in the+    -- segment-offset array.+    --+    smem  <- staticSharedMem (TupRsingle scalarTypeInt) 2++    -- Compute the number of segments and size of the innermost dimension. These+    -- are required if we are reducing a rank-2 or higher array, to properly+    -- compute the start and end indices of the portion of the array this thread+    -- block reduces. Note that this is a segment-offset array computed by+    -- 'scanl (+) 0' of the segment length array, so its size has increased by+    -- one.+    --+    sz    <- indexHead <$> delayedExtent arrIn+    ss    <- do n <- indexHead <$> delayedExtent arrSeg+                A.sub numType n (liftInt 1)++    -- Each thread block cooperatively reduces a segment.+    -- s0    <- dequeue queue (lift 1)+    -- for s0 (\s -> A.lt singleType s end) (\_ -> dequeue queue (lift 1)) $ \s -> do++    start <- return (liftInt 0)+    end   <- shapeSize shr (irArrayShape arrOut)++    Fold.imapFromTo start end $ \s -> do++      -- The first two threads of the block determine the indices of the+      -- segments array that we will reduce between and distribute those values+      -- to the other threads in the block.+      tid <- threadIdx+      when (A.lt singleType tid (liftInt32 2)) $ do+        i <- case shr of+               ShapeRsnoc ShapeRz -> return s+               _ -> A.rem integralType s ss+        j <- A.add numType i =<< int tid+        v <- app1 (delayedLinearIndex arrSeg) j+        writeArray TypeInt32 smem tid =<< A.fromIntegral intTp numType v++      -- Once all threads have caught up, begin work on the new segment.+      __syncthreads++      u <- readArray TypeInt32 smem (liftInt32 0)+      v <- readArray TypeInt32 smem (liftInt32 1)++      -- Determine the index range of the input array we will reduce over.+      -- Necessary for multidimensional segmented reduction.+      (inf,sup) <- A.unpair <$> case shr of+                                  ShapeRsnoc ShapeRz -> return (A.pair u v)+                                  _ -> do q <- A.quot integralType s ss+                                          a <- A.mul numType q sz+                                          A.pair <$> A.add numType u a+                                                 <*> A.add numType v a++      void $+        if (TupRunit, A.eq singleType inf sup)+          -- This segment is empty. If this is an exclusive reduction the+          -- first thread writes out the initial element for this segment.+          then do+            case mseed of+              Nothing -> return (lift TupRunit ())+              Just z  -> do+                when (A.eq singleType tid (liftInt32 0)) $ writeArray TypeInt arrOut s =<< z+                return (lift TupRunit ())++          -- This is a non-empty segment.+          else do+            -- Step 1: initialise local sums+            --+            -- NOTE: We require all threads to enter this branch and execute the+            -- first step, even if they do not have a valid element and must+            -- return 'undef'. If we attempt to skip this entire section for+            -- non-participating threads (i.e. 'when (i0 < sup)'), it seems that+            -- those threads die and will not participate in the computation of+            -- _any_ further segment. I'm not sure if this is a CUDA oddity+            -- (e.g. we must have all threads convergent on __syncthreads) or+            -- a bug in NVPTX / ptxas.+            --+            i0 <- A.add numType inf =<< int tid+            x0 <- if (tp, A.lt singleType i0 sup)+                    then app1 (delayedLinearIndex arrIn) i0+                    else let+                             go :: TypeR a -> Operands a+                             go TupRunit       = OP_Unit+                             go (TupRpair a b) = OP_Pair (go a) (go b)+                             go (TupRsingle t) = ir t (undef t)+                         in+                         return $ go tp++            bd  <- int =<< blockDim+            v0  <- A.sub numType sup inf+            v0' <- i32 v0+            r0  <- if (tp, A.gte singleType v0 bd)+                     then Fold.reduceBlock dev tp combine Nothing    x0+                     else Fold.reduceBlock dev tp combine (Just v0') x0++            -- Step 2: keep walking over the input+            nxt <- A.add numType inf bd+            r   <- iterFromStepTo tp nxt bd sup r0 $ \offset r -> do++                     -- Wait for threads to catch up before starting the next stripe+                     __syncthreads++                     i' <- A.add numType offset =<< int tid+                     v' <- A.sub numType sup offset+                     r' <- if (tp, A.gte singleType v' bd)+                             -- All threads in the block are in bounds, so we+                             -- can avoid bounds checks.+                             then do+                               x <- app1 (delayedLinearIndex arrIn) i'+                               y <- Fold.reduceBlock dev tp combine Nothing x+                               return y++                             -- Not all threads are valid. Note that we still+                             -- have all threads enter the reduction procedure+                             -- to avoid thread divergence on synchronisation+                             -- points, similar to the above NOTE.+                             else do+                               x <- if (tp, A.lt singleType i' sup)+                                      then app1 (delayedLinearIndex arrIn) i'+                                      else let+                                               go :: TypeR a -> Operands a+                                               go TupRunit       = OP_Unit+                                               go (TupRpair a b) = OP_Pair (go a) (go b)+                                               go (TupRsingle t) = ir t (undef t)+                                           in+                                           return $ go tp++                               z <- i32 v'+                               y <- Fold.reduceBlock dev tp combine (Just z) x+                               return y++                     -- first thread incorporates the result from the previous+                     -- iteration+                     if (tp, A.eq singleType tid (liftInt32 0))+                       then app2 combine r r'+                       else return r'++            -- Step 3: Thread zero writes the aggregate reduction for this+            -- segment to memory. If this is an exclusive fold combine with the+            -- initial element as well.+            when (A.eq singleType tid (liftInt32 0)) $+             writeArray TypeInt arrOut s =<<+               case mseed of+                 Nothing -> return r+                 Just z  -> flip (app2 combine) r =<< z  -- Note: initial element on the left++            return (lift TupRunit ())++    return_+++-- This implementation assumes that the segments array represents the offset+-- indices to the source array, rather than the lengths of each segment. The+-- segment-offset approach is required for parallel implementations.+--+-- Each segment is computed by a single warp, meaning we don't have to worry+-- about inter- or intra-block synchronisation.+--+mkFoldSegP_warp+    :: forall aenv sh i e.+       UID+    -> Gamma          aenv+    -> ArrayR (Array (sh, Int) e)+    -> IntegralType i+    -> IRFun2     PTX aenv (e -> e -> e)+    -> MIRExp     PTX aenv e+    -> MIRDelayed PTX aenv (Array (sh, Int) e)+    -> MIRDelayed PTX aenv (Segments i)+    -> CodeGen    PTX      (IROpenAcc PTX aenv (Array (sh, Int) e))+mkFoldSegP_warp uid aenv repr@(ArrayR shr tp) intTp combine mseed marr mseg = do+  dev <- liftCodeGen $ asks ptxDeviceProperties+  --+  let+      (arrOut, paramOut)  = mutableArray repr "out"+      (arrIn,  paramIn)   = delayedArray "in"  marr+      (arrSeg, paramSeg)  = delayedArray "seg" mseg+      paramEnv            = envParam aenv+      --+      config              = launchConfig dev (CUDA.decWarp dev) dsmem grid gridQ+        where dsmem _n    = 0+      --+      grid n m            = multipleOf n (m `P.quot` ws)+      gridQ               = [|| \n m -> $$multipleOfQ n (m `P.quot` ws) ||]+      --+      ws                  = CUDA.warpSize dev++      int32 :: Integral a => a -> Operands Int32+      int32 = liftInt32 . P.fromIntegral+  --+  makeOpenAccWith config uid "foldSeg_warp" (paramOut ++ paramIn ++ paramSeg ++ paramEnv) $ do++    -- Each warp works independently.+    -- Determine the ID of this warp within the thread block.+    tid   <- threadIdx+    wid   <- A.quot integralType tid (int32 ws)++    -- Number of warps per thread block+    bd    <- blockDim+    wpb   <- A.quot integralType bd (int32 ws)++    -- ID of this warp within the grid+    bid   <- blockIdx+    gwid  <- do a <- A.mul numType bid wpb+                b <- A.add numType wid a+                return b++    -- Compute the number of segments and size of the innermost dimension. These+    -- are required if we are reducing a rank-2 or higher array, to properly+    -- compute the start and end indices of the portion of the array this warp+    -- reduces. Note that this is a segment-offset array computed by 'scanl (+) 0'+    -- of the segment length array, so its size has increased by one.+    --+    sz    <- indexHead <$> delayedExtent arrIn+    ss    <- do a <- indexHead <$> delayedExtent arrSeg+                b <- A.sub numType a (liftInt 1)+                return b++    -- Each thread reduces a segment independently+    s0    <- int gwid+    gd    <- int =<< gridDim+    wpb'  <- int wpb+    step  <- A.mul numType wpb' gd+    end   <- shapeSize shr (irArrayShape arrOut)+    imapFromStepTo s0 step end $ \s -> do++      __syncwarp++      -- The first two threads of the warp determine the indices of the segments+      -- array that we will reduce between and distribute those values to the+      -- other threads in the warp+      lane <- laneId+      idx  <- if (TupRsingle scalarTypeInt, A.lt singleType lane (liftInt32 2))+                 then do+                   a <- case shr of+                          ShapeRsnoc ShapeRz -> return s+                          _                  -> A.rem integralType s ss+                   b <- A.add numType a =<< int lane+                   c <- app1 (delayedLinearIndex arrSeg) b+                   d <- A.fromIntegral intTp numType c+                   return d+                 else+                   return (ir integralType (undef scalarType))++      __syncwarp++      -- Determine the index range of the input array we will reduce over.+      -- Necessary for multidimensional segmented reduction.+      (inf,sup) <- do+        u <- __shfl_idx (TupRsingle scalarTypeInt) idx (liftWord32 0)++        v <- __shfl_idx (TupRsingle scalarTypeInt) idx (liftWord32 1)+        A.unpair <$> case shr of+                       ShapeRsnoc ShapeRz -> return (A.pair u v)+                       _ -> do q <- A.quot integralType s ss+                               a <- A.mul numType q sz+                               A.pair <$> A.add numType u a+                                      <*> A.add numType v a++      __syncwarp++      void $+        if (TupRunit, A.eq singleType inf sup)+          -- This segment is empty. If this is an exclusive reduction the first+          -- lane writes out the initial element for this segment.+          then do+            case mseed of+              Nothing -> return (lift TupRunit ())+              Just z  -> do+                when (A.eq singleType lane (liftInt32 0)) $ writeArray TypeInt arrOut s =<< z+                return (lift TupRunit ())++          -- This is a non-empty segment.+          else do+            -- Step 1: initialise local sums+            --+            -- See comment above why we initialise the loop in this way+            --+            i0  <- A.add numType inf =<< int lane+            x0  <- if (tp, A.lt singleType i0 sup)+                     then app1 (delayedLinearIndex arrIn) i0+                     else let+                              go :: TypeR a -> Operands a+                              go TupRunit       = OP_Unit+                              go (TupRpair a b) = OP_Pair (go a) (go b)+                              go (TupRsingle t) = ir t (undef t)+                          in+                          return $ go tp++            v0  <- A.sub numType sup inf+            v0' <- i32 v0+            r0  <- if (tp, A.gte singleType v0 (liftInt ws))+                     then reduceWarp dev tp combine Nothing    x0+                     else reduceWarp dev tp combine (Just v0') x0++            -- Step 2: Keep walking over the rest of the segment+            nx  <- A.add numType inf (liftInt ws)+            r   <- iterFromStepTo tp nx (liftInt ws) sup r0 $ \offset r -> do++                    -- __syncwarp+                    __syncthreads -- TLM: why is this necessary?++                    i' <- A.add numType offset =<< int lane+                    v' <- A.sub numType sup offset+                    r' <- if (tp, A.gte singleType v' (liftInt ws))+                            then do+                              -- All lanes are in bounds, so avoid bounds checks+                              x <- app1 (delayedLinearIndex arrIn) i'+                              y <- reduceWarp dev tp combine Nothing x+                              return y++                            else do+                              x <- if (tp, A.lt singleType i' sup)+                                     then app1 (delayedLinearIndex arrIn) i'+                                     else let+                                              go :: TypeR a -> Operands a+                                              go TupRunit       = OP_Unit+                                              go (TupRpair a b) = OP_Pair (go a) (go b)+                                              go (TupRsingle t) = ir t (undef t)+                                          in+                                          return $ go tp++                              z <- i32 v'+                              y <- reduceWarp dev tp combine (Just z) x+                              return y++                    -- The first lane incorporates the result from the previous+                    -- iteration+                    if (tp, A.eq singleType lane (liftInt32 0))+                      then app2 combine r r'+                      else return r'++            -- Step 3: Lane zero writes the aggregate reduction for this+            -- segment to memory. If this is an exclusive reduction, also+            -- combine with the initial element+            when (A.eq singleType lane (liftInt32 0)) $+              writeArray TypeInt arrOut s =<<+                case mseed of+                  Nothing -> return r+                  Just z  -> flip (app2 combine) r =<< z    -- Note: initial element on the left++            return (lift TupRunit ())++    return_+++i32 :: IsIntegral i => Operands i -> CodeGen PTX (Operands Int32)+i32 = A.fromIntegral integralType numType++int :: IsIntegral i => Operands i -> CodeGen PTX (Operands Int)+int = A.fromIntegral integralType numType++reduceWarp+    :: forall aenv e.+       DeviceProperties                         -- ^ properties of the target device+    -> TypeR e+    -> IRFun2 PTX aenv (e -> e -> e)            -- ^ combination function+    -> Maybe (Operands Int32)                   -- ^ number of items that will be reduced by this warp, otherwise all lanes are valid+    -> Operands e                               -- ^ calling thread's input element+    -> CodeGen PTX (Operands e)                 -- ^ warp-wide reduction using the specified operator (lane 0 only)+reduceWarp dev t c = Fold.reduceWarp dev t c+
+ src/Data/Array/Accelerate/LLVM/PTX/CodeGen/Generate.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.PTX.CodeGen.Generate+-- Copyright   : [2014..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.PTX.CodeGen.Generate+  where++import Prelude                                                  hiding ( fromIntegral )++-- accelerate+import Data.Array.Accelerate.Representation.Array+import Data.Array.Accelerate.Type++import Data.Array.Accelerate.LLVM.CodeGen.Arithmetic+import Data.Array.Accelerate.LLVM.CodeGen.Array+import Data.Array.Accelerate.LLVM.CodeGen.Base+import Data.Array.Accelerate.LLVM.CodeGen.Environment+import Data.Array.Accelerate.LLVM.CodeGen.Exp+import Data.Array.Accelerate.LLVM.CodeGen.Monad+import Data.Array.Accelerate.LLVM.CodeGen.Sugar+import Data.Array.Accelerate.LLVM.Compile.Cache++import Data.Array.Accelerate.LLVM.PTX.CodeGen.Base+import Data.Array.Accelerate.LLVM.PTX.CodeGen.Loop+import Data.Array.Accelerate.LLVM.PTX.Target                    ( PTX )+++-- Construct a new array by applying a function to each index. Each thread+-- processes multiple adjacent elements.+--+mkGenerate+    :: UID+    -> Gamma aenv+    -> ArrayR (Array sh e)+    -> IRFun1  PTX aenv (sh -> e)+    -> CodeGen PTX      (IROpenAcc PTX aenv (Array sh e))+mkGenerate uid aenv repr@(ArrayR shr _) apply =+  let+      (arrOut, paramOut)  = mutableArray repr "out"+      paramEnv            = envParam aenv+  in+  makeOpenAcc uid "generate" (paramOut ++ paramEnv) $ do++    start <- return (liftInt 0)+    end   <- shapeSize shr (irArrayShape arrOut)++    imapFromTo start end $ \i -> do+      ix <- indexOfInt shr (irArrayShape arrOut) i      -- convert to multidimensional index+      r  <- app1 apply ix                               -- apply generator function+      writeArray TypeInt arrOut i r                     -- store result++    return_+
+ 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..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- 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,48 @@+-- |+-- Module      : Data.Array.Accelerate.LLVM.PTX.CodeGen.Loop+-- Copyright   : [2015..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.PTX.CodeGen.Loop+  where++-- accelerate+import Data.Array.Accelerate.Type++import Data.Array.Accelerate.LLVM.CodeGen.Arithmetic            as A+import Data.Array.Accelerate.LLVM.CodeGen.IR+import Data.Array.Accelerate.LLVM.CodeGen.Monad+import qualified Data.Array.Accelerate.LLVM.CodeGen.Loop        as Loop++import Data.Array.Accelerate.LLVM.PTX.CodeGen.Base+import Data.Array.Accelerate.LLVM.PTX.Target+++-- | A standard loop where the CUDA threads cooperatively step over an index+-- space from the start to end indices. The threads stride the array in a way+-- that maintains memory coalescing.+--+-- The start and end array indices are given as natural array indexes, and the+-- thread specific indices are calculated by the loop.+--+-- > for ( int i = blockDim.x * blockIdx.x + threadIdx.x + start+-- >     ; i <  end+-- >     ; i += blockDim.x * gridDim.x )+--+-- TODO: This assumes that the starting offset retains alignment to the warp+--       boundary. This might not always be the case, so provide a version that+--       explicitly aligns reads to the warp boundary.+--+imapFromTo :: Operands Int -> Operands Int -> (Operands Int -> CodeGen PTX ()) -> CodeGen PTX ()+imapFromTo start end body = do+  step  <- A.fromIntegral integralType numType =<< gridSize+  tid   <- A.fromIntegral integralType numType =<< globalThreadIdx+  i0    <- add numType tid start+  --+  Loop.imapFromStepTo i0 step end body+
+ src/Data/Array/Accelerate/LLVM/PTX/CodeGen/Map.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.PTX.CodeGen.Map+-- Copyright   : [2014..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.PTX.CodeGen.Map+  where++-- accelerate+import Data.Array.Accelerate.Representation.Array+import Data.Array.Accelerate.Representation.Type+import Data.Array.Accelerate.Type++import Data.Array.Accelerate.LLVM.CodeGen.Arithmetic+import Data.Array.Accelerate.LLVM.CodeGen.Array+import Data.Array.Accelerate.LLVM.CodeGen.Base+import Data.Array.Accelerate.LLVM.CodeGen.Environment+import Data.Array.Accelerate.LLVM.CodeGen.Exp+import Data.Array.Accelerate.LLVM.CodeGen.Monad+import Data.Array.Accelerate.LLVM.CodeGen.Sugar+import Data.Array.Accelerate.LLVM.Compile.Cache++import Data.Array.Accelerate.LLVM.PTX.CodeGen.Base+import Data.Array.Accelerate.LLVM.PTX.CodeGen.Loop+import Data.Array.Accelerate.LLVM.PTX.Target                    ( PTX )+++-- Apply a unary function to each element of an array. Each thread processes+-- multiple elements, striding the array by the grid size.+--+mkMap :: UID+      -> Gamma       aenv+      -> ArrayR (Array sh a)+      -> TypeR b+      -> IRFun1  PTX aenv (a -> b)+      -> CodeGen PTX      (IROpenAcc PTX aenv (Array sh b))+mkMap uid aenv repr@(ArrayR shr _) tp' apply =+  let+      (arrOut, paramOut)  = mutableArray (ArrayR shr tp') "out"+      (arrIn,  paramIn)   = mutableArray repr             "in"+      paramEnv            = envParam aenv+  in+  makeOpenAcc uid "map" (paramOut ++ paramIn ++ paramEnv) $ do++    start <- return (liftInt 0)+    end   <- shapeSize shr (irArrayShape arrIn)++    imapFromTo start end $ \i -> do+      xs <- readArray TypeInt arrIn i+      ys <- app1 apply xs+      writeArray TypeInt arrOut i ys++    return_+
+ src/Data/Array/Accelerate/LLVM/PTX/CodeGen/Permute.hs view
@@ -0,0 +1,439 @@+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE ViewPatterns        #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.PTX.CodeGen.Permute+-- Copyright   : [2016..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.PTX.CodeGen.Permute (++  mkPermute,++) where++import Data.Array.Accelerate.AST+import Data.Array.Accelerate.Error+import Data.Array.Accelerate.Representation.Array+import Data.Array.Accelerate.Representation.Elt+import Data.Array.Accelerate.Representation.Shape+import Data.Array.Accelerate.Representation.Type++import Data.Array.Accelerate.LLVM.CodeGen.Arithmetic                as A+import Data.Array.Accelerate.LLVM.CodeGen.Array+import Data.Array.Accelerate.LLVM.CodeGen.Base+import Data.Array.Accelerate.LLVM.CodeGen.Constant+import Data.Array.Accelerate.LLVM.CodeGen.Environment+import Data.Array.Accelerate.LLVM.CodeGen.Exp+import Data.Array.Accelerate.LLVM.CodeGen.IR+import Data.Array.Accelerate.LLVM.CodeGen.Monad+import Data.Array.Accelerate.LLVM.CodeGen.Permute+import Data.Array.Accelerate.LLVM.CodeGen.Ptr+import Data.Array.Accelerate.LLVM.CodeGen.Sugar+import Data.Array.Accelerate.LLVM.Compile.Cache++import Data.Array.Accelerate.LLVM.PTX.CodeGen.Base+import Data.Array.Accelerate.LLVM.PTX.CodeGen.Loop+import Data.Array.Accelerate.LLVM.PTX.Target++import LLVM.AST.Type.Instruction+import LLVM.AST.Type.Instruction.Atomic+import LLVM.AST.Type.Instruction.RMW                                as RMW+import LLVM.AST.Type.Instruction.Volatile+import LLVM.AST.Type.GetElementPtr+import LLVM.AST.Type.Operand+import LLVM.AST.Type.Representation++import Foreign.CUDA.Analysis++import Control.Monad                                                ( void )+import Control.Monad.Reader                                         ( asks )+import Prelude+++-- Forward permutation specified by an indexing mapping. The resulting array is+-- initialised with the given defaults, and any further values that are permuted+-- into the result array are added to the current value using the combination+-- function.+--+-- The combination function must be /associative/ and /commutative/. Elements+-- that are mapped to the magic index 'ignore' are dropped.+--+-- Parallel forward permutation has to take special care because different+-- threads could concurrently try to update the same memory location. Where+-- available we make use of special atomic instructions and other optimisations,+-- but in the general case each element of the output array has a lock which+-- must be obtained by the thread before it can update that memory location.+--+-- TODO: After too many failures to acquire the lock on an element, the thread+-- should back off and try a different element, adding this failed element to+-- a queue or some such.+--+mkPermute+    :: HasCallStack+    => UID+    -> Gamma            aenv+    -> ArrayR (Array sh e)+    -> ShapeR sh'+    -> IRPermuteFun PTX aenv (e -> e -> e)+    -> IRFun1       PTX aenv (sh -> PrimMaybe sh')+    -> MIRDelayed   PTX aenv (Array sh e)+    -> CodeGen      PTX      (IROpenAcc PTX aenv (Array sh' e))+mkPermute uid aenv repr shr' IRPermuteFun{..} project arr =+  case atomicRMW of+    Just (rmw, f) -> mkPermute_rmw   uid aenv repr shr' rmw f   project arr+    _             -> mkPermute_mutex uid aenv repr shr' combine project arr+++-- Parallel forward permutation function which uses atomic instructions to+-- implement lock-free array updates.+--+-- Atomic instruction support on CUDA devices is a bit patchy, so depending on+-- the element type and compute capability of the target hardware we may need to+-- emulate the operation using atomic compare-and-swap.+--+--              Int32    Int64    Float16    Float32    Float64+--           +-------------------------------------------------+--    (+)    |  2.0       2.0       7.0        2.0        6.0+--    (-)    |  2.0       2.0        x          x          x+--    (.&.)  |  2.0       3.2+--    (.|.)  |  2.0       3.2+--    xor    |  2.0       3.2+--    min    |  2.0       3.2        x          x          x+--    max    |  2.0       3.2        x          x          x+--    CAS    |  2.0       2.0+--+-- Note that NVPTX requires at least compute 2.0, so we can always implement the+-- lockfree update operations in terms of compare-and-swap.+--+mkPermute_rmw+    :: HasCallStack+    => UID+    -> Gamma aenv+    -> ArrayR (Array sh e)+    -> ShapeR sh'+    -> RMWOperation+    -> IRFun1     PTX aenv (e -> e)+    -> IRFun1     PTX aenv (sh -> PrimMaybe sh')+    -> MIRDelayed PTX aenv (Array sh e)+    -> CodeGen    PTX      (IROpenAcc PTX aenv (Array sh' e))+mkPermute_rmw uid aenv (ArrayR shr tp) shr' rmw update project marr = do+  dev <- liftCodeGen $ asks ptxDeviceProperties+  --+  let+      outR                = ArrayR shr' tp+      (arrOut, paramOut)  = mutableArray outR "out"+      (arrIn,  paramIn)   = delayedArray "in" marr+      paramEnv            = envParam aenv+      start               = liftInt 0+      --+      bytes               = bytesElt tp+      compute             = computeCapability dev+      compute32           = Compute 3 2+      compute60           = Compute 6 0+      compute70           = Compute 7 0+  --+  makeOpenAcc uid "permute_rmw" (paramOut ++ paramIn ++ paramEnv) $ do++    shIn  <- delayedExtent arrIn+    end   <- shapeSize shr shIn++    imapFromTo start end $ \i -> do++      ix  <- indexOfInt shr shIn i+      ix' <- app1 project ix++      when (isJust ix') $ do+        j <- intOfIndex shr' (irArrayShape arrOut) =<< fromJust ix'+        x <- app1 (delayedLinearIndex arrIn) i+        r <- app1 update x++        case rmw of+          Exchange+            -> writeArray TypeInt arrOut j r+          --+          _ | TupRsingle (SingleScalarType s)   <- tp+            , adata                             <- irArrayData arrOut+            -> do+                  addr <- instr' $ GetElementPtr $ GEP1 (SingleScalarType s) (asPtr defaultAddrSpace (op s adata)) (op integralType j)+                  --+                  let+                      rmw_integral :: IntegralType t -> Operand (Ptr t) -> Operand t -> CodeGen PTX ()+                      rmw_integral t ptr val+                        | primOk    = void . instr' $ AtomicRMW (IntegralNumType t) NonVolatile rmw ptr val (CrossThread, AcquireRelease)+                        | otherwise =+                            case rmw of+                              RMW.And -> atomicCAS_rmw s' (A.band t (ir t val)) ptr+                              RMW.Or  -> atomicCAS_rmw s' (A.bor  t (ir t val)) ptr+                              RMW.Xor -> atomicCAS_rmw s' (A.xor  t (ir t val)) ptr+                              RMW.Min -> atomicCAS_cmp s' A.lt ptr val+                              RMW.Max -> atomicCAS_cmp s' A.gt ptr val+                              _       -> internalError "unexpected transition"+                        where+                          s'      = NumSingleType (IntegralNumType t)+                          primOk  = compute >= compute32+                                 || bytes == 4+                                 || case rmw of+                                      RMW.Add -> True+                                      RMW.Sub -> True+                                      _       -> False++                      rmw_floating :: FloatingType t -> Operand (Ptr t) -> Operand t -> CodeGen PTX ()+                      rmw_floating t ptr val =+                        case rmw of+                          RMW.Min       -> atomicCAS_cmp s' A.lt ptr val+                          RMW.Max       -> atomicCAS_cmp s' A.gt ptr val+                          RMW.Sub       -> atomicCAS_rmw s' (A.sub n (ir t val)) ptr+                          RMW.Add+                            | primAdd   -> atomicAdd_f t ptr val+                            | otherwise -> atomicCAS_rmw s' (A.add n (ir t val)) ptr+                          _             -> internalError "unexpected transition"+                        where+                          n       = FloatingNumType t+                          s'      = NumSingleType n+                          primAdd =+                            case t of+                              TypeHalf   -> compute >= compute70+                              TypeFloat  -> True+                              TypeDouble -> compute >= compute60+                  case s of+                    NumSingleType (IntegralNumType t) -> rmw_integral t addr (op t r)+                    NumSingleType (FloatingNumType t) -> rmw_floating t addr (op t r)+          --+          _ -> internalError "unexpected transition"++    return_+++-- Parallel forward permutation function which uses a spinlock to acquire+-- a mutex before updating the value at that location.+--+mkPermute_mutex+    :: UID+    -> Gamma          aenv+    -> ArrayR (Array sh e)+    -> ShapeR sh'+    -> IRFun2     PTX aenv (e -> e -> e)+    -> IRFun1     PTX aenv (sh -> PrimMaybe sh')+    -> MIRDelayed PTX aenv (Array sh e)+    -> CodeGen    PTX      (IROpenAcc PTX aenv (Array sh' e))+mkPermute_mutex uid aenv (ArrayR shr tp) shr' combine project marr =+  let+      outR                  = ArrayR shr' tp+      lockR                 = ArrayR (ShapeRsnoc ShapeRz) (TupRsingle scalarTypeWord32)+      (arrOut,  paramOut)   = mutableArray outR "out"+      (arrLock, paramLock)  = mutableArray lockR "lock"+      (arrIn,   paramIn)    = delayedArray "in" marr+      paramEnv              = envParam aenv+      start                 = liftInt 0+  in+  makeOpenAcc uid "permute_mutex" (paramOut ++ paramLock ++ paramIn ++ paramEnv) $ do++    shIn  <- delayedExtent arrIn+    end   <- shapeSize shr shIn++    imapFromTo start end $ \i -> do++      ix  <- indexOfInt shr shIn i+      ix' <- app1 project ix++      -- project element onto the destination array and (atomically) update+      when (isJust ix') $ do+        j <- intOfIndex shr' (irArrayShape arrOut) =<< fromJust ix'+        x <- app1 (delayedLinearIndex arrIn) i++        atomically arrLock j $ do+          y <- readArray TypeInt arrOut j+          r <- app2 combine x y+          writeArray TypeInt arrOut j r++    return_+++-- Atomically execute the critical section only when the lock at the given+-- array indexed is obtained.+--+atomically+    :: IRArray (Vector Word32)+    -> Operands Int+    -> CodeGen PTX a+    -> CodeGen PTX a+atomically barriers i action = do+  dev <- liftCodeGen $ asks ptxDeviceProperties+  if computeCapability dev >= Compute 7 0+     then atomically_thread barriers i action+     else atomically_warp   barriers i action+++-- Atomically execute the critical section only when the lock at the given+-- array index is obtained. The thread spins waiting for the lock to be+-- released with exponential backoff on failure in case the lock is+-- contended.+--+-- > uint32_t ns = 8;+-- > while ( atomic_exchange(&lock[i], 1) == 1 ) {+-- >     __nanosleep(ns);+-- >     if ( ns < 256 ) {+-- >         ns *= 2;+-- >     }+-- > }+--+-- Requires independent thread scheduling features of SM7+.+--+atomically_thread+    :: IRArray (Vector Word32)+    -> Operands Int+    -> CodeGen PTX a+    -> CodeGen PTX a+atomically_thread barriers i action = do+  let+      lock    = integral integralType 1+      unlock  = integral integralType 0+      unlock' = ir TypeWord32 unlock+      i32     = TupRsingle scalarTypeInt32+  --+  entry <- newBlock "spinlock.entry"+  sleep <- newBlock "spinlock.backoff"+  moar  <- newBlock "spinlock.backoff-moar"+  start <- newBlock "spinlock.critical-start"+  end   <- newBlock "spinlock.critical-end"+  exit  <- newBlock "spinlock.exit"+  ns    <- fresh i32++  addr  <- instr' $ GetElementPtr $ GEP1 scalarType (asPtr defaultAddrSpace (op integralType (irArrayData barriers))) (op integralType i)+  top   <- br entry++  -- Loop until this thread has completed its critical section. If the slot+  -- was unlocked we just acquired the lock and the thread can perform its+  -- critical section, otherwise sleep the thread and try again later.+  setBlock entry+  old   <- instr $ AtomicRMW numType NonVolatile Exchange addr lock (CrossThread, Acquire)+  ok    <- A.eq singleType old unlock'+  _     <- cbr ok start sleep++  -- We did not acquire the lock. Sleep the thread for a small amount of+  -- time and (possibly) increase the sleep duration for the next round+  setBlock sleep+  _     <- nanosleep ns+  p     <- A.lt singleType ns (ir TypeInt32 (integral integralType 256))+  _     <- cbr p moar entry++  setBlock moar+  ns'   <- A.mul numType ns (ir TypeInt32 (integral integralType 2))+  _     <- phi' i32 entry ns [(ir TypeInt32 (integral (integralType) 8), top), (ns, sleep), (ns', moar)]+  _     <- br entry++  -- If we just acquired the lock, execute the critical section, then+  -- release the lock and continue with your day.+  setBlock start+  r     <- action+  _     <- br end++  setBlock end+  _     <- instr $ AtomicRMW numType NonVolatile Exchange addr unlock (CrossThread, AcquireRelease)+  _     <- __threadfence_grid   -- TODO: why is this required?+  _     <- br exit++  setBlock exit+  return r+++-- Atomically execute the critical section only when the lock at the given array+-- index is obtained. The thread spins waiting for the lock to be released and+-- there is no backoff strategy in case the lock is contended.+--+-- The canonical implementation of a spin-lock looks like this:+--+-- > do {+-- >   old = atomic_exchange(&lock[i], 1);+-- > } while (old == 1);+-- >+-- > /* critical section */+-- >+-- > atomic_exchange(&lock[i], 0);+--+-- The initial loop repeatedly attempts to take the lock by writing a 1 (locked)+-- into the lock slot. Once the 'old' state of the lock returns 0 (unlocked),+-- then we just acquired the lock and the atomic section can be computed.+-- Finally, the lock is released by writing 0 back to the lock slot.+--+-- However, there is a complication with CUDA devices because all threads in+-- a warp must execute in lockstep (with predicated execution). In the above+-- setup, once a thread acquires a lock, then it will be disabled and stop+-- participating in the loop, waiting for all other threads (to acquire their+-- locks) before continuing program execution. If two threads in the same warp+-- attempt to acquire the same lock, then once the lock is acquired by one+-- thread then it will sit idle waiting while the second thread spins attempting+-- to grab a lock that will never be released because the first thread (which+-- holds the lock) can not make progress. DEADLOCK.+--+-- To prevent this situation we must invert the algorithm so that threads can+-- always make progress, until each warp in the thread has committed their+-- result.+--+-- > done = 0;+-- > do {+-- >   if ( atomic_exchange(&lock[i], 1) == 0 ) {+-- >+-- >     /* critical section */+-- >+-- >     done = 1;+-- >     atomic_exchange(&lock[i], 0);+-- >   }+-- > } while ( done == 0 );+--+atomically_warp+    :: IRArray (Vector Word32)+    -> Operands Int+    -> CodeGen PTX a+    -> CodeGen PTX a+atomically_warp barriers i action = do+  let+      lock    = integral integralType 1+      unlock  = integral integralType 0+      unlock' = ir TypeWord32 unlock+  --+  entry <- newBlock "spinlock.entry"+  start <- newBlock "spinlock.critical-start"+  end   <- newBlock "spinlock.critical-end"+  exit  <- newBlock "spinlock.exit"++  addr <- instr' $ GetElementPtr $ GEP1 scalarType (asPtr defaultAddrSpace (op integralType (irArrayData barriers))) (op integralType i)+  _    <- br entry++  -- Loop until this thread has completed its critical section. If the slot was+  -- unlocked then we just acquired the lock and the thread can perform the+  -- critical section, otherwise skip to the bottom of the critical section.+  setBlock entry+  old  <- instr $ AtomicRMW numType NonVolatile Exchange addr lock   (CrossThread, Acquire)+  ok   <- A.eq singleType old unlock'+  no   <- cbr ok start end++  -- If we just acquired the lock, execute the critical section+  setBlock start+  r    <- action+  _    <- instr $ AtomicRMW numType NonVolatile Exchange addr unlock (CrossThread, AcquireRelease)+  yes  <- br end++  -- At the base of the critical section, threads participate in a memory fence+  -- to ensure the lock state is committed to memory. Depending on which+  -- incoming edge the thread arrived at this block from determines whether they+  -- have completed their critical section.+  setBlock end+  res  <- freshLocalName+  done <- phi1 end res [(boolean True, yes), (boolean False, no)]++  __syncthreads+  _    <- cbr (OP_Bool done) exit entry++  setBlock exit+  return r+
+ src/Data/Array/Accelerate/LLVM/PTX/CodeGen/Scan.hs view
@@ -0,0 +1,1300 @@+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE PatternGuards       #-}+{-# LANGUAGE RebindableSyntax    #-}+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell     #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeOperators       #-}+{-# LANGUAGE ViewPatterns        #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.PTX.CodeGen.Scan+-- Copyright   : [2016..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.PTX.CodeGen.Scan (++  mkScan, mkScan',++) where++import Data.Array.Accelerate.AST                                    ( Direction(..) )+import Data.Array.Accelerate.Representation.Array+import Data.Array.Accelerate.Representation.Shape+import Data.Array.Accelerate.Representation.Type++import Data.Array.Accelerate.LLVM.CodeGen.Arithmetic                as A+import Data.Array.Accelerate.LLVM.CodeGen.Array+import Data.Array.Accelerate.LLVM.CodeGen.Base+import Data.Array.Accelerate.LLVM.CodeGen.Constant+import Data.Array.Accelerate.LLVM.CodeGen.Environment+import Data.Array.Accelerate.LLVM.CodeGen.Exp+import Data.Array.Accelerate.LLVM.CodeGen.IR+import Data.Array.Accelerate.LLVM.CodeGen.Loop+import Data.Array.Accelerate.LLVM.CodeGen.Monad+import Data.Array.Accelerate.LLVM.CodeGen.Sugar+import Data.Array.Accelerate.LLVM.Compile.Cache+import Data.Array.Accelerate.LLVM.PTX.Analysis.Launch+import Data.Array.Accelerate.LLVM.PTX.CodeGen.Base+import Data.Array.Accelerate.LLVM.PTX.CodeGen.Generate+import Data.Array.Accelerate.LLVM.PTX.Target++import LLVM.AST.Type.Representation++import qualified Foreign.CUDA.Analysis                              as CUDA++import Control.Applicative+import Control.Monad                                                ( (>=>), void )+import Control.Monad.Reader                                         ( asks )+import Data.String                                                  ( fromString )+import Data.Coerce                                                  as Safe+import Data.Bits                                                    as P+import Prelude                                                      as P hiding ( last )++++-- 'Data.List.scanl' or 'Data.List.scanl1' style exclusive scan, but with the+-- restriction that the combination function must be associative to enable+-- efficient parallel implementation.+--+-- > scanl (+) 10 (use $ fromList (Z :. 10) [0..])+-- >+-- > ==> Array (Z :. 11) [10,10,11,13,16,20,25,31,38,46,55]+--+mkScan+    :: forall aenv sh e.+       UID+    -> Gamma            aenv+    -> ArrayR (Array (sh, Int) e)+    -> Direction+    -> IRFun2       PTX aenv (e -> e -> e)+    -> Maybe (IRExp PTX aenv e)+    -> MIRDelayed   PTX aenv (Array (sh, Int) e)+    -> CodeGen      PTX      (IROpenAcc PTX aenv (Array (sh, Int) e))+mkScan uid aenv repr dir combine seed arr+  = foldr1 (+++) <$> sequence (codeScan ++ codeFill)++  where+    codeScan = case repr of+      ArrayR (ShapeRsnoc ShapeRz) tp -> [ mkScanAllP1 dir uid aenv tp   combine seed arr+                                        , mkScanAllP2 dir uid aenv tp   combine+                                        , mkScanAllP3 dir uid aenv tp   combine seed+                                        ]+      _                              -> [ mkScanDim   dir uid aenv repr combine seed arr+                                        ]+    codeFill = case seed of+      Just s  -> [ mkScanFill uid aenv repr s ]+      Nothing -> []+++-- Variant of 'scanl' where the final result is returned in a separate array.+--+-- > scanr' (+) 10 (use $ fromList (Z :. 10) [0..])+-- >+-- > ==> ( Array (Z :. 10) [10,10,11,13,16,20,25,31,38,46]+--       , Array Z [55]+--       )+--+mkScan'+    :: forall aenv sh e.+       UID+    -> Gamma          aenv+    -> ArrayR (Array (sh, Int) e)+    -> Direction+    -> IRFun2     PTX aenv (e -> e -> e)+    -> IRExp      PTX aenv e+    -> MIRDelayed PTX aenv (Array (sh, Int) e)+    -> CodeGen    PTX      (IROpenAcc PTX aenv (Array (sh, Int) e, Array sh e))+mkScan' uid aenv repr dir combine seed arr+  | ArrayR (ShapeRsnoc ShapeRz) tp <- repr+  = foldr1 (+++) <$> sequence [ mkScan'AllP1 dir uid aenv tp combine seed arr+                              , mkScan'AllP2 dir uid aenv tp combine+                              , mkScan'AllP3 dir uid aenv tp combine+                              , mkScan'Fill      uid aenv repr seed+                              ]+  --+  | otherwise+  = (+++) <$> mkScan'Dim dir uid aenv repr combine seed arr+          <*> mkScan'Fill    uid aenv repr seed+++-- Device wide scans+-- -----------------+--+-- This is a classic two-pass algorithm which proceeds in two phases and+-- requires ~4n data movement to global memory. In future we would like to+-- replace this with a single pass algorithm.+--++-- Parallel scan, step 1.+--+-- Threads scan a stripe of the input into a temporary array, incorporating the+-- initial element and any fused functions on the way. The final reduction+-- result of this chunk is written to a separate array.+--+mkScanAllP1+    :: forall aenv e.+       Direction+    -> UID+    -> Gamma          aenv                      -- ^ array environment+    -> TypeR e+    -> IRFun2     PTX aenv (e -> e -> e)        -- ^ combination function+    -> MIRExp     PTX aenv e                    -- ^ seed element, if this is an exclusive scan+    -> MIRDelayed PTX aenv (Vector e)           -- ^ input data+    -> CodeGen    PTX (IROpenAcc PTX aenv (Vector e))+mkScanAllP1 dir uid aenv tp combine mseed marr = do+  dev <- liftCodeGen $ asks ptxDeviceProperties+  --+  let+      (arrOut, paramOut)  = mutableArray (ArrayR dim1 tp) "out"+      (arrTmp, paramTmp)  = mutableArray (ArrayR dim1 tp) "tmp"+      (arrIn,  paramIn)   = delayedArray "in" marr+      end                 = indexHead (irArrayShape arrTmp)+      paramEnv            = envParam aenv+      --+      config              = launchConfig dev (CUDA.incWarp dev) (scanSMemSize dev tp) const [|| const ||]+  --+  makeOpenAccWith config uid "scanP1" (paramTmp ++ paramOut ++ paramIn ++ paramEnv) $ do++    -- Size of the input array+    sz  <- indexHead <$> delayedExtent arrIn++    -- A thread block scans a non-empty stripe of the input, storing the final+    -- block-wide aggregate into a separate array+    --+    -- For exclusive scans, thread 0 of segment 0 must incorporate the initial+    -- element into the input and output. Threads shuffle their indices+    -- appropriately.+    --+    bid <- blockIdx+    gd  <- gridDim+    gd' <- int gd+    s0  <- int bid++    -- iterating over thread-block-wide segments+    -- Note that 'end' is a multiple of the gd', and the control flow is thus uniform in the loop.+    -- This is set in scanAllOp in Data.Array.Accelerate.LLVM.PTX.Execute.+    -- Hence we can run __syncthreads safely.+    imapFromStepTo s0 gd' end $ \chunk -> do++      -- Make sure all threads have finished previous iterations,+      -- so we can reuse (and overwrite) shared memory.+      __syncthreads++      bd    <- blockDim+      bd'   <- int bd+      inf   <- A.mul numType chunk bd'++      -- index i* is the index that this thread will read data from. Recall that+      -- the supremum index is exclusive+      tid   <- threadIdx+      tid'  <- int tid+      i0    <- case dir of+                 LeftToRight -> A.add numType inf tid'+                 RightToLeft -> do x <- A.sub numType sz inf+                                   y <- A.sub numType x tid'+                                   z <- A.sub numType y (liftInt 1)+                                   return z++      -- index j* is the index that we write to. Recall that for exclusive scans+      -- the output array is one larger than the input; the initial element will+      -- be written into this spot by thread 0 of the first thread block.+      j0    <- case mseed of+                 Nothing -> return i0+                 Just _  -> case dir of+                              LeftToRight -> A.add numType i0 (liftInt 1)+                              RightToLeft -> return i0++      -- If this thread has input, read data and participate in thread-block scan+      let valid i = case dir of+                      LeftToRight -> A.lt  singleType i sz+                      RightToLeft -> A.gte singleType i (liftInt 0)++      when (valid i0) $ do+        x0 <- app1 (delayedLinearIndex arrIn) i0+        x1 <- case mseed of+                Nothing   -> return x0+                Just seed ->+                  if (tp, A.eq singleType tid (liftInt32 0) `A.land'` A.eq singleType chunk (liftInt 0))+                    then do+                      z <- seed+                      case dir of+                        LeftToRight -> writeArray TypeInt32 arrOut (liftInt32 0) z >> app2 combine z x0+                        RightToLeft -> writeArray TypeInt   arrOut sz            z >> app2 combine x0 z+                    else+                      return x0++        n  <- A.sub numType sz inf+        n' <- i32 n+        x2 <- if (tp, A.gte singleType n bd')+                then scanBlock dir dev tp combine Nothing   x1+                else scanBlock dir dev tp combine (Just n') x1++        -- Write this thread's scan result to memory+        writeArray TypeInt arrOut j0 x2++        -- The last thread also writes its result---the aggregate for this+        -- thread block---to the temporary partial sums array. This is only+        -- necessary for full blocks in a multi-block scan; the final+        -- partially-full tile does not have a successor block.+        last <- A.sub numType bd (liftInt32 1)+        when (A.gt singleType gd (liftInt32 1) `land'` A.eq singleType tid last) $+          case dir of+            LeftToRight -> writeArray TypeInt arrTmp chunk x2+            RightToLeft -> do u <- A.sub numType end chunk+                              v <- A.sub numType u (liftInt 1)+                              writeArray TypeInt arrTmp v x2++    return_+++-- Parallel scan, step 2+--+-- A single thread block performs a scan of the per-block aggregates computed in+-- step 1. This gives the per-block prefix which must be added to each element+-- in step 3.+--+mkScanAllP2+    :: forall aenv e.+       Direction+    -> UID+    -> Gamma       aenv                         -- ^ array environment+    -> TypeR e+    -> IRFun2  PTX aenv (e -> e -> e)           -- ^ combination function+    -> CodeGen PTX      (IROpenAcc PTX aenv (Vector e))+mkScanAllP2 dir uid aenv tp combine = do+  dev <- liftCodeGen $ asks ptxDeviceProperties+  --+  let+      (arrTmp, paramTmp)  = mutableArray (ArrayR dim1 tp) "tmp"+      paramEnv            = envParam aenv+      start               = liftInt 0+      end                 = indexHead (irArrayShape arrTmp)+      --+      config              = launchConfig dev (CUDA.incWarp dev) (scanSMemSize dev tp) grid gridQ+      grid _ _            = 1+      gridQ               = [|| \_ _ -> 1 ||]+  --+  makeOpenAccWith config uid "scanP2" (paramTmp ++ paramEnv) $ do++    -- The first and last threads of the block need to communicate the+    -- block-wide aggregate as a carry-in value across iterations.+    --+    -- TODO: We could optimise this a bit if we can get access to the shared+    -- memory area used by 'scanBlockSMem', and from there directly read the+    -- value computed by the last thread.+    carry <- staticSharedMem tp 1++    bd    <- blockDim+    bd'   <- int bd++    imapFromStepTo start bd' end $ \offset -> do++      -- Index of the partial sums array that this thread will process.+      tid   <- threadIdx+      tid'  <- int tid+      i0    <- case dir of+                 LeftToRight -> A.add numType offset tid'+                 RightToLeft -> do x <- A.sub numType end offset+                                   y <- A.sub numType x tid'+                                   z <- A.sub numType y (liftInt 1)+                                   return z++      let valid i = case dir of+                      LeftToRight -> A.lt  singleType i end+                      RightToLeft -> A.gte singleType i start++      -- wait for the carry-in value to be updated+      __syncthreads++      when (valid i0) $ do+        x0 <- readArray TypeInt arrTmp i0+        x1 <- if (tp, A.gt singleType offset (liftInt 0) `land'` A.eq singleType tid (liftInt32 0))+                then do+                  c <- readArray TypeInt32 carry (liftInt32 0)+                  case dir of+                    LeftToRight -> app2 combine c x0+                    RightToLeft -> app2 combine x0 c+                else do+                  return x0++        n  <- A.sub numType end offset+        n' <- i32 n+        x2 <- if (tp, A.gte singleType n bd')+                then scanBlock dir dev tp combine Nothing   x1+                else scanBlock dir dev tp combine (Just n') x1++        -- Update the temporary array with this thread's result+        writeArray TypeInt arrTmp i0 x2++        -- The last thread writes the carry-out value. If the last thread is not+        -- active, then this must be the last stripe anyway.+        last <- A.sub numType bd (liftInt32 1)+        when (A.eq singleType tid last) $+          writeArray TypeInt32 carry (liftInt32 0) x2++    return_+++-- Parallel scan, step 3.+--+-- Threads combine every element of the partial block results with the carry-in+-- value computed in step 2.+--+mkScanAllP3+    :: forall aenv e.+       Direction+    -> UID+    -> Gamma       aenv                         -- ^ array environment+    -> TypeR e+    -> IRFun2  PTX aenv (e -> e -> e)           -- ^ combination function+    -> MIRExp  PTX aenv e                       -- ^ seed element, if this is an exclusive scan+    -> CodeGen PTX      (IROpenAcc PTX aenv (Vector e))+mkScanAllP3 dir uid aenv tp combine mseed = do+  dev <- liftCodeGen $ asks ptxDeviceProperties+  --+  let+      (arrOut, paramOut)  = mutableArray (ArrayR dim1 tp) "out"+      (arrTmp, paramTmp)  = mutableArray (ArrayR dim1 tp) "tmp"+      paramEnv            = envParam aenv+      --+      stride              = local     (TupRsingle scalarTypeInt) "ix.stride"+      paramStride         = parameter (TupRsingle scalarTypeInt) "ix.stride"+      --+      config              = launchConfig dev (CUDA.incWarp dev) (const 0) const [|| const ||]+  --+  makeOpenAccWith config uid "scanP3" (paramTmp ++ paramOut ++ paramStride ++ paramEnv) $ do++    sz  <- return $ indexHead (irArrayShape arrOut)+    tid <- int =<< threadIdx++    -- Threads that will never contribute can just exit immediately. The size of+    -- each chunk is set by the block dimension of the step 1 kernel, which may+    -- be different from the block size of this kernel.+    when (A.lt singleType tid stride) $ do++      -- Iterate over the segments computed in phase 1. Note that we have one+      -- fewer chunk to process because the first has no carry-in.+      bid <- int =<< blockIdx+      gd  <- int =<< gridDim+      end <- A.sub numType (indexHead (irArrayShape arrTmp)) (liftInt 1)++      imapFromStepTo bid gd end $ \chunk -> do++        -- Determine the start and end indicies of this chunk to which we will+        -- carry-in the value. Returned for left-to-right traversal.+        (inf,sup) <- case dir of+                       LeftToRight -> do+                         a <- A.add numType chunk (liftInt 1)+                         b <- A.mul numType stride a+                         case mseed of+                           Just{}  -> do+                             c <- A.add numType    b (liftInt 1)+                             d <- A.add numType    c stride+                             e <- A.min singleType d sz+                             return (c,e)+                           Nothing -> do+                             c <- A.add numType    b stride+                             d <- A.min singleType c sz+                             return (b,d)+                       RightToLeft -> do+                         a <- A.sub numType end chunk+                         b <- A.mul numType stride a+                         c <- A.sub numType sz b+                         case mseed of+                           Just{}  -> do+                             d <- A.sub numType    c (liftInt 1)+                             e <- A.sub numType    d stride+                             f <- A.max singleType e (liftInt 0)+                             return (f,d)+                           Nothing -> do+                             d <- A.sub numType    c stride+                             e <- A.max singleType d (liftInt 0)+                             return (e,c)++        -- Read the carry-in value+        carry     <- case dir of+                       LeftToRight -> readArray TypeInt arrTmp chunk+                       RightToLeft -> do+                         a <- A.add numType chunk (liftInt 1)+                         b <- readArray TypeInt arrTmp a+                         return b++        -- Apply the carry-in value to each element in the chunk+        bd        <- int =<< blockDim+        i0        <- A.add numType inf tid+        imapFromStepTo i0 bd sup $ \i -> do+          v <- readArray TypeInt arrOut i+          u <- case dir of+                 LeftToRight -> app2 combine carry v+                 RightToLeft -> app2 combine v carry+          writeArray TypeInt arrOut i u++    return_+++-- Parallel scan', step 1.+--+-- Similar to mkScanAllP1. Threads scan a stripe of the input into a temporary+-- array, incorporating the initial element and any fused functions on the way.+-- The final reduction result of this chunk is written to a separate array.+--+mkScan'AllP1+    :: forall aenv e.+       Direction+    -> UID+    -> Gamma          aenv+    -> TypeR e+    -> IRFun2     PTX aenv (e -> e -> e)+    -> IRExp      PTX aenv e+    -> MIRDelayed PTX aenv (Vector e)+    -> CodeGen    PTX      (IROpenAcc PTX aenv (Vector e, Scalar e))+mkScan'AllP1 dir uid aenv tp combine seed marr = do+  dev <- liftCodeGen $ asks ptxDeviceProperties+  --+  let+      (arrOut, paramOut)  = mutableArray (ArrayR dim1 tp) "out"+      (arrTmp, paramTmp)  = mutableArray (ArrayR dim1 tp) "tmp"+      (arrIn,  paramIn)   = delayedArray "in" marr+      end                 = indexHead (irArrayShape arrTmp)+      paramEnv            = envParam aenv+      --+      config              = launchConfig dev (CUDA.incWarp dev) (scanSMemSize dev tp) const [|| const ||]+  --+  makeOpenAccWith config uid "scanP1" (paramTmp ++ paramOut ++ paramIn ++ paramEnv) $ do++    -- Size of the input array+    sz  <- indexHead <$> delayedExtent arrIn++    -- A thread block scans a non-empty stripe of the input, storing the partial+    -- result and the final block-wide aggregate+    bid <- int =<< blockIdx+    gd  <- int =<< gridDim++    -- iterate over thread-block wide segments+    -- Note that 'end' is a multiple of the gd', and the control flow is thus uniform in the loop.+    -- This is set in scan'AllOp in Data.Array.Accelerate.LLVM.PTX.Execute.+    -- Hence we can run __syncthreads safely.+    imapFromStepTo bid gd end $ \seg -> do++      -- Make sure all threads have finished previous iterations,+      -- so we can reuse (and overwrite) shared memory.+      __syncthreads++      bd  <- int =<< blockDim+      inf <- A.mul numType seg bd++      -- i* is the index that this thread will read data from+      tid <- int =<< threadIdx+      i0  <- case dir of+               LeftToRight -> A.add numType inf tid+               RightToLeft -> do x <- A.sub numType sz inf+                                 y <- A.sub numType x tid+                                 z <- A.sub numType y (liftInt 1)+                                 return z++      -- j* is the index this thread will write to. This is just shifted by one+      -- to make room for the initial element+      j0  <- case dir of+               LeftToRight -> A.add numType i0 (liftInt 1)+               RightToLeft -> A.sub numType i0 (liftInt 1)++      -- If this thread has input it participates in the scan+      let valid i = case dir of+                      LeftToRight -> A.lt  singleType i sz+                      RightToLeft -> A.gte singleType i (liftInt 0)++      when (valid i0) $ do+        x0 <- app1 (delayedLinearIndex arrIn) i0++        -- Thread 0 of the first segment must also evaluate and store the+        -- initial element+        ti <- threadIdx+        x1 <- if (tp, A.eq singleType ti (liftInt32 0) `A.land'` A.eq singleType seg (liftInt 0))+                then do+                  z <- seed+                  writeArray TypeInt arrOut i0 z+                  case dir of+                    LeftToRight -> app2 combine z x0+                    RightToLeft -> app2 combine x0 z+                else+                  return x0++        -- Block-wide scan+        n  <- A.sub numType sz inf+        n' <- i32 n+        x2 <- if (tp, A.gte singleType n bd)+                then scanBlock dir dev tp combine Nothing   x1+                else scanBlock dir dev tp combine (Just n') x1++        -- Write this thread's scan result to memory. Recall that we had to make+        -- space for the initial element, so the very last thread does not store+        -- its result here.+        case dir of+          LeftToRight -> when (A.lt  singleType j0 sz)          $ writeArray TypeInt arrOut j0 x2+          RightToLeft -> when (A.gte singleType j0 (liftInt 0)) $ writeArray TypeInt arrOut j0 x2++        -- Last active thread writes its result to the partial sums array. These+        -- will be used to compute the carry-in value in step 2.+        m  <- do x <- A.min singleType n bd+                 y <- A.sub numType x (liftInt 1)+                 return y+        when (A.eq singleType tid m) $+          case dir of+            LeftToRight -> writeArray TypeInt arrTmp seg x2+            RightToLeft -> do x <- A.sub numType end seg+                              y <- A.sub numType x (liftInt 1)+                              writeArray TypeInt arrTmp y x2++    return_+++-- Parallel scan', step 2+--+-- A single thread block performs an inclusive scan of the partial sums array to+-- compute the per-block carry-in values, as well as the final reduction result.+--+mkScan'AllP2+    :: forall aenv e.+       Direction+    -> UID+    -> Gamma aenv+    -> TypeR e+    -> IRFun2 PTX aenv (e -> e -> e)+    -> CodeGen PTX (IROpenAcc PTX aenv (Vector e, Scalar e))+mkScan'AllP2 dir uid aenv tp combine = do+  dev <- liftCodeGen $ asks ptxDeviceProperties+  --+  let+      (arrTmp, paramTmp)  = mutableArray (ArrayR dim1 tp) "tmp"+      (arrSum, paramSum)  = mutableArray (ArrayR dim0 tp) "sum"+      paramEnv            = envParam aenv+      start               = liftInt 0+      end                 = indexHead (irArrayShape arrTmp)+      --+      config              = launchConfig dev (CUDA.incWarp dev) (scanSMemSize dev tp) grid gridQ+      grid _ _            = 1+      gridQ               = [|| \_ _ -> 1 ||]+  --+  makeOpenAccWith config uid "scanP2" (paramTmp ++ paramSum ++ paramEnv) $ do++    -- The first and last threads of the block need to communicate the+    -- block-wide aggregate as a carry-in value across iterations.+    carry <- staticSharedMem tp 1++    -- A single thread block iterates over the per-block partial results from+    -- step 1+    tid   <- threadIdx+    tid'  <- int tid+    bd    <- int =<< blockDim++    imapFromStepTo start bd end $ \offset -> do++      i0  <- case dir of+               LeftToRight -> A.add numType offset tid'+               RightToLeft -> do x <- A.sub numType end offset+                                 y <- A.sub numType x tid'+                                 z <- A.sub numType y (liftInt 1)+                                 return z++      let valid i = case dir of+                      LeftToRight -> A.lt  singleType i end+                      RightToLeft -> A.gte singleType i start++      -- wait for the carry-in value to be updated+      __syncthreads++      x0 <- if (tp, valid i0)+              then readArray TypeInt arrTmp i0+              else+                return $ tupUndef tp++      x1 <- if (tp, A.gt singleType offset (liftInt 0) `A.land'` A.eq singleType tid (liftInt32 0))+              then do+                c <- readArray TypeInt32 carry (liftInt32 0)+                case dir of+                  LeftToRight -> app2 combine c x0+                  RightToLeft -> app2 combine x0 c+              else+                return x0++      n  <- A.sub numType end offset+      n' <- i32 n+      x2 <- if (tp, A.gte singleType n bd)+              then scanBlock dir dev tp combine Nothing   x1+              else scanBlock dir dev tp combine (Just n') x1++      -- Update the partial results array+      when (valid i0) $+        writeArray TypeInt arrTmp i0 x2++      -- The last active thread saves its result as the carry-out value.+      m  <- do x <- A.min singleType bd n+               y <- A.sub numType x (liftInt 1)+               z <- i32 y+               return z+      when (A.eq singleType tid m) $+        writeArray TypeInt32 carry (liftInt32 0) x2++    -- First thread stores the final carry-out values at the final reduction+    -- result for the entire array+    __syncthreads++    when (A.eq singleType tid (liftInt32 0)) $+      writeArray TypeInt32 arrSum (liftInt32 0) =<< readArray TypeInt32 carry (liftInt32 0)++    return_+++-- Parallel scan', step 3.+--+-- Threads combine every element of the partial block results with the carry-in+-- value computed in step 2.+--+mkScan'AllP3+    :: forall aenv e.+       Direction+    -> UID+    -> Gamma aenv                                   -- ^ array environment+    -> TypeR e+    -> IRFun2 PTX aenv (e -> e -> e)                -- ^ combination function+    -> CodeGen PTX (IROpenAcc PTX aenv (Vector e, Scalar e))+mkScan'AllP3 dir uid aenv tp combine = do+  dev <- liftCodeGen $ asks ptxDeviceProperties+  --+  let+      (arrOut, paramOut)  = mutableArray (ArrayR dim1 tp) "out"+      (arrTmp, paramTmp)  = mutableArray (ArrayR dim1 tp) "tmp"+      paramEnv            = envParam aenv+      --+      stride              = local     (TupRsingle scalarTypeInt) "ix.stride"+      paramStride         = parameter (TupRsingle scalarTypeInt) "ix.stride"+      --+      config              = launchConfig dev (CUDA.incWarp dev) (const 0) const [|| const ||]+  --+  makeOpenAccWith config uid "scanP3" (paramTmp ++ paramOut ++ paramStride ++ paramEnv) $ do++    sz  <- return $ indexHead (irArrayShape arrOut)+    tid <- int =<< threadIdx++    when (A.lt singleType tid stride) $ do++      bid <- int =<< blockIdx+      gd  <- int =<< gridDim+      end <- A.sub numType (indexHead (irArrayShape arrTmp)) (liftInt 1)++      imapFromStepTo bid gd end $ \chunk -> do++        (inf,sup) <- case dir of+                       LeftToRight -> do+                         a <- A.add numType    chunk  (liftInt 1)+                         b <- A.mul numType    stride a+                         c <- A.add numType    b      (liftInt 1)+                         d <- A.add numType    c      stride+                         e <- A.min singleType d      sz+                         return (c,e)+                       RightToLeft -> do+                         a <- A.sub numType    end    chunk+                         b <- A.mul numType    stride a+                         c <- A.sub numType    sz     b+                         d <- A.sub numType    c      (liftInt 1)+                         e <- A.sub numType    d      stride+                         f <- A.max singleType e      (liftInt 0)+                         return (f,d)++        carry     <- case dir of+                       LeftToRight -> readArray TypeInt arrTmp chunk+                       RightToLeft -> do+                         a <- A.add numType chunk (liftInt 1)+                         b <- readArray TypeInt arrTmp a+                         return b++        -- Apply the carry-in value to each element in the chunk+        bd        <- int =<< blockDim+        i0        <- A.add numType inf tid+        imapFromStepTo i0 bd sup $ \i -> do+          v <- readArray TypeInt arrOut i+          u <- case dir of+                 LeftToRight -> app2 combine carry v+                 RightToLeft -> app2 combine v carry+          writeArray TypeInt arrOut i u++    return_+++-- Multidimensional scans+-- ----------------------++-- Multidimensional scan along the innermost dimension+--+-- A thread block individually computes along each innermost dimension. This is+-- a single-pass operation.+--+--  * We can assume that the array is non-empty; exclusive scans with empty+--    innermost dimension will be instead filled with the seed element via+--    'mkScanFill'.+--+--  * Small but non-empty innermost dimension arrays (size << thread+--    block size) will have many threads which do no work.+--+mkScanDim+    :: forall aenv sh e.+       Direction+    -> UID+    -> Gamma          aenv                          -- ^ array environment+    -> ArrayR (Array (sh, Int) e)+    -> IRFun2     PTX aenv (e -> e -> e)            -- ^ combination function+    -> MIRExp     PTX aenv e                        -- ^ seed element, if this is an exclusive scan+    -> MIRDelayed PTX aenv (Array (sh, Int) e)      -- ^ input data+    -> CodeGen    PTX (IROpenAcc PTX aenv (Array (sh, Int) e))+mkScanDim dir uid aenv repr@(ArrayR (ShapeRsnoc shr) tp) combine mseed marr = do+  dev <- liftCodeGen $ asks ptxDeviceProperties+  --+  let+      (arrOut, paramOut)  = mutableArray repr "out"+      (arrIn,  paramIn)   = delayedArray "in" marr+      paramEnv            = envParam aenv+      --+      config              = launchConfig dev (CUDA.incWarp dev) (scanSMemSize dev tp) const [|| const ||]+  --+  makeOpenAccWith config uid "scan" (paramOut ++ paramIn ++ paramEnv) $ do++    -- The first and last threads of the block need to communicate the+    -- block-wide aggregate as a carry-in value across iterations.+    --+    -- TODO: we could optimise this a bit if we can get access to the shared+    -- memory area used by 'scanBlockSMem', and from there directly read the+    -- value computed by the last thread.+    carry <- staticSharedMem tp 1++    -- Size of the input array+    sz  <- indexHead <$> delayedExtent arrIn++    -- Thread blocks iterate over the outer dimensions. Threads in a block+    -- cooperatively scan along one dimension, but thread blocks do not+    -- communicate with each other.+    --+    bid <- int =<< blockIdx+    gd  <- int =<< gridDim+    end <- shapeSize shr (indexTail (irArrayShape arrOut))++    -- Iterate over the outer dimensions (all but the innermost dimension).+    -- Within this loop we perform a scan over a row (innermost dimension) of+    -- the input.+    --+    -- Since 'bid', 'gd' and 'end' are uniform, the control flow within this+    -- loop is also uniform. We can thus perform __syncthreads in the loop.+    imapFromStepTo bid gd end $ \seg -> do++      -- Make sure all threads have finished previous iterations,+      -- so we can reuse (and overwrite) shared memory.+      __syncthreads++      -- Index this thread reads from+      tid   <- threadIdx+      tid'  <- int tid+      i0    <- case dir of+                 LeftToRight -> do x <- A.mul numType seg sz+                                   y <- A.add numType x tid'+                                   return y++                 RightToLeft -> do x <- A.add numType seg (liftInt 1)+                                   y <- A.mul numType x sz+                                   z <- A.sub numType y tid'+                                   w <- A.sub numType z (liftInt 1)+                                   return w++      -- Index this thread writes to+      j0  <- case mseed of+               Nothing -> return i0+               Just{}  -> do szp1 <- return $ indexHead (irArrayShape arrOut)+                             case dir of+                               LeftToRight -> do x <- A.mul numType seg szp1+                                                 y <- A.add numType x tid'+                                                 return y++                               RightToLeft -> do x <- A.add numType seg (liftInt 1)+                                                 y <- A.mul numType x szp1+                                                 z <- A.sub numType y tid'+                                                 w <- A.sub numType z (liftInt 1)+                                                 return w++      -- Stride indices by block dimension+      bd  <- blockDim+      bd' <- int bd+      let next ix = case dir of+                      LeftToRight -> A.add numType ix bd'+                      RightToLeft -> A.sub numType ix bd'++      -- Initialise this scan segment+      --+      -- If this is an exclusive scan then the first thread just evaluates the+      -- seed element and stores this value into the carry-in slot. All threads+      -- shift their write-to index (j) by one, to make space for this element.+      --+      -- If this is an inclusive scan then do a block-wide scan. The last thread+      -- in the block writes the carry-in value.+      --+      r <-+        case mseed of+          Just seed -> do+            when (A.eq singleType tid (liftInt32 0)) $ do+              z <- seed+              writeArray TypeInt   arrOut j0 z+              writeArray TypeInt32 carry (liftInt32 0) z+            j1 <- case dir of+                   LeftToRight -> A.add numType j0 (liftInt 1)+                   RightToLeft -> A.sub numType j0 (liftInt 1)+            return $ A.trip sz i0 j1++          Nothing -> do+            -- We cannot call scanBlock under non-uniform control flow.+            -- Instead, we conditionally read the input, and then+            -- unconditionally call scanBlock.+            x0 <- if (tp, A.lt singleType tid' sz)+                   then app1 (delayedLinearIndex arrIn) i0+                   else return $ tupUndef tp+            n' <- i32 sz++            r0 <- if (tp, A.gte singleType sz bd')+                    then scanBlock dir dev tp combine Nothing   x0+                    else scanBlock dir dev tp combine (Just n') x0++            when (A.lt singleType tid' sz) $ do+              writeArray TypeInt arrOut j0 r0++              ll <- A.sub numType bd (liftInt32 1)+              when (A.eq singleType tid ll) $+                writeArray TypeInt32 carry (liftInt32 0) r0++            n1 <- A.sub numType sz bd'+            i1 <- next i0+            j1 <- next j0+            return $ A.trip n1 i1 j1++      -- Iterate over the remaining elements in this segment+      -- The loop condition uses the first triple of the state, 'n'.+      -- This variable is uniform (the same for all threads in the thread+      -- block), since it is initialized as 'sz' or 'sz - bd', and lowered by+      -- 'bd' each iteration. Hence the control flow in this loop is uniform,+      -- and we can thus call __syncthreads within the loop.+      void $ while+        (TupRunit `TupRpair` TupRsingle scalarTypeInt `TupRpair` TupRsingle scalarTypeInt `TupRpair` TupRsingle scalarTypeInt)+        (\(A.fst3   -> n)       -> A.gt singleType n (liftInt 0))+        (\(A.untrip -> (n,i,j)) -> do++          -- Wait for the carry-in value from the previous iteration to be updated+          __syncthreads++          -- Compute and store the next element of the scan+          --+          -- NOTE: As with 'foldSeg' we require all threads to participate in+          -- every iteration of the loop otherwise they will die prematurely.+          -- Out-of-bounds threads return 'undef' at this point, which is really+          -- unfortunate ):+          --+          x <- if (tp, A.lt singleType tid' n)+                 then app1 (delayedLinearIndex arrIn) i+                 else return $ tupUndef tp++          -- Thread zero incorporates the carry-in element+          y <- if (tp, A.eq singleType tid (liftInt32 0))+                 then do+                   c <- readArray TypeInt32 carry (liftInt32 0)+                   case dir of+                     LeftToRight -> app2 combine c x+                     RightToLeft -> app2 combine x c+                  else+                    return x++          -- Perform the scan and write the result to memory+          m <- i32 n+          z <- if (tp, A.gte singleType n bd')+                 then scanBlock dir dev tp combine Nothing  y+                 else scanBlock dir dev tp combine (Just m) y++          when (A.lt singleType tid' n) $ do+            writeArray TypeInt arrOut j z++            -- The last thread of the block writes its result as the carry-out+            -- value. If this thread is not active then we are on the last+            -- iteration of the loop and it will not be needed.+            w <- A.sub numType bd (liftInt32 1)+            when (A.eq singleType tid w) $+              writeArray TypeInt32 carry (liftInt32 0) z++          -- Update indices for the next iteration+          n' <- A.sub numType n bd'+          i' <- next i+          j' <- next j+          return $ A.trip n' i' j')+        r++    return_+++-- Multidimensional scan' along the innermost dimension+--+-- A thread block individually computes along each innermost dimension. This is+-- a single-pass operation.+--+--  * We can assume that the array is non-empty; exclusive scans with empty+--    innermost dimension will be instead filled with the seed element via+--    'mkScan'Fill'.+--+--  * Small but non-empty innermost dimension arrays (size << thread+--    block size) will have many threads which do no work.+--+mkScan'Dim+    :: forall aenv sh e.+       Direction+    -> UID+    -> Gamma          aenv                          -- ^ array environment+    -> ArrayR (Array (sh, Int) e)+    -> IRFun2     PTX aenv (e -> e -> e)            -- ^ combination function+    -> IRExp      PTX aenv e                        -- ^ seed element+    -> MIRDelayed PTX aenv (Array (sh, Int) e)      -- ^ input data+    -> CodeGen    PTX      (IROpenAcc PTX aenv (Array (sh, Int) e, Array sh e))+mkScan'Dim dir uid aenv repr@(ArrayR (ShapeRsnoc shr) tp) combine seed marr = do+  dev <- liftCodeGen $ asks ptxDeviceProperties+  --+  let+      (arrSum, paramSum)  = mutableArray (reduceRank repr) "sum"+      (arrOut, paramOut)  = mutableArray repr "out"+      (arrIn,  paramIn)   = delayedArray "in" marr+      paramEnv            = envParam aenv+      --+      config              = launchConfig dev (CUDA.incWarp dev) (scanSMemSize dev tp) const [|| const ||]+  --+  makeOpenAccWith config uid "scan" (paramOut ++ paramSum ++ paramIn ++ paramEnv) $ do++    -- The first and last threads of the block need to communicate the+    -- block-wide aggregate as a carry-in value across iterations.+    --+    -- TODO: we could optimise this a bit if we can get access to the shared+    -- memory area used by 'scanBlockSMem', and from there directly read the+    -- value computed by the last thread.+    carry <- staticSharedMem tp 1++    -- Size of the input array+    sz    <- indexHead <$> delayedExtent arrIn++    -- If the innermost dimension is smaller than the number of threads in the+    -- block, those threads will never contribute to the output.+    tid   <- threadIdx+    tid'  <- int tid+    when (A.lte singleType tid' sz) $ do++      -- Thread blocks iterate over the outer dimensions, each thread block+      -- cooperatively scanning along each outermost index.+      bid <- int =<< blockIdx+      gd  <- int =<< gridDim+      end <- shapeSize shr (irArrayShape arrSum)++      imapFromStepTo bid gd end $ \seg -> do++        -- Not necessary to wait for threads to catch up before starting this segment+        -- __syncthreads++        -- Linear index bounds for this segment+        inf <- A.mul numType seg sz+        sup <- A.add numType inf sz++        -- Index that this thread will read from. Recall that the supremum index+        -- is exclusive.+        i0  <- case dir of+                 LeftToRight -> A.add numType inf tid'+                 RightToLeft -> do x <- A.sub numType sup tid'+                                   y <- A.sub numType x (liftInt 1)+                                   return y++        -- The index that this thread will write to. This is just shifted along+        -- by one to make room for the initial element.+        j0  <- case dir of+                 LeftToRight -> A.add numType i0 (liftInt 1)+                 RightToLeft -> A.sub numType i0 (liftInt 1)++        -- Evaluate the initial element. Store it into the carry-in slot as well+        -- as to the array as the first element. This is always valid because if+        -- the input array is empty then we will be evaluating via mkScan'Fill.+        when (A.eq singleType tid (liftInt32 0)) $ do+          z <- seed+          writeArray TypeInt   arrOut i0            z+          writeArray TypeInt32 carry  (liftInt32 0) z++        bd  <- blockDim+        bd' <- int bd+        let next ix = case dir of+                        LeftToRight -> A.add numType ix bd'+                        RightToLeft -> A.sub numType ix bd'++        -- Now, threads iterate over the elements along the innermost dimension.+        -- At each iteration the first thread incorporates the carry-in value+        -- from the previous step.+        --+        -- The index tracks how many elements remain for the thread block, since+        -- indices i* and j* are local to each thread+        n0  <- A.sub numType sup inf+        void $ while+          (TupRunit `TupRpair` TupRsingle scalarTypeInt `TupRpair` TupRsingle scalarTypeInt `TupRpair` TupRsingle scalarTypeInt)+          (\(A.fst3   -> n)       -> A.gt singleType n (liftInt 0))+          (\(A.untrip -> (n,i,j)) -> do++            -- Wait for threads to catch up to ensure the carry-in value from+            -- the last iteration has been updated+            __syncthreads++            -- If all threads in the block will participate this round we can+            -- avoid (almost) all bounds checks.+            _ <- if (TupRunit, A.gte singleType n bd')+                    -- All threads participate. No bounds checks required but+                    -- the last thread needs to update the carry-in value.+                    then do+                      x <- app1 (delayedLinearIndex arrIn) i+                      y <- if (tp, A.eq singleType tid (liftInt32 0))+                              then do+                                c <- readArray TypeInt32 carry (liftInt32 0)+                                case dir of+                                  LeftToRight -> app2 combine c x+                                  RightToLeft -> app2 combine x c+                              else+                                return x+                      z <- scanBlock dir dev tp combine Nothing y++                      -- Write results to the output array. Note that if we+                      -- align directly on the boundary of the array this is not+                      -- valid for the last thread.+                      case dir of+                        LeftToRight -> when (A.lt  singleType j sup) $ writeArray TypeInt arrOut j z+                        RightToLeft -> when (A.gte singleType j inf) $ writeArray TypeInt arrOut j z++                      -- Last thread of the block also saves its result as the+                      -- carry-in value+                      bd1 <- A.sub numType bd (liftInt32 1)+                      when (A.eq singleType tid bd1) $+                        writeArray TypeInt32 carry (liftInt32 0) z++                      return (lift TupRunit ())++                    -- Only threads that are in bounds can participate. This is+                    -- the last iteration of the loop. The last active thread+                    -- still needs to store its value into the carry-in slot.+                    --+                    -- Note that all threads must call the block-wide scan.+                    -- SEE: [Synchronisation problems with SM_70 and greater]+                    else do+                      x <- if (tp, A.lt singleType tid' n)+                              then do+                                x <- app1 (delayedLinearIndex arrIn) i+                                y <- if (tp, A.eq singleType tid (liftInt32 0))+                                        then do+                                          c <- readArray TypeInt32 carry (liftInt32 0)+                                          case dir of+                                            LeftToRight -> app2 combine c x+                                            RightToLeft -> app2 combine x c+                                        else+                                          return x+                                return y+                              else+                                return $ tupUndef tp++                      l <- i32 n+                      y <- scanBlock dir dev tp combine (Just l) x++                      m <- A.sub numType l (liftInt32 1)+                      when (A.lt singleType tid m) $ writeArray TypeInt   arrOut j            y+                      when (A.eq singleType tid m) $ writeArray TypeInt32 carry (liftInt32 0) y++                      return (lift TupRunit ())++            A.trip <$> A.sub numType n bd' <*> next i <*> next j)+          (A.trip n0 i0 j0)++        -- Wait for the carry-in value to be updated+        __syncthreads++        -- Store the carry-in value to the separate final results array+        when (A.eq singleType tid (liftInt32 0)) $+          writeArray TypeInt arrSum seg =<< readArray TypeInt32 carry (liftInt32 0)++    return_++++-- Parallel scan, auxiliary+--+-- If this is an exclusive scan of an empty array, we just fill the result with+-- the seed element.+--+mkScanFill+    :: UID+    -> Gamma aenv+    -> ArrayR (Array sh e)+    -> IRExp PTX aenv e+    -> CodeGen PTX (IROpenAcc PTX aenv (Array sh e))+mkScanFill uid aenv repr seed =+  mkGenerate uid aenv repr (IRFun1 (const seed))++mkScan'Fill+    :: UID+    -> Gamma aenv+    -> ArrayR (Array (sh, Int) e)+    -> IRExp PTX aenv e+    -> CodeGen PTX (IROpenAcc PTX aenv (Array (sh, Int) e, Array sh e))+mkScan'Fill uid aenv repr seed =+  Safe.coerce <$> mkGenerate uid aenv (reduceRank repr) (IRFun1 (const seed))++scanSMemSize :: DeviceProperties -> TypeR e -> Int -> Int+scanSMemSize dev tp n = sharedMemorySizeAdd tp warps 0+  where+    ws        = CUDA.warpSize dev+    warps     = n `P.quot` ws++-- Block wide scan+-- ---------------++-- Efficient block-wide (inclusive) scan using the specified operator.+--+-- Each block requires (#warps * (1 + 1.5*warp size)) elements of dynamically+-- allocated shared memory.+--+-- Example: https://github.com/NVlabs/cub/blob/1.5.4/cub/block/specializations/block_scan_warp_scans.cuh+--+-- Must be called under uniform control flow within a thread block+-- (as this function may use __syncthreads)+scanBlock+    :: forall aenv e.+       Direction+    -> DeviceProperties                             -- ^ properties of the target device+    -> TypeR e+    -> IRFun2 PTX aenv (e -> e -> e)                -- ^ combination function+    -> Maybe (Operands Int32)                       -- ^ number of valid elements (may be less than block size)+    -> Operands e                                   -- ^ calling thread's input element+    -> CodeGen PTX (Operands e)+scanBlock dir dev tp combine nelem = warpScan >=> warpPrefix+  where+    int32 :: Integral a => a -> Operands Int32+    int32 = liftInt32 . P.fromIntegral++    -- Temporary storage required for each warp+    -- warp_smem_elems = CUDA.warpSize dev + (CUDA.warpSize dev `P.quot` 2)+    -- warp_smem_bytes = warp_smem_elems  * bytesElt tp++    -- Step 1: Scan in every warp+    warpScan :: Operands e -> CodeGen PTX (Operands e)+    warpScan = scanWarp dir dev tp combine++    -- Step 2: Collect the aggregate results of each warp to compute the prefix+    -- values for each warp and combine with the partial result to compute each+    -- thread's final value.+    warpPrefix :: Operands e -> CodeGen PTX (Operands e)+    warpPrefix input = do+      -- Allocate #warps elements of shared memory+      bd    <- blockDim+      warps <- A.quot integralType bd (int32 (CUDA.warpSize dev))+      smem  <- dynamicSharedMem tp TypeInt32 warps (liftInt32 0)++      -- Share warp aggregates+      wid   <- warpId+      lane  <- laneId+      when (A.eq singleType lane (int32 (CUDA.warpSize dev - 1))) $ do+        writeArray TypeInt32 smem wid input++      -- Wait for each warp to finish its local scan and share the aggregate+      __syncthreads++      -- Compute the prefix value for this warp and add to the partial result.+      -- This step is not required for the first warp, which has no carry-in.+      if (tp, A.eq singleType wid (liftInt32 0))+        then return input+        else do+          -- Every thread sequentially scans the warp aggregates to compute+          -- their prefix value. We do this sequentially, but could also have+          -- warp 0 do it cooperatively if we limit thread block sizes to+          -- (warp size ^ 2).+          steps <- case nelem of+                      Nothing -> return wid+                      Just n  -> A.min singleType wid =<< A.quot integralType n (int32 (CUDA.warpSize dev))++          p0     <- readArray TypeInt32 smem (liftInt32 0)+          prefix <- iterFromStepTo tp (liftInt32 1) (liftInt32 1) steps p0 $ \step x -> do+                      y <- readArray TypeInt32 smem step+                      case dir of+                        LeftToRight -> app2 combine x y+                        RightToLeft -> app2 combine y x++          case dir of+            LeftToRight -> app2 combine prefix input+            RightToLeft -> app2 combine input prefix+++-- Warp-wide scan+-- --------------++-- Efficient warp-wide (inclusive) scan using the specified operator.+--+-- Each warp requires 48 (1.5 x warp size) elements of shared memory. The+-- routine assumes that it is allocated individually per-warp (i.e. can be+-- indexed in the range [0, warp size)).+--+-- Example: https://github.com/NVlabs/cub/blob/1.5.4/cub/warp/specializations/warp_scan_smem.cuh+--+scanWarp+    :: forall aenv e.+       Direction+    -> DeviceProperties                             -- ^ properties of the target device+    -> TypeR e+    -> IRFun2 PTX aenv (e -> e -> e)                -- ^ combination function+    -> Operands e                                   -- ^ calling thread's input element+    -> CodeGen PTX (Operands e)+scanWarp dir dev tp combine = scan 0+  where+    log2 :: Double -> Double+    log2 = P.logBase 2++    -- Number of steps required to scan warp+    steps = P.floor (log2 (P.fromIntegral (CUDA.warpSize dev)))++    -- Unfold the scan as a recursive code generation function+    scan :: Int -> Operands e -> CodeGen PTX (Operands e)+    scan step x+      | step >= steps = return x+      | otherwise     = do+          let offset = 1 `P.shiftL` step++          -- share partial result through shared memory buffer+          y    <- __shfl_up tp x (liftWord32 offset)+          lane <- laneId++          -- update partial result if in range+          x'   <- if (tp, A.gte singleType lane (liftInt32 . P.fromIntegral $ offset))+                    then do+                      case dir of+                        LeftToRight -> app2 combine y x+                        RightToLeft -> app2 combine x y++                    else+                      return x++          scan (step+1) x'++tupUndef :: TypeR a -> Operands a+tupUndef TupRunit       = OP_Unit+tupUndef (TupRpair a b) = OP_Pair (tupUndef a) (tupUndef b)+tupUndef (TupRsingle t) = ir t (undef t)++-- Utilities+-- ---------++i32 :: Operands Int -> CodeGen PTX (Operands Int32)+i32 = A.fromIntegral integralType numType++int :: Operands Int32 -> CodeGen PTX (Operands Int)+int = A.fromIntegral integralType numType+
+ src/Data/Array/Accelerate/LLVM/PTX/CodeGen/Stencil.hs view
@@ -0,0 +1,190 @@+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell     #-}+{-# LANGUAGE TypeApplications    #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.PTX.CodeGen.Stencil+-- Copyright   : [2018..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.PTX.CodeGen.Stencil (++  mkStencil1,+  mkStencil2,++) where++import Data.Array.Accelerate.Representation.Array+import Data.Array.Accelerate.Representation.Shape+import Data.Array.Accelerate.Representation.Stencil+import Data.Array.Accelerate.Representation.Type+import Data.Array.Accelerate.Type++import Data.Array.Accelerate.LLVM.CodeGen.Arithmetic+import Data.Array.Accelerate.LLVM.CodeGen.Array+import Data.Array.Accelerate.LLVM.CodeGen.Base+import Data.Array.Accelerate.LLVM.CodeGen.Environment+import Data.Array.Accelerate.LLVM.CodeGen.Exp+import Data.Array.Accelerate.LLVM.CodeGen.IR+import Data.Array.Accelerate.LLVM.CodeGen.Monad+import Data.Array.Accelerate.LLVM.CodeGen.Stencil+import Data.Array.Accelerate.LLVM.CodeGen.Sugar+import Data.Array.Accelerate.LLVM.Compile.Cache++import Data.Array.Accelerate.LLVM.PTX.CodeGen.Base+import Data.Array.Accelerate.LLVM.PTX.CodeGen.Loop+import Data.Array.Accelerate.LLVM.PTX.Target                        ( PTX )++import qualified Data.Array.Accelerate.LLVM.Internal.LLVMPretty.AST as LP++import Control.Monad+++-- The stencil function is similar to a map, but has access to surrounding+-- elements as specified by the stencil pattern.+--+-- This generates two functions:+--+--  * stencil_inside: does not apply boundary conditions, assumes all element+--                    accesses are valid+--+--  * stencil_border: applies boundary condition check to each array access+--+mkStencil1+    :: UID+    -> Gamma           aenv+    -> StencilR sh a stencil+    -> TypeR b+    -> IRFun1      PTX aenv (stencil -> b)+    -> IRBoundary  PTX aenv (Array sh a)+    -> MIRDelayed  PTX aenv (Array sh a)+    -> CodeGen     PTX      (IROpenAcc PTX aenv (Array sh b))+mkStencil1 uid aenv stencil tp fun bnd marr =+  let repr             = ArrayR shr tp+      (shr, halo)      = stencilHalo stencil+      (arrIn, paramIn) = delayedArray "in" marr+  in+  (+++) <$> mkInside uid aenv repr halo (IRFun1 $ app1 fun <=< stencilAccess stencil Nothing    arrIn) paramIn+        <*> mkBorder uid aenv repr      (IRFun1 $ app1 fun <=< stencilAccess stencil (Just bnd) arrIn) paramIn+++mkStencil2+    :: UID+    -> Gamma           aenv+    -> StencilR sh a stencil1+    -> StencilR sh b stencil2+    -> TypeR c+    -> IRFun2      PTX aenv (stencil1 -> stencil2 -> c)+    -> IRBoundary  PTX aenv (Array sh a)+    -> MIRDelayed  PTX aenv (Array sh a)+    -> IRBoundary  PTX aenv (Array sh b)+    -> MIRDelayed  PTX aenv (Array sh b)+    -> CodeGen     PTX      (IROpenAcc PTX aenv (Array sh c))+mkStencil2 uid aenv stencil1 stencil2 tp f bnd1 marr1 bnd2 marr2 =+  let+      repr = ArrayR shr tp+      (arrIn1, paramIn1)  = delayedArray "in1" marr1+      (arrIn2, paramIn2)  = delayedArray "in2" marr2++      inside  = IRFun1 $ \ix -> do+        s1 <- stencilAccess stencil1 Nothing arrIn1 ix+        s2 <- stencilAccess stencil2 Nothing arrIn2 ix+        app2 f s1 s2+      --+      border  = IRFun1 $ \ix -> do+        s1 <- stencilAccess stencil1 (Just bnd1) arrIn1 ix+        s2 <- stencilAccess stencil2 (Just bnd2) arrIn2 ix+        app2 f s1 s2++      (shr, halo1) = stencilHalo stencil1+      (_,   halo2) = stencilHalo stencil2+      halo         = union shr halo1 halo2+  in+  (+++) <$> mkInside uid aenv repr halo inside (paramIn1 ++ paramIn2)+        <*> mkBorder uid aenv repr      border (paramIn1 ++ paramIn2)+++mkInside+    :: UID+    -> Gamma aenv+    -> ArrayR (Array sh e)+    -> sh+    -> IRFun1  PTX aenv (sh -> e)+    -> [LP.Typed LP.Ident]+    -> CodeGen PTX      (IROpenAcc PTX aenv (Array sh e))+mkInside uid aenv repr@(ArrayR shr _) halo apply paramIn =+  let+      (arrOut, paramOut)  = mutableArray repr "out"+      paramInside         = parameter    (shapeType shr) "shInside"+      shInside            = local        (shapeType shr) "shInside"+      shOut               = irArrayShape arrOut+      paramEnv            = envParam aenv+  in+  makeOpenAcc uid "stencil_inside" (paramInside ++ paramOut ++ paramIn ++ paramEnv) $ do++    start <- return (liftInt 0)+    end   <- shapeSize shr shInside++    -- iterate over the inside region as a linear index space+    --+    imapFromTo start end $ \i -> do++      ixIn  <- indexOfInt shr shInside i                    -- convert to multidimensional index of inside region+      ixOut <- offset shr ixIn (lift (shapeType shr) halo)  -- shift to multidimensional index of outside region+      r     <- app1 apply ixOut                             -- apply generator function+      j     <- intOfIndex shr shOut ixOut+      writeArray TypeInt arrOut j r++    return_+++mkBorder+    :: UID+    -> Gamma aenv+    -> ArrayR (Array sh e)+    -> IRFun1  PTX aenv (sh -> e)+    -> [LP.Typed LP.Ident]+    -> CodeGen PTX      (IROpenAcc PTX aenv (Array sh e))+mkBorder uid aenv repr@(ArrayR shr _) apply paramIn =+  let+      (arrOut, paramOut)  = mutableArray repr "out"+      paramFrom           = parameter    (shapeType shr) "shFrom"+      shFrom              = local        (shapeType shr) "shFrom"+      paramInside         = parameter    (shapeType shr) "shInside"+      shInside            = local        (shapeType shr) "shInside"+      shOut               = irArrayShape arrOut+      paramEnv            = envParam aenv+  in+  makeOpenAcc uid "stencil_border" (paramFrom ++ paramInside ++ paramOut ++ paramIn ++ paramEnv) $ do++    start <- return (liftInt 0)+    end   <- shapeSize shr shInside++    imapFromTo start end $ \i -> do++      ixIn  <- indexOfInt shr shInside i    -- convert to multidimensional index of inside region+      ixOut <- offset shr ixIn shFrom       -- shift to multidimensional index of outside region+      r     <- app1 apply ixOut             -- apply generator function+      j     <- intOfIndex shr shOut ixOut+      writeArray TypeInt arrOut j r++    return_+++offset :: ShapeR sh -> Operands sh -> Operands sh -> CodeGen PTX (Operands sh)+offset shr sh1 sh2 = go shr sh1 sh2+  where+    go :: ShapeR t -> Operands t -> Operands t -> CodeGen PTX (Operands t)+    go ShapeRz OP_Unit OP_Unit+      = return OP_Unit++    go (ShapeRsnoc t) (OP_Pair sa1 sb1) (OP_Pair sa2 sb2)+      = do x <- add (numType :: NumType Int) sb1 sb2+           OP_Pair <$> go t sa1 sa2 <*> return x+
+ src/Data/Array/Accelerate/LLVM/PTX/CodeGen/Transform.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.PTX.CodeGen.Transform+-- Copyright   : [2014..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.PTX.CodeGen.Transform+  where++-- accelerate+import Data.Array.Accelerate.Representation.Array+import Data.Array.Accelerate.Type++import Data.Array.Accelerate.LLVM.CodeGen.Arithmetic+import Data.Array.Accelerate.LLVM.CodeGen.Array+import Data.Array.Accelerate.LLVM.CodeGen.Base+import Data.Array.Accelerate.LLVM.CodeGen.Environment+import Data.Array.Accelerate.LLVM.CodeGen.Exp+import Data.Array.Accelerate.LLVM.CodeGen.Monad+import Data.Array.Accelerate.LLVM.CodeGen.Sugar+import Data.Array.Accelerate.LLVM.Compile.Cache++import Data.Array.Accelerate.LLVM.PTX.CodeGen.Base+import Data.Array.Accelerate.LLVM.PTX.CodeGen.Loop+import Data.Array.Accelerate.LLVM.PTX.Target                    ( PTX )+++-- Apply a unary function to each element of an array. Each thread processes+-- multiple elements, striding the array by the grid size.+--+mkTransform+    :: UID+    -> Gamma       aenv+    -> ArrayR (Array sh  a)+    -> ArrayR (Array sh' b)+    -> IRFun1  PTX aenv (sh' -> sh)+    -> IRFun1  PTX aenv (a -> b)+    -> CodeGen PTX      (IROpenAcc PTX aenv (Array sh' b))+mkTransform uid aenv repr@(ArrayR shr _) repr'@(ArrayR shr' _) p f =+  let+      (arrOut, paramOut)  = mutableArray repr' "out"+      (arrIn,  paramIn)   = mutableArray repr  "in"+      paramEnv            = envParam aenv+  in+  makeOpenAcc uid "transform" (paramOut ++ paramIn ++ paramEnv) $ do++    let start = liftInt 0+    end   <- shapeSize shr' (irArrayShape arrOut)++    imapFromTo start end $ \i' -> do+      ix' <- indexOfInt shr' (irArrayShape arrOut) i'+      ix  <- app1 p ix'+      i   <- intOfIndex shr  (irArrayShape arrIn) ix+      a   <- readArray TypeInt arrIn i+      b   <- app1 f a+      writeArray TypeInt arrOut i' b++    return_+
+ src/Data/Array/Accelerate/LLVM/PTX/Compile.hs view
@@ -0,0 +1,283 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards   #-}+{-# LANGUAGE TemplateHaskell   #-}+{-# LANGUAGE TypeFamilies      #-}+{-# OPTIONS_GHC -Wno-orphans   #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.PTX.Compile+-- Copyright   : [2014..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.PTX.Compile (++  module Data.Array.Accelerate.LLVM.Compile,+  ObjectR(..),++) where++import Data.Array.Accelerate.AST                                    ( PreOpenAcc )+import Data.Array.Accelerate.Error+import Data.Array.Accelerate.Trafo.Delayed++import Data.Array.Accelerate.LLVM.CodeGen                           ( llvmOfPreOpenAcc )+import Data.Array.Accelerate.LLVM.CodeGen.Environment               ( Gamma )+import Data.Array.Accelerate.LLVM.CodeGen.Module                    ( Module(..) )+import Data.Array.Accelerate.LLVM.Compile+import Data.Array.Accelerate.LLVM.State+import Data.Array.Accelerate.LLVM.Target.ClangInfo                  ( hostLLVMVersion, llvmverFromTuple, clangExePath, clangExePathEnvironment )++import Data.Array.Accelerate.LLVM.PTX.Analysis.Launch+import Data.Array.Accelerate.LLVM.PTX.CodeGen+import Data.Array.Accelerate.LLVM.PTX.Compile.Cache+import Data.Array.Accelerate.LLVM.PTX.Compile.Libdevice.Load+import Data.Array.Accelerate.LLVM.PTX.Foreign                       ( )+import Data.Array.Accelerate.LLVM.PTX.Target+import qualified Data.Array.Accelerate.LLVM.PTX.Debug               as Debug++import Foreign.CUDA.Path                                            ( cudaInstallPath )+import qualified Foreign.CUDA.Analysis                              as CUDA++import qualified LLVM.AST.Type.Name                                 as LLVM++import qualified Data.Array.Accelerate.LLVM.Internal.LLVMPretty     as LP+import qualified Data.Array.Accelerate.LLVM.Internal.LLVMPretty.PP  as LP+import qualified Text.PrettyPrint                                   as Pretty++import Control.Monad                                                ( when )+import Control.Monad.Reader+import Data.ByteString.Short                                        ( ShortByteString )+import Data.List                                                    ( intercalate )+import qualified Data.List.NonEmpty                                 as NE+import Data.Foldable                                                ( toList )+import GHC.IO.Exception                                             ( IOErrorType(OtherError) )+import Formatting+import System.Directory+import System.Exit                                                  ( ExitCode(..) )+import System.IO                                                    ( hPutStrLn, stderr )+import System.IO.Error                                              ( mkIOError )+import System.IO.Unsafe+import System.Process+import Text.Printf                                                  ( printf )+import qualified Data.ByteString.Short.Char8                        as SBS8+import qualified Data.Map.Strict                                    as Map+++instance Compile PTX where+  data ObjectR PTX = ObjectR { objId     :: {-# UNPACK #-} !UID+                             , -- | Config for each exported kernel (symbol)+                               ptxConfig :: ![(ShortByteString, LaunchConfig)]+                             , objPath   :: {- LAZY -} FilePath+                             }+  compileForTarget = compile+++-- | Compile an Accelerate expression to object code.+--+-- This generates the target code together with a list of each kernel function+-- defined in the module paired with its occupancy information.+--+compile :: HasCallStack => PreOpenAcc DelayedOpenAcc aenv a -> Gamma aenv -> LLVM PTX (ObjectR PTX)+compile pacc aenv = do++  -- Generate code for this Acc operation+  --+  dev                  <- asks ptxDeviceProperties+  let CUDA.Compute m n = CUDA.computeCapability dev+  let arch             = printf "sm_%d%d" m n+  (uid, cacheFile)     <- cacheOfPreOpenAcc pacc+  Module ast md        <- llvmOfPreOpenAcc uid pacc aenv+  let config           = [ (SBS8.pack f, x) | (LP.Symbol f, KM_PTX x) <- Map.toList md ]++  libdevice_bc <- liftIO libdeviceBitcodePath++  case isDeviceSupported (CUDA.computeCapability dev) of+    Nothing -> return ()  -- all fine+    Just err -> internalError string err++  -- Lower the generated LLVM into a CUBIN object code.+  --+  -- The 'objData' field is lazily evaluated since the object code might have+  -- already been loaded into the current context from a different function, in+  -- which case it will be found by the linker cache.+  --+  cubin <- liftIO . unsafeInterleaveIO $ do+    exists <- doesFileExist cacheFile+    recomp <- if Debug.debuggingIsEnabled then Debug.getFlag Debug.force_recomp else return False+    if exists && not recomp+      then do+        Debug.traceM Debug.dump_cc ("cc: found cached object code " % shown) uid++      else do+        -- Detect LLVM version+        -- Note: this LLVM version is incorporated in the cache path, so we're safe detecting it at runtime.+        let prettyHostLLVMVersion = intercalate "." (map show (toList hostLLVMVersion))+        llvmver <- case llvmverFromTuple hostLLVMVersion of+                     Just llvmver -> return llvmver+                     Nothing -> internalError ("accelerate-llvm-ptx: Unsupported LLVM version: " % string)+                                              prettyHostLLVMVersion+        Debug.traceM Debug.dump_cc ("Using Clang at " % string % " version " % shown) clangExePath prettyHostLLVMVersion++        when (NE.head hostLLVMVersion < 16) $+          case clangExePathEnvironment of+            Nothing -> do+              hPutStrLn stderr $+                "[accelerate-llvm-ptx] Clang version 16 or newer is required for the Nvidia PTX " +++                "backend, but version " ++ prettyHostLLVMVersion ++ " was found at '" +++                clangExePath ++ "'. To override this choice, set the ACCELERATE_LLVM_CLANG_PATH " +++                "environment variable to point to the desired clang executable."+              -- not an IOError because we're in unsafePerformIO, somewhere up the call chain+              errorWithoutStackTrace $+                "accelerate-llvm-ptx: Clang version " ++ prettyHostLLVMVersion +++                " found but >=16 required (set ACCELERATE_LLVM_CLANG_PATH to override)"+            Just{} ->  -- If an explicit path was given, let's just continue and see what happens.+              return ()++        -- Convert module to llvm-pretty format so that we can print it+        let unoptimisedText = Pretty.renderStyle+                                Pretty.style { Pretty.lineLength = maxBound `div` 2 }+                                (LP.ppLLVM llvmver (LP.ppModule ast))+                              ++ "\n\n" ++ accPreludePTX+        Debug.when Debug.verbose $ do+          Debug.traceM Debug.dump_cc ("Unoptimised LLVM IR:\n" % string) unoptimisedText++        isVerboseFlagSet <- Debug.getFlag Debug.verbose+        let clangArgs = ["-O3", "--target=nvptx64-nvidia-cuda", "-march=" ++ arch+                        ,"-o", cacheFile+                        ,"-Wno-override-module"+                        ,"--cuda-path=" ++ cudaInstallPath+                        ,"-x", "ir", "-"+                        -- See Note [Internalizing Libdevice]+                        -- TODO: only link in libdevice if we're actually using __nv_ functions!+                        ,"-Xclang", "-mlink-builtin-bitcode", "-Xclang", libdevice_bc]+                        ++ (if isVerboseFlagSet then ["-v"] else [])++        Debug.traceM Debug.dump_cc ("Arguments to clang: " % shown) clangArgs++        -- Remove some diagnostics from clang (and subprocesses) output that we+        -- know are fine. See filterClangStderr. Unfortunately, System.Process+        -- does not have a combinator for "give me stdout and stderr but throw+        -- exception on ExitFailure", so we do it manually.+        (clangEC, clangOut, clangErr) <- readProcessWithExitCode clangExePath clangArgs unoptimisedText+        putStr clangOut+        putStr (filterClangStderr clangErr)+        case clangEC of+          ExitSuccess -> return ()+          ExitFailure code -> do+            let msg = "clang returned non-zero exit code: " ++ show code +++                      " (invocation: " ++ show (clangExePath : clangArgs) ++ ")"+            ioError $ mkIOError OtherError msg Nothing Nothing++        Debug.traceM Debug.dump_cc ("Written PTX to: " % string) cacheFile++    return cacheFile++  return $! ObjectR uid config cubin+++{- Note [Internalizing Libdevice]++"Libdevice" refers to $CUDAPATH/nvvm/libdevice/libdevice.XX.bc, an LLVM bitcode+file that (reportedly) contains definitions of various math functions for use+in NVIDIA PTX. Most interesting primitive arithmetic operations on+floating-point numbers get compiled to calls to functions from libdevice, so it+is essential that we link it into any kernel that we create (or at least, any+kernel that references functions from libdevice).++However, libdevice is quite large; it is 473 KB of LLVM bitcode for cuda 12.6+on my machine, and clang takes >1 second to compile it on my (5 GHz Intel)+machine. Indeed, the LLVM NVPTX usage guide [1] recommends _internalizing_ the+symbols from libdevice after linking it with the kernel module; more precisely,+it recommends to first link the kernel module with libdevice, and subsequently+internalize all functions that we don't explicitly want exported (the public+kernel functions).++Clang doesn't have a command-line option to internalize symbols. Indeed, it+would be somewhat ambiguous when in the compilation process to do said+internalization. The LLVM command-line tool that _can_ do internalization is+`llvm-link`, the tool for linking LLVM modules together (and doing little+else). So translating the recommended [1] strategy to command-line tools+(because linking with LLVM through bindings is a version nightmare -- been+there, done that, not again), we get the following sensible procedure:++$ llvm-link --internalize kernel.ll libdevice.bc -o kernel-linked.bc+$ clang --target=... kernel-linked.bc -o kernel.sass++However, llvm-link is not clang, and we'd very much like to depend _only_ on+clang, not on the full LLVM suite of tools. Especially not for this vexingly+small bit of functionality! But clang is huge, and surely it can do+internalization somehow?++It turns out it can, but they did their absolute best to hide it. (All+references in this paragraph are to LLVM HEAD on 2024-12-04: 7954a0514ba7de.)+The workhorse function, called from `llvm-link`, is internalizeModule(). This+function is also called from clang in BackendConsumer::LinkInModules() in+clang/lib/CodeGen/CodeGenAction.cpp, but only if .Internalize is set on the+CodeGenAction::LinkModule in question. In CompilerInvocation::ParseCodeGenArgs+(clang/lib/Frontend/CompilerInvocation.cpp), we see that _some_ field called+"Internalize" is set on _something_ (not a LinkModule, but whatever?) if the+OPT_mlink_builtin_bitcode flag is set. Of course, no documentation anywhere+explains what this option does; the only mention I could find anywhere is here+[2], as well as some mailing list posts / issue tracker comments mentioning it.+How do we use the option? Well, it's not a clang option, it's actually a (I+think!) cc1 option, so you have to do:++$ clang -Xclang -mlink-builtin-bitcode -Xclang libdevice.bc++This makes clang internalize everything in that module that is not globally+exported (I think), which is what we want.++[1]: https://releases.llvm.org/19.1.0/docs/NVPTXUsage.html#linking-with-libdevice+[2]: https://clang.llvm.org/docs/OffloadingDesign.html#offload-device-compilation+-}++filterClangStderr :: String -> String+filterClangStderr = unlines . filter (not . isShflSyncWarn) . lines+  where+    -- ptxas warns about use of shfl instructions without the .sync suffix on+    -- CC 6.0, because such non-sync shuffles are deprecated (and indeed+    -- removed in CC 7.0). We still use them in CC 6.0 (and not any more in CC+    -- 7.0) because the shfl.sync in CC 6.0 has restrictions:+    --+    -- > For .target `sm_6x` or below, all threads in `membermask` must execute+    -- > the same `shfl.sync` instruction in convergence, and only threads+    -- > belonging to some `membermask` can be active when the `shfl.sync`+    -- > instruction is executed. Otherwise, the behavior is undefined.+    -- (https://docs.nvidia.com/cuda/parallel-thread-execution/index.html#data-movement-and-conversion-instructions-shfl-sync)+    --+    -- Perhaps we do use the shuffles in convergence, but we don't want to risk+    -- it. Hence in CC 6.0, we still use non-sync shuffles.+    --+    -- The ptxas warning cannot be turned off, however, and is **incredibly**+    -- noisy (there's a warning for every single shfl instruction). Hence we+    -- filter them out here.+    --+    -- > ptxas /tmp/--f8a421.s, line 119; warning : Instruction 'shfl' without '.sync' is deprecated since PTX ISA version 6.0 and will be discontinued in a future PTX ISA version+    isShflSyncWarn line =+      let (presemi, postsemi) = break (== ';') line+      in takeWhile (/= ' ') presemi == "ptxas" &&+           postsemi == "; warning : Instruction 'shfl' without '.sync' is deprecated since " +++                       "PTX ISA version 6.0 and will be discontinued in a future PTX ISA version"++-- | Returns a human-readable error message in case the device is unsupported,+-- and Nothing if everything is alright.+isDeviceSupported :: CUDA.Compute -> Maybe String+isDeviceSupported cc@(CUDA.Compute m _)+  -- We require shfl instructions which are available only from CC 3.0.+  | m >= 3 = Nothing+  | otherwise = Just $+      "Your GPU has compute capability " ++ show cc ++ ", but only >= 3.0 is supported."++accPreludePTX :: String+accPreludePTX = unlines+  -- see Data.Array.Accelerate.LLVM.PTX.CodeGen.Base.nanosleep for why this is a hand-written function+  ["define private void @" ++ name_nanosleep ++ "(i32 noundef %0) alwaysinline convergent nounwind {"+  ,"  tail call void asm sideeffect \"nanosleep.u32 $0;\", \"r\"(i32 %0)"+  ,"  ret void"+  ,"}"]+  where+    name_nanosleep = let LLVM.Label name = LLVM.makeAccPreludeLabel "nanosleep" in SBS8.unpack name
+ src/Data/Array/Accelerate/LLVM/PTX/Compile/Cache.hs view
@@ -0,0 +1,42 @@+{-# OPTIONS_GHC -Wno-orphans #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.PTX.Compile.Cache+-- Copyright   : [2017..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.PTX.Compile.Cache (++  module Data.Array.Accelerate.LLVM.Compile.Cache++) where++import Data.Array.Accelerate.LLVM.Compile.Cache+import Data.Array.Accelerate.LLVM.PTX.Target+import Data.Array.Accelerate.LLVM.Target.ClangInfo                  ( hostLLVMVersion )++import Control.Monad.Reader+import Data.Foldable                                                ( toList )+import Data.List                                                    ( intercalate )+import Data.Version+import Foreign.CUDA.Analysis+import System.FilePath+import Text.Printf+import qualified Data.ByteString.Short.Char8                        as S8++import Paths_accelerate_llvm_ptx+++instance Persistent PTX where+  targetCacheTemplate = do+    Compute m n <- asks (computeCapability . ptxDeviceProperties)+    return $ "accelerate-llvm-ptx-" ++ showVersion version+         </> "llvmpr-" ++ intercalate "." (map show (toList hostLLVMVersion))+         </> S8.unpack ptxTargetTriple+         </> printf "sm%d%d" m n+         </> "morp.sass"+
+ src/Data/Array/Accelerate/LLVM/PTX/Compile/Libdevice/Load.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      : Data.Array.Accelerate.LLVM.PTX.Compile.Libdevice.Load+-- Copyright   : [2014..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.PTX.Compile.Libdevice.Load (++  libdeviceBitcodePath,++) where++import Data.Array.Accelerate.Error+import Data.Array.Accelerate.LLVM.PTX.Execute.Event                 ( ) -- GHC#1012+import Data.Array.Accelerate.LLVM.PTX.Execute.Stream                ( ) -- GHC#1012++import qualified Foreign.CUDA.Driver                                as CUDA++import Foreign.CUDA.Path++import Data.List                                                    ( isPrefixOf, sortBy )+import System.Directory+import System.FilePath+++-- libdevice+-- ---------++-- Compatible version of libdevice for a given compute capability should be+-- listed here:+--+--   https://github.com/llvm/llvm-project/blob/master/lib/Target/NVPTX/NVPTX.td++-- | Find the libdevice bitcode file for the given compute architecture. The name+-- of the bitcode file follows the format @libdevice.XX.bc@, where XX+-- represents a version(?). We search the libdevice path for all files of the+-- appropriate compute capability and load the "most recent" (by sort order).+libdeviceBitcodePath :: HasCallStack => IO FilePath+libdeviceBitcodePath+  | CUDA.libraryVersion < 9000 =+      -- There is some support code for cuda < 9 in an earlier version of these+      -- files; in particular, look at commit+      --   2b5d69448557e89002c0179ea1aaf59bb757a6e3 (2023-08-22)+      -- for original llvm-hs code.+      internalError "Cuda < 9 is unsupported."+  | otherwise = do+      let nvvm    = cudaInstallPath </> "nvvm" </> "libdevice"++      files <- getDirectoryContents nvvm++      let matches f = "libdevice" `isPrefixOf` f && takeExtension f == ".bc"+      return $ case sortBy (flip compare) (filter matches files) of+                 name : _ -> nvvm </> name+                 [] -> internalError "not found: libdevice.XX.bc"
+ src/Data/Array/Accelerate/LLVM/PTX/Context.hs view
@@ -0,0 +1,269 @@+{-# LANGUAGE BangPatterns      #-}+{-# LANGUAGE LambdaCase        #-}+{-# LANGUAGE MagicHash         #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards   #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.PTX.Context+-- Copyright   : [2014..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.PTX.Context (++  Context(..),+  new, raw, withContext,+  contextFinalizeResource,++) where++import Data.Array.Accelerate.Lifetime+import Data.Array.Accelerate.LLVM.PTX.Analysis.Device+import qualified Data.Array.Accelerate.LLVM.PTX.Debug               as Debug++import qualified Foreign.CUDA.Driver.Device                         as CUDA+import qualified Foreign.CUDA.Driver.Context                        as CUDA++import Control.Concurrent+import Control.Exception+import Control.Monad+import Data.Char+import Data.Hashable+import Data.Int+import Data.IORef+import Data.Primitive.ByteArray+import Data.Text.Lazy.Builder+import Data.Word+import Formatting+import Prettyprinter+import Prettyprinter.Internal+import Prettyprinter.Render.Util.Panic+import Text.Printf+import qualified Data.Text.Lazy.Builder                             as TLB+import Prelude                                                      hiding ( (<>) )++import GHC.Base                                                     ( Int(..), addr2Int#, )+import GHC.Ptr                                                      ( Ptr(..) )+++-- | An execution context, which is tied to a specific device and CUDA execution+-- context.+--+data Context = Context {+    deviceProperties    :: {-# UNPACK #-} !CUDA.DeviceProperties        -- information on hardware resources+  , deviceName          :: {-# UNPACK #-} !ByteArray                    -- device name, used for profiling+  , deviceContext       :: {-# UNPACK #-} !(Lifetime CUDA.Context)      -- device execution context++  -- | The number of finalizers currently using the context to free resources,+  -- plus 1 if the Context finalizer does not yet want to destroy the context+  -- itself. See Note: [Finalizing a CUDA Context].+  , deviceFinalizerRefcount :: {-# UNPACK #-} !(IORef Int)+  }++instance Eq Context where+  c1 == c2 = deviceContext c1 == deviceContext c2++instance Hashable Context where+  hashWithSalt salt =+    let+        ptrToInt :: Ptr a -> Int+        ptrToInt (Ptr addr#) = I# (addr2Int# addr#)+    in+    hashWithSalt salt . ptrToInt . CUDA.useContext . unsafeGetValue . deviceContext+++-- | Create a new CUDA execution context+--+new :: CUDA.Device+    -> CUDA.DeviceProperties+    -> [CUDA.ContextFlag]+    -> IO Context+new dev prp flags = do+  ctx <- raw dev prp =<< CUDA.create dev flags+  _   <- CUDA.pop+  return ctx++-- | Wrap a raw CUDA execution context+--+raw :: CUDA.Device+    -> CUDA.DeviceProperties+    -> CUDA.Context+    -> IO Context+raw dev prp ctx = do+  refcountVar <- newIORef 1  -- there is one user of the context: the context itself++  -- The kernels don't use much shared memory, so for devices that support it+  -- prefer using those memory banks as an L1 cache.+  --+  -- TLM: Is this a good idea? For example, external libraries such as cuBLAS+  -- rely heavily on shared memory and thus this could adversely affect+  -- performance. Perhaps we should use 'setCacheConfigFun' for individual+  -- functions which might benefit from this.+  --+  when (CUDA.computeCapability prp >= CUDA.Compute 2 0)+       (CUDA.setCache CUDA.PreferL1)++  -- Generate the context name+  let str = printf "[%d] %s\0" (fromIntegral (CUDA.useDevice dev) :: Int) (CUDA.deviceName prp)+  mba <- newPinnedByteArray (length str)++  let go !_ []     = unsafeFreezeByteArray mba+      go !i (x:xs) = do+        writeByteArray mba i (fromIntegral (ord x) :: Word8)+        go (i+1) xs++  nm   <- go 0 str++  -- Display information about the selected device+  Debug.traceM Debug.dump_phases builder (deviceInfo dev prp)++  lft <- newLifetime ctx  -- on the CUDA context+  let !result = Context prp nm lft refcountVar+  addFinalizer lft $ decrementContext result++  return result+++-- | Push the context onto the CPUs thread stack of current contexts and execute+-- some operation.+--+{-# INLINE withContext #-}+withContext :: Context -> IO a -> IO a+withContext Context{..} action+  = runInBoundThread+  $ withLifetime deviceContext $ \ctx ->+      bracket_ (push ctx) pop action++{-# INLINE push #-}+push :: CUDA.Context -> IO ()+push ctx = do+  message ("push context: " % formatContext) ctx+  CUDA.push ctx++{-# INLINE pop #-}+pop :: IO ()+pop = do+  ctx <- CUDA.pop+  message ("pop context: " % formatContext) ctx++decrementContext :: Context -> IO ()+decrementContext ctx = do+  newCount <- atomicModifyIORef' (deviceFinalizerRefcount ctx) (\i -> (i - 1, i - 1))+  message ("decrement context " % formatContext % " to " % shown) (unsafeGetValue (deviceContext ctx)) newCount+  when (newCount == 0) $ CUDA.destroy (unsafeGetValue (deviceContext ctx))++-- | If the underlying CUDA context is already slated for destruction entirely+-- (or has already been destroyed) by its finalizer, this function does+-- nothing. If the CUDA context will live on (for now), the passed @IO@ action+-- is invoked with a lock held so that the CUDA context will not be destroyed+-- while your action runs. Use this in finalizers of CUDA resources such as+-- arrays and linked modules.+--+-- The context is not automatically pushed in the action; if you need to+-- 'withContext', do it yourself.+contextFinalizeResource :: Context -> IO () -> IO ()+contextFinalizeResource ctx action =+  -- See Note: [Finalizing a CUDA Context]+  bracket+    (do newCount <- atomicModifyIORef' (deviceFinalizerRefcount ctx) $ \i ->+                      if i == 0 then (0, 0) else (i + 1, i + 1)+        message ("increment context " % formatContext % " to " % shown) (unsafeGetValue (deviceContext ctx)) newCount+        return (newCount > 0))+    (\contextStillLive ->+        when contextStillLive (decrementContext ctx))+    (\contextStillLive ->+        when contextStillLive action)+++-- Debugging+-- ---------++-- Nicely format a summary of the selected CUDA device, example:+--+-- Device 0: GeForce 9600M GT (compute capability 1.1), 4 multiprocessors @ 1.25GHz (32 cores), 512MB global memory+--+deviceInfo :: CUDA.Device -> CUDA.DeviceProperties -> Builder+deviceInfo dev prp = go $ layoutPretty defaultLayoutOptions $+  devID <> colon <+> name <+> parens compute+        <> comma <+> processors <+> at <+> pretty clock <+> parens cores+        <> comma <+> memory+  where+    name        = pretty (CUDA.deviceName prp)+    compute     = "compute capability" <+> unsafeViaShow (CUDA.computeCapability prp)+    devID       = "device" <+> unsafeViaShow (CUDA.useDevice dev)+    processors  = pretty (CUDA.multiProcessorCount prp)                              <+> "multiprocessors"+    cores       = pretty (CUDA.multiProcessorCount prp * coresPerMultiProcessor prp) <+> "cores"+    memory      = pretty mem <+> "global memory"+    ----+    clock       = toLazyText $ Debug.showFFloatSIBase (Just 2) 1000 (fromIntegral $ CUDA.clockRate prp * 1000 :: Double) "Hz"+    mem         = toLazyText $ Debug.showFFloatSIBase (Just 0) 1024 (fromIntegral $ CUDA.totalGlobalMem prp   :: Double) "B"+    at          = pretty '@'++    go = \case+      SFail              -> panicUncaughtFail+      SEmpty             -> mempty+      SChar c rest       -> TLB.singleton c <> go rest+      SText _l t rest    -> TLB.fromText t <> go rest+      SLine i rest       -> TLB.singleton '\n' <> (TLB.fromText (textSpaces i) <> go rest)+      SAnnPush _ann rest -> go rest+      SAnnPop rest       -> go rest+++{-# INLINE message #-}+message :: Format (IO ()) a -> a+message fmt = Debug.traceM Debug.dump_gc ("gc: " % fmt)++{-# INLINE formatContext #-}+formatContext :: Format r (CUDA.Context -> r)+formatContext = later $ \(CUDA.Context c) -> bformat shown c+++-- Note: [Finalizing a CUDA Context]+--+-- Both a CUDA context and the resources we allocate within such a context+-- (currently, arrays, executable modules and events) are freed with+-- finalizers; these are invoked by the GC when it detects (after a GC pass)+-- that the Haskell heap objects are no longer reachable.+--+-- In our case, finalizers are attached to 'Lifetime' objects. The problem is+-- that even if a finalizer for Lifetime 1 refers to Lifetime 2, the GC does+-- not guarantee that the finalizer for Lifetime 1 runs to completion before the+-- finalizer of Lifetime 2 starts. (See the documentation for 'touchForeignPtr'+-- in base.) This is a problem for us because we are in this situation: to free+-- a resource within a CUDA context, we need a reference to that context and+-- the context needs to be alive. Thus finalizers for e.g. arrays reference the+-- Lifetime for the CUDA context.+--+-- If we just leave GHC to do finalization as it wishes, this means that a CUDA+-- context may well be destroyed before the resourcees in it are finalized,+-- leading to use-after-free errors and segfaults. We have two choices here:+-- 1. either we let the finalizer for a Context wait until the other finalizers+--    have run, or+-- 2. we free the Context when first we can, and let resource finalizers that+--    come later, do nothing.+-- We choose option 2 because destroying a CUDA context already frees the+-- resources in it, so there is no need to do meticulous manual cleanup here.+--+-- To accomplish this, we use reference counting. The context itself being+-- alive (precisely: its finalizer not yet having run) counts for one "use";+-- the only other "uses" are the finalizers for the CUDA resources in the+-- context. (There is no need to track anything before we start finalizing, so+-- this is enough.) The Context finalizer does nothing more than a decrement on+-- the refcount to release the "use" of the CUDA context by the Context object+-- itself.+--+-- To complete the picture:+-- - When decrementing, if we decremented to zero, we destroy the CUDA context.+-- - When incrementing, we are apparently in a resource finalizer, because that+--   is the only place where we increment. If here we see that the refcount is+--   already zero, we simply do nothing (and *skip* the resource finalizer+--   entirely): the CUDA context has already been destroyed, taking this+--   resource with it, so nothing more needs to be done.+--+-- The resource finalizers use 'contextFinalizeResource' to access this+-- functionality.+
+ src/Data/Array/Accelerate/LLVM/PTX/Debug.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE LambdaCase               #-}+{-# LANGUAGE OverloadedStrings        #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.PTX.Debug+-- Copyright   : [2014..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.PTX.Debug (++  module Data.Array.Accelerate.Debug.Internal,+  module Data.Array.Accelerate.LLVM.PTX.Debug,++) where++import Data.Array.Accelerate.Debug.Internal                         hiding ( timed, elapsed )+import qualified Data.Array.Accelerate.Debug.Internal               as D++import Foreign.CUDA.Driver.Stream                                   ( Stream )+import qualified Foreign.CUDA.Driver.Event                          as Event++import Control.Concurrent+import Control.Monad.Trans+import Data.Text.Lazy.Builder+import Formatting+import System.CPUTime++import GHC.Float+++-- | Execute an action and time the results. The second argument specifies how+-- to format the output string given elapsed GPU and CPU time respectively+--+timed+    :: MonadIO m+    => Flag+    -> (Double -> Double -> Double -> IO ())+    -> Maybe Stream+    -> m a+    -> m a+{-# INLINE timed #-}+timed f fmt =+  monitorProcTime (getFlag f) fmt++monitorProcTime+    :: MonadIO m+    => IO Bool+    -> (Double -> Double -> Double -> IO ())+    -> Maybe Stream+    -> m a+    -> m a+{-# INLINE monitorProcTime #-}+monitorProcTime enabled display stream action = do+  yes <- if debuggingIsEnabled then liftIO enabled else return False+  if yes+    then do+      gpuBegin  <- liftIO $ Event.create []+      gpuEnd    <- liftIO $ Event.create []+      wallBegin <- liftIO $ getMonotonicTime+      cpuBegin  <- liftIO $ getCPUTime+      _         <- liftIO $ Event.record gpuBegin stream+      result    <- action+      _         <- liftIO $ Event.record gpuEnd stream+      cpuEnd    <- liftIO $ getCPUTime+      wallEnd   <- liftIO $ getMonotonicTime++      -- Wait for the GPU to finish executing then display the timing execution+      -- message. Do this in a separate thread so that the remaining kernels can+      -- be queued asynchronously.+      --+      _         <- liftIO . forkIO $ do+        Event.block gpuEnd+        diff    <- Event.elapsedTime gpuBegin gpuEnd+        let gpuTime  = float2Double $ diff * 1E-3                   -- milliseconds+            cpuTime  = fromIntegral (cpuEnd - cpuBegin) * 1E-12     -- picoseconds+            wallTime = wallEnd - wallBegin                          -- seconds++        Event.destroy gpuBegin+        Event.destroy gpuEnd+        --+        display wallTime cpuTime gpuTime+      --+      return result++    else+      action+++{-# INLINE elapsed #-}+elapsed :: Format r (Double -> Double -> Double -> r)+elapsed = formatSIBase (Just 3) 1000 % "s (wall), "+        % formatSIBase (Just 3) 1000 % "s (cpu), "+        % formatSIBase (Just 3) 1000 % "s (gpu)"++-- accelerate/cbits/clock.c+foreign import ccall unsafe "clock_gettime_monotonic_seconds" getMonotonicTime :: IO Double++data Phase = Compile | Link | Execute++buildPhase :: Phase -> Builder+buildPhase = \case+  Compile -> "compile"+  Link    -> "link"+  Execute -> "execute"++phase :: MonadIO m => Phase -> m a -> m a+phase p = D.timed dump_phases (now ("phase " <> buildPhase p <> ": ") % D.elapsed)+
+ src/Data/Array/Accelerate/LLVM/PTX/Embed.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE QuasiQuotes     #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -Wno-orphans #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.PTX.Embed+-- Copyright   : [2017..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.PTX.Embed (++  module Data.Array.Accelerate.LLVM.Embed,++) where++import Data.ByteString.Short.Extra                                  as BS++import Data.Array.Accelerate.Lifetime++import Data.Array.Accelerate.LLVM.Compile+import Data.Array.Accelerate.LLVM.Embed++import Data.Array.Accelerate.LLVM.PTX.Compile+import Data.Array.Accelerate.LLVM.PTX.Link+import Data.Array.Accelerate.LLVM.PTX.Target+import Data.Array.Accelerate.LLVM.PTX.Context++import qualified Foreign.CUDA.Driver                                as CUDA++import Control.Monad.IO.Class                                       ( liftIO )+import Foreign.Ptr+import GHC.Ptr                                                      ( Ptr(..) )+import Data.Array.Accelerate.TH.Compat                              ( CodeQ )+import System.IO.Unsafe+import qualified Data.ByteString                                    as B+import qualified Data.ByteString.Unsafe                             as B+import qualified Data.Array.Accelerate.TH.Compat                    as TH+++instance Embed PTX where+  embedForTarget = embed++-- Embed the given object code and set up to be reloaded at execution time.+--+embed :: PTX -> ObjectR PTX -> CodeQ (ExecutableR PTX)+embed target (ObjectR _ cfg objFname) = do+  -- Generate the embedded kernel executable. This will load the embedded object+  -- code into the current (at execution time) context.+  loadQ `TH.bindCode` \kmd ->+    [|| unsafePerformIO $ do+          jit <- CUDA.loadDataFromPtrEx+                   $$( liftIO (B.readFile objFname) `TH.bindCode` \obj ->+                       TH.unsafeCodeCoerce [| Ptr $(TH.litE (TH.StringPrimL (B.unpack obj))) |] )+                   []+          fun <- newLifetime (FunctionTable $$(listE (map (linkQ 'jit) kmd)))+          return $ PTXR fun+     ||]+  where+    -- Load the module to recover information such as number of registers+    -- and bytes of shared memory. It may be possible to do this without+    -- requiring an active CUDA context.+    loadQ :: TH.Q [(Kernel, CodeQ (Int -> Int))]+    loadQ = TH.runIO $ withContext (ptxContext target) $ do+      obj <- B.readFile objFname+      jit <- B.unsafeUseAsCString obj $ \p -> CUDA.loadDataFromPtrEx (castPtr p) []+      ks  <- mapM (uncurry (linkFunctionQ (CUDA.jitModule jit))) cfg+      CUDA.unload (CUDA.jitModule jit)+      return ks++    linkQ :: TH.Name -> (Kernel, CodeQ (Int -> Int)) -> CodeQ Kernel+    linkQ jit (Kernel name _ dsmem cta _, grid) =+      [|| unsafePerformIO $ do+            f <- CUDA.getFun (CUDA.jitModule $$(TH.unsafeCodeCoerce (TH.varE jit))) $$(liftSBS name)+            return $ Kernel $$(liftSBS name) f dsmem cta $$grid+       ||]++    listE :: [CodeQ a] -> CodeQ [a]+    listE xs = TH.unsafeCodeCoerce (TH.listE (map TH.unTypeCode xs))+
+ src/Data/Array/Accelerate/LLVM/PTX/Execute.hs view
@@ -0,0 +1,882 @@+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell     #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeOperators       #-}+{-# LANGUAGE ViewPatterns        #-}+{-# OPTIONS_GHC -Wno-orphans     #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.PTX.Execute+-- Copyright   : [2014..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.PTX.Execute (++  executeAcc,+  executeOpenAcc,++) where++import Data.Array.Accelerate.Analysis.Match+import Data.Array.Accelerate.Error+import Data.Array.Accelerate.Lifetime+import Data.Array.Accelerate.Representation.Array+import Data.Array.Accelerate.Representation.Shape+import Data.Array.Accelerate.Representation.Type+import Data.Array.Accelerate.Type++import Data.Array.Accelerate.LLVM.Execute++import Data.Array.Accelerate.LLVM.PTX.Analysis.Launch               ( multipleOf )+import Data.Array.Accelerate.LLVM.PTX.Array.Data+import Data.Array.Accelerate.LLVM.PTX.Array.Prim                    ( memsetArrayAsync )+import Data.Array.Accelerate.LLVM.PTX.Execute.Async+import Data.Array.Accelerate.LLVM.PTX.Execute.Environment+import Data.Array.Accelerate.LLVM.PTX.Execute.Marshal+import Data.Array.Accelerate.LLVM.PTX.Execute.Stream                ( Stream )+import Data.Array.Accelerate.LLVM.PTX.Link+import Data.Array.Accelerate.LLVM.PTX.Target+import qualified Data.Array.Accelerate.LLVM.PTX.Debug               as Debug+import qualified Data.Array.Accelerate.LLVM.PTX.Execute.Event       as Event++import qualified Foreign.CUDA.Driver                                as CUDA++import Control.Monad                                                ( forM_ )+import Control.Monad.State                                          ( liftIO )+import Data.ByteString.Short.Char8                                  ( ShortByteString, unpack )+import Data.List                                                    ( find )+import Data.Maybe                                                   ( fromMaybe )+import Formatting+import Prelude                                                      hiding ( exp, map, sum, scanl, scanr )+import qualified Data.ByteString.Short                              as S+import qualified Data.ByteString.Short.Extra                        as SE+import qualified Data.DList                                         as DL+++{-# SPECIALISE INLINE executeAcc     :: ExecAcc     PTX      a ->             Par PTX (FutureArraysR PTX a) #-}+{-# SPECIALISE INLINE executeOpenAcc :: ExecOpenAcc PTX aenv a -> Val aenv -> Par PTX (FutureArraysR PTX a) #-}++-- Array expression evaluation+-- ---------------------------++-- Computations are evaluated by traversing the AST bottom up, and for each node+-- distinguishing between three cases:+--+--  1. If it is a Use node, we return a reference to the array data. The data+--     will already have been copied to the device during compilation of the+--     kernels.+--+--  2. If it is a non-skeleton node, such as a let binding or shape conversion,+--     then execute directly by updating the environment or similar.+--+--  3. If it is a skeleton node, then we need to execute the generated LLVM+--     code.+--+instance Execute PTX where+  {-# INLINE map         #-}+  {-# INLINE generate    #-}+  {-# INLINE transform   #-}+  {-# INLINE backpermute #-}+  {-# INLINE fold        #-}+  {-# INLINE foldSeg     #-}+  {-# INLINE scan        #-}+  {-# INLINE scan'       #-}+  {-# INLINE permute     #-}+  {-# INLINE stencil1    #-}+  {-# INLINE stencil2    #-}+  {-# INLINE aforeign    #-}+  map           = mapOp+  generate      = generateOp+  transform     = transformOp+  backpermute   = backpermuteOp+  fold True     = foldOp+  fold False    = fold1Op+  foldSeg i _   = foldSegOp i+  scan _ True   = scanOp+  scan _ False  = scan1Op+  scan' _       = scan'Op+  permute       = permuteOp+  stencil1      = stencil1Op+  stencil2      = stencil2Op+  aforeign      = aforeignOp+++-- Skeleton implementation+-- -----------------------++-- Simple kernels just need to know the shape of the output array+--+{-# INLINE simpleOp #-}+simpleOp+    :: HasCallStack+    => ShortByteString+    -> ArrayR (Array sh e)+    -> ExecutableR PTX+    -> Gamma aenv+    -> Val aenv+    -> sh+    -> Par PTX (Future (Array sh e))+simpleOp name repr exe gamma aenv sh =+  withExecutable exe $ \ptxExecutable -> do+    future <- new+    result <- allocateRemote repr sh+    --+    let paramR = TupRsingle $ ParamRarray repr+    cleanup <- executeOp (ptxExecutable !# name) gamma aenv (arrayRshape repr) sh paramR result+    putCleanup future cleanup result+    return future++-- Mapping over an array can ignore the dimensionality of the array and+-- treat it as its underlying linear representation.+--+{-# INLINE mapOp #-}+mapOp+    :: HasCallStack+    => Maybe (a :~: b)+    -> ArrayR (Array sh a)+    -> TypeR b+    -> ExecutableR PTX+    -> Gamma aenv+    -> Val aenv+    -> Array sh a+    -> Par PTX (Future (Array sh b))+mapOp inplace repr tp exe gamma aenv input@(shape -> sh) =+  withExecutable exe $ \ptxExecutable -> do+    let reprOut = ArrayR (arrayRshape repr) tp+    future <- new+    result <- case inplace of+                Just Refl -> return input+                Nothing   -> allocateRemote reprOut sh+    --+    let paramsR = TupRsingle (ParamRarray reprOut) `TupRpair` TupRsingle (ParamRarray repr)+    cleanup <- executeOp (ptxExecutable !# "map") gamma aenv (arrayRshape repr) sh paramsR (result, input)+    putCleanup future cleanup result+    return future++{-# INLINE generateOp #-}+generateOp+    :: HasCallStack+    => ArrayR (Array sh e)+    -> ExecutableR PTX+    -> Gamma aenv+    -> Val aenv+    -> sh+    -> Par PTX (Future (Array sh e))+generateOp = simpleOp "generate"++{-# INLINE transformOp #-}+transformOp+    :: HasCallStack+    => ArrayR (Array sh a)+    -> ArrayR (Array sh' b)+    -> ExecutableR PTX+    -> Gamma aenv+    -> Val aenv+    -> sh'+    -> Array sh a+    -> Par PTX (Future (Array sh' b))+transformOp repr repr' exe gamma aenv sh' input =+  withExecutable exe $ \ptxExecutable -> do+    future <- new+    result <- allocateRemote repr' sh'+    let paramsR = TupRsingle (ParamRarray repr') `TupRpair` TupRsingle (ParamRarray repr)+    cleanup <- executeOp (ptxExecutable !# "transform") gamma aenv (arrayRshape repr') sh' paramsR (result, input)+    putCleanup future cleanup result+    return future++{-# INLINE backpermuteOp #-}+backpermuteOp+    :: HasCallStack+    => ArrayR (Array sh e)+    -> ShapeR sh'+    -> ExecutableR PTX+    -> Gamma aenv+    -> Val aenv+    -> sh'+    -> Array sh e+    -> Par PTX (Future (Array sh' e))+backpermuteOp (ArrayR shr tp) shr' = transformOp (ArrayR shr tp) (ArrayR shr' tp)++-- There are two flavours of fold operation:+--+--   1. If we are collapsing to a single value, then multiple thread blocks are+--      working together. Since thread blocks synchronise with each other via+--      kernel launches, each block computes a partial sum and the kernel is+--      launched recursively until the final value is reached.+--+--   2. If this is a multidimensional reduction, then each inner dimension is+--      handled by a single thread block, so no global communication is+--      necessary. Furthermore are two kernel flavours: each innermost dimension+--      can be cooperatively reduced by (a) a thread warp; or (b) a thread+--      block. Currently we always use the first, but require benchmarking to+--      determine when to select each.+--+{-# INLINE fold1Op #-}+fold1Op+    :: HasCallStack+    => ArrayR (Array sh e)+    -> ExecutableR PTX+    -> Gamma aenv+    -> Val aenv+    -> Delayed (Array (sh, Int) e)+    -> Par PTX (Future (Array sh e))+fold1Op repr exe gamma aenv arr@(delayedShape -> sh@(sx, sz))+  = boundsCheck "empty array" (sz > 0)+  $ case size (ShapeRsnoc $ arrayRshape repr) sh of+      0 -> newFull =<< allocateRemote repr sx  -- empty, but possibly with one or more non-zero dimensions+      _ -> foldCore repr exe gamma aenv arr++{-# INLINE foldOp #-}+foldOp+    :: HasCallStack+    => ArrayR (Array sh e)+    -> ExecutableR PTX+    -> Gamma aenv+    -> Val aenv+    -> Delayed (Array (sh, Int) e)+    -> Par PTX (Future (Array sh e))+foldOp repr exe gamma aenv arr@(delayedShape -> sh@(sx, _))+  = case size (ShapeRsnoc $ arrayRshape repr) sh of+      0 -> generateOp repr exe gamma aenv sx+      _ -> foldCore repr exe gamma aenv arr++{-# INLINE foldCore #-}+foldCore+    :: HasCallStack+    => ArrayR (Array sh e)+    -> ExecutableR PTX+    -> Gamma aenv+    -> Val aenv+    -> Delayed (Array (sh, Int) e)+    -> Par PTX (Future (Array sh e))+foldCore repr exe gamma aenv arr+  | ArrayR ShapeRz tp <- repr+  = foldAllOp tp exe gamma aenv arr+  --+  | otherwise+  = foldDimOp repr exe gamma aenv arr++{-# INLINE foldAllOp #-}+foldAllOp+    :: forall aenv e. HasCallStack+    => TypeR e+    -> ExecutableR PTX+    -> Gamma aenv+    -> Val aenv+    -> Delayed (Vector e)+    -> Par PTX (Future (Scalar e))+foldAllOp tp exe gamma aenv input =+  withExecutable exe $ \ptxExecutable -> do+    future <- new+    let+        ks        = ptxExecutable !# "foldAllS"+        km1       = ptxExecutable !# "foldAllM1"+        km2       = ptxExecutable !# "foldAllM2"+        sh@((), n) = delayedShape input+        paramsRinput = TupRsingle $ ParamRmaybe $ ParamRarray $ ArrayR dim1 tp+        paramsRdim0  = TupRsingle $ ParamRarray $ ArrayR dim0 tp+        paramsRdim1  = TupRsingle $ ParamRarray $ ArrayR dim1 tp+    --+    if kernelThreadBlocks ks n == 1+      then do+        -- The array is small enough that we can compute it in a single step+        result <- allocateRemote (ArrayR dim0 tp) ()+        let paramsR = paramsRdim0 `TupRpair` paramsRinput+        cleanup <- executeOp ks gamma aenv dim1 sh paramsR (result, manifest input)+        putCleanup future cleanup result++      else do+        -- Multi-kernel reduction to a single element. The first kernel integrates+        -- any delayed elements, and the second is called recursively until+        -- reaching a single element.+        -- The cleanup function is accumulated.+        let+            rec :: Vector e -> IO () -> Par PTX ()+            rec tmp@(Array ((),m) adata) cleanup+              | m <= 1    = putCleanup future cleanup (Array () adata)+              | otherwise = do+                  let sh' = ((), m `multipleOf` kernelThreadBlockSize km2)+                  out <- allocateRemote (ArrayR dim1 tp) sh'+                  let paramsR2 = paramsRdim1 `TupRpair` paramsRdim1+                  cleanup2 <- executeOp km2 gamma aenv dim1 sh' paramsR2 (tmp, out)+                  rec out (cleanup >> cleanup2)+        --+        let sh' = ((), n `multipleOf` kernelThreadBlockSize km1)+        tmp <- allocateRemote (ArrayR dim1 tp) sh'+        let paramsR1 = paramsRdim1 `TupRpair` paramsRinput+        cleanup <- executeOp km1 gamma aenv dim1 sh' paramsR1 (tmp, manifest input)+        rec tmp cleanup+    --+    return future+++{-# INLINE foldDimOp #-}+foldDimOp+    :: HasCallStack+    => ArrayR (Array sh e)+    -> ExecutableR PTX+    -> Gamma aenv+    -> Val aenv+    -> Delayed (Array (sh, Int) e)+    -> Par PTX (Future (Array sh e))+foldDimOp repr@(ArrayR shr tp) exe gamma aenv input@(delayedShape -> (sh, sz))+  | sz == 0   = generateOp repr exe gamma aenv sh+  | otherwise =+    withExecutable exe $ \ptxExecutable -> do+      future <- new+      result <- allocateRemote repr sh+      --+      let paramsR = TupRsingle (ParamRarray repr) `TupRpair` TupRsingle (ParamRmaybe $ ParamRarray $ ArrayR (ShapeRsnoc shr) tp)+      cleanup <- executeOp (ptxExecutable !# "fold") gamma aenv shr sh paramsR (result, manifest input)+      putCleanup future cleanup result+      return future+++{-# INLINE foldSegOp #-}+foldSegOp+    :: HasCallStack+    => IntegralType i+    -> ArrayR (Array (sh, Int) e)+    -> ExecutableR PTX+    -> Gamma aenv+    -> Val aenv+    -> Delayed (Array (sh, Int) e)+    -> Delayed (Segments i)+    -> Par PTX (Future (Array (sh, Int) e))+foldSegOp intTp repr exe gamma aenv input@(delayedShape -> (sh, sz)) segments@(delayedShape -> ((), ss)) =+  withExecutable exe $ \ptxExecutable -> do+    let+        ArrayR (ShapeRsnoc shr') _ = repr+        reprSeg = ArrayR dim1 $ TupRsingle $ SingleScalarType $ NumSingleType $ IntegralNumType intTp+        n       = ss - 1  -- segments array has been 'scanl (+) 0'`ed+        m       = size shr' sh * n+        foldseg = if (sz`quot`ss) < (2 * kernelThreadBlockSize foldseg_cta)+                    then foldseg_warp+                    else foldseg_cta+        --+        foldseg_cta   = ptxExecutable !# "foldSeg_block"+        foldseg_warp  = ptxExecutable !# "foldSeg_warp"+        -- qinit         = ptxExecutable !# "qinit"+    --+    future  <- new+    result  <- allocateRemote repr (sh, n)+    let paramsR = TupRsingle (ParamRarray repr) `TupRpair` TupRsingle (ParamRmaybe $ ParamRarray repr) `TupRpair` TupRsingle (ParamRmaybe $ ParamRarray reprSeg)+    cleanup <- executeOp foldseg gamma aenv dim1 ((), m) paramsR ((result, manifest input), manifest segments)+    putCleanup future cleanup result+    return future+++{-# INLINE scanOp #-}+scanOp+    :: HasCallStack+    => ArrayR (Array (sh, Int) e)+    -> ExecutableR PTX+    -> Gamma aenv+    -> Val aenv+    -> Delayed (Array (sh, Int) e)+    -> Par PTX (Future (Array (sh, Int) e))+scanOp repr exe gamma aenv input@(delayedShape -> (sz, n)) =+  case n of+    0 -> generateOp repr exe gamma aenv (sz, 1)+    _ -> scanCore repr exe gamma aenv (n+1) input++{-# INLINE scan1Op #-}+scan1Op+    :: HasCallStack+    => ArrayR (Array (sh, Int) e)+    -> ExecutableR PTX+    -> Gamma aenv+    -> Val aenv+    -> Delayed (Array (sh, Int) e)+    -> Par PTX (Future (Array (sh, Int) e))+scan1Op repr exe gamma aenv input@(delayedShape -> sh@(_, n)) =+  case n of+    0 -> newFull =<< allocateRemote repr sh+    _ -> scanCore repr exe gamma aenv n input++{-# INLINE scanCore #-}+scanCore+    :: HasCallStack+    => ArrayR (Array (sh, Int) e)+    -> ExecutableR PTX+    -> Gamma aenv+    -> Val aenv+    -> Int                    -- output size of innermost dimension+    -> Delayed (Array (sh, Int) e)+    -> Par PTX (Future (Array (sh, Int) e))+scanCore repr exe gamma aenv m input+  | ArrayR (ShapeRsnoc ShapeRz) tp <- repr+  = scanAllOp tp exe gamma aenv m input+  --+  | otherwise+  = scanDimOp repr exe gamma aenv m input++{-# INLINE scanAllOp #-}+scanAllOp+    :: HasCallStack+    => TypeR e+    -> ExecutableR PTX+    -> Gamma aenv+    -> Val aenv+    -> Int                    -- output size+    -> Delayed (Vector e)+    -> Par PTX (Future (Vector e))+scanAllOp tp exe gamma aenv m input@(delayedShape -> ((), n)) =+  withExecutable exe $ \ptxExecutable -> do+    let+        k1  = ptxExecutable !# "scanP1"+        k2  = ptxExecutable !# "scanP2"+        k3  = ptxExecutable !# "scanP3"+        --+        c   = kernelThreadBlockSize k1+        s   = n `multipleOf` c+        --+        repr = ArrayR dim1 tp+        paramR = TupRsingle $ ParamRarray repr+        paramsR1 = paramR `TupRpair` paramR `TupRpair` TupRsingle (ParamRmaybe $ ParamRarray repr)+        paramsR3 = paramR `TupRpair` paramR `TupRpair` TupRsingle ParamRint+    --+    future  <- new+    result  <- allocateRemote repr ((), m)++    -- Step 1: Independent thread-block-wide scans of the input. Small arrays+    -- which can be computed by a single thread block will require no+    -- additional work.+    tmp     <- allocateRemote repr ((), s)+    cleanup1 <- executeOp k1 gamma aenv dim1 ((), s) paramsR1 ((tmp, result), manifest input)++    -- Step 2: Multi-block reductions need to compute the per-block prefix,+    -- then apply those values to the partial results.+    cleanup2 <-+      if s > 1+        then do+          cleanup2a <- executeOp k2 gamma aenv dim1 ((), s)   paramR tmp+          cleanup2b <- executeOp k3 gamma aenv dim1 ((), s-1) paramsR3 ((tmp, result), c)+          return (cleanup2a >> cleanup2b)+        else+          return (return ())++    putCleanup future (cleanup1 >> cleanup2) result+    return future++{-# INLINE scanDimOp #-}+scanDimOp+    :: HasCallStack+    => ArrayR (Array (sh, Int) e)+    -> ExecutableR PTX+    -> Gamma aenv+    -> Val aenv+    -> Int+    -> Delayed (Array (sh, Int) e)+    -> Par PTX (Future (Array (sh, Int) e))+scanDimOp repr exe gamma aenv m input@(delayedShape -> (sz, _)) =+  withExecutable exe $ \ptxExecutable -> do+    let ArrayR (ShapeRsnoc shr') _ = repr+    future  <- new+    result  <- allocateRemote repr (sz, m)+    let paramsR = TupRsingle (ParamRarray repr) `TupRpair` TupRsingle (ParamRmaybe $ ParamRarray repr)+    cleanup <- executeOp (ptxExecutable !# "scan") gamma aenv dim1 ((), size shr' sz) paramsR (result, manifest input)+    putCleanup future cleanup result+    return future+++{-# INLINE scan'Op #-}+scan'Op+    :: HasCallStack+    => ArrayR (Array (sh, Int) e)+    -> ExecutableR PTX+    -> Gamma aenv+    -> Val aenv+    -> Delayed (Array (sh, Int) e)+    -> Par PTX (Future (Array (sh, Int) e, Array sh e))+scan'Op repr exe gamma aenv input@(delayedShape -> (sz, n)) =+  case n of+    0 -> do+      future  <- new+      result  <- allocateRemote repr (sz, 0)+      sums    <- generateOp (reduceRank repr) exe gamma aenv sz+      fork $ do sums' <- get sums+                put future (result, sums')+      return future+    --+    _ -> scan'Core repr exe gamma aenv input++{-# INLINE scan'Core #-}+scan'Core+    :: HasCallStack+    => ArrayR (Array (sh, Int) e)+    -> ExecutableR PTX+    -> Gamma aenv+    -> Val aenv+    -> Delayed (Array (sh, Int) e)+    -> Par PTX (Future (Array (sh, Int) e, Array sh e))+scan'Core repr exe gamma aenv input+  | ArrayR (ShapeRsnoc ShapeRz) tp <- repr+  = scan'AllOp tp exe gamma aenv input+  --+  | otherwise+  = scan'DimOp repr exe gamma aenv input++{-# INLINE scan'AllOp #-}+scan'AllOp+    :: HasCallStack+    => TypeR e+    -> ExecutableR PTX+    -> Gamma aenv+    -> Val aenv+    -> Delayed (Vector e)+    -> Par PTX (Future (Vector e, Scalar e))+scan'AllOp tp exe gamma aenv input@(delayedShape -> ((), n)) =+  withExecutable exe $ \ptxExecutable -> do+    let+        repr = ArrayR dim1 tp+        paramRdim0 = TupRsingle $ ParamRarray $ ArrayR dim0 tp+        paramRdim1 = TupRsingle $ ParamRarray repr+        k1  = ptxExecutable !# "scanP1"+        k2  = ptxExecutable !# "scanP2"+        k3  = ptxExecutable !# "scanP3"+        --+        c   = kernelThreadBlockSize k1+        s   = n `multipleOf` c+    --+    future  <- new+    result  <- allocateRemote repr ((), n)+    tmp     <- allocateRemote repr ((), s)++    -- Step 1: independent thread-block-wide scans. Each block stores its partial+    -- sum to a temporary array.+    let paramsR1 = paramRdim1 `TupRpair` paramRdim1 `TupRpair` TupRsingle (ParamRmaybe $ ParamRarray repr)+    cleanup1 <- executeOp k1 gamma aenv dim1 ((), s) paramsR1 ((tmp, result), manifest input)++    -- If this was a small array that was processed by a single thread block then+    -- we are done, otherwise compute the per-block prefix and apply those values+    -- to the partial results.+    if s == 1+      then+        case tmp of+          Array _ ad -> putCleanup future cleanup1 (result, Array () ad)++      else do+        sums <- allocateRemote (ArrayR dim0 tp) ()+        let paramsR2 = paramRdim1 `TupRpair` paramRdim0+        let paramsR3 = paramRdim1 `TupRpair` paramRdim1 `TupRpair` TupRsingle ParamRint+        cleanup2 <- executeOp k2 gamma aenv dim1 ((), s)   paramsR2 (tmp, sums)+        cleanup3 <- executeOp k3 gamma aenv dim1 ((), s-1) paramsR3 ((tmp, result), c)+        putCleanup future (cleanup1 >> cleanup2 >> cleanup3) (result, sums)+    --+    return future++{-# INLINE scan'DimOp #-}+scan'DimOp+    :: HasCallStack+    => ArrayR (Array (sh, Int) e)+    -> ExecutableR PTX+    -> Gamma aenv+    -> Val aenv+    -> Delayed (Array (sh, Int) e)+    -> Par PTX (Future (Array (sh, Int) e, Array sh e))+scan'DimOp repr@(ArrayR (ShapeRsnoc shr') _) exe gamma aenv input@(delayedShape -> sh@(sz, _)) =+  withExecutable exe $ \ptxExecutable -> do+    future  <- new+    result  <- allocateRemote repr sh+    sums    <- allocateRemote (reduceRank repr) sz+    let paramsR = TupRsingle (ParamRarray repr) `TupRpair` TupRsingle (ParamRarray $ reduceRank repr) `TupRpair` TupRsingle (ParamRmaybe $ ParamRarray repr)+    cleanup <- executeOp (ptxExecutable !# "scan") gamma aenv dim1 ((), size shr' sz) paramsR ((result, sums), manifest input)+    putCleanup future cleanup (result, sums)+    return future+++{-# INLINE permuteOp #-}+permuteOp+    :: HasCallStack+    => Bool+    -> ArrayR (Array sh e)+    -> ShapeR sh'+    -> ExecutableR PTX+    -> Gamma aenv+    -> Val aenv+    -> Array sh' e+    -> Delayed (Array sh e)+    -> Par PTX (Future (Array sh' e))+permuteOp inplace repr@(ArrayR shr tp) shr' exe gamma aenv defaults@(shape -> shOut) input@(delayedShape -> shIn) =+  withExecutable exe $ \ptxExecutable -> do+    let+        n        = size shr  shIn+        m        = size shr' shOut+        repr'    = ArrayR shr' tp+        reprLock = ArrayR dim1 $ TupRsingle $ scalarTypeWord32+        paramR   = TupRsingle $ ParamRmaybe $ ParamRarray repr+        paramR'  = TupRsingle $ ParamRarray repr'+        kernel   = case functionTable ptxExecutable of+                      k:_ -> k+                      _   -> internalError "no kernels found"+    --+    future  <- new+    result  <- if inplace+                 then Debug.trace Debug.dump_exec "exec: permute/inplace" $ return defaults+                 else Debug.trace Debug.dump_exec "exec: permute/clone"   $ get =<< cloneArrayAsync repr' defaults+    --+    let kernelName' =+          let kn = kernelName kernel+          in SE.take (S.length kn - 65) kn+    cleanup <- case kernelName' of+      -- execute directly using atomic operations+      "permute_rmw"   ->+        let paramsR = paramR' `TupRpair` paramR+        in  executeOp kernel gamma aenv dim1 ((), n) paramsR (result, manifest input)++      -- a temporary array is required for spin-locks around the critical section+      "permute_mutex" -> do+        barrier     <- new :: Par PTX (Future (Vector Word32))+        Array _ ad  <- allocateRemote reprLock ((), m)+        fork $ do fill <- memsetArrayAsync (NumSingleType $ IntegralNumType TypeWord32) m 0 ad+                  put barrier . Array ((), m) =<< get fill+        --+        let paramsR = paramR' `TupRpair` TupRsingle (ParamRfuture $ ParamRarray reprLock) `TupRpair` paramR+        executeOp kernel gamma aenv dim1 ((), n) paramsR ((result, barrier), manifest input)++      _               -> internalError "unexpected kernel image"+    --+    putCleanup future cleanup result+    return future+++{-# INLINE stencil1Op #-}+stencil1Op+    :: HasCallStack+    => TypeR a+    -> ArrayR (Array sh b)+    -> sh+    -> ExecutableR PTX+    -> Gamma aenv+    -> Val aenv+    -> Delayed (Array sh a)+    -> Par PTX (Future (Array sh b))+stencil1Op tp repr@(ArrayR shr _) halo exe gamma aenv input@(delayedShape -> sh) =+  stencilCore repr exe gamma aenv halo sh paramsR (manifest input)+  where paramsR = TupRsingle $ ParamRmaybe $ ParamRarray $ ArrayR shr tp++-- Using the defaulting instances for stencil operations (for now).+--+{-# INLINE stencil2Op #-}+stencil2Op+    :: HasCallStack+    => TypeR a+    -> TypeR b+    -> ArrayR (Array sh c)+    -> sh+    -> ExecutableR PTX+    -> Gamma aenv+    -> Val aenv+    -> Delayed (Array sh a)+    -> Delayed (Array sh b)+    -> Par PTX (Future (Array sh c))+stencil2Op tpA tpB repr@(ArrayR shr _) halo exe gamma aenv input1@(delayedShape -> sh1) input2@(delayedShape -> sh2) =+  stencilCore repr exe gamma aenv halo (intersect (arrayRshape repr) sh1 sh2) paramsR (manifest input1, manifest input2)+  where paramsR = TupRsingle (ParamRmaybe $ ParamRarray $ ArrayR shr tpA) `TupRpair` TupRsingle (ParamRmaybe $ ParamRarray $ ArrayR shr tpB)++{-# INLINE stencilCore #-}+stencilCore+    :: forall aenv sh e params. HasCallStack+    => ArrayR (Array sh e)+    -> ExecutableR PTX+    -> Gamma aenv+    -> Val aenv+    -> sh                       -- border dimensions (i.e. index of first interior element)+    -> sh                       -- output array size+    -> ParamsR PTX params+    -> params+    -> Par PTX (Future (Array sh e))+stencilCore repr@(ArrayR shr _) exe gamma aenv halo shOut paramsR params =+  withExecutable exe $ \ptxExecutable -> do+    let+        inside  = ptxExecutable !# "stencil_inside"+        border  = ptxExecutable !# "stencil_border"++        shIn :: sh+        shIn = trav (\x y -> x - 2*y) shOut halo++        trav :: (Int -> Int -> Int) -> sh -> sh -> sh+        trav f a b = go (arrayRshape repr) a b+          where+            go :: ShapeR t -> t -> t -> t+            go ShapeRz           ()      ()      = ()+            go (ShapeRsnoc shr') (xa,xb) (ya,yb) = (go shr' xa ya, f xb yb)+    --+    future  <- new+    result  <- allocateRemote repr shOut+    parent  <- asksParState ptxStream+    parentStartPoint <- liftPar (Event.waypoint parent)++    -- interior (no bounds checking)+    let paramsRinside = TupRsingle (ParamRshape shr) `TupRpair` TupRsingle (ParamRarray repr) `TupRpair` paramsR+    cleanup1 <- executeOp inside gamma aenv shr shIn paramsRinside ((shIn, result), params)++    -- halo regions (bounds checking)+    -- executed in separate streams so that they might overlap the main stencil+    -- and each other, as individually they will not saturate the device+    forM_ (stencilBorders (arrayRshape repr) shOut halo) $ \(u, v) ->+      fork $ do+        -- synchronise with start of stencil computation, so that the arguments+        -- are available+        child <- asksParState ptxStream+        liftIO (Event.after parentStartPoint child)++        -- launch in a separate stream+        let sh = trav (-) v u+        let paramsRborder = TupRsingle (ParamRshape shr) `TupRpair` TupRsingle (ParamRshape shr)+                              `TupRpair` TupRsingle (ParamRarray repr)+                              `TupRpair` paramsR+        cleanup2 <- executeOp border gamma aenv shr sh paramsRborder (((u, sh), result), params)+        addCleanup future cleanup2++        -- make remainder of the parent stream depend on the border results+        event <- liftPar (Event.waypoint child)+        ready <- liftIO  (Event.query event)+        if ready then return ()+                 else liftIO (Event.after event parent)++    putCleanup future cleanup1 result+    return future++-- Compute the stencil border regions, where we may need to evaluate the+-- boundary conditions.+--+{-# INLINE stencilBorders #-}+stencilBorders+    :: forall sh. HasCallStack+    => ShapeR sh+    -> sh+    -> sh+    -> [(sh, sh)]+stencilBorders shr sh halo = [ face i | i <- [0 .. (2 * rank shr - 1)] ]+  where+    face :: Int -> (sh, sh)+    face n = go n shr sh halo++    go :: Int -> ShapeR t -> t -> t -> (t, t)+    go _ ShapeRz           ()         ()         = ((), ())+    go n (ShapeRsnoc shr') (sha, sza) (shb, szb)+      = let+            (sha', shb')  = go (n-2) shr' sha shb+            (sza', szb')+              | n <  0    = (0,       sza)+              | n == 0    = (0,       szb)+              | n == 1    = (sza-szb, sza)+              | otherwise = (szb,     sza-szb)+        in+        ((sha', sza'), (shb', szb'))+++-- Foreign functions+--+{-# INLINE aforeignOp #-}+aforeignOp+    :: HasCallStack+    => String+    -> ArraysR as+    -> ArraysR bs+    -> (as -> Par PTX (Future bs))+    -> as+    -> Par PTX (Future bs)+aforeignOp name _ _ asm arr = do+  stream <- asksParState ptxStream+  Debug.monitorProcTime query msg (Just (unsafeGetValue stream)) (asm arr)+  where+    msg   = Debug.traceM Debug.dump_exec ("exec: " % string % " " % Debug.elapsed) name+    query = if Debug.debuggingIsEnabled+              then return True+              else liftIO $ Debug.getFlag Debug.dump_exec++++-- Skeleton execution+-- ------------------++-- | Retrieve the named kernel+--+(!#) :: HasCallStack => FunctionTable -> ShortByteString -> Kernel+(!#) exe name+  = fromMaybe (internalError ("function not found: " % string) (unpack name))+  $ lookupKernel name exe++lookupKernel :: ShortByteString -> FunctionTable -> Maybe Kernel+lookupKernel name ptxExecutable =+  find (\k -> let n = kernelName k in SE.take (S.length n - 65) n == name) (functionTable ptxExecutable)++delayedShape :: Delayed (Array sh e) -> sh+delayedShape (Delayed sh) = sh+delayedShape (Manifest a) = shape a++manifest :: Delayed (Array sh e) -> Maybe (Array sh e)+manifest (Manifest a) = Just a+manifest Delayed{}    = Nothing++-- | Execute some operation with the supplied executable functions+--+withExecutable :: HasCallStack => ExecutableR PTX -> (FunctionTable -> Par PTX b) -> Par PTX b+withExecutable PTXR{..} f =+  localParState (\(s,_) -> (s,Just ptxExecutable)) $ do+    r <- f (unsafeGetValue ptxExecutable)+    liftIO $ touchLifetime ptxExecutable+    return r+++-- Execute the function implementing this kernel.+--+executeOp+    :: HasCallStack+    => Kernel+    -> Gamma aenv+    -> Val aenv+    -> ShapeR sh+    -> sh+    -> ParamsR PTX params+    -> params+    -> Par PTX (IO ())+executeOp kernel gamma aenv shr sh paramsR params =+  let n = size shr sh+  in  if n > 0+        then do+          stream <- asksParState ptxStream+          (argv, cleanup) <- marshalParams' @PTX (paramsR `TupRpair` TupRsingle (ParamRenv gamma)) (params, aenv)+          liftIO $ launch kernel stream n $ DL.toList argv+          return cleanup+        else+          return (return ())+++-- Execute a device function with the given thread configuration and function+-- parameters.+--+launch :: HasCallStack => Kernel -> Stream -> Int -> [CUDA.FunParam] -> IO ()+launch Kernel{..} stream n args =+  withLifetime stream $ \st ->+    Debug.monitorProcTime query msg (Just st) $+      CUDA.launchKernel kernelFun grid cta smem (Just st) args+  where+    cta   = (kernelThreadBlockSize, 1, 1)+    grid  = (kernelThreadBlocks n, 1, 1)+    smem  = kernelSharedMemBytes++    -- Debugging/monitoring support+    query = if Debug.debuggingIsEnabled+              then return True+              else Debug.getFlag Debug.dump_exec++    fst3 (x,_,_)      = x+    msg wall cpu gpu  = do+      verbose <- Debug.getFlag Debug.verbose+      let kernelName' | verbose   = kernelName+                      | otherwise = SE.take (S.length kernelName - 65) kernelName+      Debug.traceM Debug.dump_exec ("exec: " % string % " <<< " % int % ", " % int % ", " % int % " >>> " % Debug.elapsed)+        (unpack kernelName') (fst3 grid) (fst3 cta) smem wall cpu gpu+
+ src/Data/Array/Accelerate/LLVM/PTX/Execute/Async.hs view
@@ -0,0 +1,197 @@+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase                 #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE TypeSynonymInstances       #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.PTX.Execute.Async+-- Copyright   : [2014..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.PTX.Execute.Async (++  module Data.Array.Accelerate.LLVM.Execute.Async,+  module Data.Array.Accelerate.LLVM.PTX.Execute.Async,++) where++import Data.Array.Accelerate.Error+import Data.Array.Accelerate.Lifetime++import Data.Array.Accelerate.LLVM.Execute.Async+import Data.Array.Accelerate.LLVM.State++import Data.Array.Accelerate.LLVM.PTX.Target+import Data.Array.Accelerate.LLVM.PTX.Execute.Event                 ( Event )+import Data.Array.Accelerate.LLVM.PTX.Execute.Stream                ( Stream )+import Data.Array.Accelerate.LLVM.PTX.Link.Object                   ( FunctionTable )+import qualified Data.Array.Accelerate.LLVM.PTX.Execute.Event       as Event+import qualified Data.Array.Accelerate.LLVM.PTX.Execute.Stream      as Stream++import Control.Monad.Reader+import Data.IORef+++-- | Evaluate a parallel computation+--+{-# INLINE evalPar #-}+evalPar :: Par PTX a -> LLVM PTX a+evalPar p = do+  s <- Stream.create+  r <- runReaderT (runPar p) (s, Nothing)+  return r+++type ParState = (Stream, Maybe (Lifetime FunctionTable))++ptxStream :: ParState -> Stream+ptxStream = fst++ptxKernel :: ParState -> Maybe (Lifetime FunctionTable)+ptxKernel = snd+++-- Implementation+-- --------------++data Future a = Future {-# UNPACK #-} !(IORef (IVar a))++data IVar a+    = Full !a+    | Pending {-# UNPACK #-} !Event !(IO ()) !a+    | Empty !(IO ())+++askParState :: Par PTX ParState+askParState = Par ask++asksParState :: (ParState -> a) -> Par PTX a+asksParState f = Par (asks f)++localParState :: (ParState -> ParState) -> Par PTX a -> Par PTX a+localParState f (Par m) = Par (local f m)++instance MonadReader PTX (Par PTX) where+  ask = Par (lift ask)+  local f (Par (ReaderT g)) = Par (ReaderT (\parstate -> local f (g parstate)))++instance Async PTX where+  type FutureR PTX = Future++  newtype Par PTX a = Par { runPar :: ReaderT ParState (LLVM PTX) a }+    deriving ( Functor, Applicative, Monad, MonadIO )++  {-# INLINEABLE new     #-}+  {-# INLINEABLE newFull #-}+  new       = Future <$> liftIO (newIORef (Empty (return ())))+  newFull v = Future <$> liftIO (newIORef (Full v))++  {-# INLINEABLE spawn #-}+  spawn m = do+    s' <- liftPar Stream.create+    r  <- localParState (const (s', Nothing)) m+    liftIO (Stream.destroy s')+    return r++  {-# INLINEABLE fork #-}+  fork m = do+    s' <- liftPar (Stream.create)+    () <- localParState (const (s', Nothing)) m+    liftIO (Stream.destroy s')++  -- When we call 'put' the actual work may not have been evaluated yet; get+  -- a new event in the current execution stream and once that is filled we can+  -- transition the IVar to Full.+  --+  {-# INLINEABLE put #-}+  put (Future ref) v = do+    stream <- asksParState ptxStream+    kernel <- asksParState ptxKernel+    event  <- liftPar (Event.waypoint stream)+    ready  <- liftIO  (Event.query event)+    let cleanupK = case kernel of+                     Just k -> touchLifetime k+                     Nothing -> return ()+    liftIO . atomicModifyIORef' ref $ \case+      Empty cleanup -> if ready then (Full v, ())+                                else (Pending event (cleanup >> cleanupK) v, ())+      _     -> internalError "multiple put"++  -- Get the value of Future. Since the actual cross-stream synchronisation+  -- happens on the device, we should never have to block/reschedule the main+  -- thread waiting on a value; if we get an empty IVar at this point, something+  -- has gone wrong.+  --+  {-# INLINEABLE get #-}+  get (Future ref) = do+    stream <- asksParState ptxStream+    liftIO  $ do+      ivar <- readIORef ref+      case ivar of+        Full v            -> return v+        Pending event cleanup v -> do+          ready <- Event.query event+          if ready+            then do+              writeIORef ref (Full v)+              cleanup+            else+              Event.after event stream+          return v+        Empty _         -> internalError "blocked on an IVar"++  {-# INLINEABLE block #-}+  block = liftIO . wait++  {-# INLINE liftPar #-}+  liftPar = Par . lift+++-- | Block the calling _host_ thread until the value offered by the future is+-- available.+--+{-# INLINEABLE wait #-}+wait :: Future a -> IO a+wait (Future ref) = do+  ivar <- readIORef ref+  case ivar of+    Full v            -> return v+    Pending event cleanup v -> do+      Event.block event+      writeIORef ref (Full v)+      cleanup+      return v+    Empty _         -> internalError "blocked on an IVar"++{-# INLINEABLE putCleanup #-}+putCleanup :: HasCallStack => FutureR PTX a -> IO () -> a -> Par PTX ()+putCleanup (Future ref) cleanup v = do+  stream <- asksParState ptxStream+  kernel <- asksParState ptxKernel+  event  <- liftPar (Event.waypoint stream)+  ready  <- liftIO  (Event.query event)+  let cleanupK = case kernel of+                   Just k -> touchLifetime k+                   Nothing -> return ()+  liftIO . atomicModifyIORef' ref $ \case+    Empty cleanup2 -> if ready then (Full v, ())+                               else (Pending event (cleanup2 >> cleanup >> cleanupK) v, ())+    _     -> internalError "multiple put"++{-# INLINEABLE addCleanup #-}+addCleanup :: HasCallStack => FutureR PTX a -> IO () -> Par PTX ()+addCleanup (Future ref) cleanup = liftIO $ do+  toRunNow <- atomicModifyIORef' ref $ \case+    Full v -> (Full v, cleanup)+    Pending event cleanup2 v -> (Pending event (cleanup2 >> cleanup) v, return ())+    Empty cleanup2 -> (Empty (cleanup2 >> cleanup), return ())+  toRunNow+
+ src/Data/Array/Accelerate/LLVM/PTX/Execute/Environment.hs view
@@ -0,0 +1,22 @@+-- |+-- Module      : Data.Array.Accelerate.LLVM.PTX.Execute.Environment+-- Copyright   : [2014..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.PTX.Execute.Environment (++  module Data.Array.Accelerate.LLVM.Execute.Environment,+  module Data.Array.Accelerate.LLVM.PTX.Execute.Environment,++) where++import Data.Array.Accelerate.LLVM.PTX.Target+import Data.Array.Accelerate.LLVM.Execute.Environment++type Val = ValR PTX+
+ src/Data/Array/Accelerate/LLVM/PTX/Execute/Event.hs view
@@ -0,0 +1,161 @@+{-# LANGUAGE NamedFieldPuns    #-}+{-# LANGUAGE OverloadedStrings #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.PTX.Execute.Event+-- Copyright   : [2014..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.PTX.Execute.Event (++  Event,+  create, destroy, query, waypoint, after, block,++) where++import Data.Array.Accelerate.Lifetime+import qualified Data.Array.Accelerate.Array.Remote.LRU             as Remote++import Data.Array.Accelerate.LLVM.PTX.Array.Remote                  ( )+import qualified Data.Array.Accelerate.LLVM.PTX.Context             as Context+import Data.Array.Accelerate.LLVM.PTX.Target                        ( PTX(..) )+import Data.Array.Accelerate.LLVM.State+import qualified Data.Array.Accelerate.LLVM.PTX.Debug               as Debug+import {-# SOURCE #-} Data.Array.Accelerate.LLVM.PTX.Execute.Stream++import Foreign.CUDA.Driver.Error+import qualified Foreign.CUDA.Driver.Event                          as Event+import qualified Foreign.CUDA.Driver.Stream                         as Stream++import Control.Exception+import Control.Monad+import Control.Monad.Reader+import Data.Text.Lazy.Builder+import Formatting+++-- | Events can be used for efficient device-side synchronisation between+-- execution streams and between the host.+--+type Event = Lifetime Event.Event+++-- | Create a new event. It will not be automatically garbage collected, and is+-- not suitable for timing purposes.+--+{-# INLINEABLE create #-}+create :: LLVM PTX Event+create = do+  ctx   <- asks ptxContext+  e     <- create'+  event <- liftIO $ newLifetime e+  liftIO $ addFinalizer event $ do+             message ("destroy " % formatEvent) e+             Context.contextFinalizeResource ctx $+               Event.destroy e+  return event++create' :: LLVM PTX Event.Event+create' = do+  PTX{ptxMemoryTable} <- asks llvmTarget+  me      <- attempt "create/new" (liftIO . catchOOM $ Event.create [Event.DisableTiming])+             `orElse` do+               Remote.reclaim ptxMemoryTable+               liftIO $ do+                 message "create/new: failed (purging)"+                 catchOOM $ Event.create [Event.DisableTiming]+  case me of+    Just e  -> return e+    Nothing -> liftIO $ do+      message "create/new: failed (non-recoverable)"+      throwIO (ExitCode OutOfMemory)++  where+    catchOOM :: IO a -> IO (Maybe a)+    catchOOM it =+      liftM Just it `catch` \e -> case e of+                                    ExitCode OutOfMemory -> return Nothing+                                    _                    -> throwIO e++    attempt :: MonadIO m => Builder -> m (Maybe a) -> m (Maybe a)+    attempt msg ea = do+      ma <- ea+      case ma of+        Nothing -> return Nothing+        Just a  -> do message builder msg+                      return (Just a)++    orElse :: MonadIO m => m (Maybe a) -> m (Maybe a) -> m (Maybe a)+    orElse ea eb = do+      ma <- ea+      case ma of+        Just a  -> return (Just a)+        Nothing -> eb+++-- | Delete an event+--+{-# INLINEABLE destroy #-}+destroy :: Event -> IO ()+destroy = finalize++-- | Create a new event marker that will be filled once execution in the+-- specified stream has completed all previously submitted work.+--+{-# INLINEABLE waypoint #-}+waypoint :: Stream -> LLVM PTX Event+waypoint stream = do+  event <- create+  liftIO $+    withLifetime stream  $ \s -> do+      withLifetime event $ \e -> do+        message ("add waypoint " % formatEvent % " in stream " % formatStream) e s+        Event.record e (Just s)+        return event++-- | Make all future work submitted to the given stream wait until the event+-- reports completion before beginning execution.+--+{-# INLINEABLE after #-}+after :: Event -> Stream -> IO ()+after event stream =+  withLifetime stream $ \s ->+  withLifetime event  $ \e -> do+    message ("after " % formatEvent % " in stream " % formatStream) e s+    Event.wait e (Just s) []++-- | Block the calling thread until the event is recorded+--+{-# INLINEABLE block #-}+block :: Event -> IO ()+block event =+  withLifetime event $ \e -> do+    message ("blocked on event " % formatEvent) e+    Event.block e++-- | Test whether an event has completed+--+{-# INLINEABLE query #-}+query :: Event -> IO Bool+query event = withLifetime event Event.query+++-- Debug+-- -----++{-# INLINE message #-}+message :: MonadIO m => Format (m ()) a -> a+message fmt = Debug.traceM Debug.dump_sched ("event: " % fmt)++{-# INLINE formatEvent #-}+formatEvent :: Format r (Event.Event -> r)+formatEvent = later $ \(Event.Event e) -> bformat shown e++{-# INLINE formatStream #-}+formatStream :: Format r (Stream.Stream -> r)+formatStream = later $ \(Stream.Stream s) -> bformat shown s+
+ 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..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- 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,108 @@+{-# LANGUAGE BangPatterns          #-}+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeFamilies          #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.PTX.Execute.Marshal+-- Copyright   : [2014..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.PTX.Execute.Marshal (++  module Data.Array.Accelerate.LLVM.Execute.Marshal++) where++import Data.Array.Accelerate.LLVM.State+import Data.Array.Accelerate.LLVM.Execute.Marshal++import Data.Array.Accelerate.LLVM.PTX.Target+import Data.Array.Accelerate.LLVM.PTX.Execute.Async+import qualified Data.Array.Accelerate.LLVM.PTX.Array.Prim      as Prim++import Data.Array.Accelerate.Type+import Data.Array.Accelerate.Array.Data++import qualified Foreign.CUDA.Driver                            as CUDA++import Control.Concurrent+import Control.Monad.IO.Class (liftIO)+import qualified Data.DList                                     as DL+++instance Marshal PTX where+  type ArgR PTX = CUDA.FunParam+  type MarshalCleanup PTX = IO ()++  marshalInt = CUDA.VArg+  marshalScalarData' t+    | SingleArrayDict <- singleArrayDict t+    = liftPar . fmap (\(ptr, cleanup) -> (DL.singleton (CUDA.VArg ptr), cleanup)) . getCudaDevicePtr t++-- | Return the CUDA device pointer corresponding to the given array, as well+-- as a cleanup IO action that __MUST__ be run once you are done with the+-- pointer (i.e. the GPU kernel has completed). Not calling the cleanup action+-- will result in leaked memory and resources. Calling the action twice will+-- block indefinitely on an MVar.+--+-- This function is a hack. Prim.withDevicePtr is intended to be a wrapping+-- function that retains the resource while the callback is running and+-- releases it when the callback returns. This is all nice, but since the PTX+-- Accelerate runtime is asynchronous, uses of withDevicePtr would not all be+-- neatly nested: the actual array lifetimes are haphazard intervals during+-- program execution.+--+-- Originally, this function just gave up and extracted the DevicePtr by+-- calling withDevicePtr with a trivial body that simply leaks p; this is+-- unsound (which was acknowledged by a 'fixme' comment...) and appears to have+-- been the cause of silent incorrect results (!) on a GTX 1050 Ti on the+-- adbench-gmmgrad test in accelerate-tests [1].+--+-- [1]: https://github.com/tomsmeding/accelerate-tests/blob/master/src/Data/Array/Accelerate/Tests/Prog/ADBenchGMMGrad.hs+--+-- Fortunately, it turns out that the MemoryTable implementation underlying+-- withDevicePtr does not in fact assume lexical nesting of array usages. Thus+-- we can use a hack to let the callback of withDevicePtr live for the correct+-- amount of time without needing to rearchitect the entire PTX backend: let+-- the call run in a forkIO thread and use MVars to communicate when it should+-- return. This means that we now have the possibility to return a+-- self-contained "cleanup" handler from getCudaDevicePtr that does nothing but+-- signal to the withDevicePtr callback that the array's lifetime has ended and+-- the scope can close. All this is possible because the 'LLVM' monad is just a+-- reader monad over IO, so we can unlift it into IO.+--+-- As a final, questionable improvement, we let the "cleanup" handler wait+-- until withDevicePtr has properly returned so that we know the array's+-- refcount has been properly decremented and memory has been released if+-- possible.+getCudaDevicePtr+    :: SingleType e+    -> ArrayData e+    -> LLVM PTX (CUDA.DevicePtr (ScalarArrayDataR e), IO ())+getCudaDevicePtr !t !ad = do+  ptrVar <- liftIO newEmptyMVar+  doneVar <- liftIO newEmptyMVar+  releasedVar <- liftIO newEmptyMVar++  _ <- unliftIOLLVM $ \inLLVM -> forkIO $ inLLVM $ do+    Prim.withDevicePtr t ad $ \p -> liftIO $ do+      putMVar ptrVar p+      takeMVar doneVar+      return (Nothing, ())+    liftIO $ putMVar releasedVar ()++  ptr <- liftIO $ readMVar ptrVar+  return (ptr, putMVar doneVar () >> readMVar releasedVar)+
+ src/Data/Array/Accelerate/LLVM/PTX/Execute/Stream.hs view
@@ -0,0 +1,174 @@+{-# LANGUAGE BangPatterns      #-}+{-# LANGUAGE MagicHash         #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards   #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.PTX.Execute.Stream+-- Copyright   : [2014..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.PTX.Execute.Stream (++  Reservoir, new,+  Stream, create, destroy, streaming,++) where++import Data.Array.Accelerate.Lifetime+import qualified Data.Array.Accelerate.Array.Remote.LRU             as Remote++import Data.Array.Accelerate.LLVM.PTX.Array.Remote                  ( )+import Data.Array.Accelerate.LLVM.PTX.Execute.Event                 ( Event )+import Data.Array.Accelerate.LLVM.PTX.Target                        ( PTX(..) )+import Data.Array.Accelerate.LLVM.State+import qualified Data.Array.Accelerate.LLVM.PTX.Debug               as Debug+import qualified Data.Array.Accelerate.LLVM.PTX.Execute.Event       as Event+import Data.Array.Accelerate.LLVM.PTX.Execute.Stream.Reservoir      as RSV++import Foreign.CUDA.Driver.Error+import qualified Foreign.CUDA.Driver.Stream                         as Stream++import Control.Exception+import Control.Monad+import Control.Monad.Reader+import Data.Text.Lazy.Builder+import Formatting+++-- | A 'Stream' represents an independent sequence of computations executed on+-- the GPU. Operations in different streams may be executed concurrently with+-- each other, but operations in the same stream can never overlap.+-- 'Data.Array.Accelerate.LLVM.PTX.Execute.Event.Event's can be used for+-- efficient cross-stream synchronisation.+--+type Stream = Lifetime Stream.Stream+++-- Executing operations in streams+-- -------------------------------++-- | Execute an operation in a unique execution stream. The (asynchronous)+-- result is passed to a second operation together with an event that will be+-- signalled once the operation is complete. The stream and event are released+-- after the second operation completes.+--+{-# INLINEABLE streaming #-}+streaming+    :: (Stream -> LLVM PTX a)+    -> (Event -> a -> LLVM PTX b)+    -> LLVM PTX b+streaming !action !after = do+  stream  <- create+  first   <- action stream+  end     <- Event.waypoint stream+  final   <- after end first+  liftIO $ do+    destroy stream+    Event.destroy end+  return final+++-- Primitive operations+-- --------------------++{--+-- | Delete all execution streams from the reservoir+--+{-# INLINEABLE flush #-}+flush :: Context -> Reservoir -> IO ()+flush !Context{..} !ref = do+  mc <- deRefWeak weakContext+  case mc of+    Nothing     -> message "delete reservoir/dead context"+    Just ctx    -> do+      message "flush reservoir"+      old <- swapMVar ref Seq.empty+      bracket_ (CUDA.push ctx) CUDA.pop $ Seq.mapM_ Stream.destroy old+--}+++-- | Create a CUDA execution stream. If an inactive stream is available for use,+-- use that, otherwise generate a fresh stream.+--+-- Note: [Finalising execution streams]+--+-- We don't actually ensure that the stream has executed all of its operations+-- to completion before attempting to return it to the reservoir for reuse.+-- Doing so increases overhead of the LLVM RTS due to 'forkIO', and consumes CPU+-- time as 'Stream.block' busy-waits for the stream to complete. It is quicker+-- to optimistically return the streams to the end of the reservoir immediately,+-- and just check whether the stream is done before reusing it.+--+-- > void . forkIO $ do+-- >   Stream.block stream+-- >   modifyMVar_ ref $ \rsv -> return (rsv Seq.|> stream)+--+{-# INLINEABLE create #-}+create :: LLVM PTX Stream+create = do+  PTX{..} <- asks llvmTarget+  s       <- create'+  stream  <- liftIO $ newLifetime s+  liftIO $ addFinalizer stream (RSV.insert ptxStreamReservoir s)+  return stream++create' :: LLVM PTX Stream.Stream+create' = do+  PTX{..} <- asks llvmTarget+  ms      <- attempt "create/reservoir" (liftIO $ RSV.malloc ptxStreamReservoir)+             `orElse`+             attempt "create/new"       (liftIO . catchOOM $ Stream.create [])+             `orElse` do+               Remote.reclaim ptxMemoryTable+               liftIO $ do+                 message "create/new: failed (purging)"+                 catchOOM $ Stream.create []+  case ms of+    Just s  -> return s+    Nothing -> liftIO $ do+      message "create/new: failed (non-recoverable)"+      throwIO (ExitCode OutOfMemory)++  where+    catchOOM :: IO a -> IO (Maybe a)+    catchOOM it =+      liftM Just it `catch` \e -> case e of+                                    ExitCode OutOfMemory -> return Nothing+                                    _                    -> throwIO e++    attempt :: MonadIO m => Builder -> m (Maybe a) -> m (Maybe a)+    attempt msg ea = do+      ma <- ea+      case ma of+        Nothing -> return Nothing+        Just a  -> do message builder msg+                      return (Just a)++    orElse :: MonadIO m => m (Maybe a) -> m (Maybe a) -> m (Maybe a)+    orElse ea eb = do+      ma <- ea+      case ma of+        Just a  -> return (Just a)+        Nothing -> eb+++-- | Merge a stream back into the reservoir. This must only be done once all+-- pending operations in the stream have completed.+--+{-# INLINEABLE destroy #-}+destroy :: Stream -> IO ()+destroy = finalize+++-- Debug+-- -----++{-# INLINE message #-}+message :: MonadIO m => Format (m ()) a -> a+message fmt = Debug.traceM Debug.dump_sched ("stream: " % fmt)+
+ 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..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- 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,98 @@+{-# LANGUAGE BangPatterns      #-}+{-# LANGUAGE OverloadedStrings #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.PTX.Execute.Stream.Reservoir+-- Copyright   : [2016..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.PTX.Execute.Stream.Reservoir (++  Reservoir,+  new, malloc, insert,++) where++import Data.Array.Accelerate.LLVM.PTX.Context                       ( Context )+import qualified Data.Array.Accelerate.LLVM.PTX.Debug               as Debug++import Control.Concurrent.MVar+import Data.Sequence                                                ( Seq )+import Formatting+import qualified Data.Sequence                                      as Seq+import qualified Foreign.CUDA.Driver.Stream                         as Stream+++-- | The reservoir is a place to store CUDA execution streams that are currently+-- inactive. When a new stream is requested one is provided from the reservoir+-- if available, otherwise a fresh execution stream is created.+--+type Reservoir = MVar (Seq Stream.Stream)+++-- | Generate a new empty reservoir. It is not necessary to pre-populate it with+-- any streams because stream creation does not cause a device synchronisation.+--+-- Additionally, we do not need to finalise any of the streams. A reservoir is+-- tied to a specific execution context, so when the reservoir dies it is+-- because the PTX state and contained CUDA context have died, so there is+-- nothing more to do.+--+{-# INLINEABLE new #-}+new :: Context -> IO Reservoir+new _ctx = newMVar Seq.empty+++-- | Retrieve an execution stream from the reservoir, if one is available.+--+-- Since we put streams back onto the reservoir once we have finished adding+-- work to them, not once they have completed execution of the tasks, we must+-- check for one which has actually completed.+--+-- See note: [Finalising execution streams]+--+{-# INLINEABLE malloc #-}+malloc :: Reservoir -> IO (Maybe Stream.Stream)+malloc !ref =+  modifyMVar ref (search Seq.empty)+  where+    -- scan through the streams in the reservoir looking for the first inactive+    -- one. Optimistically adding the streams to the end of the reservoir as+    -- soon as we stop assigning new work to them (c.f. async), and just+    -- checking they have completed before reusing them, is quicker than having+    -- a finaliser thread block until completion before retiring them.+    --+    search !acc !rsv =+      case Seq.viewl rsv of+        Seq.EmptyL  -> return (acc, Nothing)+        s Seq.:< ss -> do+          done <- Stream.finished s+          case done of+            True  -> return (acc Seq.>< ss, Just s)+            False -> search (acc Seq.|> s) ss+++-- | Add a stream to the reservoir+--+{-# INLINEABLE insert #-}+insert :: Reservoir -> Stream.Stream -> IO ()+insert !ref !stream = do+  message ("stash stream " % formatStream) stream+  modifyMVar_ ref $ \rsv -> return (rsv Seq.|> stream)+++-- Debug+-- -----++{-# INLINE message #-}+message :: Format (IO ()) a -> a+message fmt = Debug.traceM Debug.dump_sched ("stream: " % fmt)++{-# INLINE formatStream #-}+formatStream :: Format r (Stream.Stream -> r)+formatStream = later $ \(Stream.Stream s) -> bformat shown s+
+ src/Data/Array/Accelerate/LLVM/PTX/Foreign.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE DeriveDataTypeable  #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving  #-}+{-# LANGUAGE TypeApplications    #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.PTX.Foreign+-- Copyright   : [2016..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.PTX.Foreign (++  -- Foreign functions+  ForeignAcc(..),+  ForeignExp(..),++  -- useful re-exports+  LLVM,+  PTX(..),+  Context(..),+  liftIO,+  withDevicePtr,+  module Data.Array.Accelerate.LLVM.PTX.Array.Data,+  module Data.Array.Accelerate.LLVM.PTX.Execute.Async,+  module Data.Array.Accelerate.LLVM.PTX.Execute.Event,+  module Data.Array.Accelerate.LLVM.PTX.Execute.Stream,++) where++import qualified Data.Array.Accelerate.Sugar.Foreign                as S++import Data.Array.Accelerate.LLVM.State+import Data.Array.Accelerate.LLVM.CodeGen.Sugar++import Data.Array.Accelerate.LLVM.Foreign+import Data.Array.Accelerate.LLVM.PTX.Array.Data+import Data.Array.Accelerate.LLVM.PTX.Array.Prim+import Data.Array.Accelerate.LLVM.PTX.Context+import Data.Array.Accelerate.LLVM.PTX.Execute.Async+import Data.Array.Accelerate.LLVM.PTX.Target+import Data.Array.Accelerate.LLVM.PTX.Execute.Stream                ( Stream )+import Data.Array.Accelerate.LLVM.PTX.Execute.Event                 ( Event, waypoint, query )++import Control.Monad.State+import Data.Typeable+++instance Foreign PTX where+  foreignAcc (ff :: asm (a -> b))+    | Just Refl        <- eqT @asm @ForeignAcc+    , ForeignAcc _ asm <- ff = Just asm+    | otherwise              = Nothing++  foreignExp (ff :: asm (x -> y))+    | Just Refl        <- eqT @asm @ForeignExp+    , ForeignExp _ asm <- ff = Just asm+    | otherwise              = Nothing++instance S.Foreign ForeignAcc where+  strForeign (ForeignAcc s _) = s++instance S.Foreign ForeignExp where+  strForeign (ForeignExp s _) = s+++-- Foreign functions in the PTX backend.+--+data ForeignAcc f where+  ForeignAcc :: String+             -> (a -> Par PTX (Future b))+             -> ForeignAcc (a -> b)++-- Foreign expressions in the PTX backend.+--+data ForeignExp f where+  ForeignExp :: String+             -> IRFun1 PTX () (x -> y)+             -> ForeignExp (x -> y)++deriving instance Typeable ForeignAcc+deriving instance Typeable ForeignExp+
+ src/Data/Array/Accelerate/LLVM/PTX/Link.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards   #-}+{-# LANGUAGE TypeFamilies      #-}+{-# OPTIONS_GHC -Wno-orphans   #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.PTX.Link+-- Copyright   : [2017..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.PTX.Link (++  module Data.Array.Accelerate.LLVM.Link,+  ExecutableR(..), FunctionTable(..), Kernel(..), ObjectCode,+  linkFunctionQ,++) where++import Data.Array.Accelerate.Lifetime++import Data.Array.Accelerate.LLVM.Link+import Data.Array.Accelerate.LLVM.State++import Data.Array.Accelerate.LLVM.PTX.Analysis.Launch+import Data.Array.Accelerate.LLVM.PTX.Compile+import Data.Array.Accelerate.LLVM.PTX.Context+import Data.Array.Accelerate.LLVM.PTX.Link.Cache+import Data.Array.Accelerate.LLVM.PTX.Link.Object+import Data.Array.Accelerate.LLVM.PTX.Target+import qualified Data.Array.Accelerate.LLVM.PTX.Debug               as Debug++import qualified Foreign.CUDA.Analysis                              as CUDA+import qualified Foreign.CUDA.Driver                                as CUDA++import Control.Monad.Reader+import Data.ByteString.Short.Char8                                  ( ShortByteString, unpack )+import Formatting+import Foreign.Ptr+import Data.Array.Accelerate.TH.Compat+import qualified Data.ByteString                                    as B+import qualified Data.ByteString.Unsafe                             as B+import Prelude                                                      as P hiding ( lookup )+++instance Link PTX where+  data ExecutableR PTX = PTXR { ptxExecutable :: {-# UNPACK #-} !(Lifetime FunctionTable)+                              }+  linkForTarget = link+++-- | Load the generated object code into the current CUDA context.+--+link :: ObjectR PTX -> LLVM PTX (ExecutableR PTX)+link (ObjectR uid cfg objFname) = do+  target <- asks llvmTarget+  cache  <- asks ptxKernelTable+  funs   <- liftIO $ dlsym uid cache $ do+    -- Load the SASS object code into the current CUDA context+    obj <- B.readFile objFname+    jit <- B.unsafeUseAsCString obj $ \p -> CUDA.loadDataFromPtrEx (castPtr p) []+    let mdl = CUDA.jitModule jit++    -- Extract the kernel functions+    nm  <- FunctionTable `fmap` mapM (uncurry (linkFunction mdl)) cfg+    oc  <- newLifetime mdl++    -- Finalise the module by unloading it from the CUDA context+    addFinalizer oc $ do+      Debug.traceM Debug.dump_ld ("ld: unload module: " % formatFunctionTable) nm+      contextFinalizeResource (ptxContext target) $+        withContext (ptxContext target) (CUDA.unload mdl)++    return (nm, oc)+  --+  return $! PTXR funs+++-- | Extract the named function from the module and package into a Kernel+-- object, which includes meta-information on resource usage.+--+-- If we are in debug mode, print statistics on kernel resource usage, etc.+--+linkFunction+    :: CUDA.Module                      -- the compiled module+    -> ShortByteString                  -- __global__ entry function name+    -> LaunchConfig                     -- launch configuration for this global function+    -> IO Kernel+linkFunction mdl name configure =+  fst `fmap` linkFunctionQ mdl name configure++linkFunctionQ+    :: CUDA.Module+    -> ShortByteString+    -> LaunchConfig+    -> IO (Kernel, CodeQ (Int -> Int))+linkFunctionQ mdl name configure = do+  f     <- CUDA.getFun mdl name+  regs  <- CUDA.requires f CUDA.NumRegs+  ssmem <- CUDA.requires f CUDA.SharedSizeBytes+  cmem  <- CUDA.requires f CUDA.ConstSizeBytes+  lmem  <- CUDA.requires f CUDA.LocalSizeBytes+  maxt  <- CUDA.requires f CUDA.MaxKernelThreadsPerBlock++  let+      (occ, cta, grid, dsmem, gridQ) = configure maxt regs ssmem++      msg1 = bformat ("kernel function " % squoted string % " used " % int % " registers, " % int % " bytes smem, " % int % " bytes lmem, " % int % " bytes cmem")+                      (unpack name) regs (ssmem + dsmem) lmem cmem++      msg2 = bformat ("multiprocessor occupancy " % fixed 1 % "% : " % int % " threads over " % int % " warps in " % int % " blocks")+                      (CUDA.occupancy100 occ)+                      (CUDA.activeThreads occ)+                      (CUDA.activeWarps occ)+                      (CUDA.activeThreadBlocks occ)++  Debug.traceM Debug.dump_cc ("cc: " % builder % "\n               " % builder) msg1 msg2+  return (Kernel name f dsmem cta grid, gridQ)+++{--+-- | Extract the names of the function definitions from the module.+--+-- Note: [Extracting global function names]+--+-- It is important to run this on the module given to us by code generation.+-- After combining modules with 'libdevice', extra function definitions,+-- corresponding to basic maths operations, will be added to the module. These+-- functions will not be callable as __global__ functions.+--+-- The list of names will be exported in the order that they appear in the+-- module.+--+globalFunctions :: [Definition] -> [String]+globalFunctions defs =+  [ n | GlobalDefinition Function{..} <- defs+      , not (null basicBlocks)+      , let Name n = name+      ]+--}+
+ src/Data/Array/Accelerate/LLVM/PTX/Link/Cache.hs view
@@ -0,0 +1,22 @@+-- |+-- Module      : Data.Array.Accelerate.LLVM.PTX.Link.Cache+-- Copyright   : [2017..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- 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,46 @@+-- |+-- Module      : Data.Array.Accelerate.LLVM.PTX.Link.Object+-- Copyright   : [2017..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.PTX.Link.Object+  where++import Data.Array.Accelerate.Lifetime+import Data.ByteString.Short.Char8                                  ( ShortByteString, unpack )+import Data.List+import Formatting+import qualified Foreign.CUDA.Driver                                as CUDA+++-- | The kernel function table is a list of the kernels implemented by a given+-- CUDA device module+--+data FunctionTable  = FunctionTable { functionTable :: [Kernel] }+data Kernel         = Kernel+  { kernelName                  :: {-# UNPACK #-} !ShortByteString+  , kernelFun                   :: {-# UNPACK #-} !CUDA.Fun+  , kernelSharedMemBytes        :: {-# UNPACK #-} !Int+  , kernelThreadBlockSize       :: {-# UNPACK #-} !Int+  , kernelThreadBlocks          :: (Int -> Int)+  }++instance Show FunctionTable where+  showsPrec _ f+    = showString "<<"+    . showString (intercalate "," [ unpack (kernelName k) | k <- functionTable f ])+    . showString ">>"++formatFunctionTable :: Format r (FunctionTable -> r)+formatFunctionTable = later $ \f ->+  bformat (angled (angled (commaSep string))) [ unpack (kernelName k) | k <- functionTable f ]++-- | Object code consists of executable code in the device address space+--+type ObjectCode = Lifetime CUDA.Module+
+ src/Data/Array/Accelerate/LLVM/PTX/Pool.hs view
@@ -0,0 +1,193 @@+{-# LANGUAGE ScopedTypeVariables #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.PTX.Pool+-- Copyright   : [2017..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- 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,176 @@+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.PTX.State+-- Copyright   : [2014..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.PTX.State (++  evalPTX,+  createTargetForDevice, createTargetFromContext,++  Pool(..),+  withPool, unsafeWithPool,+  defaultTarget,+  defaultTargetPool,++) where++import Data.Array.Accelerate.Error++import Data.Array.Accelerate.LLVM.State+import Data.Array.Accelerate.LLVM.PTX.Target+import qualified Data.Array.Accelerate.LLVM.PTX.Array.Table         as MT+import qualified Data.Array.Accelerate.LLVM.PTX.Context             as CT+import qualified Data.Array.Accelerate.LLVM.PTX.Debug               as Debug+import qualified Data.Array.Accelerate.LLVM.PTX.Execute.Stream      as ST+import qualified Data.Array.Accelerate.LLVM.PTX.Link.Cache          as LC+import qualified Data.Array.Accelerate.LLVM.PTX.Pool                as Pool++import Foreign.CUDA.Driver.Error+import qualified Foreign.CUDA.Driver                                as CUDA+import qualified Foreign.CUDA.Driver.Context                        as Context++import Control.Concurrent+import Control.Exception                                            ( try, catch )+import Data.Maybe                                                   ( fromMaybe, catMaybes )+import Formatting+import System.Environment                                           ( lookupEnv )+import System.IO.Unsafe                                             ( unsafePerformIO, unsafeInterleaveIO )+import Text.Read                                                    ( readMaybe )+++-- | Execute a PTX computation+--+evalPTX :: PTX -> LLVM PTX a -> IO a+evalPTX ptx acc =+  CT.withContext (ptxContext ptx) (evalLLVM ptx acc)+  `catch`+  \e -> internalError shown (e :: CUDAException)+++-- | Create a new PTX execution target for the given device+--+createTargetForDevice+    :: CUDA.Device+    -> CUDA.DeviceProperties+    -> [CUDA.ContextFlag]+    -> IO PTX+createTargetForDevice dev prp flags = do+  raw <- CUDA.create dev flags+  ptx <- createTarget dev prp raw+  _   <- CUDA.pop+  return ptx+++-- | Create a PTX execute target for the given device context+--+createTargetFromContext+    :: CUDA.Context+    -> IO PTX+createTargetFromContext raw = do+  dev <- Context.device+  prp <- CUDA.props dev+  createTarget dev prp raw+++-- | Create a PTX execution target+--+createTarget+    :: CUDA.Device+    -> CUDA.DeviceProperties+    -> CUDA.Context+    -> IO PTX+createTarget dev prp raw = do+  ctx <- CT.raw dev prp raw+  mt  <- MT.new ctx+  lc  <- LC.new+  st  <- ST.new ctx+  return $! PTX ctx mt lc st+++-- Shared execution contexts+-- -------------------------++-- In order to implement runN, we need to keep track of all available contexts,+-- as well as the managed resource pool.+--+data Pool a = Pool+    { managed   :: {-# UNPACK #-} !(Pool.Pool a)+    , unmanaged :: [a]+    }++-- Evaluate a thing given an execution context from the default pool+--+withPool :: Pool a -> (a -> IO b) -> IO b+withPool p = Pool.with (managed p)++unsafeWithPool :: Pool a -> (a -> b) -> b+unsafeWithPool p = Pool.unsafeWith (managed p)+++-- Top-level mutable state+-- -----------------------+--+-- It is important to keep some information alive for the entire run of the+-- program, not just a single execution. These tokens use 'unsafePerformIO' to+-- ensure they are executed only once, and reused for subsequent invocations.+--++-- | Select a device from the default pool.+--+{-# NOINLINE defaultTarget #-}+defaultTarget :: PTX+defaultTarget = case unmanaged defaultTargetPool of+                  ptx : _ -> ptx+                  _ -> error "impossible"  -- ensured by defaultTargetPool++-- | Create a shared resource pool of the available CUDA devices.+--+-- This globally shared resource pool is auto-initialised on startup. It will+-- consist of every currently available device, or those specified by the value+-- of the environment variable @ACCELERATE_LLVM_PTX_DEVICES@ (as a list of+-- device ordinals).+--+{-# NOINLINE defaultTargetPool #-}+defaultTargetPool :: Pool PTX+defaultTargetPool = unsafePerformIO $! do+  Debug.traceM Debug.dump_gc "gc: initialise default PTX pool"+  CUDA.initialise []++  -- Figure out which GPUs we should put into the execution pool+  --+  ngpu  <- CUDA.count+  menv  <- (readMaybe =<<) <$> lookupEnv "ACCELERATE_LLVM_PTX_DEVICES"++  let ids = fromMaybe [0..ngpu-1] menv++      -- Spin up the GPU at the given ordinal.+      --+      boot :: Int -> IO (Maybe PTX)+      boot i = unsafeInterleaveIO $ runInBoundThread $ do+        dev <- CUDA.device i+        prp <- CUDA.props dev+        r   <- try $ createTargetForDevice dev prp [CUDA.SchedAuto]+        case r of+          Right ptx               -> return (Just ptx)+          Left (e::CUDAException) -> do+            Debug.traceM Debug.dump_gc ("gc: failed to initialise device " % int % ": " % shown) i e+            return Nothing++  -- Create the pool from the available devices, which get spun-up lazily as+  -- required (due to the implementation of the Pool, we will look ahead by one+  -- each time one device is requested).+  --+  devices <- catMaybes <$> mapM boot ids+  if null devices+    then error "No CUDA-capable devices are available"+    else Pool <$> Pool.create devices+              <*> return devices+
+ src/Data/Array/Accelerate/LLVM/PTX/Target.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE EmptyDataDecls    #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications  #-}+{-# LANGUAGE TypeFamilies      #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.PTX.Target+-- Copyright   : [2014..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.PTX.Target (++  module Data.Array.Accelerate.LLVM.Target,+  module Data.Array.Accelerate.LLVM.PTX.Target,++) where++-- accelerate+import Data.Array.Accelerate.Error++import Data.Array.Accelerate.LLVM.Extra+import Data.Array.Accelerate.LLVM.Target++import Data.Array.Accelerate.LLVM.PTX.Array.Table                   ( MemoryTable )+import Data.Array.Accelerate.LLVM.PTX.Context                       ( Context, deviceProperties, deviceName )+import Data.Array.Accelerate.LLVM.PTX.Execute.Stream.Reservoir      ( Reservoir )+import Data.Array.Accelerate.LLVM.PTX.Link.Cache                    ( KernelTable )++-- CUDA+import Foreign.CUDA.Analysis.Device                                 ( DeviceProperties )++-- standard library+import Data.ByteString.Short                                        ( ShortByteString )+import Data.Primitive.ByteArray+import Foreign.C.String+import Foreign.Ptr+++-- | The PTX execution target for NVIDIA GPUs.+--+-- The execution target carries state specific for the current execution+-- context. The data here --- device memory and execution streams --- are+-- implicitly tied to this CUDA execution context.+--+-- Don't store anything here that is independent of the context, for example+-- state related to [persistent] kernel caching should _not_ go here.+--+data PTX = PTX {+    ptxContext                  :: {-# UNPACK #-} !Context+  , ptxMemoryTable              :: {-# UNPACK #-} !MemoryTable+  , ptxKernelTable              :: {-# UNPACK #-} !KernelTable+  , ptxStreamReservoir          :: {-# UNPACK #-} !Reservoir+  }++instance Target PTX where+  targetTriple     = Just ptxTargetTriple+  targetDataLayout = Nothing+++-- | Extract the properties of the device the current PTX execution state is+-- executing on.+--+ptxDeviceProperties :: PTX -> DeviceProperties+ptxDeviceProperties = deviceProperties . ptxContext++-- | Extract the name of the device of the current execution context+--+ptxDeviceName :: PTX -> CString+ptxDeviceName = castPtr . byteArrayContents . deviceName . ptxContext+++-- | String that describes the target host.+--+ptxTargetTriple :: HasCallStack => ShortByteString+ptxTargetTriple =+  case bitSize (undefined::Int) of+    32  -> "nvptx-nvidia-cuda"+    64  -> "nvptx64-nvidia-cuda"+    _   -> internalError "I don't know what architecture I am"
+ src/GHC/Heap/NormalForm.hs view
@@ -0,0 +1,93 @@+-- |+-- Module      : GHC.Heap.NormalForm+-- Copyright   : [2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--+-- https://github.com/input-output-hk/cardano-prelude/blob/96e8dcb29dc3c29eee99c0d020152fad6071af6d/src/Cardano/Prelude/GHC/Heap/NormalForm.hs+--+-- This code has been adapted from the module "GHC.AssertNF" of the package+-- <http://hackage.haskell.org/package/ghc-heap-view ghc-heap-view>+-- (<https://github.com/nomeata/ghc-heap-view GitHub>) authored by+-- Joachim Breitner.+--+-- To avoid space leaks and unwanted evaluation behaviour, the programmer+-- might want his data to be fully evaluated at certain positions in the+-- code. This can be enforced, for example, by ample use of+-- "Control.DeepSeq", but this comes at a cost.+--+-- Experienced users hence use 'Control.DeepSeq.deepseq' only to find out+-- about the existence of space leaks and optimize their code to not create+-- the thunks in the first place, until the code no longer shows better+-- performance with 'deepseq'.+--++module GHC.Heap.NormalForm (++  isHeadNormalForm,+  isNormalForm,++) where++import GHC.Exts.Heap++-- Everything is in normal form, unless it is a thunk explicitly marked as+-- such. Indirection are also considered to be in HNF.+--+isHeadNormalForm :: Closure -> IO Bool+isHeadNormalForm c = do+  case c of+    ThunkClosure{}    -> return False+    APClosure{}       -> return False+    SelectorClosure{} -> return False+    BCOClosure{}      -> return False+    _                 -> return True++-- | The function 'isNormalForm' checks whether its argument is fully evaluated+-- and deeply evaluated.+--+-- NOTE 1: If you want to override the behaviour of 'isNormalForm' for specific+-- types (in particular, for specific types that may be /nested/ somewhere+-- inside the @a@), consider using+-- 'Cardano.Prelude.GHC.Heap.NormalForm.Classy.noUnexpectedThunks' instead.+--+-- NOTE 2: The normal form check can be quite brittle, especially with @-O0@.+-- For example, writing something like+--+-- > let !(Value x) = ... in ....+--+-- might translate to+--+-- > let !.. = ... in ... (case ... of Value x -> x)+--+-- which would trivially be @False@. In general, 'isNormalForm' should probably+-- only be used with @-O1@, but even then the answer may still depend on+-- internal decisions made by ghc during compilation.+--+isNormalForm :: a -> IO Bool+isNormalForm x = isNormalFormBoxed (asBox x)++isNormalFormBoxed :: Box -> IO Bool+isNormalFormBoxed b = do+  c  <- getBoxedClosureData b+  nf <- isHeadNormalForm c+  if nf+    then do+      c' <- getBoxedClosureData b+      allM isNormalFormBoxed (allClosures c')+    else do+      return False++-- From Control.Monad.Loops in monad-loops+--+allM :: Monad m => (a -> m Bool) -> [a] -> m Bool+allM _ []       = return True+allM p (x : xs) = do+  q <- p x+  if q+    then allM p xs+    else return False+
+ src/System/Process/Extra.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE RecordWildCards #-}+-- |+-- Module      : System.Process.Extra+-- Copyright   : [2017..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- 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/Data/Array/Accelerate/LLVM/PTX/NoFib/RunQ.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE TemplateHaskell #-}+module Data.Array.Accelerate.LLVM.PTX.NoFib.RunQ where++import qualified Data.Array.Accelerate as A+import qualified Data.Array.Accelerate.LLVM.PTX as GPU++import Test.Tasty+import Test.Tasty.HUnit+++-- WARNING: This module is duplicated (apart from Native/PTX) between the+-- accelerate-llvm-native and accelerate-llvm-ptx backends. This code is not+-- included in the main Accelerate nofib testsuite because of staging issues:+-- the test can only be defined after runQ is known, and runQ is only built+-- after the 'accelerate' package has already finished building. It would be+-- possible to deduplicate the little Accelerate program in there, but that was+-- not deemed worth the effort.+++test_runq :: TestTree+test_runq =+  testGroup "runQ"+    [ testCase "simple" test_simple ]++test_simple :: Assertion+test_simple = do+  let prog :: A.Vector Int -> A.Scalar Int+      !prog = $(GPU.runQ $ \a -> A.sum (A.map (+1) (a :: A.Acc (A.Vector Int))))+  let n = 10000+  prog (A.fromList (A.Z A.:. 10000) [1..]) @=? A.fromList A.Z [n * (n + 1) `div` 2 + n]
+ test/nofib/Main.hs view
@@ -0,0 +1,19 @@+-- |+-- Module      : nofib-llvm-ptx+-- Copyright   : [2017..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Main where++import Data.Array.Accelerate.Test.NoFib+import Data.Array.Accelerate.LLVM.PTX+import Data.Array.Accelerate.LLVM.PTX.NoFib.RunQ++main :: IO ()+main = nofib runN test_runq+