cuda 0.6.7.0 → 0.13.0.0
raw patch · 70 files changed
Files
- CHANGELOG.md +223/−0
- Foreign/CUDA.hs +0/−19
- Foreign/CUDA/Analysis.hs +0/−20
- Foreign/CUDA/Analysis/Device.chs +0/−170
- Foreign/CUDA/Analysis/Occupancy.hs +0/−210
- Foreign/CUDA/Driver.hs +0/−32
- Foreign/CUDA/Driver/Context.chs +0/−362
- Foreign/CUDA/Driver/Device.chs +0/−321
- Foreign/CUDA/Driver/Error.chs +0/−191
- Foreign/CUDA/Driver/Event.chs +0/−146
- Foreign/CUDA/Driver/Exec.chs +0/−320
- Foreign/CUDA/Driver/Marshal.chs +0/−1005
- Foreign/CUDA/Driver/Module.chs +0/−331
- Foreign/CUDA/Driver/Stream.chs +0/−94
- Foreign/CUDA/Driver/Texture.chs +0/−284
- Foreign/CUDA/Driver/Utils.chs +0/−37
- Foreign/CUDA/Internal/C2HS.hs +0/−230
- Foreign/CUDA/Ptr.hs +0/−184
- Foreign/CUDA/Runtime.hs +0/−28
- Foreign/CUDA/Runtime/Device.chs +0/−444
- Foreign/CUDA/Runtime/Error.chs +0/−114
- Foreign/CUDA/Runtime/Event.chs +0/−147
- Foreign/CUDA/Runtime/Exec.chs +0/−274
- Foreign/CUDA/Runtime/Marshal.chs +0/−647
- Foreign/CUDA/Runtime/Stream.chs +0/−115
- Foreign/CUDA/Runtime/Texture.chs +0/−203
- Foreign/CUDA/Runtime/Utils.chs +0/−49
- Foreign/CUDA/Types.chs +0/−147
- README.md +175/−0
- Setup.hs +675/−278
- WINDOWS.md +54/−0
- cbits/init.c +54/−0
- cbits/stubs.c +142/−99
- cbits/stubs.h +51/−93
- changelog.md +0/−34
- cuda.cabal +122/−60
- examples/src/deviceQueryDrv/DeviceQuery.hs +111/−53
- src/Foreign/C/Extra.hs +38/−0
- src/Foreign/CUDA/Analysis.hs +20/−0
- src/Foreign/CUDA/Analysis/Device.chs +531/−0
- src/Foreign/CUDA/Analysis/Occupancy.hs +229/−0
- src/Foreign/CUDA/Driver.hs +246/−0
- src/Foreign/CUDA/Driver/Context.hs +23/−0
- src/Foreign/CUDA/Driver/Context/Base.chs +241/−0
- src/Foreign/CUDA/Driver/Context/Config.chs +297/−0
- src/Foreign/CUDA/Driver/Context/Peer.chs +173/−0
- src/Foreign/CUDA/Driver/Context/Primary.chs +170/−0
- src/Foreign/CUDA/Driver/Device.chs +410/−0
- src/Foreign/CUDA/Driver/Error.chs +216/−0
- src/Foreign/CUDA/Driver/Event.chs +203/−0
- src/Foreign/CUDA/Driver/Exec.chs +453/−0
- src/Foreign/CUDA/Driver/Graph/Base.chs +77/−0
- src/Foreign/CUDA/Driver/Graph/Build.chs +745/−0
- src/Foreign/CUDA/Driver/Graph/Capture.chs +223/−0
- src/Foreign/CUDA/Driver/Graph/Exec.chs +192/−0
- src/Foreign/CUDA/Driver/IPC/Event.chs +140/−0
- src/Foreign/CUDA/Driver/IPC/Marshal.chs +177/−0
- src/Foreign/CUDA/Driver/Marshal.chs +1197/−0
- src/Foreign/CUDA/Driver/Module.hs +20/−0
- src/Foreign/CUDA/Driver/Module/Base.chs +283/−0
- src/Foreign/CUDA/Driver/Module/Link.chs +227/−0
- src/Foreign/CUDA/Driver/Module/Query.chs +139/−0
- src/Foreign/CUDA/Driver/Profiler.chs +100/−0
- src/Foreign/CUDA/Driver/Stream.chs +523/−0
- src/Foreign/CUDA/Driver/Unified.chs +280/−0
- src/Foreign/CUDA/Driver/Utils.chs +50/−0
- src/Foreign/CUDA/Internal/C2HS.hs +277/−0
- src/Foreign/CUDA/Internal/Describe.hs +18/−0
- src/Foreign/CUDA/Path.chs +41/−0
- src/Foreign/CUDA/Ptr.hs +222/−0
+ CHANGELOG.md view
@@ -0,0 +1,223 @@+# Change Log++Notable changes to the project will be documented in this file.++The format is based on [Keep a Changelog](http://keepachangelog.com/).++**NOTE:** The version numbers of this package roughly align to the latest+version of the CUDA API this package is built against. This means that this+package _DOES NOT_ follow the PVP, or indeed any sensible version scheme,+because NVIDIA are A-OK introducing breaking changes in minor updates.+++## [0.13.0.0] - 2026-03-30+### Added+ * Support for CUDA-13++### Removed+ * Support for the runtime API (`Foreign.CUDA.RUntime`). There is an+ experimental cuda-runtime package in the Git repository; contact us if you+ depend on this.++## [0.12.8.0] - 2025-08-21+### Added+ * Support for CUDA-12+ - Thanks to @noahmartinwilliams on GitHub for helping out!++### Removed+ * The following modules have been deprecated for a long time, and have+ finally been removed in CUDA-12:+ - `Foreign.CUDA.Driver.Texture`+ - `Foreign.CUDA.Runtime.Texture`+ Support for Texture Objects (their replacement) is missing in these+ bindings so far. Contributions welcome.++## [0.11.0.1] - 2023-08-15+### Fixed+ * Build fixes for GHC 9.2 .. 9.6++## [0.11.0.0] - 2021-07-05+### Added+ * Add support for CUDA-11.[0..4]++## [0.10.2.0] - 2020-08-26+### Added+ * Add support for CUDA-10.2+ * Add support for Cabal-3+ * Add device properties for SM7.x, SM8++## [0.10.1.0] - 2019-04-29+### Added+ * Add support for CUDA-10.1++### Changed+ * The function `Foreign.CUDA.Driver.Graph.Capture.start` has an extra+ parameter to specify the capture mode++### Removed+ * The following functions have been deprecated (since at least CUDA-8) and are+ finally removed:+ - `Foreign.CUDA.Runtime.Exec.launch`+ - `Foreign.CUDA.Runtime.Exec.setParams`+ - `Foreign.CUDA.Runtime.Exec.setConfig`++## [0.10.0.0] - 2018-10-02+### Added+ * Device properties for SM7+ * Functions from CUDA-9.2+ * `Device.uuid`+ * `Stream.getContext`++ * Functions from CUDA-10.0+ * `Foreign.CUDA.Driver.Graph*`++ * Additional bindings from older CUDA releases++### Changed+ * Replace uses of `String` with `ShortByteString`++### Removed+ * Support for ghc-7.6++## [0.9.0.3] - 2018-03-12+### Fixed+ * Build fix for Cabal-2.2 (ghc-8.4)++## [0.9.0.2] - 2018-03-07+### Fixed+ * Build fix for Nix ([#53])++## [0.9.0.1] - 2018-02-16+### Fixed+ * Build fix for macOS High Sierra (10.13)++## [0.9.0.0] - 2017-11-15+### Fixed+ * Build fixes for CUDA-9++### Added+ * `Peer.getAttribute`+ * `Exec.launchKernelCooperative`++### Changed+ * Changed type of `Stream.wait` and `Stream.write` to support 64-bit values++## [0.8.0.1] - 2017-10-24+### Fixed+ * Escape backslashes used in -D flags on Windows ([#50])++## [0.8.0.0] - 2017-08-24+### Changed+ * Tested with CUDA toolkit 8.0++### Added+ * Add operations for unified addressing in the device API+ * Add `write` and `wait` operations for streams in the device API+ * (internals) The paths this module was configured against are exposed by the+ module `Foreign.CUDA.Paths`.++## [0.7.5.3] - 2017-03-23+### Fixed+ * Bug fix in occupancy calculator++## [0.7.5.2] - 2017-01-06+### Fixed+ * Build fails with library profiling ([#43])+ * On Windows, the Cabal installer is looking in the wrong place ([#45])+ * Windows install fix ([#47])++## [0.7.5.1] - 2016-10-21+### Fixed+ * Re-enable support for Cabal-1.22+ * Unknown CUDA device compute capability 6.1 ([#40])+ * Compilation fails for CUDA-8 [was: ghc 7.10.3 fail to install] ([#44])++## [0.7.5.0] - 2016-10-07+### Changed+ * Tested with CUDA toolkit 7.5++### Added+ * Add functions from CUDA-7.5+ * Add profiler control functions+ * Add function `mallocHostForeignPtr`++## [0.7.0.0] - 2015-11-30+### Changed+ * Add support for operations from CUDA-7.0+ * Add support for online linking+ * Add support for inter-process communication+ * Bug fixes, extra documentation, improve library coverage.+ * Mac OS X no longer requires the DYLD_LIBRARY_PATH environment variable in+ order to compile or run programs that use this package.++## [0.6.7.0] - 2015-09-12+### Added+ * Add support for building on Windows (thanks to @mwu-tow)++## [0.6.6.2] - 2015-04-04+### Fixed+ * Build fix++## [0.6.6.1] - 2015-04-04 [YANKED]+### Fixed+ * Build fixes for ghc-7.6 and ghc-7.10++## [0.6.6.0] - 2015-03-10+### Added+ * Add compute-capability data for 3.7, 5.2 devices.++### Changed+ * Combine the definition of the 'Event' and 'Stream' data types. As of+ CUDA-3.1 these data structures are equivalent, and can be safely shared+ between runtime and driver API calls and libraries.++ * Mark FFI imports of potentially long-running API functions as safe. This+ allows them to be safely called from Haskell threads without blocking the+ entire HEC.++### Removed+ * Drop support for CUDA 3.0 and older.++## [0.6.5.1] - 2014-12-02+### Fixed+ * Build fix for Mac OS X 10.10 (Yosemite)++## [0.6.5.0] - 2014-09-03+### Changed+ * Tested with CUDA toolkit 6.5++### Added+ * Add functions from CUDA-6.5++[next]: https://github.com/tmcdonell/cuda/compare/v0.11.0.1...HEAD+[0.11.0.1]: https://github.com/tmcdonell/cuda/compare/v0.11.0.0...v0.11.0.1+[0.11.0.0]: https://github.com/tmcdonell/cuda/compare/v0.10.2.0...v0.11.0.0+[0.10.2.0]: https://github.com/tmcdonell/cuda/compare/v0.10.1.0...v0.10.2.0+[0.10.1.0]: https://github.com/tmcdonell/cuda/compare/v0.10.0.0...v0.10.1.0+[0.10.0.0]: https://github.com/tmcdonell/cuda/compare/0.9.0.3...v0.10.0.0+[0.9.0.3]: https://github.com/tmcdonell/cuda/compare/0.9.0.2...0.9.0.3+[0.9.0.2]: https://github.com/tmcdonell/cuda/compare/0.9.0.1...0.9.0.2+[0.9.0.1]: https://github.com/tmcdonell/cuda/compare/0.9.0.0...0.9.0.1+[0.9.0.0]: https://github.com/tmcdonell/cuda/compare/0.8.0.1...0.9.0.0+[0.8.0.1]: https://github.com/tmcdonell/cuda/compare/0.8.0.0...0.8.0.1+[0.8.0.0]: https://github.com/tmcdonell/cuda/compare/0.7.5.3...0.8.0.0+[0.7.5.3]: https://github.com/tmcdonell/cuda/compare/0.7.5.2...0.7.5.3+[0.7.5.2]: https://github.com/tmcdonell/cuda/compare/0.7.5.1...0.7.5.2+[0.7.5.1]: https://github.com/tmcdonell/cuda/compare/0.7.5.0...0.7.5.1+[0.7.5.0]: https://github.com/tmcdonell/cuda/compare/0.7.0.0...0.7.5.0+[0.7.0.0]: https://github.com/tmcdonell/cuda/compare/0.6.7.0...0.7.0.0+[0.6.7.0]: https://github.com/tmcdonell/cuda/compare/0.6.6.2...0.6.7.0+[0.6.6.2]: https://github.com/tmcdonell/cuda/compare/0.6.6.1...0.6.6.2+[0.6.6.1]: https://github.com/tmcdonell/cuda/compare/0.6.6.0...0.6.6.1+[0.6.6.0]: https://github.com/tmcdonell/cuda/compare/0.6.5.1...0.6.6.0+[0.6.5.1]: https://github.com/tmcdonell/cuda/compare/0.6.5.0...0.6.5.1+[0.6.5.0]: https://github.com/tmcdonell/cuda/compare/0.6.0.1...0.6.5.0++[#40]: https://github.com/tmcdonell/cuda/issues/40+[#43]: https://github.com/tmcdonell/cuda/issues/43+[#44]: https://github.com/tmcdonell/cuda/issues/44+[#45]: https://github.com/tmcdonell/cuda/issues/45+[#47]: https://github.com/tmcdonell/cuda/pull/47+[#50]: https://github.com/tmcdonell/cuda/pull/50+[#53]: https://github.com/tmcdonell/cuda/pull/53+
− Foreign/CUDA.hs
@@ -1,19 +0,0 @@------------------------------------------------------------------------------------ |--- Module : Foreign.CUDA--- Copyright : [2009..2014] Trevor L. McDonell--- License : BSD------ Top level bindings. By default, expose the C-for-CUDA runtime API bindings,--- as they are slightly more user friendly.--------------------------------------------------------------------------------------module Foreign.CUDA (-- module Foreign.CUDA.Runtime--) where--import Foreign.CUDA.Runtime-
− Foreign/CUDA/Analysis.hs
@@ -1,20 +0,0 @@------------------------------------------------------------------------------------ |--- Module : Foreign.CUDA.Analysis--- Copyright : [2009..2014] Trevor L. McDonell--- License : BSD------ Meta-module exporting CUDA analysis routines--------------------------------------------------------------------------------------module Foreign.CUDA.Analysis (-- module Foreign.CUDA.Analysis.Device,- module Foreign.CUDA.Analysis.Occupancy--) where--import Foreign.CUDA.Analysis.Device-import Foreign.CUDA.Analysis.Occupancy-
− Foreign/CUDA/Analysis/Device.chs
@@ -1,170 +0,0 @@------------------------------------------------------------------------------------ |--- Module : Foreign.CUDA.Analysis.Device--- Copyright : [2009..2014] Trevor L. McDonell--- License : BSD------ Common device functions--------------------------------------------------------------------------------------module Foreign.CUDA.Analysis.Device- (- Compute(..), ComputeMode(..),- DeviceProperties(..), DeviceResources(..), Allocation(..), PCI(..),- deviceResources- )- where--#include "cbits/stubs.h"--import Data.Int-import Debug.Trace----- |--- The compute mode the device is currently in----{# enum CUcomputemode as ComputeMode- { underscoreToCase }- with prefix="CU_COMPUTEMODE" deriving (Eq, Show) #}---- |--- GPU compute capability, major and minor revision number respectively.----data Compute = Compute !Int !Int- deriving Eq--instance Show Compute where- show (Compute major minor) = show major ++ "." ++ show minor--instance Ord Compute where- compare (Compute m1 n1) (Compute m2 n2) =- case compare m1 m2 of- EQ -> compare n1 n2- x -> x--{---cap :: Int -> Int -> Double-cap a 0 = fromIntegral a-cap a b = let a' = fromIntegral a in- let b' = fromIntegral b in- a' + b' / max 10 (10^ ((ceiling . logBase 10) b' :: Int))---}---- |--- The properties of a compute device----data DeviceProperties = DeviceProperties- {- deviceName :: !String, -- ^ Identifier- computeCapability :: !Compute, -- ^ Supported compute capability- totalGlobalMem :: !Int64, -- ^ Available global memory on the device in bytes- totalConstMem :: !Int64, -- ^ Available constant memory on the device in bytes- sharedMemPerBlock :: !Int64, -- ^ Available shared memory per block in bytes- regsPerBlock :: !Int, -- ^ 32-bit registers per block- warpSize :: !Int, -- ^ Warp size in threads (SIMD width)- maxThreadsPerBlock :: !Int, -- ^ Max number of threads per block-#if CUDA_VERSION >= 4000- maxThreadsPerMultiProcessor :: !Int, -- ^ Max number of threads per multiprocessor-#endif- maxBlockSize :: !(Int,Int,Int), -- ^ Max size of each dimension of a block- maxGridSize :: !(Int,Int,Int), -- ^ Max size of each dimension of a grid-#if CUDA_VERSION >= 3000- maxTextureDim1D :: !Int, -- ^ Maximum texture dimensions- maxTextureDim2D :: !(Int,Int),- maxTextureDim3D :: !(Int,Int,Int),-#endif- clockRate :: !Int, -- ^ Clock frequency in kilohertz- multiProcessorCount :: !Int, -- ^ Number of multiprocessors on the device- memPitch :: !Int64, -- ^ Max pitch in bytes allowed by memory copies-#if CUDA_VERSION >= 4000- memBusWidth :: !Int, -- ^ Global memory bus width in bits- memClockRate :: !Int, -- ^ Peak memory clock frequency in kilohertz-#endif- textureAlignment :: !Int64, -- ^ Alignment requirement for textures- computeMode :: !ComputeMode,- deviceOverlap :: !Bool, -- ^ Device can concurrently copy memory and execute a kernel-#if CUDA_VERSION >= 3000- concurrentKernels :: !Bool, -- ^ Device can possibly execute multiple kernels concurrently- eccEnabled :: !Bool, -- ^ Device supports and has enabled error correction-#endif-#if CUDA_VERSION >= 4000- asyncEngineCount :: !Int, -- ^ Number of asynchronous engines- cacheMemL2 :: !Int, -- ^ Size of the L2 cache in bytes- tccDriverEnabled :: !Bool, -- ^ Whether this is a Tesla device using the TCC driver- pciInfo :: !PCI, -- ^ PCI device information for the device-#endif- kernelExecTimeoutEnabled :: !Bool, -- ^ Whether there is a runtime limit on kernels- integrated :: !Bool, -- ^ As opposed to discrete- canMapHostMemory :: !Bool, -- ^ Device can use pinned memory-#if CUDA_VERSION >= 4000- unifiedAddressing :: !Bool -- ^ Device shares a unified address space with the host-#endif- }- deriving (Show)---data PCI = PCI- {- busID :: !Int, -- ^ PCI bus ID of the device- deviceID :: !Int, -- ^ PCI device ID- domainID :: !Int -- ^ PCI domain ID- }- deriving (Show)----- GPU Hardware Resources----data Allocation = Warp | Block-data DeviceResources = DeviceResources- {- threadsPerWarp :: !Int, -- ^ Warp size- threadsPerMP :: !Int, -- ^ Maximum number of in-flight threads on a multiprocessor- threadBlocksPerMP :: !Int, -- ^ Maximum number of thread blocks resident on a multiprocessor- warpsPerMP :: !Int, -- ^ Maximum number of in-flight warps per multiprocessor- coresPerMP :: !Int, -- ^ Number of SIMD arithmetic units per multiprocessor- sharedMemPerMP :: !Int, -- ^ Total amount of shared memory per multiprocessor (bytes)- sharedMemAllocUnit :: !Int, -- ^ Shared memory allocation unit size (bytes)- regFileSize :: !Int, -- ^ Total number of registers in a multiprocessor- regAllocUnit :: !Int, -- ^ Register allocation unit size- regAllocWarp :: !Int, -- ^ Register allocation granularity for warps- regPerThread :: !Int, -- ^ Maximum number of registers per thread- allocation :: !Allocation -- ^ How multiprocessor resources are divided- }----- |--- Extract some additional hardware resource limitations for a given device.----deviceResources :: DeviceProperties -> DeviceResources-deviceResources = resources . computeCapability- where- -- This is mostly extracted from tables in the CUDA occupancy calculator.- --- resources compute = case compute of- Compute 1 0 -> DeviceResources 32 768 8 24 8 16384 512 8192 256 2 124 Block -- Tesla G80- Compute 1 1 -> DeviceResources 32 768 8 24 8 16384 512 8192 256 2 124 Block -- Tesla G8x- Compute 1 2 -> DeviceResources 32 1024 8 32 8 16384 512 16384 512 2 124 Block -- Tesla G9x- Compute 1 3 -> DeviceResources 32 1024 8 32 8 16384 512 16384 512 2 124 Block -- Tesla GT200- Compute 2 0 -> DeviceResources 32 1536 8 48 32 49152 128 32768 64 2 63 Warp -- Fermi GF100- Compute 2 1 -> DeviceResources 32 1536 8 48 48 49152 128 32768 64 2 63 Warp -- Fermi GF10x- Compute 3 0 -> DeviceResources 32 2048 16 64 192 49152 256 65536 256 4 63 Warp -- Kepler GK10x- Compute 3 2 -> DeviceResources 32 2048 16 64 192 49152 256 65536 256 4 255 Warp -- Jetson TK1 (speculative)- Compute 3 5 -> DeviceResources 32 2048 16 64 192 49152 256 65536 256 4 255 Warp -- Kepler GK11x- Compute 3 7 -> DeviceResources 32 2048 16 64 192 114688 256 131072 256 4 266 Warp -- Kepler GK21x- Compute 5 0 -> DeviceResources 32 2048 32 64 128 65536 256 65536 256 4 255 Warp -- Maxwell GM10x- Compute 5 2 -> DeviceResources 32 2048 32 64 128 98304 256 65536 256 4 255 Warp -- Maxwell GM20x-- -- Something might have gone wrong, or the library just needs to be- -- updated for the next generation of hardware, in which case we just want- -- to pick a sensible default and carry on.- --- -- This is slightly dodgy as the warning message is coming from pure code.- -- However, it should be OK because all library functions run in IO, so it- -- is likely the user code is as well.- --- _ -> trace warning $ resources (Compute 3 0)- where warning = unlines [ "*** Warning: Unknown CUDA device compute capability: " ++ show compute- , "*** Please submit a bug report at https://github.com/tmcdonell/cuda/issues" ]-
− Foreign/CUDA/Analysis/Occupancy.hs
@@ -1,210 +0,0 @@-{-# LANGUAGE BangPatterns #-}------------------------------------------------------------------------------------ |--- Module : Foreign.CUDA.Analysis.Occupancy--- Copyright : [2009..2014] Trevor L. McDonell--- License : BSD------ Occupancy calculations for CUDA kernels------ <http://developer.download.nvidia.com/compute/cuda/3_0/sdk/docs/CUDA_Occupancy_calculator.xls>------ /Determining Registers Per Thread and Shared Memory Per Block/------ To determine the number of registers used per thread in your kernel, simply--- compile the kernel code using the option------ > --ptxas-options=-v------ to nvcc. This will output information about register, local memory, shared--- memory, and constant memory usage for each kernel in the @.cu@ file.--- Alternatively, you can compile with the @-cubin@ option to nvcc. This will--- generate a @.cubin@ file, which you can open in a text editor. Look for the--- @code@ section with your kernel's name. Within the curly braces (@{ ... }@)--- for that code block, you will see a line with @reg = X@, where @x@ is the--- number of registers used by your kernel. You can also see the amount of--- shared memory used as @smem = Y@. However, if your kernel declares any--- external shared memory that is allocated dynamically, you will need to add--- the number in the @.cubin@ file to the amount you dynamically allocate at run--- time to get the correct shared memory usage.------ /Notes About Occupancy/------ Higher occupancy does not necessarily mean higher performance. If a kernel--- is not bandwidth bound, then increasing occupancy will not necessarily--- increase performance. If a kernel invocation is already running at least one--- thread block per multiprocessor in the GPU, and it is bottlenecked by--- computation and not by global memory accesses, then increasing occupancy may--- have no effect. In fact, making changes just to increase occupancy can have--- other effects, such as additional instructions, spills to local memory (which--- is off chip), divergent branches, etc. As with any optimization, you should--- experiment to see how changes affect the *wall clock time* of the kernel--- execution. For bandwidth bound applications, on the other hand, increasing--- occupancy can help better hide the latency of memory accesses, and therefore--- improve performance.---------------------------------------------------------------------------------------module Foreign.CUDA.Analysis.Occupancy (-- Occupancy(..),- occupancy, optimalBlockSize, optimalBlockSizeBy, maxResidentBlocks,- incPow2, incWarp, decPow2, decWarp--) where--import Data.Ord-import Data.List--import Foreign.CUDA.Analysis.Device----- GPU Occupancy per multiprocessor----data Occupancy = Occupancy- {- activeThreads :: !Int, -- ^ Active threads per multiprocessor- activeThreadBlocks :: !Int, -- ^ Active thread blocks per multiprocessor- activeWarps :: !Int, -- ^ Active warps per multiprocessor- occupancy100 :: !Double -- ^ Occupancy of each multiprocessor (percent)- }- deriving (Eq, Ord, Show)----- |--- Calculate occupancy data for a given GPU and kernel resource usage----{-# INLINEABLE occupancy #-}-occupancy- :: DeviceProperties -- ^ Properties of the card in question- -> Int -- ^ Threads per block- -> Int -- ^ Registers per thread- -> Int -- ^ Shared memory per block (bytes)- -> Occupancy-occupancy !dev !thds !regs !smem- = Occupancy at ab aw oc- where- at = ab * thds- aw = ab * warps- ab = minimum [limitWarpBlock, limitRegMP, limitSMemMP]- oc = 100 * fromIntegral aw / fromIntegral (warpsPerMP gpu)-- regs' = 1 `max` regs- smem' = 1 `max` smem-- floor' = floor :: Double -> Int- ceiling' = ceiling :: Double -> Int- ceilingBy x s = s * ceiling' (fromIntegral x / fromIntegral s)-- -- Physical resources- --- gpu = deviceResources dev-- -- Allocation per thread block- --- warps = ceiling' (fromIntegral thds / fromIntegral (threadsPerWarp gpu))- sharedMem = ceilingBy smem' (sharedMemAllocUnit gpu)- registers = case allocation gpu of- Block -> (warps `ceilingBy` regAllocWarp gpu * regs' * threadsPerWarp gpu) `ceilingBy` regAllocUnit gpu- Warp -> warps * ceilingBy (regs' * threadsPerWarp gpu) (regAllocUnit gpu)-- -- Maximum thread blocks per multiprocessor- --- limitWarpBlock = threadBlocksPerMP gpu `min` floor' (fromIntegral (warpsPerMP gpu) / fromIntegral warps)- limitRegMP = threadBlocksPerMP gpu `min` floor' (fromIntegral (regFileSize gpu) / fromIntegral registers)- limitSMemMP = threadBlocksPerMP gpu `min` floor' (fromIntegral (sharedMemPerMP gpu) / fromIntegral sharedMem)----- |--- Optimise multiprocessor occupancy as a function of thread block size and--- resource usage. This returns the smallest satisfying block size in increments--- of a single warp.----{-# INLINEABLE optimalBlockSize #-}-optimalBlockSize- :: DeviceProperties -- ^ Architecture to optimise for- -> (Int -> Int) -- ^ Register count as a function of thread block size- -> (Int -> Int) -- ^ Shared memory usage (bytes) as a function of thread block size- -> (Int, Occupancy)-optimalBlockSize = flip optimalBlockSizeBy decWarp----- |--- As 'optimalBlockSize', but with a generator that produces the specific thread--- block sizes that should be tested. The generated list can produce values in--- any order, but the last satisfying block size will be returned. Hence, values--- should be monotonically decreasing to return the smallest block size yielding--- maximum occupancy, and vice-versa.----{-# INLINEABLE optimalBlockSizeBy #-}-optimalBlockSizeBy- :: DeviceProperties- -> (DeviceProperties -> [Int])- -> (Int -> Int)- -> (Int -> Int)- -> (Int, Occupancy)-optimalBlockSizeBy !dev !fblk !freg !fsmem- = maximumBy (comparing (occupancy100 . snd)) $ zip threads residency- where- residency = map (\t -> occupancy dev t (freg t) (fsmem t)) threads- threads = fblk dev----- | Increments in powers-of-two, over the range of supported thread block sizes--- for the given device.----{-# INLINEABLE incPow2 #-}-incPow2 :: DeviceProperties -> [Int]-incPow2 !dev = map ((2::Int)^) [lb, lb+1 .. ub]- where- round' = round :: Double -> Int- lb = round' . logBase 2 . fromIntegral $ warpSize dev- ub = round' . logBase 2 . fromIntegral $ maxThreadsPerBlock dev---- | Decrements in powers-of-two, over the range of supported thread block sizes--- for the given device.----{-# INLINEABLE decPow2 #-}-decPow2 :: DeviceProperties -> [Int]-decPow2 !dev = map ((2::Int)^) [ub, ub-1 .. lb]- where- round' = round :: Double -> Int- lb = round' . logBase 2 . fromIntegral $ warpSize dev- ub = round' . logBase 2 . fromIntegral $ maxThreadsPerBlock dev---- | Decrements in the warp size of the device, over the range of supported--- thread block sizes.----{-# INLINEABLE decWarp #-}-decWarp :: DeviceProperties -> [Int]-decWarp !dev = [block, block-warp .. warp]- where- !warp = warpSize dev- !block = maxThreadsPerBlock dev---- | Increments in the warp size of the device, over the range of supported--- thread block sizes.----{-# INLINEABLE incWarp #-}-incWarp :: DeviceProperties -> [Int]-incWarp !dev = [warp, 2*warp .. block]- where- warp = warpSize dev- block = maxThreadsPerBlock dev----- |--- Determine the maximum number of CTAs that can be run simultaneously for a--- given kernel / device combination.----{-# INLINEABLE maxResidentBlocks #-}-maxResidentBlocks- :: DeviceProperties -- ^ Properties of the card in question- -> Int -- ^ Threads per block- -> Int -- ^ Registers per thread- -> Int -- ^ Shared memory per block (bytes)- -> Int -- ^ Maximum number of resident blocks-maxResidentBlocks !dev !thds !regs !smem =- multiProcessorCount dev * activeThreadBlocks (occupancy dev thds regs smem)-
− Foreign/CUDA/Driver.hs
@@ -1,32 +0,0 @@------------------------------------------------------------------------------------ |--- Module : Foreign.CUDA.Driver--- Copyright : [2009..2014] Trevor L. McDonell--- License : BSD------ Top level bindings to CUDA driver API--------------------------------------------------------------------------------------module Foreign.CUDA.Driver (-- module Foreign.CUDA.Ptr,- module Foreign.CUDA.Driver.Context,- module Foreign.CUDA.Driver.Device,- module Foreign.CUDA.Driver.Error,- module Foreign.CUDA.Driver.Exec,- module Foreign.CUDA.Driver.Marshal,- module Foreign.CUDA.Driver.Module,- module Foreign.CUDA.Driver.Utils--) where--import Foreign.CUDA.Ptr-import Foreign.CUDA.Driver.Context hiding ( device, useContext )-import Foreign.CUDA.Driver.Device-import Foreign.CUDA.Driver.Error-import Foreign.CUDA.Driver.Exec-import Foreign.CUDA.Driver.Marshal hiding ( useDeviceHandle, peekDeviceHandle )-import Foreign.CUDA.Driver.Module-import Foreign.CUDA.Driver.Utils-
− Foreign/CUDA/Driver/Context.chs
@@ -1,362 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE ForeignFunctionInterface #-}-#ifdef USE_EMPTY_CASE-{-# LANGUAGE EmptyCase #-}-#endif------------------------------------------------------------------------------------ |--- Module : Foreign.CUDA.Driver.Context--- Copyright : [2009..2014] Trevor L. McDonell--- License : BSD------ Context management for low-level driver interface--------------------------------------------------------------------------------------module Foreign.CUDA.Driver.Context (-- -- * Context Management- Context(..), ContextFlag(..),- create, attach, detach, destroy, device, pop, push, sync, get, set,-- -- * Peer Access- PeerFlag,- accessible, add, remove,-- -- * Cache Configuration- Cache(..), Limit(..),- getLimit, setLimit, setCacheConfig--) where--#include "cbits/stubs.h"-{# context lib="cuda" #}---- Friends-import Foreign.CUDA.Driver.Device ( Device(..) )-import Foreign.CUDA.Driver.Error-import Foreign.CUDA.Internal.C2HS---- System-import Foreign-import Foreign.C-import Control.Monad ( liftM )-------------------------------------------------------------------------------------- Data Types------------------------------------------------------------------------------------- |--- A device context----newtype Context = Context { useContext :: {# type CUcontext #}}- deriving (Eq, Show)----- |--- Context creation flags----{# enum CUctx_flags as ContextFlag- { underscoreToCase }- with prefix="CU_CTX" deriving (Eq, Show) #}---- |--- Device limits flags----#if CUDA_VERSION < 3010-data Limit-#else-{# enum CUlimit_enum as Limit- { underscoreToCase }- with prefix="CU_LIMIT" deriving (Eq, Show) #}-#endif---- |--- Device cache configuration preference----#if CUDA_VERSION < 3000-data Cache-#else-{# enum CUfunc_cache_enum as Cache- { underscoreToCase }- with prefix="CU_FUNC_CACHE" deriving (Eq, Show) #}-#endif---- |--- Possible option values for direct peer memory access----data PeerFlag-instance Enum PeerFlag where-#ifdef USE_EMPTY_CASE- toEnum x = case x of {}- fromEnum x = case x of {}-#endif---#if CUDA_VERSION >= 4000-{-# DEPRECATED attach, detach "deprecated as of CUDA-4.0" #-}-{-# DEPRECATED BlockingSync "use SchedBlockingSync instead" #-}-#endif-------------------------------------------------------------------------------------- Context management------------------------------------------------------------------------------------- |--- Create a new CUDA context and associate it with the calling thread----{-# INLINEABLE create #-}-create :: Device -> [ContextFlag] -> IO Context-create !dev !flags = resultIfOk =<< cuCtxCreate flags dev--{-# INLINE cuCtxCreate #-}-{# fun unsafe cuCtxCreate- { alloca- `Context' peekCtx*- , combineBitMasks `[ContextFlag]'- , useDevice `Device' } -> `Status' cToEnum #}- where peekCtx = liftM Context . peek----- |--- Increments the usage count of the context. API: no context flags are--- currently supported, so this parameter must be empty.----{-# INLINEABLE attach #-}-attach :: Context -> [ContextFlag] -> IO ()-attach !ctx !flags = nothingIfOk =<< cuCtxAttach ctx flags--{-# INLINE cuCtxAttach #-}-{# fun unsafe cuCtxAttach- { withCtx* `Context'- , combineBitMasks `[ContextFlag]' } -> `Status' cToEnum #}- where withCtx = with . useContext----- |--- Detach the context, and destroy if no longer used----{-# INLINEABLE detach #-}-detach :: Context -> IO ()-detach !ctx = nothingIfOk =<< cuCtxDetach ctx--{-# INLINE cuCtxDetach #-}-{# fun unsafe cuCtxDetach- { useContext `Context' } -> `Status' cToEnum #}----- |--- Destroy the specified context. This fails if the context is more than a--- single attachment (including that from initial creation).----{-# INLINEABLE destroy #-}-destroy :: Context -> IO ()-destroy !ctx = nothingIfOk =<< cuCtxDestroy ctx--{-# INLINE cuCtxDestroy #-}-{# fun unsafe cuCtxDestroy- { useContext `Context' } -> `Status' cToEnum #}----- |--- Return the context bound to the calling CPU thread. Requires cuda-4.0.----{-# INLINEABLE get #-}-get :: IO Context-#if CUDA_VERSION < 4000-get = requireSDK 4.0 "get"-#else-get = resultIfOk =<< cuCtxGetCurrent--{-# INLINE cuCtxGetCurrent #-}-{# fun unsafe cuCtxGetCurrent- { alloca- `Context' peekCtx* } -> `Status' cToEnum #}- where peekCtx = liftM Context . peek-#endif----- |--- Bind the specified context to the calling thread. Requires cuda-4.0.----{-# INLINEABLE set #-}-set :: Context -> IO ()-#if CUDA_VERSION < 4000-set _ = requireSDK 4.0 "set"-#else-set !ctx = nothingIfOk =<< cuCtxSetCurrent ctx--{-# INLINE cuCtxSetCurrent #-}-{# fun unsafe cuCtxSetCurrent- { useContext `Context' } -> `Status' cToEnum #}-#endif---- |--- Return the device of the currently active context----{-# INLINEABLE device #-}-device :: IO Device-device = resultIfOk =<< cuCtxGetDevice--{-# INLINE cuCtxGetDevice #-}-{# fun unsafe cuCtxGetDevice- { alloca- `Device' dev* } -> `Status' cToEnum #}- where dev = liftM Device . peekIntConv----- |--- Pop the current CUDA context from the CPU thread. The context must have a--- single usage count (matching calls to 'attach' and 'detach'). If successful,--- the new context is returned, and the old may be attached to a different CPU.----{-# INLINEABLE pop #-}-pop :: IO Context-pop = resultIfOk =<< cuCtxPopCurrent--{-# INLINE cuCtxPopCurrent #-}-{# fun unsafe cuCtxPopCurrent- { alloca- `Context' peekCtx* } -> `Status' cToEnum #}- where peekCtx = liftM Context . peek----- |--- Push the given context onto the CPU's thread stack of current contexts. The--- context must be floating (via 'pop'), i.e. not attached to any thread.----{-# INLINEABLE push #-}-push :: Context -> IO ()-push !ctx = nothingIfOk =<< cuCtxPushCurrent ctx--{-# INLINE cuCtxPushCurrent #-}-{# fun unsafe cuCtxPushCurrent- { useContext `Context' } -> `Status' cToEnum #}----- |--- Block until the device has completed all preceding requests----{-# INLINEABLE sync #-}-sync :: IO ()-sync = nothingIfOk =<< cuCtxSynchronize--{-# INLINE cuCtxSynchronize #-}-{# fun cuCtxSynchronize- { } -> `Status' cToEnum #}-------------------------------------------------------------------------------------- Peer access------------------------------------------------------------------------------------- |--- Queries if the first device can directly access the memory of the second. If--- direct access is possible, it can then be enabled with 'add'. Requires--- cuda-4.0.----{-# INLINEABLE accessible #-}-accessible :: Device -> Device -> IO Bool-#if CUDA_VERSION < 4000-accessible _ _ = requireSDK 4.0 "accessible"-#else-accessible !dev !peer = resultIfOk =<< cuDeviceCanAccessPeer dev peer--{-# INLINE cuDeviceCanAccessPeer #-}-{# fun unsafe cuDeviceCanAccessPeer- { alloca- `Bool' peekBool*- , useDevice `Device'- , useDevice `Device' } -> `Status' cToEnum #}-#endif----- |--- If the devices of both the current and supplied contexts support unified--- addressing, then enable allocations in the supplied context to be accessible--- by the current context. Requires cuda-4.0.----{-# INLINEABLE add #-}-add :: Context -> [PeerFlag] -> IO ()-#if CUDA_VERSION < 4000-add _ _ = requireSDK 4.0 "add"-#else-add !ctx !flags = nothingIfOk =<< cuCtxEnablePeerAccess ctx flags--{-# INLINE cuCtxEnablePeerAccess #-}-{# fun unsafe cuCtxEnablePeerAccess- { useContext `Context'- , combineBitMasks `[PeerFlag]' } -> `Status' cToEnum #}-#endif----- |--- Disable direct memory access from the current context to the supplied--- context. Requires cuda-4.0.----{-# INLINEABLE remove #-}-remove :: Context -> IO ()-#if CUDA_VERSION < 4000-remove _ = requireSDK 4.0 "remove"-#else-remove !ctx = nothingIfOk =<< cuCtxDisablePeerAccess ctx--{-# INLINE cuCtxDisablePeerAccess #-}-{# fun unsafe cuCtxDisablePeerAccess- { useContext `Context' } -> `Status' cToEnum #}-#endif-------------------------------------------------------------------------------------- Cache configuration------------------------------------------------------------------------------------- |--- Query compute 2.0 call stack limits. Requires cuda-3.1.----{-# INLINEABLE getLimit #-}-getLimit :: Limit -> IO Int-#if CUDA_VERSION < 3010-getLimit _ = requireSDK 3.1 "getLimit"-#else-getLimit !l = resultIfOk =<< cuCtxGetLimit l--{-# INLINE cuCtxGetLimit #-}-{# fun unsafe cuCtxGetLimit- { alloca- `Int' peekIntConv*- , cFromEnum `Limit' } -> `Status' cToEnum #}-#endif---- |--- Specify the size of the call stack, for compute 2.0 devices. Requires--- cuda-3.1.----{-# INLINEABLE setLimit #-}-setLimit :: Limit -> Int -> IO ()-#if CUDA_VERSION < 3010-setLimit _ _ = requireSDK 3.1 "setLimit"-#else-setLimit !l !n = nothingIfOk =<< cuCtxSetLimit l n--{-# INLINE cuCtxSetLimit #-}-{# fun unsafe cuCtxSetLimit- { cFromEnum `Limit'- , cIntConv `Int' } -> `Status' cToEnum #}-#endif---- |--- On devices where the L1 cache and shared memory use the same hardware--- resources, this sets the preferred cache configuration for the current--- context. This is only a preference. Requires cuda-3.2.----{-# INLINEABLE setCacheConfig #-}-setCacheConfig :: Cache -> IO ()-#if CUDA_VERSION < 3020-setCacheConfig _ = requireSDK 3.2 "setCacheConfig"-#else-setCacheConfig !c = nothingIfOk =<< cuCtxSetCacheConfig c--{-# INLINE cuCtxSetCacheConfig #-}-{# fun unsafe cuCtxSetCacheConfig- { cFromEnum `Cache' } -> `Status' cToEnum #}-#endif-
− Foreign/CUDA/Driver/Device.chs
@@ -1,321 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE ForeignFunctionInterface #-}-#ifdef USE_EMPTY_CASE-{-# LANGUAGE EmptyCase #-}-#endif------------------------------------------------------------------------------------ |--- Module : Foreign.CUDA.Driver.Device--- Copyright : [2009..2014] Trevor L. McDonell--- License : BSD------ Device management for low-level driver interface--------------------------------------------------------------------------------------module Foreign.CUDA.Driver.Device (-- -- * Device Management- Device(..), -- should be exported abstractly- DeviceProperties(..), DeviceAttribute(..), Compute(..), ComputeMode(..), InitFlag,- initialise, capability, device, attribute, count, name, props, totalMem--) where--#include "cbits/stubs.h"-{# context lib="cuda" #}---- Friends-import Foreign.CUDA.Analysis.Device-import Foreign.CUDA.Driver.Error-import Foreign.CUDA.Internal.C2HS---- System-import Foreign-import Foreign.C-import Control.Monad ( liftM )-------------------------------------------------------------------------------------- Data Types-----------------------------------------------------------------------------------newtype Device = Device { useDevice :: {# type CUdevice #}}- deriving (Eq, Show)----- |--- Device attributes----{# enum CUdevice_attribute as DeviceAttribute- { underscoreToCase- , MAX as CU_DEVICE_ATTRIBUTE_MAX } -- ignore- with prefix="CU_DEVICE_ATTRIBUTE" deriving (Eq, Show) #}--{# pointer *CUdevprop as ^ foreign -> CUDevProp nocode #}-------- Properties of the compute device (internal helper)----data CUDevProp = CUDevProp- {- cuMaxThreadsPerBlock :: !Int, -- Maximum number of threads per block- cuMaxBlockSize :: !(Int,Int,Int), -- Maximum size of each dimension of a block- cuMaxGridSize :: !(Int,Int,Int), -- Maximum size of each dimension of a grid- cuSharedMemPerBlock :: !Int64, -- Shared memory available per block in bytes- cuTotalConstMem :: !Int64, -- Constant memory available on device in bytes- cuWarpSize :: !Int, -- Warp size in threads (SIMD width)- cuMemPitch :: !Int64, -- Maximum pitch in bytes allowed by memory copies- cuRegsPerBlock :: !Int, -- 32-bit registers available per block- cuClockRate :: !Int, -- Clock frequency in kilohertz- cuTextureAlignment :: !Int64 -- Alignment requirement for textures- }- deriving (Show)---instance Storable CUDevProp where- sizeOf _ = {#sizeof CUdevprop#}- alignment _ = alignment (undefined :: Ptr ())-- poke _ _ = error "no instance for Foreign.Storable.poke DeviceProperties"- peek p = do- tb <- cIntConv `fmap` {#get CUdevprop.maxThreadsPerBlock#} p- sm <- cIntConv `fmap` {#get CUdevprop.sharedMemPerBlock#} p- cm <- cIntConv `fmap` {#get CUdevprop.totalConstantMemory#} p- ws <- cIntConv `fmap` {#get CUdevprop.SIMDWidth#} p- mp <- cIntConv `fmap` {#get CUdevprop.memPitch#} p- rb <- cIntConv `fmap` {#get CUdevprop.regsPerBlock#} p- cl <- cIntConv `fmap` {#get CUdevprop.clockRate#} p- ta <- cIntConv `fmap` {#get CUdevprop.textureAlign#} p-- [t1,t2,t3] <- peekArrayWith cIntConv 3 =<< {#get CUdevprop.maxThreadsDim#} p- [g1,g2,g3] <- peekArrayWith cIntConv 3 =<< {#get CUdevprop.maxGridSize#} p-- return CUDevProp- {- cuMaxThreadsPerBlock = tb,- cuMaxBlockSize = (t1,t2,t3),- cuMaxGridSize = (g1,g2,g3),- cuSharedMemPerBlock = sm,- cuTotalConstMem = cm,- cuWarpSize = ws,- cuMemPitch = mp,- cuRegsPerBlock = rb,- cuClockRate = cl,- cuTextureAlignment = ta- }----- |--- Possible option flags for CUDA initialisation. Dummy instance until the API--- exports actual option values.----data InitFlag-instance Enum InitFlag where-#ifdef USE_EMPTY_CASE- toEnum x = case x of {}- fromEnum x = case x of {}-#endif-------------------------------------------------------------------------------------- Initialisation------------------------------------------------------------------------------------- |--- Initialise the CUDA driver API. Must be called before any other driver--- function.----{-# INLINEABLE initialise #-}-initialise :: [InitFlag] -> IO ()-initialise !flags = nothingIfOk =<< cuInit flags--{-# INLINE cuInit #-}-{# fun unsafe cuInit- { combineBitMasks `[InitFlag]' } -> `Status' cToEnum #}-------------------------------------------------------------------------------------- Device Management------------------------------------------------------------------------------------- |--- Return the compute compatibility revision supported by the device----{-# INLINEABLE capability #-}-capability :: Device -> IO Compute-capability !dev =- (\(!s,!a,!b) -> resultIfOk (s,Compute a b)) =<< cuDeviceComputeCapability dev--{-# INLINE cuDeviceComputeCapability #-}-{# fun unsafe cuDeviceComputeCapability- { alloca- `Int' peekIntConv*- , alloca- `Int' peekIntConv*- , useDevice `Device' } -> `Status' cToEnum #}----- |--- Return a device handle----{-# INLINEABLE device #-}-device :: Int -> IO Device-device !d = resultIfOk =<< cuDeviceGet d--{-# INLINE cuDeviceGet #-}-{# fun unsafe cuDeviceGet- { alloca- `Device' dev*- , cIntConv `Int' } -> `Status' cToEnum #}- where dev = liftM Device . peek----- |--- Return the selected attribute for the given device----{-# INLINEABLE attribute #-}-attribute :: Device -> DeviceAttribute -> IO Int-attribute !d !a = resultIfOk =<< cuDeviceGetAttribute a d--{-# INLINE cuDeviceGetAttribute #-}-{# fun unsafe cuDeviceGetAttribute- { alloca- `Int' peekIntConv*- , cFromEnum `DeviceAttribute'- , useDevice `Device' } -> `Status' cToEnum #}----- |--- Return the number of device with compute capability > 1.0----{-# INLINEABLE count #-}-count :: IO Int-count = resultIfOk =<< cuDeviceGetCount--{-# INLINE cuDeviceGetCount #-}-{# fun unsafe cuDeviceGetCount- { alloca- `Int' peekIntConv* } -> `Status' cToEnum #}----- |--- Name of the device----{-# INLINEABLE name #-}-name :: Device -> IO String-name !d = resultIfOk =<< cuDeviceGetName d--{-# INLINE cuDeviceGetName #-}-{# fun unsafe cuDeviceGetName- { allocaS- `String'& peekS*- , useDevice `Device' } -> `Status' cToEnum #}- where- len = 512- allocaS a = allocaBytes len $ \p -> a (p, cIntConv len)- peekS s _ = peekCString s----- |--- Return the properties of the selected device------- Annoyingly, the driver API requires several different functions to extract--- all device properties that are part of a single structure in the runtime API----{-# INLINEABLE props #-}-props :: Device -> IO DeviceProperties-props !d = do- p <- resultIfOk =<< cuDeviceGetProperties d-- -- And the remaining properties- --- n <- name d- cc <- capability d- gm <- totalMem d- pc <- attribute d MultiprocessorCount- md <- toEnum `fmap` attribute d ComputeMode- ov <- toBool `fmap` attribute d GpuOverlap- ke <- toBool `fmap` attribute d KernelExecTimeout- tg <- toBool `fmap` attribute d Integrated- hm <- toBool `fmap` attribute d CanMapHostMemory-#if CUDA_VERSION >= 3000- ck <- toBool `fmap` attribute d ConcurrentKernels- ee <- toBool `fmap` attribute d EccEnabled- u1 <- attribute d MaximumTexture1dWidth- u21 <- attribute d MaximumTexture2dWidth- u22 <- attribute d MaximumTexture2dHeight- u31 <- attribute d MaximumTexture3dWidth- u32 <- attribute d MaximumTexture3dHeight- u33 <- attribute d MaximumTexture3dDepth-#endif-#if CUDA_VERSION >= 4000- ae <- attribute d AsyncEngineCount- l2 <- attribute d L2CacheSize- tm <- attribute d MaxThreadsPerMultiprocessor- mw <- attribute d GlobalMemoryBusWidth- mc <- attribute d MemoryClockRate- pb <- attribute d PciBusId- pd <- attribute d PciDeviceId- pm <- attribute d PciDomainId- ua <- toBool `fmap` attribute d UnifiedAddressing- tcc <- toBool `fmap` attribute d TccDriver-#endif-- return DeviceProperties- {- deviceName = n,- computeCapability = cc,- totalGlobalMem = gm,- totalConstMem = cuTotalConstMem p,- sharedMemPerBlock = cuSharedMemPerBlock p,- regsPerBlock = cuRegsPerBlock p,- warpSize = cuWarpSize p,- maxThreadsPerBlock = cuMaxThreadsPerBlock p,- maxBlockSize = cuMaxBlockSize p,- maxGridSize = cuMaxGridSize p,- clockRate = cuClockRate p,- multiProcessorCount = pc,- memPitch = cuMemPitch p,- textureAlignment = cuTextureAlignment p,- computeMode = md,- deviceOverlap = ov,-#if CUDA_VERSION >= 3000- concurrentKernels = ck,- eccEnabled = ee,- maxTextureDim1D = u1,- maxTextureDim2D = (u21,u22),- maxTextureDim3D = (u31,u32,u33),-#endif-#if CUDA_VERSION >= 4000- asyncEngineCount = ae,- cacheMemL2 = l2,- maxThreadsPerMultiProcessor = tm,- memBusWidth = mw,- memClockRate = mc,- pciInfo = PCI pb pd pm,- tccDriverEnabled = tcc,- unifiedAddressing = ua,-#endif- kernelExecTimeoutEnabled = ke,- integrated = tg,- canMapHostMemory = hm- }---{-# INLINE cuDeviceGetProperties #-}-{# fun unsafe cuDeviceGetProperties- { alloca- `CUDevProp' peek*- , useDevice `Device' } -> `Status' cToEnum #}----- |--- Total memory available on the device (bytes)----{-# INLINEABLE totalMem #-}-totalMem :: Device -> IO Int64-totalMem !d = resultIfOk =<< cuDeviceTotalMem d--{-# INLINE cuDeviceTotalMem #-}-{# fun unsafe cuDeviceTotalMem- { alloca- `Int64' peekIntConv*- , useDevice `Device' } -> `Status' cToEnum #}-
− Foreign/CUDA/Driver/Error.chs
@@ -1,191 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE ForeignFunctionInterface #-}------------------------------------------------------------------------------------ |--- Module : Foreign.CUDA.Driver.Error--- Copyright : [2009..2014] Trevor L. McDonell--- License : BSD------ Error handling--------------------------------------------------------------------------------------module Foreign.CUDA.Driver.Error- where---- Friends-import Foreign.CUDA.Internal.C2HS---- System-import Data.Typeable-import Control.Exception-import Control.Monad-import Foreign.C-import Foreign.Ptr-import Foreign.Marshal-import Foreign.Storable-import System.IO.Unsafe--#include "cbits/stubs.h"-{# context lib="cuda" #}-------------------------------------------------------------------------------------- Return Status---------------------------------------------------------------------------------------- Error Codes----{# enum CUresult as Status- { underscoreToCase- , CUDA_SUCCESS as Success- , CUDA_ERROR_NO_BINARY_FOR_GPU as NoBinaryForGPU- , CUDA_ERROR_INVALID_PTX as InvalidPTX- , CUDA_ERROR_INVALID_PC as InvalidPC- }- with prefix="CUDA_ERROR" deriving (Eq, Show) #}----- |--- Return a descriptive error string associated with a particular error code----describe :: Status -> String-#if CUDA_VERSION >= 6000-describe status- = unsafePerformIO $ resultIfOk =<< cuGetErrorString status--{# fun unsafe cuGetErrorString- { cFromEnum `Status'- , alloca- `String' ppeek* } -> `Status' cToEnum #}- where- ppeek = peek >=> peekCString--#else-describe Success = "no error"-describe InvalidValue = "invalid argument"-describe OutOfMemory = "out of memory"-describe NotInitialized = "driver not initialised"-describe Deinitialized = "driver deinitialised"-describe NoDevice = "no CUDA-capable device is available"-describe InvalidDevice = "invalid device ordinal"-describe InvalidImage = "invalid kernel image"-describe InvalidContext = "invalid context handle"-describe ContextAlreadyCurrent = "context already current"-describe MapFailed = "map failed"-describe UnmapFailed = "unmap failed"-describe ArrayIsMapped = "array is mapped"-describe AlreadyMapped = "already mapped"-describe NoBinaryForGPU = "no binary available for this GPU"-describe AlreadyAcquired = "resource already acquired"-describe NotMapped = "not mapped"-describe InvalidSource = "invalid source"-describe FileNotFound = "file not found"-describe InvalidHandle = "invalid handle"-describe NotFound = "not found"-describe NotReady = "device not ready"-describe LaunchFailed = "unspecified launch failure"-describe LaunchOutOfResources = "too many resources requested for launch"-describe LaunchTimeout = "the launch timed out and was terminated"-describe LaunchIncompatibleTexturing = "launch with incompatible texturing"-#if CUDA_VERSION >= 3000-describe NotMappedAsArray = "mapped resource not available for access as an array"-describe NotMappedAsPointer = "mapped resource not available for access as a pointer"-describe EccUncorrectable = "uncorrectable ECC error detected"-#endif-#if CUDA_VERSION >= 3000 && CUDA_VERSION < 3020-describe PointerIs64bit = "attempt to retrieve a 64-bit pointer via a 32-bit API function"-describe SizeIs64bit = "attempt to retrieve 64-bit size via a 32-bit API function"-#endif-#if CUDA_VERSION >= 3010-describe UnsupportedLimit = "limits not supported by device"-describe SharedObjectSymbolNotFound = "link to a shared object failed to resolve"-describe SharedObjectInitFailed = "shared object initialisation failed"-#endif-#if CUDA_VERSION >= 3020-describe OperatingSystem = "operating system call failed"-#endif-#if CUDA_VERSION >= 4000-describe ProfilerDisabled = "profiling APIs disabled: application running with visual profiler"-describe ProfilerNotInitialized = "profiler not initialised"-describe ProfilerAlreadyStarted = "profiler already started"-describe ProfilerAlreadyStopped = "profiler already stopped"-describe ContextAlreadyInUse = "context is already bound to a thread and in use"-describe PeerAccessAlreadyEnabled = "peer access already enabled"-describe PeerAccessNotEnabled = "peer access has not been enabled"-describe PrimaryContextActive = "primary context for this device has already been initialised"-describe ContextIsDestroyed = "context already destroyed"-#endif-#if CUDA_VERSION >= 4010-describe Assert = "device-side assert triggered"-describe TooManyPeers = "peer mapping resources exhausted"-describe HostMemoryAlreadyRegistered = "part or all of the requested memory range is already mapped"-describe HostMemoryNotRegistered = "pointer does not correspond to a registered memory region"-#endif-#if CUDA_VERSION >= 5000-describe PeerAccessUnsupported = "peer access is not supported across the given devices"-describe NotPermitted = "not permitted"-describe NotSupported = "not supported"-#endif-describe Unknown = "unknown error"-#endif-------------------------------------------------------------------------------------- Exceptions-----------------------------------------------------------------------------------data CUDAException- = ExitCode Status- | UserError String- deriving Typeable--instance Exception CUDAException--instance Show CUDAException where- showsPrec _ (ExitCode s) = showString ("CUDA Exception: " ++ describe s)- showsPrec _ (UserError s) = showString ("CUDA Exception: " ++ s)----- |--- Raise a CUDAException in the IO Monad----cudaError :: String -> IO a-cudaError s = throwIO (UserError s)---- |--- A specially formatted error message----requireSDK :: Double -> String -> IO a-requireSDK v s = cudaError ("'" ++ s ++ "' requires at least cuda-" ++ show v)-------------------------------------------------------------------------------------- Helper Functions-------------------------------------------------------------------------------------- |--- Return the results of a function on successful execution, otherwise throw an--- exception with an error string associated with the return code----{-# INLINE resultIfOk #-}-resultIfOk :: (Status, a) -> IO a-resultIfOk (status, !result) =- case status of- Success -> return result- _ -> throwIO (ExitCode status)----- |--- Throw an exception with an error string associated with an unsuccessful--- return code, otherwise return unit.----{-# INLINE nothingIfOk #-}-nothingIfOk :: Status -> IO ()-nothingIfOk status =- case status of- Success -> return ()- _ -> throwIO (ExitCode status)-
− Foreign/CUDA/Driver/Event.chs
@@ -1,146 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE ForeignFunctionInterface #-}------------------------------------------------------------------------------------ |--- Module : Foreign.CUDA.Driver.Event--- Copyright : [2009..2014] Trevor L. McDonell--- License : BSD------ Event management for low-level driver interface--------------------------------------------------------------------------------------module Foreign.CUDA.Driver.Event (-- -- * Event Management- Event(..), EventFlag(..), WaitFlag,- create, destroy, elapsedTime, query, record, wait, block--) where--#include "cbits/stubs.h"-{# context lib="cuda" #}---- Friends-import Foreign.CUDA.Types-import Foreign.CUDA.Internal.C2HS-import Foreign.CUDA.Driver.Error---- System-import Foreign-import Foreign.C-import Data.Maybe-import Control.Monad ( liftM )-import Control.Exception ( throwIO )-------------------------------------------------------------------------------------- Event management------------------------------------------------------------------------------------- |--- Create a new event----{-# INLINEABLE create #-}-create :: [EventFlag] -> IO Event-create !flags = resultIfOk =<< cuEventCreate flags--{-# INLINE cuEventCreate #-}-{# fun unsafe cuEventCreate- { alloca- `Event' peekEvt*- , combineBitMasks `[EventFlag]' } -> `Status' cToEnum #}- where peekEvt = liftM Event . peek----- |--- Destroy an event----{-# INLINEABLE destroy #-}-destroy :: Event -> IO ()-destroy !ev = nothingIfOk =<< cuEventDestroy ev--{-# INLINE cuEventDestroy #-}-{# fun unsafe cuEventDestroy- { useEvent `Event' } -> `Status' cToEnum #}----- |--- Determine the elapsed time (in milliseconds) between two events----{-# INLINEABLE elapsedTime #-}-elapsedTime :: Event -> Event -> IO Float-elapsedTime !ev1 !ev2 = resultIfOk =<< cuEventElapsedTime ev1 ev2--{-# INLINE cuEventElapsedTime #-}-{# fun unsafe cuEventElapsedTime- { alloca- `Float' peekFloatConv*- , useEvent `Event'- , useEvent `Event' } -> `Status' cToEnum #}----- |--- Determines if a event has actually been recorded----{-# INLINEABLE query #-}-query :: Event -> IO Bool-query !ev =- cuEventQuery ev >>= \rv ->- case rv of- Success -> return True- NotReady -> return False- _ -> throwIO (ExitCode rv)--{-# INLINE cuEventQuery #-}-{# fun unsafe cuEventQuery- { useEvent `Event' } -> `Status' cToEnum #}----- |--- Record an event once all operations in the current context (or optionally--- specified stream) have completed. This operation is asynchronous.----{-# INLINEABLE record #-}-record :: Event -> Maybe Stream -> IO ()-record !ev !mst =- nothingIfOk =<< cuEventRecord ev (fromMaybe defaultStream mst)--{-# INLINE cuEventRecord #-}-{# fun unsafe cuEventRecord- { useEvent `Event'- , useStream `Stream' } -> `Status' cToEnum #}----- |--- Makes all future work submitted to the (optional) stream wait until the given--- event reports completion before beginning execution. Synchronisation is--- performed on the device, including when the event and stream are from--- different device contexts. Requires cuda-3.2.----{-# INLINEABLE wait #-}-wait :: Event -> Maybe Stream -> [WaitFlag] -> IO ()-#if CUDA_VERSION < 3020-wait _ _ _ = requireSDK 3.2 "wait"-#else-wait !ev !mst !flags =- nothingIfOk =<< cuStreamWaitEvent (fromMaybe defaultStream mst) ev flags--{-# INLINE cuStreamWaitEvent #-}-{# fun unsafe cuStreamWaitEvent- { useStream `Stream'- , useEvent `Event'- , combineBitMasks `[WaitFlag]' } -> `Status' cToEnum #}-#endif---- |--- Wait until the event has been recorded----{-# INLINEABLE block #-}-block :: Event -> IO ()-block !ev = nothingIfOk =<< cuEventSynchronize ev--{-# INLINE cuEventSynchronize #-}-{# fun cuEventSynchronize- { useEvent `Event' } -> `Status' cToEnum #}-
− Foreign/CUDA/Driver/Exec.chs
@@ -1,320 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE ForeignFunctionInterface #-}-{-# LANGUAGE GADTs #-}------------------------------------------------------------------------------------ |--- Module : Foreign.CUDA.Driver.Exec--- Copyright : [2009..2014] Trevor L. McDonell--- License : BSD------ Kernel execution control for low-level driver interface--------------------------------------------------------------------------------------module Foreign.CUDA.Driver.Exec (-- -- * Kernel Execution- Fun(Fun), FunParam(..), FunAttribute(..),- requires, setBlockShape, setSharedSize, setParams, setCacheConfigFun,- launch, launchKernel, launchKernel'--) where--#include "cbits/stubs.h"-{# context lib="cuda" #}---- Friends-import Foreign.CUDA.Internal.C2HS-import Foreign.CUDA.Driver.Error-import Foreign.CUDA.Driver.Context ( Cache(..) )-import Foreign.CUDA.Driver.Stream ( Stream(..), defaultStream )---- System-import Foreign-import Foreign.C-import Data.Maybe-import Control.Monad ( zipWithM_ )---#if CUDA_VERSION >= 4000-{-# DEPRECATED setBlockShape, setSharedSize, setParams, launch- "use launchKernel instead" #-}-#endif-------------------------------------------------------------------------------------- Data Types------------------------------------------------------------------------------------- |--- A @__global__@ device function----newtype Fun = Fun { useFun :: {# type CUfunction #}}----- |--- Function attributes----{# enum CUfunction_attribute as FunAttribute- { underscoreToCase- , MAX_THREADS_PER_BLOCK as MaxKernelThreadsPerBlock- , MAX as CU_FUNC_ATTRIBUTE_MAX } -- ignore- with prefix="CU_FUNC_ATTRIBUTE" deriving (Eq, Show) #}---- |--- Kernel function parameters----data FunParam where- IArg :: !Int32 -> FunParam- FArg :: !Float -> FunParam- VArg :: Storable a => !a -> FunParam--instance Storable FunParam where- sizeOf (IArg _) = sizeOf (undefined :: CUInt)- sizeOf (FArg _) = sizeOf (undefined :: CFloat)- sizeOf (VArg v) = sizeOf v-- alignment (IArg _) = alignment (undefined :: CUInt)- alignment (FArg _) = alignment (undefined :: CFloat)- alignment (VArg v) = alignment v-- poke p (IArg i) = poke (castPtr p) i- poke p (FArg f) = poke (castPtr p) f- poke p (VArg v) = poke (castPtr p) v-- peek _ = error "Can not peek Foreign.CUDA.Driver.FunParam"-------------------------------------------------------------------------------------- Execution Control------------------------------------------------------------------------------------- |--- Returns the value of the selected attribute requirement for the given kernel----{-# INLINEABLE requires #-}-requires :: Fun -> FunAttribute -> IO Int-requires !fn !att = resultIfOk =<< cuFuncGetAttribute att fn--{-# INLINE cuFuncGetAttribute #-}-{# fun unsafe cuFuncGetAttribute- { alloca- `Int' peekIntConv*- , cFromEnum `FunAttribute'- , useFun `Fun' } -> `Status' cToEnum #}----- |--- Specify the @(x,y,z)@ dimensions of the thread blocks that are created when--- the given kernel function is launched.----{-# INLINEABLE setBlockShape #-}-setBlockShape :: Fun -> (Int,Int,Int) -> IO ()-setBlockShape !fn (!x,!y,!z) = nothingIfOk =<< cuFuncSetBlockShape fn x y z--{-# INLINE cuFuncSetBlockShape #-}-{# fun unsafe cuFuncSetBlockShape- { useFun `Fun'- , `Int'- , `Int'- , `Int' } -> `Status' cToEnum #}----- |--- Set the number of bytes of dynamic shared memory to be available to each--- thread block when the function is launched----{-# INLINEABLE setSharedSize #-}-setSharedSize :: Fun -> Integer -> IO ()-setSharedSize !fn !bytes = nothingIfOk =<< cuFuncSetSharedSize fn bytes--{-# INLINE cuFuncSetSharedSize #-}-{# fun unsafe cuFuncSetSharedSize- { useFun `Fun'- , cIntConv `Integer' } -> `Status' cToEnum #}----- |--- On devices where the L1 cache and shared memory use the same hardware--- resources, this sets the preferred cache configuration for the given device--- function. This is only a preference; the driver is free to choose a different--- configuration as required to execute the function.------ Switching between configuration modes may insert a device-side--- synchronisation point for streamed kernel launches.----{-# INLINEABLE setCacheConfigFun #-}-setCacheConfigFun :: Fun -> Cache -> IO ()-#if CUDA_VERSION < 3000-setCacheConfigFun _ _ = requireSDK 3.0 "setCacheConfigFun"-#else-setCacheConfigFun !fn !pref = nothingIfOk =<< cuFuncSetCacheConfig fn pref--{-# INLINE cuFuncSetCacheConfig #-}-{# fun unsafe cuFuncSetCacheConfig- { useFun `Fun'- , cFromEnum `Cache' } -> `Status' cToEnum #}-#endif---- |--- Invoke the kernel on a size @(w,h)@ grid of blocks. Each block contains the--- number of threads specified by a previous call to 'setBlockShape'. The launch--- may also be associated with a specific 'Stream'.----{-# INLINEABLE launch #-}-launch :: Fun -> (Int,Int) -> Maybe Stream -> IO ()-launch !fn (!w,!h) mst =- nothingIfOk =<< cuLaunchGridAsync fn w h (fromMaybe defaultStream mst)--{-# INLINE cuLaunchGridAsync #-}-{# fun unsafe cuLaunchGridAsync- { useFun `Fun'- , `Int'- , `Int'- , useStream `Stream' } -> `Status' cToEnum #}----- |--- Invoke a kernel on a @(gx * gy * gz)@ grid of blocks, where each block--- contains @(tx * ty * tz)@ threads and has access to a given number of bytes--- of shared memory. The launch may also be associated with a specific 'Stream'.------ In 'launchKernel', the number of kernel parameters and their offsets and--- sizes do not need to be specified, as this information is retrieved directly--- from the kernel's image. This requires the kernel to have been compiled with--- toolchain version 3.2 or later.------ The alternative 'launchKernel'' will pass the arguments in directly,--- requiring the application to know the size and alignment/padding of each--- kernel parameter.----{-# INLINEABLE launchKernel #-}-{-# INLINEABLE launchKernel' #-}-launchKernel, launchKernel'- :: Fun -- ^ function to execute- -> (Int,Int,Int) -- ^ block grid dimension- -> (Int,Int,Int) -- ^ thread block shape- -> Int -- ^ shared memory (bytes)- -> Maybe Stream -- ^ (optional) stream to execute in- -> [FunParam] -- ^ list of function parameters- -> IO ()-#if CUDA_VERSION >= 4000-launchKernel !fn (!gx,!gy,!gz) (!tx,!ty,!tz) !sm !mst !args- = (=<<) nothingIfOk- $ withMany withFP args- $ \pa -> withArray pa- $ \pp -> cuLaunchKernel fn gx gy gz tx ty tz sm st pp nullPtr- where- !st = fromMaybe defaultStream mst-- withFP :: FunParam -> (Ptr FunParam -> IO b) -> IO b- withFP !p !f = case p of- IArg v -> with' v (f . castPtr)- FArg v -> with' v (f . castPtr)- VArg v -> with' v (f . castPtr)-- -- can't use the standard 'with' because 'alloca' will pass an undefined- -- dummy argument when determining 'sizeOf' and 'alignment', but sometimes- -- instances in Accelerate need to evaluate this argument.- --- with' :: Storable a => a -> (Ptr a -> IO b) -> IO b- with' !val !f =- allocaBytes (sizeOf val) $ \ptr -> do- poke ptr val- f ptr---launchKernel' !fn (!gx,!gy,!gz) (!tx,!ty,!tz) !sm !mst !args- = (=<<) nothingIfOk- $ with bytes- $ \pb -> withArray' args- $ \pa -> withArray0 nullPtr [buffer, castPtr pa, size, castPtr pb]- $ \pp -> cuLaunchKernel fn gx gy gz tx ty tz sm st nullPtr pp- where- buffer = wordPtrToPtr 0x01 -- CU_LAUNCH_PARAM_BUFFER_POINTER- size = wordPtrToPtr 0x02 -- CU_LAUNCH_PARAM_BUFFER_SIZE- bytes = foldl (\a x -> a + sizeOf x) 0 args- st = fromMaybe defaultStream mst-- -- can't use the standard 'withArray' because 'mallocArray' will pass- -- 'undefined' to 'sizeOf' when determining how many bytes to allocate, but- -- our Storable instance for FunParam needs to dispatch on each constructor,- -- hence evaluating the undefined.- --- withArray' !vals !f =- allocaBytes bytes $ \ptr -> do- pokeArray ptr vals- f ptr---{-# INLINE cuLaunchKernel #-}-{# fun unsafe cuLaunchKernel- { useFun `Fun'- , `Int', `Int', `Int'- , `Int', `Int', `Int'- , `Int'- , useStream `Stream'- , castPtr `Ptr (Ptr FunParam)'- , castPtr `Ptr (Ptr ())' } -> `Status' cToEnum #}--#else-launchKernel !fn (!gx,!gy,_) (!tx,!ty,!tz) !sm !mst !args = do- setParams fn args- setSharedSize fn (toInteger sm)- setBlockShape fn (tx,ty,tz)- launch fn (gx,gy) mst--launchKernel' = launchKernel-#endif-------------------------------------------------------------------------------------- Kernel function parameters------------------------------------------------------------------------------------- |--- Set the parameters that will specified next time the kernel is invoked----{-# INLINEABLE setParams #-}-setParams :: Fun -> [FunParam] -> IO ()-setParams !fn !prs = do- zipWithM_ (set fn) offsets prs- nothingIfOk =<< cuParamSetSize fn (last offsets)- where- offsets = scanl (\a b -> a + size b) 0 prs-- size (IArg _) = sizeOf (undefined :: CUInt)- size (FArg _) = sizeOf (undefined :: CFloat)- size (VArg v) = sizeOf v-- set f o (IArg v) = nothingIfOk =<< cuParamSeti f o v- set f o (FArg v) = nothingIfOk =<< cuParamSetf f o v- set f o (VArg v) = with v $ \p -> (nothingIfOk =<< cuParamSetv f o p (sizeOf v))---{-# INLINE cuParamSetSize #-}-{# fun unsafe cuParamSetSize- { useFun `Fun'- , `Int' } -> `Status' cToEnum #}--{-# INLINE cuParamSeti #-}-{# fun unsafe cuParamSeti- { useFun `Fun'- , `Int'- , `Int32' } -> `Status' cToEnum #}--{-# INLINE cuParamSetf #-}-{# fun unsafe cuParamSetf- { useFun `Fun'- , `Int'- , `Float' } -> `Status' cToEnum #}--{-# INLINE cuParamSetv #-}-{# fun unsafe cuParamSetv- `Storable a' =>- { useFun `Fun'- , `Int'- , castPtr `Ptr a'- , `Int' } -> `Status' cToEnum #}-
− Foreign/CUDA/Driver/Marshal.chs
@@ -1,1005 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE ForeignFunctionInterface #-}-{-# OPTIONS_HADDOCK prune #-}------------------------------------------------------------------------------------ |--- Module : Foreign.CUDA.Driver.Marshal--- Copyright : [2009..2014] Trevor L. McDonell--- License : BSD------ Memory management for low-level driver interface--------------------------------------------------------------------------------------module Foreign.CUDA.Driver.Marshal (-- -- * Host Allocation- AllocFlag(..),- mallocHostArray, freeHost, registerArray, unregisterArray,-- -- * Device Allocation- mallocArray, allocaArray, free,-- -- * Unified Memory Allocation- AttachFlag(..),- mallocManagedArray,-- -- * Marshalling- peekArray, peekArrayAsync, peekArray2D, peekArray2DAsync, peekListArray,- pokeArray, pokeArrayAsync, pokeArray2D, pokeArray2DAsync, pokeListArray,- copyArray, copyArrayAsync, copyArray2D, copyArray2DAsync,- copyArrayPeer, copyArrayPeerAsync,-- -- * Combined Allocation and Marshalling- newListArray, newListArrayLen,- withListArray, withListArrayLen,-- -- * Utility- memset, memsetAsync,- getDevicePtr, getBasePtr, getMemInfo,-- -- Internal- useDeviceHandle, peekDeviceHandle--) where--#include "cbits/stubs.h"-{# context lib="cuda" #}---- Friends-import Foreign.CUDA.Ptr-import Foreign.CUDA.Driver.Error-import Foreign.CUDA.Driver.Stream ( Stream(..), defaultStream )-import Foreign.CUDA.Driver.Context ( Context(..) )-import Foreign.CUDA.Internal.C2HS---- System-import Data.Int-import Data.Maybe-import Unsafe.Coerce-import Control.Applicative-import Control.Exception-import Prelude--import Foreign.C-import Foreign.Ptr-import Foreign.Storable-import qualified Foreign.Marshal as F--#c-typedef enum CUmemhostalloc_option_enum {- CU_MEMHOSTALLOC_OPTION_PORTABLE = CU_MEMHOSTALLOC_PORTABLE,- CU_MEMHOSTALLOC_OPTION_DEVICE_MAPPED = CU_MEMHOSTALLOC_DEVICEMAP,- CU_MEMHOSTALLOC_OPTION_WRITE_COMBINED = CU_MEMHOSTALLOC_WRITECOMBINED-} CUmemhostalloc_option;-#endc-------------------------------------------------------------------------------------- Host Allocation------------------------------------------------------------------------------------- |--- Options for host allocation----{# enum CUmemhostalloc_option as AllocFlag- { underscoreToCase }- with prefix="CU_MEMHOSTALLOC_OPTION" deriving (Eq, Show) #}---- |--- Allocate a section of linear memory on the host which is page-locked and--- directly accessible from the device. The storage is sufficient to hold the--- given number of elements of a storable type.------ Note that since the amount of pageable memory is thusly reduced, overall--- system performance may suffer. This is best used sparingly to allocate--- staging areas for data exchange.----{-# INLINEABLE mallocHostArray #-}-mallocHostArray :: Storable a => [AllocFlag] -> Int -> IO (HostPtr a)-mallocHostArray !flags = doMalloc undefined- where- doMalloc :: Storable a' => a' -> Int -> IO (HostPtr a')- doMalloc x !n = resultIfOk =<< cuMemHostAlloc (n * sizeOf x) flags--{-# INLINE cuMemHostAlloc #-}-{# fun unsafe cuMemHostAlloc- { alloca'- `HostPtr a' peekHP*- , `Int'- , combineBitMasks `[AllocFlag]' } -> `Status' cToEnum #}- where- alloca' !f = F.alloca $ \ !p -> poke p nullPtr >> f (castPtr p)- peekHP !p = HostPtr . castPtr <$> peek p----- |--- Free a section of page-locked host memory----{-# INLINEABLE freeHost #-}-freeHost :: HostPtr a -> IO ()-freeHost !p = nothingIfOk =<< cuMemFreeHost p--{-# INLINE cuMemFreeHost #-}-{# fun unsafe cuMemFreeHost- { useHP `HostPtr a' } -> `Status' cToEnum #}- where- useHP = castPtr . useHostPtr----- |--- Page-locks the specified array (on the host) and maps it for the device(s) as--- specified by the given allocation flags. Subsequently, the memory is accessed--- directly by the device so can be read and written with much higher bandwidth--- than pageable memory that has not been registered. The memory range is added--- to the same tracking mechanism as 'mallocHostArray' to automatically--- accelerate calls to functions such as 'pokeArray'.------ Note that page-locking excessive amounts of memory may degrade system--- performance, since it reduces the amount of pageable memory available. This--- is best used sparingly to allocate staging areas for data exchange.------ This function is not yet implemented on Mac OS X. Requires cuda-4.0.----{-# INLINEABLE registerArray #-}-registerArray :: Storable a => [AllocFlag] -> Int -> Ptr a -> IO (HostPtr a)-#if CUDA_VERSION < 4000-registerArray _ _ _ = requireSDK 4.0 "registerArray"-#else-registerArray !flags !n = go undefined- where- go :: Storable b => b -> Ptr b -> IO (HostPtr b)- go x !p = do- status <- cuMemHostRegister p (n * sizeOf x) flags- resultIfOk (status,HostPtr p)--{-# INLINE cuMemHostRegister #-}-{# fun unsafe cuMemHostRegister- { castPtr `Ptr a'- , `Int'- , combineBitMasks `[AllocFlag]' } -> `Status' cToEnum #}-#endif----- |--- Unmaps the memory from the given pointer, and makes it pageable again.------ This function is not yet implemented on Mac OS X. Requires cuda-4.0.----{-# INLINEABLE unregisterArray #-}-unregisterArray :: HostPtr a -> IO (Ptr a)-#if CUDA_VERSION < 4000-unregisterArray _ = requireSDK 4.0 "unregisterArray"-#else-unregisterArray (HostPtr !p) = do- status <- cuMemHostUnregister p- resultIfOk (status,p)--{-# INLINE cuMemHostUnregister #-}-{# fun unsafe cuMemHostUnregister- { castPtr `Ptr a' } -> `Status' cToEnum #}-#endif-------------------------------------------------------------------------------------- Device Allocation------------------------------------------------------------------------------------- |--- Allocate a section of linear memory on the device, and return a reference to--- it. The memory is sufficient to hold the given number of elements of storable--- type. It is suitably aligned for any type, and is not cleared.----{-# INLINEABLE mallocArray #-}-mallocArray :: Storable a => Int -> IO (DevicePtr a)-mallocArray = doMalloc undefined- where- doMalloc :: Storable a' => a' -> Int -> IO (DevicePtr a')- doMalloc x !n = resultIfOk =<< cuMemAlloc (n * sizeOf x)--{-# INLINE cuMemAlloc #-}-{# fun unsafe cuMemAlloc- { alloca'- `DevicePtr a' peekDeviceHandle*- , `Int' } -> `Status' cToEnum #}- where- alloca' !f = F.alloca $ \ !p -> poke p nullPtr >> f (castPtr p)----- |--- Execute a computation on the device, passing a pointer to a temporarily--- allocated block of memory sufficient to hold the given number of elements of--- storable type. The memory is freed when the computation terminates (normally--- or via an exception), so the pointer must not be used after this.------ Note that kernel launches can be asynchronous, so you may want to add a--- synchronisation point using 'sync' as part of the computation.----{-# INLINEABLE allocaArray #-}-allocaArray :: Storable a => Int -> (DevicePtr a -> IO b) -> IO b-allocaArray !n = bracket (mallocArray n) free----- |--- Release a section of device memory----{-# INLINEABLE free #-}-free :: DevicePtr a -> IO ()-free !dp = nothingIfOk =<< cuMemFree dp--{-# INLINE cuMemFree #-}-{# fun unsafe cuMemFree- { useDeviceHandle `DevicePtr a' } -> `Status' cToEnum #}-------------------------------------------------------------------------------------- Unified memory allocations------------------------------------------------------------------------------------- |--- Options for unified memory allocations----#if CUDA_VERSION < 6000-data AttachFlag-#else-{# enum CUmemAttach_flags as AttachFlag- { underscoreToCase }- with prefix="CU_MEM_ATTACH_OPTION" deriving (Eq, Show) #}-#endif---- |--- Allocates memory that will be automatically managed by the Unified Memory--- system----{-# INLINEABLE mallocManagedArray #-}-mallocManagedArray :: Storable a => [AttachFlag] -> Int -> IO (DevicePtr a)-#if CUDA_VERSION < 6000-mallocManagedArray _ _ = requireSDK 6.0 "mallocManagedArray"-#else-mallocManagedArray !flags = doMalloc undefined- where- doMalloc :: Storable a' => a' -> Int -> IO (DevicePtr a')- doMalloc x !n = resultIfOk =<< cuMemAllocManaged (n * sizeOf x) flags--{-# INLINE cuMemAllocManaged #-}-{# fun unsafe cuMemAllocManaged- { alloca'- `DevicePtr a' peekDeviceHandle*- , `Int'- , combineBitMasks `[AttachFlag]' } -> `Status' cToEnum #}- where- alloca' !f = F.alloca $ \ !p -> poke p nullPtr >> f (castPtr p)-#endif-------------------------------------------------------------------------------------- Marshalling------------------------------------------------------------------------------------- Device -> Host--- ------------------ |--- Copy a number of elements from the device to host memory. This is a--- synchronous operation----{-# INLINEABLE peekArray #-}-peekArray :: Storable a => Int -> DevicePtr a -> Ptr a -> IO ()-peekArray !n !dptr !hptr = doPeek undefined dptr- where- doPeek :: Storable a' => a' -> DevicePtr a' -> IO ()- doPeek x _ = nothingIfOk =<< cuMemcpyDtoH hptr dptr (n * sizeOf x)--{-# INLINE cuMemcpyDtoH #-}-{# fun cuMemcpyDtoH- { castPtr `Ptr a'- , useDeviceHandle `DevicePtr a'- , `Int' } -> `Status' cToEnum #}----- |--- Copy memory from the device asynchronously, possibly associated with a--- particular stream. The destination host memory must be page-locked.----{-# INLINEABLE peekArrayAsync #-}-peekArrayAsync :: Storable a => Int -> DevicePtr a -> HostPtr a -> Maybe Stream -> IO ()-peekArrayAsync !n !dptr !hptr !mst = doPeek undefined dptr- where- doPeek :: Storable a' => a' -> DevicePtr a' -> IO ()- doPeek x _ = nothingIfOk =<< cuMemcpyDtoHAsync hptr dptr (n * sizeOf x) (fromMaybe defaultStream mst)--{-# INLINE cuMemcpyDtoHAsync #-}-{# fun cuMemcpyDtoHAsync- { useHP `HostPtr a'- , useDeviceHandle `DevicePtr a'- , `Int'- , useStream `Stream' } -> `Status' cToEnum #}- where- useHP = castPtr . useHostPtr----- |--- Copy a 2D array from the device to the host.----{-# INLINEABLE peekArray2D #-}-peekArray2D- :: Storable a- => Int -- ^ width to copy (elements)- -> Int -- ^ height to copy (elements)- -> DevicePtr a -- ^ source array- -> Int -- ^ source array width- -> Int -- ^ source x-coordinate- -> Int -- ^ source y-coordinate- -> Ptr a -- ^ destination array- -> Int -- ^ destination array width- -> Int -- ^ destination x-coordinate- -> Int -- ^ destination y-coordinate- -> IO ()-peekArray2D !w !h !dptr !dw !dx !dy !hptr !hw !hx !hy = doPeek undefined dptr- where- doPeek :: Storable a' => a' -> DevicePtr a' -> IO ()- doPeek x _ =- let bytes = sizeOf x- w' = w * bytes- hw' = hw * bytes- hx' = hx * bytes- dw' = dw * bytes- dx' = dx * bytes- in- nothingIfOk =<< cuMemcpy2DDtoH hptr hw' hx' hy dptr dw' dx' dy w' h--{-# INLINE cuMemcpy2DDtoH #-}-{# fun cuMemcpy2DDtoH- { castPtr `Ptr a'- , `Int'- , `Int'- , `Int'- , useDeviceHandle `DevicePtr a'- , `Int'- , `Int'- , `Int'- , `Int'- , `Int'- }- -> `Status' cToEnum #}----- |--- Copy a 2D array from the device to the host asynchronously, possibly--- associated with a particular execution stream. The destination host memory--- must be page-locked.----{-# INLINEABLE peekArray2DAsync #-}-peekArray2DAsync- :: Storable a- => Int -- ^ width to copy (elements)- -> Int -- ^ height to copy (elements)- -> DevicePtr a -- ^ source array- -> Int -- ^ source array width- -> Int -- ^ source x-coordinate- -> Int -- ^ source y-coordinate- -> HostPtr a -- ^ destination array- -> Int -- ^ destination array width- -> Int -- ^ destination x-coordinate- -> Int -- ^ destination y-coordinate- -> Maybe Stream -- ^ stream to associate to- -> IO ()-peekArray2DAsync !w !h !dptr !dw !dx !dy !hptr !hw !hx !hy !mst = doPeek undefined dptr- where- doPeek :: Storable a' => a' -> DevicePtr a' -> IO ()- doPeek x _ =- let bytes = sizeOf x- w' = w * bytes- hw' = hw * bytes- hx' = hx * bytes- dw' = dw * bytes- dx' = dx * bytes- st = fromMaybe defaultStream mst- in- nothingIfOk =<< cuMemcpy2DDtoHAsync hptr hw' hx' hy dptr dw' dx' dy w' h st--{-# INLINE cuMemcpy2DDtoHAsync #-}-{# fun cuMemcpy2DDtoHAsync- { useHP `HostPtr a'- , `Int'- , `Int'- , `Int'- , useDeviceHandle `DevicePtr a'- , `Int'- , `Int'- , `Int'- , `Int'- , `Int'- , useStream `Stream'- }- -> `Status' cToEnum #}- where- useHP = castPtr . useHostPtr----- |--- Copy a number of elements from the device into a new Haskell list. Note that--- this requires two memory copies: firstly from the device into a heap--- allocated array, and from there marshalled into a list.----{-# INLINEABLE peekListArray #-}-peekListArray :: Storable a => Int -> DevicePtr a -> IO [a]-peekListArray !n !dptr =- F.allocaArray n $ \p -> do- peekArray n dptr p- F.peekArray n p----- Host -> Device--- ------------------ |--- Copy a number of elements onto the device. This is a synchronous operation----{-# INLINEABLE pokeArray #-}-pokeArray :: Storable a => Int -> Ptr a -> DevicePtr a -> IO ()-pokeArray !n !hptr !dptr = doPoke undefined dptr- where- doPoke :: Storable a' => a' -> DevicePtr a' -> IO ()- doPoke x _ = nothingIfOk =<< cuMemcpyHtoD dptr hptr (n * sizeOf x)--{-# INLINE cuMemcpyHtoD #-}-{# fun cuMemcpyHtoD- { useDeviceHandle `DevicePtr a'- , castPtr `Ptr a'- , `Int' } -> `Status' cToEnum #}----- |--- Copy memory onto the device asynchronously, possibly associated with a--- particular stream. The source host memory must be page-locked.----{-# INLINEABLE pokeArrayAsync #-}-pokeArrayAsync :: Storable a => Int -> HostPtr a -> DevicePtr a -> Maybe Stream -> IO ()-pokeArrayAsync !n !hptr !dptr !mst = dopoke undefined dptr- where- dopoke :: Storable a' => a' -> DevicePtr a' -> IO ()- dopoke x _ = nothingIfOk =<< cuMemcpyHtoDAsync dptr hptr (n * sizeOf x) (fromMaybe defaultStream mst)--{-# INLINE cuMemcpyHtoDAsync #-}-{# fun cuMemcpyHtoDAsync- { useDeviceHandle `DevicePtr a'- , useHP `HostPtr a'- , `Int'- , useStream `Stream' } -> `Status' cToEnum #}- where- useHP = castPtr . useHostPtr----- |--- Copy a 2D array from the host to the device.----{-# INLINEABLE pokeArray2D #-}-pokeArray2D- :: Storable a- => Int -- ^ width to copy (elements)- -> Int -- ^ height to copy (elements)- -> Ptr a -- ^ source array- -> Int -- ^ source array width- -> Int -- ^ source x-coordinate- -> Int -- ^ source y-coordinate- -> DevicePtr a -- ^ destination array- -> Int -- ^ destination array width- -> Int -- ^ destination x-coordinate- -> Int -- ^ destination y-coordinate- -> IO ()-pokeArray2D !w !h !hptr !hw !hx !hy !dptr !dw !dx !dy = doPoke undefined dptr- where- doPoke :: Storable a' => a' -> DevicePtr a' -> IO ()- doPoke x _ =- let bytes = sizeOf x- w' = w * bytes- hw' = hw * bytes- hx' = hx * bytes- dw' = dw * bytes- dx' = dx * bytes- in- nothingIfOk =<< cuMemcpy2DHtoD dptr dw' dx' dy hptr hw' hx' hy w' h--{-# INLINE cuMemcpy2DHtoD #-}-{# fun cuMemcpy2DHtoD- { useDeviceHandle `DevicePtr a'- , `Int'- , `Int'- , `Int'- , castPtr `Ptr a'- , `Int'- , `Int'- , `Int'- , `Int'- , `Int'- }- -> `Status' cToEnum #}----- |--- Copy a 2D array from the host to the device asynchronously, possibly--- associated with a particular execution stream. The source host memory must be--- page-locked.----{-# INLINEABLE pokeArray2DAsync #-}-pokeArray2DAsync- :: Storable a- => Int -- ^ width to copy (elements)- -> Int -- ^ height to copy (elements)- -> HostPtr a -- ^ source array- -> Int -- ^ source array width- -> Int -- ^ source x-coordinate- -> Int -- ^ source y-coordinate- -> DevicePtr a -- ^ destination array- -> Int -- ^ destination array width- -> Int -- ^ destination x-coordinate- -> Int -- ^ destination y-coordinate- -> Maybe Stream -- ^ stream to associate to- -> IO ()-pokeArray2DAsync !w !h !hptr !hw !hx !hy !dptr !dw !dx !dy !mst = doPoke undefined dptr- where- doPoke :: Storable a' => a' -> DevicePtr a' -> IO ()- doPoke x _ =- let bytes = sizeOf x- w' = w * bytes- hw' = hw * bytes- hx' = hx * bytes- dw' = dw * bytes- dx' = dx * bytes- st = fromMaybe defaultStream mst- in- nothingIfOk =<< cuMemcpy2DHtoDAsync dptr dw' dx' dy hptr hw' hx' hy w' h st--{-# INLINE cuMemcpy2DHtoDAsync #-}-{# fun cuMemcpy2DHtoDAsync- { useDeviceHandle `DevicePtr a'- , `Int'- , `Int'- , `Int'- , useHP `HostPtr a'- , `Int'- , `Int'- , `Int'- , `Int'- , `Int'- , useStream `Stream'- }- -> `Status' cToEnum #}- where- useHP = castPtr . useHostPtr----- |--- Write a list of storable elements into a device array. The device array must--- be sufficiently large to hold the entire list. This requires two marshalling--- operations.----{-# INLINEABLE pokeListArray #-}-pokeListArray :: Storable a => [a] -> DevicePtr a -> IO ()-pokeListArray !xs !dptr = F.withArrayLen xs $ \ !len !p -> pokeArray len p dptr----- Device -> Device--- -------------------- |--- Copy the given number of elements from the first device array (source) to the--- second device (destination). The copied areas may not overlap. This operation--- is asynchronous with respect to the host, but will never overlap with kernel--- execution.----{-# INLINEABLE copyArray #-}-copyArray :: Storable a => Int -> DevicePtr a -> DevicePtr a -> IO ()-copyArray !n = docopy undefined- where- docopy :: Storable a' => a' -> DevicePtr a' -> DevicePtr a' -> IO ()- docopy x src dst = nothingIfOk =<< cuMemcpyDtoD dst src (n * sizeOf x)--{-# INLINE cuMemcpyDtoD #-}-{# fun unsafe cuMemcpyDtoD- { useDeviceHandle `DevicePtr a'- , useDeviceHandle `DevicePtr a'- , `Int' } -> `Status' cToEnum #}----- |--- Copy the given number of elements from the first device array (source) to the--- second device array (destination). The copied areas may not overlap. The--- operation is asynchronous with respect to the host, and can be asynchronous--- to other device operations by associating it with a particular stream.----{-# INLINEABLE copyArrayAsync #-}-copyArrayAsync :: Storable a => Int -> DevicePtr a -> DevicePtr a -> Maybe Stream -> IO ()-copyArrayAsync !n !src !dst !mst = docopy undefined src- where- docopy :: Storable a' => a' -> DevicePtr a' -> IO ()- docopy x _ = nothingIfOk =<< cuMemcpyDtoDAsync dst src (n * sizeOf x) (fromMaybe defaultStream mst)--{-# INLINE cuMemcpyDtoDAsync #-}-{# fun unsafe cuMemcpyDtoDAsync- { useDeviceHandle `DevicePtr a'- , useDeviceHandle `DevicePtr a'- , `Int'- , useStream `Stream' } -> `Status' cToEnum #}----- |--- Copy a 2D array from the first device array (source) to the second device--- array (destination). The copied areas must not overlap. This operation is--- asynchronous with respect to the host, but will never overlap with kernel--- execution.----{-# INLINEABLE copyArray2D #-}-copyArray2D- :: Storable a- => Int -- ^ width to copy (elements)- -> Int -- ^ height to copy (elements)- -> DevicePtr a -- ^ source array- -> Int -- ^ source array width- -> Int -- ^ source x-coordinate- -> Int -- ^ source y-coordinate- -> DevicePtr a -- ^ destination array- -> Int -- ^ destination array width- -> Int -- ^ destination x-coordinate- -> Int -- ^ destination y-coordinate- -> IO ()-copyArray2D !w !h !src !hw !hx !hy !dst !dw !dx !dy = doCopy undefined dst- where- doCopy :: Storable a' => a' -> DevicePtr a' -> IO ()- doCopy x _ =- let bytes = sizeOf x- w' = w * bytes- hw' = hw * bytes- hx' = hx * bytes- dw' = dw * bytes- dx' = dx * bytes- in- nothingIfOk =<< cuMemcpy2DDtoD dst dw' dx' dy src hw' hx' hy w' h--{-# INLINE cuMemcpy2DDtoD #-}-{# fun unsafe cuMemcpy2DDtoD- { useDeviceHandle `DevicePtr a'- , `Int'- , `Int'- , `Int'- , useDeviceHandle `DevicePtr a'- , `Int'- , `Int'- , `Int'- , `Int'- , `Int'- }- -> `Status' cToEnum #}----- |--- Copy a 2D array from the first device array (source) to the second device--- array (destination). The copied areas may not overlap. The operation is--- asynchronous with respect to the host, and can be asynchronous to other--- device operations by associating it with a particular execution stream.----{-# INLINEABLE copyArray2DAsync #-}-copyArray2DAsync- :: Storable a- => Int -- ^ width to copy (elements)- -> Int -- ^ height to copy (elements)- -> DevicePtr a -- ^ source array- -> Int -- ^ source array width- -> Int -- ^ source x-coordinate- -> Int -- ^ source y-coordinate- -> DevicePtr a -- ^ destination array- -> Int -- ^ destination array width- -> Int -- ^ destination x-coordinate- -> Int -- ^ destination y-coordinate- -> Maybe Stream -- ^ stream to associate to- -> IO ()-copyArray2DAsync !w !h !src !hw !hx !hy !dst !dw !dx !dy !mst = doCopy undefined dst- where- doCopy :: Storable a' => a' -> DevicePtr a' -> IO ()- doCopy x _ =- let bytes = sizeOf x- w' = w * bytes- hw' = hw * bytes- hx' = hx * bytes- dw' = dw * bytes- dx' = dx * bytes- st = fromMaybe defaultStream mst- in- nothingIfOk =<< cuMemcpy2DDtoDAsync dst dw' dx' dy src hw' hx' hy w' h st--{-# INLINE cuMemcpy2DDtoDAsync #-}-{# fun unsafe cuMemcpy2DDtoDAsync- { useDeviceHandle `DevicePtr a'- , `Int'- , `Int'- , `Int'- , useDeviceHandle `DevicePtr a'- , `Int'- , `Int'- , `Int'- , `Int'- , `Int'- , useStream `Stream'- }- -> `Status' cToEnum #}------ Context -> Context--- ---------------------- |--- Copies an array from device memory in one context to device memory in another--- context. Note that this function is asynchronous with respect to the host,--- but serialised with respect to all pending and future asynchronous work in--- the source and destination contexts. To avoid this synchronisation, use--- 'copyArrayPeerAsync' instead.----{-# INLINEABLE copyArrayPeer #-}-copyArrayPeer :: Storable a- => Int -- ^ number of array elements- -> DevicePtr a -> Context -- ^ source array and context- -> DevicePtr a -> Context -- ^ destination array and context- -> IO ()-#if CUDA_VERSION < 4000-copyArrayPeer _ _ _ _ _ = requireSDK 4.0 "copyArrayPeer"-#else-copyArrayPeer !n !src !srcCtx !dst !dstCtx = go undefined src dst- where- go :: Storable b => b -> DevicePtr b -> DevicePtr b -> IO ()- go x _ _ = nothingIfOk =<< cuMemcpyPeer dst dstCtx src srcCtx (n * sizeOf x)--{-# INLINE cuMemcpyPeer #-}-{# fun unsafe cuMemcpyPeer- { useDeviceHandle `DevicePtr a'- , useContext `Context'- , useDeviceHandle `DevicePtr a'- , useContext `Context'- , `Int' } -> `Status' cToEnum #}-#endif----- |--- Copies from device memory in one context to device memory in another context.--- Note that this function is asynchronous with respect to the host and all work--- in other streams and devices.----{-# INLINEABLE copyArrayPeerAsync #-}-copyArrayPeerAsync :: Storable a- => Int -- ^ number of array elements- -> DevicePtr a -> Context -- ^ source array and context- -> DevicePtr a -> Context -- ^ destination array and device context- -> Maybe Stream -- ^ stream to associate with- -> IO ()-#if CUDA_VERSION < 4000-copyArrayPeerAsync _ _ _ _ _ _ = requireSDK 4.0 "copyArrayPeerAsync"-#else-copyArrayPeerAsync !n !src !srcCtx !dst !dstCtx !st = go undefined src dst- where- go :: Storable b => b -> DevicePtr b -> DevicePtr b -> IO ()- go x _ _ = nothingIfOk =<< cuMemcpyPeerAsync dst dstCtx src srcCtx (n * sizeOf x) stream- stream = fromMaybe defaultStream st--{-# INLINE cuMemcpyPeerAsync #-}-{# fun unsafe cuMemcpyPeerAsync- { useDeviceHandle `DevicePtr a'- , useContext `Context'- , useDeviceHandle `DevicePtr a'- , useContext `Context'- , `Int'- , useStream `Stream' } -> `Status' cToEnum #}-#endif-------------------------------------------------------------------------------------- Combined Allocation and Marshalling------------------------------------------------------------------------------------- |--- Write a list of storable elements into a newly allocated device array,--- returning the device pointer together with the number of elements that were--- written. Note that this requires two memory copies: firstly from a Haskell--- list to a heap allocated array, and from there onto the graphics device. The--- memory should be 'free'd when no longer required.----{-# INLINEABLE newListArrayLen #-}-newListArrayLen :: Storable a => [a] -> IO (DevicePtr a, Int)-newListArrayLen xs =- F.withArrayLen xs $ \len p ->- bracketOnError (mallocArray len) free $ \d_xs -> do- pokeArray len p d_xs- return (d_xs, len)----- |--- Write a list of storable elements into a newly allocated device array. This--- is 'newListArrayLen' composed with 'fst'.----{-# INLINEABLE newListArray #-}-newListArray :: Storable a => [a] -> IO (DevicePtr a)-newListArray xs = fst `fmap` newListArrayLen xs----- |--- Temporarily store a list of elements into a newly allocated device array. An--- IO action is applied to to the array, the result of which is returned.--- Similar to 'newListArray', this requires copying the data twice.------ As with 'allocaArray', the memory is freed once the action completes, so you--- should not return the pointer from the action, and be wary of asynchronous--- kernel execution.----{-# INLINEABLE withListArray #-}-withListArray :: Storable a => [a] -> (DevicePtr a -> IO b) -> IO b-withListArray xs = withListArrayLen xs . const----- |--- A variant of 'withListArray' which also supplies the number of elements in--- the array to the applied function----{-# INLINEABLE withListArrayLen #-}-withListArrayLen :: Storable a => [a] -> (Int -> DevicePtr a -> IO b) -> IO b-withListArrayLen xs f =- bracket (newListArrayLen xs) (free . fst) (uncurry . flip $ f)------ XXX: Will this attempt to double-free the device array on error (together--- with newListArrayLen)?----------------------------------------------------------------------------------------- Utility------------------------------------------------------------------------------------- |--- Set a number of data elements to the specified value, which may be either 8-,--- 16-, or 32-bits wide.----{-# INLINEABLE memset #-}-memset :: Storable a => DevicePtr a -> Int -> a -> IO ()-memset !dptr !n !val = case sizeOf val of- 1 -> nothingIfOk =<< cuMemsetD8 dptr val n- 2 -> nothingIfOk =<< cuMemsetD16 dptr val n- 4 -> nothingIfOk =<< cuMemsetD32 dptr val n- _ -> cudaError "can only memset 8-, 16-, and 32-bit values"------- We use unsafe coerce below to reinterpret the bits of the value to memset as,--- into the integer type required by the setting functions.----{-# INLINE cuMemsetD8 #-}-{# fun unsafe cuMemsetD8- { useDeviceHandle `DevicePtr a'- , unsafeCoerce `a'- , `Int' } -> `Status' cToEnum #}--{-# INLINE cuMemsetD16 #-}-{# fun unsafe cuMemsetD16- { useDeviceHandle `DevicePtr a'- , unsafeCoerce `a'- , `Int' } -> `Status' cToEnum #}--{-# INLINE cuMemsetD32 #-}-{# fun unsafe cuMemsetD32- { useDeviceHandle `DevicePtr a'- , unsafeCoerce `a'- , `Int' } -> `Status' cToEnum #}----- |--- Set the number of data elements to the specified value, which may be either--- 8-, 16-, or 32-bits wide. The operation is asynchronous and may optionally be--- associated with a stream. Requires cuda-3.2.----{-# INLINEABLE memsetAsync #-}-memsetAsync :: Storable a => DevicePtr a -> Int -> a -> Maybe Stream -> IO ()-#if CUDA_VERSION < 3020-memsetAsync _ _ _ _ = requireSDK 3.2 "memsetAsync"-#else-memsetAsync !dptr !n !val !mst = case sizeOf val of- 1 -> nothingIfOk =<< cuMemsetD8Async dptr val n stream- 2 -> nothingIfOk =<< cuMemsetD16Async dptr val n stream- 4 -> nothingIfOk =<< cuMemsetD32Async dptr val n stream- _ -> cudaError "can only memset 8-, 16-, and 32-bit values"- where- stream = fromMaybe defaultStream mst--{-# INLINE cuMemsetD8Async #-}-{# fun unsafe cuMemsetD8Async- { useDeviceHandle `DevicePtr a'- , unsafeCoerce `a'- , `Int'- , useStream `Stream' } -> `Status' cToEnum #}--{-# INLINE cuMemsetD16Async #-}-{# fun unsafe cuMemsetD16Async- { useDeviceHandle `DevicePtr a'- , unsafeCoerce `a'- , `Int'- , useStream `Stream' } -> `Status' cToEnum #}--{-# INLINE cuMemsetD32Async #-}-{# fun unsafe cuMemsetD32Async- { useDeviceHandle `DevicePtr a'- , unsafeCoerce `a'- , `Int'- , useStream `Stream' } -> `Status' cToEnum #}-#endif----- |--- Return the device pointer associated with a mapped, pinned host buffer, which--- was allocated with the 'DeviceMapped' option by 'mallocHostArray'.------ Currently, no options are supported and this must be empty.----{-# INLINEABLE getDevicePtr #-}-getDevicePtr :: [AllocFlag] -> HostPtr a -> IO (DevicePtr a)-getDevicePtr !flags !hp = resultIfOk =<< cuMemHostGetDevicePointer hp flags--{-# INLINE cuMemHostGetDevicePointer #-}-{# fun unsafe cuMemHostGetDevicePointer- { alloca'- `DevicePtr a' peekDeviceHandle*- , useHP `HostPtr a'- , combineBitMasks `[AllocFlag]' } -> `Status' cToEnum #}- where- alloca' = F.alloca- useHP = castPtr . useHostPtr---- |--- Return the base address and allocation size of the given device pointer----{-# INLINEABLE getBasePtr #-}-getBasePtr :: DevicePtr a -> IO (DevicePtr a, Int64)-getBasePtr !dptr = do- (status,base,size) <- cuMemGetAddressRange dptr- resultIfOk (status, (base,size))--{-# INLINE cuMemGetAddressRange #-}-{# fun unsafe cuMemGetAddressRange- { alloca'- `DevicePtr a' peekDeviceHandle*- , alloca'- `Int64' peekIntConv*- , useDeviceHandle `DevicePtr a' } -> `Status' cToEnum #}- where- alloca' :: Storable a => (Ptr a -> IO b) -> IO b- alloca' = F.alloca---- |--- Return the amount of free and total memory respectively available to the--- current context (bytes)----{-# INLINEABLE getMemInfo #-}-getMemInfo :: IO (Int64, Int64)-getMemInfo = do- (!status,!f,!t) <- cuMemGetInfo- resultIfOk (status,(f,t))--{-# INLINE cuMemGetInfo #-}-{# fun unsafe cuMemGetInfo- { alloca'- `Int64' peekIntConv*- , alloca'- `Int64' peekIntConv* } -> `Status' cToEnum #}- where- alloca' = F.alloca-------------------------------------------------------------------------------------- Internal-----------------------------------------------------------------------------------type DeviceHandle = {# type CUdeviceptr #}---- Lift an opaque handle to a typed DevicePtr representation. This occasions--- arcane distinctions for the different driver versions and Tesla (compute 1.x)--- and Fermi (compute 2.x) class architectures on 32- and 64-bit hosts.----{-# INLINE peekDeviceHandle #-}-peekDeviceHandle :: Ptr DeviceHandle -> IO (DevicePtr a)-peekDeviceHandle !p = DevicePtr . intPtrToPtr . fromIntegral <$> peek p---- Use a device pointer as an opaque handle type----{-# INLINE useDeviceHandle #-}-useDeviceHandle :: DevicePtr a -> DeviceHandle-useDeviceHandle = fromIntegral . ptrToIntPtr . useDevicePtr-
− Foreign/CUDA/Driver/Module.chs
@@ -1,331 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE ForeignFunctionInterface #-}------------------------------------------------------------------------------------ |--- Module : Foreign.CUDA.Driver.Module--- Copyright : [2009..2014] Trevor L. McDonell--- License : BSD------ Module management for low-level driver interface--------------------------------------------------------------------------------------module Foreign.CUDA.Driver.Module (-- -- * Module Management- Module, JITOption(..), JITTarget(..), JITResult(..), JITFallback(..),-- -- ** Querying module inhabitants- getFun, getPtr, getTex,-- -- ** Loading and unloading modules- loadFile,- loadData, loadDataFromPtr,- loadDataEx, loadDataFromPtrEx,- unload--) where--#include "cbits/stubs.h"-{# context lib="cuda" #}---- Friends-import Foreign.CUDA.Analysis.Device-import Foreign.CUDA.Ptr-import Foreign.CUDA.Driver.Error-import Foreign.CUDA.Driver.Exec-import Foreign.CUDA.Driver.Marshal ( peekDeviceHandle )-import Foreign.CUDA.Driver.Texture-import Foreign.CUDA.Internal.C2HS---- System-import Foreign-import Foreign.C-import Unsafe.Coerce--import Control.Monad ( liftM )-import Control.Exception ( throwIO )-import Data.Maybe ( mapMaybe )-import Data.ByteString.Char8 ( ByteString )-import qualified Data.ByteString.Char8 as B-import qualified Data.ByteString.Internal as B--#if CUDA_VERSION < 5050-import Debug.Trace ( trace )-#endif------------------------------------------------------------------------------------- Data Types------------------------------------------------------------------------------------- |--- A reference to a Module object, containing collections of device functions----newtype Module = Module { useModule :: {# type CUmodule #}}- deriving (Eq, Show)----- |--- Just-in-time compilation options----data JITOption- = MaxRegisters !Int -- ^ maximum number of registers per thread- | ThreadsPerBlock !Int -- ^ number of threads per block to target for- | OptimisationLevel !Int -- ^ level of optimisation to apply (1-4, default 4)- | Target !Compute -- ^ compilation target, otherwise determined from context- | FallbackStrategy !JITFallback -- ^ fallback strategy if matching cubin not found- | GenerateDebugInfo -- ^ generate debug info (-g) (requires cuda >= 5.5)- | GenerateLineInfo -- ^ generate line number information (-lineinfo) (requires cuda >= 5.5)- | Verbose -- ^ verbose log messages (requires cuda >= 5.5)- deriving (Show)---- |--- Results of online compilation----data JITResult = JITResult- {- jitTime :: !Float, -- ^ milliseconds spent compiling PTX- jitInfoLog :: !ByteString, -- ^ information about PTX assembly- jitModule :: !Module -- ^ compilation error log or compiled module- }- deriving (Show)---{# enum CUjit_option as JITOptionInternal- { }- with prefix="CU" deriving (Eq, Show) #}--{# enum CUjit_target as JITTarget- { underscoreToCase }- with prefix="CU_TARGET" deriving (Eq, Show) #}--{# enum CUjit_fallback as JITFallback- { underscoreToCase- , CU_PREFER_PTX as PTX }- with prefix="CU_PREFER" deriving (Eq, Show) #}-------------------------------------------------------------------------------------- Module management------------------------------------------------------------------------------------- |--- Returns a function handle----{-# INLINEABLE getFun #-}-getFun :: Module -> String -> IO Fun-getFun !mdl !fn = resultIfFound "function" fn =<< cuModuleGetFunction mdl fn--{-# INLINE cuModuleGetFunction #-}-{# fun unsafe cuModuleGetFunction- { alloca- `Fun' peekFun*- , useModule `Module'- , withCString* `String' } -> `Status' cToEnum #}- where peekFun = liftM Fun . peek----- |--- Return a global pointer, and size of the global (in bytes)----{-# INLINEABLE getPtr #-}-getPtr :: Module -> String -> IO (DevicePtr a, Int)-getPtr !mdl !name = do- (!status,!dptr,!bytes) <- cuModuleGetGlobal mdl name- resultIfFound "global" name (status,(dptr,bytes))--{-# INLINE cuModuleGetGlobal #-}-{# fun unsafe cuModuleGetGlobal- { alloca- `DevicePtr a' peekDeviceHandle*- , alloca- `Int' peekIntConv*- , useModule `Module'- , withCString* `String' } -> `Status' cToEnum #}----- |--- Return a handle to a texture reference----{-# INLINEABLE getTex #-}-getTex :: Module -> String -> IO Texture-getTex !mdl !name = resultIfFound "texture" name =<< cuModuleGetTexRef mdl name--{-# INLINE cuModuleGetTexRef #-}-{# fun unsafe cuModuleGetTexRef- { alloca- `Texture' peekTex*- , useModule `Module'- , withCString* `String' } -> `Status' cToEnum #}----- |--- Load the contents of the specified file (either a ptx or cubin file) to--- create a new module, and load that module into the current context.----{-# INLINEABLE loadFile #-}-loadFile :: FilePath -> IO Module-loadFile !ptx = resultIfOk =<< cuModuleLoad ptx--{-# INLINE cuModuleLoad #-}-{# fun unsafe cuModuleLoad- { alloca- `Module' peekMod*- , withCString* `FilePath' } -> `Status' cToEnum #}----- |--- Load the contents of the given image into a new module, and load that module--- into the current context. The image is (typically) the contents of a cubin or--- PTX file.------ Note that the 'ByteString' will be copied into a temporary staging area so--- that it can be passed to C.----{-# INLINEABLE loadData #-}-loadData :: ByteString -> IO Module-loadData !img =- B.useAsCString img (\p -> loadDataFromPtr (castPtr p))---- |--- As 'loadData', but read the image data from the given pointer. The image is a--- NULL-terminated sequence of bytes.----{-# INLINEABLE loadDataFromPtr #-}-loadDataFromPtr :: Ptr Word8 -> IO Module-loadDataFromPtr !img = resultIfOk =<< cuModuleLoadData img--{-# INLINE cuModuleLoadData #-}-{# fun unsafe cuModuleLoadData- { alloca- `Module' peekMod*- , castPtr `Ptr Word8' } -> ` Status' cToEnum #}----- |--- Load the contents of the given image into a module with online compiler--- options, and load the module into the current context. The image is--- (typically) the contents of a cubin or PTX file. The actual attributes of the--- compiled kernel can be probed using 'requires'.------ Note that the 'ByteString' will be copied into a temporary staging area so--- that it can be passed to C.----{-# INLINEABLE loadDataEx #-}-loadDataEx :: ByteString -> [JITOption] -> IO JITResult-loadDataEx !img !options =- B.useAsCString img (\p -> loadDataFromPtrEx (castPtr p) options)---- |--- As 'loadDataEx', but read the image data from the given pointer. The image is--- a NULL-terminated sequence of bytes.----{-# INLINEABLE loadDataFromPtrEx #-}-loadDataFromPtrEx :: Ptr Word8 -> [JITOption] -> IO JITResult-loadDataFromPtrEx !img !options = do- fp_ilog <- B.mallocByteString logSize-- allocaArray logSize $ \p_elog -> do- withForeignPtr fp_ilog $ \p_ilog -> do-- let (opt,val) = unzip $- [ (JIT_WALL_TIME, 0) -- must be first, this is extracted below- , (JIT_INFO_LOG_BUFFER_SIZE_BYTES, logSize)- , (JIT_ERROR_LOG_BUFFER_SIZE_BYTES, logSize)- , (JIT_INFO_LOG_BUFFER, unsafeCoerce (p_ilog :: CString))- , (JIT_ERROR_LOG_BUFFER, unsafeCoerce (p_elog :: CString)) ] ++ mapMaybe unpack options-- withArray (map cFromEnum opt) $ \p_opts -> do- withArray (map unsafeCoerce val) $ \p_vals -> do-- (s,mdl) <- cuModuleLoadDataEx img (length opt) p_opts p_vals-- case s of- Success -> do- time <- peek (castPtr p_vals)- infoLog <- B.fromForeignPtr (castForeignPtr fp_ilog) 0 `fmap` c_strnlen p_ilog logSize- return $! JITResult time infoLog mdl-- _ -> do- errLog <- peekCString p_elog- cudaError (unlines [describe s, errLog])-- where- logSize = 2048-- unpack (MaxRegisters x) = Just (JIT_MAX_REGISTERS, x)- unpack (ThreadsPerBlock x) = Just (JIT_THREADS_PER_BLOCK, x)- unpack (OptimisationLevel x) = Just (JIT_OPTIMIZATION_LEVEL, x)- unpack (Target x) = Just (JIT_TARGET, jitTargetOfCompute x)- unpack (FallbackStrategy x) = Just (JIT_FALLBACK_STRATEGY, fromEnum x)-#if CUDA_VERSION >= 5050- unpack GenerateDebugInfo = Just (JIT_GENERATE_DEBUG_INFO, fromEnum True)- unpack GenerateLineInfo = Just (JIT_GENERATE_LINE_INFO, fromEnum True)- unpack Verbose = Just (JIT_LOG_VERBOSE, fromEnum True)-#else- unpack x = trace ("Warning: JITOption '" ++ show x ++ "' requires at least cuda-5.5") Nothing-#endif-- jitTargetOfCompute (Compute x y)- = fromEnum- $ case (x,y) of- (1,0) -> Compute10- (1,1) -> Compute11- (1,2) -> Compute12- (1,3) -> Compute13- (2,0) -> Compute20- (2,1) -> Compute21- (3,0) -> Compute30- (3,5) -> Compute35- _ -> error ("Unknown JIT Target for Compute " ++ show (Compute x y))---{-# INLINE cuModuleLoadDataEx #-}-{# fun unsafe cuModuleLoadDataEx- { alloca- `Module' peekMod*- , castPtr `Ptr Word8'- , `Int'- , id `Ptr CInt'- , id `Ptr (Ptr ())' } -> `Status' cToEnum #}----- |--- Unload a module from the current context----{-# INLINEABLE unload #-}-unload :: Module -> IO ()-unload !m = nothingIfOk =<< cuModuleUnload m--{-# INLINE cuModuleUnload #-}-{# fun unsafe cuModuleUnload- { useModule `Module' } -> `Status' cToEnum #}-------------------------------------------------------------------------------------- Internal-----------------------------------------------------------------------------------{-# INLINE resultIfFound #-}-resultIfFound :: String -> String -> (Status, a) -> IO a-resultIfFound kind name (!status,!result) =- case status of- Success -> return result- NotFound -> cudaError (kind ++ ' ' : describe status ++ ": " ++ name)- _ -> throwIO (ExitCode status)--{-# INLINE peekMod #-}-peekMod :: Ptr {# type CUmodule #} -> IO Module-peekMod = liftM Module . peek--{-# INLINE c_strnlen' #-}-#if defined(WIN32)-c_strnlen' :: CString -> CSize -> IO CSize-c_strnlen' str size = do- str' <- peekCStringLen (str, fromIntegral size)- return $ stringLen 0 str'- where stringLen acc [] = acc- stringLen acc ('\0':xs) = acc- stringLen acc (_:xs) = stringLen (acc+1) xs-#else-foreign import ccall unsafe "string.h strnlen" c_strnlen'- :: CString -> CSize -> IO CSize-#endif--{-# INLINE c_strnlen #-}-c_strnlen :: CString -> Int -> IO Int-c_strnlen str maxlen = cIntConv `fmap` c_strnlen' str (cIntConv maxlen)-
− Foreign/CUDA/Driver/Stream.chs
@@ -1,94 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE ForeignFunctionInterface #-}------------------------------------------------------------------------------------ |--- Module : Foreign.CUDA.Driver.Stream--- Copyright : [2009..2014] Trevor L. McDonell--- License : BSD------ Stream management for low-level driver interface--------------------------------------------------------------------------------------module Foreign.CUDA.Driver.Stream (-- -- * Stream Management- Stream(..), StreamFlag,- create, destroy, finished, block, defaultStream--) where--#include "cbits/stubs.h"-{# context lib="cuda" #}---- Friends-import Foreign.CUDA.Types-import Foreign.CUDA.Driver.Error-import Foreign.CUDA.Internal.C2HS---- System-import Foreign-import Foreign.C-import Control.Monad ( liftM )-import Control.Exception ( throwIO )-------------------------------------------------------------------------------------- Stream management------------------------------------------------------------------------------------- |--- Create a new stream----{-# INLINEABLE create #-}-create :: [StreamFlag] -> IO Stream-create !flags = resultIfOk =<< cuStreamCreate flags--{-# INLINE cuStreamCreate #-}-{# fun unsafe cuStreamCreate- { alloca- `Stream' peekStream*- , combineBitMasks `[StreamFlag]' } -> `Status' cToEnum #}- where- peekStream = liftM Stream . peek---- |--- Destroy a stream----{-# INLINEABLE destroy #-}-destroy :: Stream -> IO ()-destroy !st = nothingIfOk =<< cuStreamDestroy st--{-# INLINE cuStreamDestroy #-}-{# fun unsafe cuStreamDestroy- { useStream `Stream' } -> `Status' cToEnum #}----- |--- Check if all operations in the stream have completed----{-# INLINEABLE finished #-}-finished :: Stream -> IO Bool-finished !st =- cuStreamQuery st >>= \rv ->- case rv of- Success -> return True- NotReady -> return False- _ -> throwIO (ExitCode rv)--{-# INLINE cuStreamQuery #-}-{# fun unsafe cuStreamQuery- { useStream `Stream' } -> `Status' cToEnum #}----- |--- Wait until the device has completed all operations in the Stream----{-# INLINEABLE block #-}-block :: Stream -> IO ()-block !st = nothingIfOk =<< cuStreamSynchronize st--{-# INLINE cuStreamSynchronize #-}-{# fun cuStreamSynchronize- { useStream `Stream' } -> `Status' cToEnum #}-
− Foreign/CUDA/Driver/Texture.chs
@@ -1,284 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE ForeignFunctionInterface #-}-{-# OPTIONS_HADDOCK prune #-}------------------------------------------------------------------------------------ |--- Module : Foreign.CUDA.Driver.Texture--- Copyright : [2009..2014] Trevor L. McDonell--- License : BSD------ Texture management for low-level driver interface--------------------------------------------------------------------------------------module Foreign.CUDA.Driver.Texture (-- -- * Texture Reference Management- Texture(..), Format(..), AddressMode(..), FilterMode(..), ReadMode(..),- create, destroy,- bind, bind2D,- getAddressMode, getFilterMode, getFormat,- setAddressMode, setFilterMode, setFormat, setReadMode,-- -- Internal- peekTex--) where--#include "cbits/stubs.h"-{# context lib="cuda" #}---- Friends-import Foreign.CUDA.Ptr-import Foreign.CUDA.Driver.Error-import Foreign.CUDA.Driver.Marshal-import Foreign.CUDA.Internal.C2HS---- System-import Foreign-import Foreign.C-import Control.Monad--#if CUDA_VERSION >= 3020-{-# DEPRECATED create, destroy "as of CUDA version 3.2" #-}-#endif-------------------------------------------------------------------------------------- Data Types------------------------------------------------------------------------------------- |--- A texture reference----newtype Texture = Texture { useTexture :: {# type CUtexref #}}- deriving (Eq, Show)--instance Storable Texture where- sizeOf _ = sizeOf (undefined :: {# type CUtexref #})- alignment _ = alignment (undefined :: {# type CUtexref #})- peek p = Texture `fmap` peek (castPtr p)- poke p t = poke (castPtr p) (useTexture t)---- |--- Texture reference addressing modes----{# enum CUaddress_mode as AddressMode- { underscoreToCase }- with prefix="CU_TR_ADDRESS_MODE" deriving (Eq, Show) #}---- |--- Texture reference filtering mode----{# enum CUfilter_mode as FilterMode- { underscoreToCase }- with prefix="CU_TR_FILTER_MODE" deriving (Eq, Show) #}---- |--- Texture read mode options----#c-typedef enum CUtexture_flag_enum {- CU_TEXTURE_FLAG_READ_AS_INTEGER = CU_TRSF_READ_AS_INTEGER,- CU_TEXTURE_FLAG_NORMALIZED_COORDINATES = CU_TRSF_NORMALIZED_COORDINATES,- CU_TEXTURE_FLAG_SRGB = CU_TRSF_SRGB-} CUtexture_flag;-#endc--{# enum CUtexture_flag as ReadMode- { underscoreToCase- , CU_TEXTURE_FLAG_SRGB as SRGB }- with prefix="CU_TEXTURE_FLAG" deriving (Eq, Show) #}---- |--- Texture data formats----{# enum CUarray_format as Format- { underscoreToCase- , UNSIGNED_INT8 as Word8- , UNSIGNED_INT16 as Word16- , UNSIGNED_INT32 as Word32- , SIGNED_INT8 as Int8- , SIGNED_INT16 as Int16- , SIGNED_INT32 as Int32 }- with prefix="CU_AD_FORMAT" deriving (Eq, Show) #}-------------------------------------------------------------------------------------- Texture management------------------------------------------------------------------------------------- |--- Create a new texture reference. Once created, the application must call--- 'setPtr' to associate the reference with allocated memory. Other texture--- reference functions are used to specify the format and interpretation to be--- used when the memory is read through this reference.----{-# INLINEABLE create #-}-create :: IO Texture-create = resultIfOk =<< cuTexRefCreate--{-# INLINE cuTexRefCreate #-}-{# fun unsafe cuTexRefCreate- { alloca- `Texture' peekTex* } -> `Status' cToEnum #}----- |--- Destroy a texture reference----{-# INLINEABLE destroy #-}-destroy :: Texture -> IO ()-destroy !tex = nothingIfOk =<< cuTexRefDestroy tex--{-# INLINE cuTexRefDestroy #-}-{# fun unsafe cuTexRefDestroy- { useTexture `Texture' } -> `Status' cToEnum #}----- |--- Bind a linear array address of the given size (bytes) as a texture--- reference. Any previously bound references are unbound.----{-# INLINEABLE bind #-}-bind :: Texture -> DevicePtr a -> Int64 -> IO ()-bind !tex !dptr !bytes = nothingIfOk =<< cuTexRefSetAddress tex dptr bytes--{-# INLINE cuTexRefSetAddress #-}-{# fun unsafe cuTexRefSetAddress- { alloca- `Int'- , useTexture `Texture'- , useDeviceHandle `DevicePtr a'- , `Int64' } -> `Status' cToEnum #}----- |--- Bind a linear address range to the given texture reference as a--- two-dimensional arena. Any previously bound reference is unbound. Note that--- calls to 'setFormat' can not follow a call to 'bind2D' for the same texture--- reference.----{-# INLINEABLE bind2D #-}-bind2D :: Texture -> Format -> Int -> DevicePtr a -> (Int,Int) -> Int64 -> IO ()-bind2D !tex !fmt !chn !dptr (!width,!height) !pitch =- nothingIfOk =<< cuTexRefSetAddress2DSimple tex fmt chn dptr width height pitch--{-# INLINE cuTexRefSetAddress2DSimple #-}-{# fun unsafe cuTexRefSetAddress2DSimple- { useTexture `Texture'- , cFromEnum `Format'- , `Int'- , useDeviceHandle `DevicePtr a'- , `Int'- , `Int'- , `Int64' } -> `Status' cToEnum #}----- |--- Get the addressing mode used by a texture reference, corresponding to the--- given dimension (currently the only supported dimension values are 0 or 1).----{-# INLINEABLE getAddressMode #-}-getAddressMode :: Texture -> Int -> IO AddressMode-getAddressMode !tex !dim = resultIfOk =<< cuTexRefGetAddressMode tex dim--{-# INLINE cuTexRefGetAddressMode #-}-{# fun unsafe cuTexRefGetAddressMode- { alloca- `AddressMode' peekEnum*- , useTexture `Texture'- , `Int' } -> `Status' cToEnum #}----- |--- Get the filtering mode used by a texture reference----{-# INLINEABLE getFilterMode #-}-getFilterMode :: Texture -> IO FilterMode-getFilterMode !tex = resultIfOk =<< cuTexRefGetFilterMode tex--{-# INLINE cuTexRefGetFilterMode #-}-{# fun unsafe cuTexRefGetFilterMode- { alloca- `FilterMode' peekEnum*- , useTexture `Texture' } -> `Status' cToEnum #}----- |--- Get the data format and number of channel components of the bound texture----{-# INLINEABLE getFormat #-}-getFormat :: Texture -> IO (Format, Int)-getFormat !tex = do- (!status,!fmt,!dim) <- cuTexRefGetFormat tex- resultIfOk (status,(fmt,dim))--{-# INLINE cuTexRefGetFormat #-}-{# fun unsafe cuTexRefGetFormat- { alloca- `Format' peekEnum*- , alloca- `Int' peekIntConv*- , useTexture `Texture' } -> `Status' cToEnum #}----- |--- Specify the addressing mode for the given dimension of a texture reference----{-# INLINEABLE setAddressMode #-}-setAddressMode :: Texture -> Int -> AddressMode -> IO ()-setAddressMode !tex !dim !mode = nothingIfOk =<< cuTexRefSetAddressMode tex dim mode--{-# INLINE cuTexRefSetAddressMode #-}-{# fun unsafe cuTexRefSetAddressMode- { useTexture `Texture'- , `Int'- , cFromEnum `AddressMode' } -> `Status' cToEnum #}----- |--- Specify the filtering mode to be used when reading memory through a texture--- reference----{-# INLINEABLE setFilterMode #-}-setFilterMode :: Texture -> FilterMode -> IO ()-setFilterMode !tex !mode = nothingIfOk =<< cuTexRefSetFilterMode tex mode--{-# INLINE cuTexRefSetFilterMode #-}-{# fun unsafe cuTexRefSetFilterMode- { useTexture `Texture'- , cFromEnum `FilterMode' } -> `Status' cToEnum #}----- |--- Specify additional characteristics for reading and indexing the texture--- reference----{-# INLINEABLE setReadMode #-}-setReadMode :: Texture -> ReadMode -> IO ()-setReadMode !tex !mode = nothingIfOk =<< cuTexRefSetFlags tex mode--{-# INLINE cuTexRefSetFlags #-}-{# fun unsafe cuTexRefSetFlags- { useTexture `Texture'- , cFromEnum `ReadMode' } -> `Status' cToEnum #}----- |--- Specify the format of the data and number of packed components per element to--- be read by the texture reference----{-# INLINEABLE setFormat #-}-setFormat :: Texture -> Format -> Int -> IO ()-setFormat !tex !fmt !chn = nothingIfOk =<< cuTexRefSetFormat tex fmt chn--{-# INLINE cuTexRefSetFormat #-}-{# fun unsafe cuTexRefSetFormat- { useTexture `Texture'- , cFromEnum `Format'- , `Int' } -> `Status' cToEnum #}-------------------------------------------------------------------------------------- Internal-----------------------------------------------------------------------------------{-# INLINE peekTex #-}-peekTex :: Ptr {# type CUtexref #} -> IO Texture-peekTex = liftM Texture . peek-
− Foreign/CUDA/Driver/Utils.chs
@@ -1,37 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface #-}------------------------------------------------------------------------------------ |--- Module : Foreign.CUDA.Driver.Utils--- Copyright : [2009..2014] Trevor L. McDonell--- License : BSD------ Utility functions--------------------------------------------------------------------------------------module Foreign.CUDA.Driver.Utils (driverVersion)- where--#include "cbits/stubs.h"-{# context lib="cuda" #}---- Friends-import Foreign.CUDA.Driver.Error-import Foreign.CUDA.Internal.C2HS---- System-import Foreign-import Foreign.C----- |--- Return the version number of the installed CUDA driver----{-# INLINEABLE driverVersion #-}-driverVersion :: IO Int-driverVersion = resultIfOk =<< cuDriverGetVersion--{-# INLINE cuDriverGetVersion #-}-{# fun unsafe cuDriverGetVersion- { alloca- `Int' peekIntConv* } -> `Status' cToEnum #}-
− Foreign/CUDA/Internal/C2HS.hs
@@ -1,230 +0,0 @@--- C->Haskell Compiler: Marshalling library------ Copyright (c) [1999...2005] Manuel M T Chakravarty------ Redistribution and use in source and binary forms, with or without--- modification, are permitted provided that the following conditions are met:------ 1. Redistributions of source code must retain the above copyright notice,--- this list of conditions and the following disclaimer.--- 2. Redistributions in binary form must reproduce the above copyright--- notice, this list of conditions and the following disclaimer in the--- documentation and/or other materials provided with the distribution.--- 3. The name of the author may not be used to endorse or promote products--- derived from this software without specific prior written permission.------ THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR--- IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES--- OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN--- NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,--- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED--- TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR--- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF--- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING--- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS--- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.------- Description --------------------------------------------------------------------- Language: Haskell 98------ This module provides the marshaling routines for Haskell files produced by--- C->Haskell for binding to C library interfaces. It exports all of the--- low-level FFI (language-independent plus the C-specific parts) together--- with the C->HS-specific higher-level marshalling routines.-----module Foreign.CUDA.Internal.C2HS (-- -- * Composite marshalling functions- withCStringLenIntConv, peekCStringLenIntConv, withIntConv, withFloatConv,- peekIntConv, peekFloatConv, withBool, peekBool, withEnum, peekEnum,- peekArrayWith,-- -- * Conditional results using 'Maybe'- nothingIf, nothingIfNull,-- -- * Bit masks- combineBitMasks, containsBitMask, extractBitMasks,-- -- * Conversion between C and Haskell types- cIntConv, cFloatConv, cToBool, cFromBool, cToEnum, cFromEnum-) where---import Foreign-import Foreign.C-import Control.Monad ( liftM )----- Composite marshalling functions--- ----------------------------------- Strings with explicit length----withCStringLenIntConv :: String -> (CStringLen -> IO a) -> IO a-withCStringLenIntConv s f = withCStringLen s $ \(p, n) -> f (p, cIntConv n)--peekCStringLenIntConv :: CStringLen -> IO String-peekCStringLenIntConv (s, n) = peekCStringLen (s, cIntConv n)---- Marshalling of numerals-----withIntConv :: (Storable b, Integral a, Integral b) => a -> (Ptr b -> IO c) -> IO c-withIntConv = with . cIntConv--withFloatConv :: (Storable b, RealFloat a, RealFloat b) => a -> (Ptr b -> IO c) -> IO c-withFloatConv = with . cFloatConv--peekIntConv :: (Storable a, Integral a, Integral b) => Ptr a -> IO b-peekIntConv = liftM cIntConv . peek--peekFloatConv :: (Storable a, RealFloat a, RealFloat b) => Ptr a -> IO b-peekFloatConv = liftM cFloatConv . peek---- Passing Booleans by reference-----withBool :: (Integral a, Storable a) => Bool -> (Ptr a -> IO b) -> IO b-withBool = with . fromBool--peekBool :: (Integral a, Storable a) => Ptr a -> IO Bool-peekBool = liftM toBool . peek----- Read and marshal array elements-----peekArrayWith :: Storable a => (a -> b) -> Int -> Ptr a -> IO [b]-peekArrayWith f n p = map f `fmap` peekArray n p----- Passing enums by reference-----withEnum :: (Enum a, Integral b, Storable b) => a -> (Ptr b -> IO c) -> IO c-withEnum = with . cFromEnum--peekEnum :: (Enum a, Integral b, Storable b) => Ptr b -> IO a-peekEnum = liftM cToEnum . peek---{---- Storing of 'Maybe' values--- ---------------------------instance Storable a => Storable (Maybe a) where- sizeOf _ = sizeOf (undefined :: Ptr ())- alignment _ = alignment (undefined :: Ptr ())-- peek p = do- ptr <- peek (castPtr p)- if ptr == nullPtr- then return Nothing- else liftM Just $ peek ptr-- poke p v = do- ptr <- case v of- Nothing -> return nullPtr- Just v' -> new v'- poke (castPtr p) ptr--}----- Conditional results using 'Maybe'--- ------------------------------------- Wrap the result into a 'Maybe' type.------ * the predicate determines when the result is considered to be non-existing,--- ie, it is represented by `Nothing'------ * the second argument allows to map a result wrapped into `Just' to some--- other domain----nothingIf :: (a -> Bool) -> (a -> b) -> a -> Maybe b-nothingIf p f x = if p x then Nothing else Just $ f x---- |Instance for special casing null pointers.----nothingIfNull :: (Ptr a -> b) -> Ptr a -> Maybe b-nothingIfNull = nothingIf (== nullPtr)----- Support for bit masks--- ------------------------- Given a list of enumeration values that represent bit masks, combine these--- masks using bitwise disjunction.----combineBitMasks :: (Enum a, Num b, Bits b) => [a] -> b-combineBitMasks = foldl (.|.) 0 . map (fromIntegral . fromEnum)---- Tests whether the given bit mask is contained in the given bit pattern--- (i.e., all bits set in the mask are also set in the pattern).----containsBitMask :: (Num a, Bits a, Enum b) => a -> b -> Bool-bits `containsBitMask` bm = let bm' = fromIntegral . fromEnum $ bm- in- bm' .&. bits == bm'---- |Given a bit pattern, yield all bit masks that it contains.------ * This does *not* attempt to compute a minimal set of bit masks that when--- combined yield the bit pattern, instead all contained bit masks are--- produced.----extractBitMasks :: (Num a, Bits a, Enum b, Bounded b) => a -> [b]-extractBitMasks bits =- [bm | bm <- [minBound..maxBound], bits `containsBitMask` bm]----- Conversion routines--- ----------------------- |Integral conversion----{-# INLINE [1] cIntConv #-}-cIntConv :: (Integral a, Integral b) => a -> b-cIntConv = fromIntegral---- |Floating conversion----{-# INLINE [1] cFloatConv #-}-cFloatConv :: (RealFloat a, RealFloat b) => a -> b-cFloatConv = realToFrac--- As this conversion by default goes via `Rational', it can be very slow...-{-# RULES- "cFloatConv/Float->Float" forall (x::Float). cFloatConv x = x;- "cFloatConv/Double->Double" forall (x::Double). cFloatConv x = x;- "cFloatConv/Float->CFloat" forall (x::Float). cFloatConv x = CFloat x;- "cFloatConv/CFloat->Float" forall (x::Float). cFloatConv CFloat x = x;- "cFloatConv/Double->CDouble" forall (x::Double). cFloatConv x = CDouble x;- "cFloatConv/CDouble->Double" forall (x::Double). cFloatConv CDouble x = x- #-}---- |Obtain C value from Haskell 'Bool'.----{-# INLINE [1] cFromBool #-}-cFromBool :: Num a => Bool -> a-cFromBool = fromBool---- |Obtain Haskell 'Bool' from C value.----{-# INLINE [1] cToBool #-}-cToBool :: (Eq a, Num a) => a -> Bool-cToBool = toBool---- |Convert a C enumeration to Haskell.----{-# INLINE [1] cToEnum #-}-cToEnum :: (Integral i, Enum e) => i -> e-cToEnum = toEnum . cIntConv---- |Convert a Haskell enumeration to C.----{-# INLINE [1] cFromEnum #-}-cFromEnum :: (Enum e, Integral i) => e -> i-cFromEnum = cIntConv . fromEnum-
− Foreign/CUDA/Ptr.hs
@@ -1,184 +0,0 @@-{-# LANGUAGE BangPatterns #-}------------------------------------------------------------------------------------ |--- Module : Foreign.CUDA.Ptr--- Copyright : [2009..2014] Trevor L. McDonell--- License : BSD------ Data pointers on the host and device. These can be shared freely between the--- CUDA runtime and Driver APIs.--------------------------------------------------------------------------------------module Foreign.CUDA.Ptr (-- -- * Device pointers- DevicePtr(..),- withDevicePtr,- devPtrToWordPtr,- wordPtrToDevPtr,- nullDevPtr,- castDevPtr,- plusDevPtr,- alignDevPtr,- minusDevPtr,- advanceDevPtr,-- -- * Host pointers- HostPtr(..),- withHostPtr,- nullHostPtr,- castHostPtr,- plusHostPtr,- alignHostPtr,- minusHostPtr,- advanceHostPtr,--) where---- friends-import Foreign.CUDA.Types---- system-import Foreign.Ptr-import Foreign.Storable-------------------------------------------------------------------------------------- Device Pointer------------------------------------------------------------------------------------- |--- Look at the contents of device memory. This takes an IO action that will be--- applied to that pointer, the result of which is returned. It would be silly--- to return the pointer from the action.----{-# INLINEABLE withDevicePtr #-}-withDevicePtr :: DevicePtr a -> (Ptr a -> IO b) -> IO b-withDevicePtr !p !f = f (useDevicePtr p)---- |--- Return a unique handle associated with the given device pointer----{-# INLINEABLE devPtrToWordPtr #-}-devPtrToWordPtr :: DevicePtr a -> WordPtr-devPtrToWordPtr = ptrToWordPtr . useDevicePtr---- |--- Return a device pointer from the given handle----{-# INLINEABLE wordPtrToDevPtr #-}-wordPtrToDevPtr :: WordPtr -> DevicePtr a-wordPtrToDevPtr = DevicePtr . wordPtrToPtr---- |--- The constant 'nullDevPtr' contains the distinguished memory location that is--- not associated with a valid memory location----{-# INLINEABLE nullDevPtr #-}-nullDevPtr :: DevicePtr a-nullDevPtr = DevicePtr nullPtr---- |--- Cast a device pointer from one type to another----{-# INLINEABLE castDevPtr #-}-castDevPtr :: DevicePtr a -> DevicePtr b-castDevPtr (DevicePtr !p) = DevicePtr (castPtr p)---- |--- Advance the pointer address by the given offset in bytes.----{-# INLINEABLE plusDevPtr #-}-plusDevPtr :: DevicePtr a -> Int -> DevicePtr a-plusDevPtr (DevicePtr !p) !d = DevicePtr (p `plusPtr` d)---- |--- Given an alignment constraint, align the device pointer to the next highest--- address satisfying the constraint----{-# INLINEABLE alignDevPtr #-}-alignDevPtr :: DevicePtr a -> Int -> DevicePtr a-alignDevPtr (DevicePtr !p) !i = DevicePtr (p `alignPtr` i)---- |--- Compute the difference between the second and first argument. This fulfils--- the relation------ > p2 == p1 `plusDevPtr` (p2 `minusDevPtr` p1)----{-# INLINEABLE minusDevPtr #-}-minusDevPtr :: DevicePtr a -> DevicePtr a -> Int-minusDevPtr (DevicePtr !a) (DevicePtr !b) = a `minusPtr` b---- |--- Advance a pointer into a device array by the given number of elements----{-# INLINEABLE advanceDevPtr #-}-advanceDevPtr :: Storable a => DevicePtr a -> Int -> DevicePtr a-advanceDevPtr = doAdvance undefined- where- doAdvance :: Storable a' => a' -> DevicePtr a' -> Int -> DevicePtr a'- doAdvance x !p !i = p `plusDevPtr` (i * sizeOf x)-------------------------------------------------------------------------------------- Host Pointer------------------------------------------------------------------------------------- |--- Apply an IO action to the memory reference living inside the host pointer--- object. All uses of the pointer should be inside the 'withHostPtr' bracket.----{-# INLINEABLE withHostPtr #-}-withHostPtr :: HostPtr a -> (Ptr a -> IO b) -> IO b-withHostPtr !p !f = f (useHostPtr p)----- |--- The constant 'nullHostPtr' contains the distinguished memory location that is--- not associated with a valid memory location----{-# INLINEABLE nullHostPtr #-}-nullHostPtr :: HostPtr a-nullHostPtr = HostPtr nullPtr---- |--- Cast a host pointer from one type to another----{-# INLINEABLE castHostPtr #-}-castHostPtr :: HostPtr a -> HostPtr b-castHostPtr (HostPtr !p) = HostPtr (castPtr p)---- |--- Advance the pointer address by the given offset in bytes----{-# INLINEABLE plusHostPtr #-}-plusHostPtr :: HostPtr a -> Int -> HostPtr a-plusHostPtr (HostPtr !p) !d = HostPtr (p `plusPtr` d)---- |--- Given an alignment constraint, align the host pointer to the next highest--- address satisfying the constraint----{-# INLINEABLE alignHostPtr #-}-alignHostPtr :: HostPtr a -> Int -> HostPtr a-alignHostPtr (HostPtr !p) !i = HostPtr (p `alignPtr` i)---- |--- Compute the difference between the second and first argument----{-# INLINEABLE minusHostPtr #-}-minusHostPtr :: HostPtr a -> HostPtr a -> Int-minusHostPtr (HostPtr !a) (HostPtr !b) = a `minusPtr` b---- |--- Advance a pointer into a host array by a given number of elements----{-# INLINEABLE advanceHostPtr #-}-advanceHostPtr :: Storable a => HostPtr a -> Int -> HostPtr a-advanceHostPtr = doAdvance undefined- where- doAdvance :: Storable a' => a' -> HostPtr a' -> Int -> HostPtr a'- doAdvance x !p !i = p `plusHostPtr` (i * sizeOf x)-
− Foreign/CUDA/Runtime.hs
@@ -1,28 +0,0 @@------------------------------------------------------------------------------------ |--- Module : Foreign.CUDA.Runtime--- Copyright : [2009..2014] Trevor L. McDonell--- License : BSD------ Top level bindings to the C-for-CUDA runtime API--------------------------------------------------------------------------------------module Foreign.CUDA.Runtime (-- module Foreign.CUDA.Ptr,- module Foreign.CUDA.Runtime.Device,- module Foreign.CUDA.Runtime.Error,- module Foreign.CUDA.Runtime.Exec,- module Foreign.CUDA.Runtime.Marshal,- module Foreign.CUDA.Runtime.Utils--) where--import Foreign.CUDA.Ptr-import Foreign.CUDA.Runtime.Device-import Foreign.CUDA.Runtime.Error-import Foreign.CUDA.Runtime.Exec-import Foreign.CUDA.Runtime.Marshal-import Foreign.CUDA.Runtime.Utils-
− Foreign/CUDA/Runtime/Device.chs
@@ -1,444 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE ForeignFunctionInterface #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-#ifdef USE_EMPTY_CASE-{-# LANGUAGE EmptyCase #-}-#endif------------------------------------------------------------------------------------ |--- Module : Foreign.CUDA.Runtime.Device--- Copyright : [2009..2014] Trevor L. McDonell--- License : BSD------ Device management routines--------------------------------------------------------------------------------------module Foreign.CUDA.Runtime.Device (-- -- * Device Management- Device, DeviceFlag(..), DeviceProperties(..), Compute(..), ComputeMode(..),- choose, get, count, props, set, setFlags, setOrder, reset, sync,-- -- * Peer Access- PeerFlag,- accessible, add, remove,-- -- * Cache Configuration- Limit(..),- getLimit, setLimit--) where--#include "cbits/stubs.h"-{# context lib="cudart" #}---- Friends-import Foreign.CUDA.Analysis.Device-import Foreign.CUDA.Runtime.Error-import Foreign.CUDA.Internal.C2HS---- System-import Foreign-import Foreign.C--#c-typedef struct cudaDeviceProp cudaDeviceProp;--typedef enum-{- cudaDeviceFlagScheduleAuto = cudaDeviceScheduleAuto,- cudaDeviceFlagScheduleSpin = cudaDeviceScheduleSpin,- cudaDeviceFlagScheduleYield = cudaDeviceScheduleYield,- cudaDeviceFlagBlockingSync = cudaDeviceBlockingSync,- cudaDeviceFlagMapHost = cudaDeviceMapHost,-#if CUDART_VERSION >= 3000- cudaDeviceFlagLMemResizeToMax = cudaDeviceLmemResizeToMax-#endif-} cudaDeviceFlags;-#endc-------------------------------------------------------------------------------------- Data Types------------------------------------------------------------------------------------- |--- A device identifier----type Device = Int--{# pointer *cudaDeviceProp as ^ foreign -> DeviceProperties nocode #}---- |--- Device execution flags----{# enum cudaDeviceFlags as DeviceFlag { }- with prefix="cudaDeviceFlag" deriving (Eq, Show) #}---instance Storable DeviceProperties where- sizeOf _ = {#sizeof cudaDeviceProp#}- alignment _ = alignment (undefined :: Ptr ())-- poke _ _ = error "no instance for Foreign.Storable.poke DeviceProperties"- peek p = do- n <- peekCString =<< {#get cudaDeviceProp.name#} p- gm <- cIntConv `fmap` {#get cudaDeviceProp.totalGlobalMem#} p- sm <- cIntConv `fmap` {#get cudaDeviceProp.sharedMemPerBlock#} p- rb <- cIntConv `fmap` {#get cudaDeviceProp.regsPerBlock#} p- ws <- cIntConv `fmap` {#get cudaDeviceProp.warpSize#} p- mp <- cIntConv `fmap` {#get cudaDeviceProp.memPitch#} p- tb <- cIntConv `fmap` {#get cudaDeviceProp.maxThreadsPerBlock#} p- cl <- cIntConv `fmap` {#get cudaDeviceProp.clockRate#} p- cm <- cIntConv `fmap` {#get cudaDeviceProp.totalConstMem#} p- v1 <- fromIntegral `fmap` {#get cudaDeviceProp.major#} p- v2 <- fromIntegral `fmap` {#get cudaDeviceProp.minor#} p- ta <- cIntConv `fmap` {#get cudaDeviceProp.textureAlignment#} p- ov <- cToBool `fmap` {#get cudaDeviceProp.deviceOverlap#} p- pc <- cIntConv `fmap` {#get cudaDeviceProp.multiProcessorCount#} p- ke <- cToBool `fmap` {#get cudaDeviceProp.kernelExecTimeoutEnabled#} p- tg <- cToBool `fmap` {#get cudaDeviceProp.integrated#} p- hm <- cToBool `fmap` {#get cudaDeviceProp.canMapHostMemory#} p- md <- cToEnum `fmap` {#get cudaDeviceProp.computeMode#} p-#if CUDART_VERSION >= 3000- ck <- cToBool `fmap` {#get cudaDeviceProp.concurrentKernels#} p- u1 <- cIntConv `fmap` {#get cudaDeviceProp.maxTexture1D#} p-#endif-#if CUDART_VERSION >= 3010- ee <- cToBool `fmap` {#get cudaDeviceProp.ECCEnabled#} p-#endif-#if CUDART_VERSION >= 4000- ae <- cIntConv `fmap` {#get cudaDeviceProp.asyncEngineCount#} p- l2 <- cIntConv `fmap` {#get cudaDeviceProp.l2CacheSize#} p- tm <- cIntConv `fmap` {#get cudaDeviceProp.maxThreadsPerMultiProcessor#} p- mw <- cIntConv `fmap` {#get cudaDeviceProp.memoryBusWidth#} p- mc <- cIntConv `fmap` {#get cudaDeviceProp.memoryClockRate#} p- pb <- cIntConv `fmap` {#get cudaDeviceProp.pciBusID#} p- pd <- cIntConv `fmap` {#get cudaDeviceProp.pciDeviceID#} p- pm <- cIntConv `fmap` {#get cudaDeviceProp.pciDomainID#} p- tc <- cToBool `fmap` {#get cudaDeviceProp.tccDriver#} p- ua <- cToBool `fmap` {#get cudaDeviceProp.unifiedAddressing#} p-#endif-- [t1,t2,t3] <- peekArrayWith cIntConv 3 =<< {#get cudaDeviceProp.maxThreadsDim#} p- [g1,g2,g3] <- peekArrayWith cIntConv 3 =<< {#get cudaDeviceProp.maxGridSize#} p-#if CUDART_VERSION >= 3000- [u21,u22] <- peekArrayWith cIntConv 2 =<< {#get cudaDeviceProp.maxTexture2D#} p- [u31,u32,u33] <- peekArrayWith cIntConv 3 =<< {#get cudaDeviceProp.maxTexture3D#} p-#endif-- return DeviceProperties- {- deviceName = n,- computeCapability = Compute v1 v2,- totalGlobalMem = gm,- totalConstMem = cm,- sharedMemPerBlock = sm,- regsPerBlock = rb,- warpSize = ws,- maxThreadsPerBlock = tb,- maxBlockSize = (t1,t2,t3),- maxGridSize = (g1,g2,g3),- clockRate = cl,- multiProcessorCount = pc,- memPitch = mp,- textureAlignment = ta,- computeMode = md,- deviceOverlap = ov,-#if CUDART_VERSION >= 3000- concurrentKernels = ck,- maxTextureDim1D = u1,- maxTextureDim2D = (u21,u22),- maxTextureDim3D = (u31,u32,u33),-#endif-#if CUDART_VERSION >= 3010- eccEnabled = ee,-#endif-#if CUDART_VERSION >= 3000 && CUDART_VERSION < 3010- -- not visible from runtime API < 3.1- eccEnabled = False,-#endif-#if CUDART_VERSION >= 4000- asyncEngineCount = ae,- cacheMemL2 = l2,- maxThreadsPerMultiProcessor = tm,- memBusWidth = mw,- memClockRate = mc,- tccDriverEnabled = tc,- unifiedAddressing = ua,- pciInfo = PCI pb pd pm,-#endif- kernelExecTimeoutEnabled = ke,- integrated = tg,- canMapHostMemory = hm- }-------------------------------------------------------------------------------------- Device Management------------------------------------------------------------------------------------- |--- Select the compute device which best matches the given criteria----{-# INLINEABLE choose #-}-choose :: DeviceProperties -> IO Device-choose !dev = resultIfOk =<< cudaChooseDevice dev--{-# INLINE cudaChooseDevice #-}-{# fun unsafe cudaChooseDevice- { alloca- `Int' peekIntConv*- , withDevProp* `DeviceProperties' } -> `Status' cToEnum #}- where- withDevProp = with----- |--- Returns which device is currently being used----{-# INLINEABLE get #-}-get :: IO Device-get = resultIfOk =<< cudaGetDevice--{-# INLINE cudaGetDevice #-}-{# fun unsafe cudaGetDevice- { alloca- `Int' peekIntConv* } -> `Status' cToEnum #}----- |--- Returns the number of devices available for execution, with compute--- capability >= 1.0----{-# INLINEABLE count #-}-count :: IO Int-count = resultIfOk =<< cudaGetDeviceCount--{-# INLINE cudaGetDeviceCount #-}-{# fun unsafe cudaGetDeviceCount- { alloca- `Int' peekIntConv* } -> `Status' cToEnum #}----- |--- Return information about the selected compute device----{-# INLINEABLE props #-}-props :: Device -> IO DeviceProperties-props !n = resultIfOk =<< cudaGetDeviceProperties n--{-# INLINE cudaGetDeviceProperties #-}-{# fun unsafe cudaGetDeviceProperties- { alloca- `DeviceProperties' peek*- , `Int' } -> `Status' cToEnum #}----- |--- Set device to be used for GPU execution----{-# INLINEABLE set #-}-set :: Device -> IO ()-set !n = nothingIfOk =<< cudaSetDevice n--{-# INLINE cudaSetDevice #-}-{# fun unsafe cudaSetDevice- { `Int' } -> `Status' cToEnum #}----- |--- Set flags to be used for device executions----{-# INLINEABLE setFlags #-}-setFlags :: [DeviceFlag] -> IO ()-setFlags !f = nothingIfOk =<< cudaSetDeviceFlags (combineBitMasks f)--{-# INLINE cudaSetDeviceFlags #-}-{# fun unsafe cudaSetDeviceFlags- { `Int' } -> `Status' cToEnum #}----- |--- Set list of devices for CUDA execution in priority order----{-# INLINEABLE setOrder #-}-setOrder :: [Device] -> IO ()-setOrder !l = nothingIfOk =<< cudaSetValidDevices l (length l)--{-# INLINE cudaSetValidDevices #-}-{# fun unsafe cudaSetValidDevices- { withArrayIntConv* `[Int]'- , `Int' } -> `Status' cToEnum #}- where- withArrayIntConv = withArray . map cIntConv---- |--- Block until the device has completed all preceding requested tasks. Returns--- an error if one of the tasks fails.----{-# INLINEABLE sync #-}-sync :: IO ()-#if CUDART_VERSION < 4000-{-# INLINE cudaThreadSynchronize #-}-sync = nothingIfOk =<< cudaThreadSynchronize-{# fun cudaThreadSynchronize { } -> `Status' cToEnum #}-#else-{-# INLINE cudaDeviceSynchronize #-}-sync = nothingIfOk =<< cudaDeviceSynchronize-{# fun cudaDeviceSynchronize { } -> `Status' cToEnum #}-#endif---- |--- Explicitly destroys and cleans up all runtime resources associated with the--- current device in the current process. Any subsequent API call will--- reinitialise the device.------ Note that this function will reset the device immediately. It is the caller’s--- responsibility to ensure that the device is not being accessed by any other--- host threads from the process when this function is called.----{-# INLINEABLE reset #-}-reset :: IO ()-#if CUDART_VERSION >= 4000-{-# INLINE cudaDeviceReset #-}-reset = nothingIfOk =<< cudaDeviceReset-{# fun unsafe cudaDeviceReset { } -> `Status' cToEnum #}-#else-{-# INLINE cudaThreadExit #-}-reset = nothingIfOk =<< cudaThreadExit-{# fun unsafe cudaThreadExit { } -> `Status' cToEnum #}-#endif-------------------------------------------------------------------------------------- Peer Access------------------------------------------------------------------------------------- |--- Possible option values for direct peer memory access----data PeerFlag-instance Enum PeerFlag where-#ifdef USE_EMPTY_CASE- toEnum x = case x of {}- fromEnum x = case x of {}-#endif---- |--- Queries if the first device can directly access the memory of the second. If--- direct access is possible, it can then be enabled with 'add'. Requires--- cuda-4.0.----{-# INLINEABLE accessible #-}-accessible :: Device -> Device -> IO Bool-#if CUDART_VERSION < 4000-accessible _ _ = requireSDK 4.0 "accessible"-#else-accessible !dev !peer = resultIfOk =<< cudaDeviceCanAccessPeer dev peer--{-# INLINE cudaDeviceCanAccessPeer #-}-{# fun unsafe cudaDeviceCanAccessPeer- { alloca- `Bool' peekBool*- , cIntConv `Device'- , cIntConv `Device' } -> `Status' cToEnum #}-#endif---- |--- If the devices of both the current and supplied contexts support unified--- addressing, then enable allocations in the supplied context to be accessible--- by the current context. Requires cuda-4.0.----{-# INLINEABLE add #-}-add :: Device -> [PeerFlag] -> IO ()-#if CUDART_VERSION < 4000-add _ _ = requireSDK 4.0 "add"-#else-add !dev !flags = nothingIfOk =<< cudaDeviceEnablePeerAccess dev flags--{-# INLINE cudaDeviceEnablePeerAccess #-}-{# fun unsafe cudaDeviceEnablePeerAccess- { cIntConv `Device'- , combineBitMasks `[PeerFlag]' } -> `Status' cToEnum #}-#endif----- |--- Disable direct memory access from the current context to the supplied--- context. Requires cuda-4.0.----{-# INLINEABLE remove #-}-remove :: Device -> IO ()-#if CUDART_VERSION < 4000-remove _ = requireSDK 4.0 "remove"-#else-remove !dev = nothingIfOk =<< cudaDeviceDisablePeerAccess dev--{-# INLINE cudaDeviceDisablePeerAccess #-}-{# fun unsafe cudaDeviceDisablePeerAccess- { cIntConv `Device' } -> `Status' cToEnum #}-#endif-------------------------------------------------------------------------------------- Cache Configuration------------------------------------------------------------------------------------- |--- Device limit flags----#if CUDART_VERSION < 3010-data Limit-#else-{# enum cudaLimit as Limit- { underscoreToCase }- with prefix="cudaLimit" deriving (Eq, Show) #}-#endif----- |--- Query compute 2.0 call stack limits. Requires cuda-3.1.----{-# INLINEABLE getLimit #-}-getLimit :: Limit -> IO Int-#if CUDART_VERSION < 3010-getLimit _ = requireSDK 3.1 "getLimit"-#elif CUDART_VERSION < 4000-getLimit !l = resultIfOk =<< cudaThreadGetLimit l--{-# INLINE cudaThreadGetLimit #-}-{# fun unsafe cudaThreadGetLimit- { alloca- `Int' peekIntConv*- , cFromEnum `Limit' } -> `Status' cToEnum #}-#else-getLimit !l = resultIfOk =<< cudaDeviceGetLimit l--{-# INLINE cudaDeviceGetLimit #-}-{# fun unsafe cudaDeviceGetLimit- { alloca- `Int' peekIntConv*- , cFromEnum `Limit' } -> `Status' cToEnum #}-#endif----- |--- Set compute 2.0 call stack limits. Requires cuda-3.1.----{-# INLINEABLE setLimit #-}-setLimit :: Limit -> Int -> IO ()-#if CUDART_VERSION < 3010-setLimit _ _ = requireSDK 3.1 "setLimit"-#elif CUDART_VERSION < 4000-setLimit !l !n = nothingIfOk =<< cudaThreadSetLimit l n--{-# INLINE cudaThreadSetLimit #-}-{# fun unsafe cudaThreadSetLimit- { cFromEnum `Limit'- , cIntConv `Int' } -> `Status' cToEnum #}-#else-setLimit !l !n = nothingIfOk =<< cudaDeviceSetLimit l n--{-# INLINE cudaDeviceSetLimit #-}-{# fun unsafe cudaDeviceSetLimit- { cFromEnum `Limit'- , cIntConv `Int' } -> `Status' cToEnum #}-#endif-
− Foreign/CUDA/Runtime/Error.chs
@@ -1,114 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE ForeignFunctionInterface #-}------------------------------------------------------------------------------------ |--- Module : Foreign.CUDA.Runtime.Error--- Copyright : [2009..2014] Trevor L. McDonell--- License : BSD------ Error handling functions--------------------------------------------------------------------------------------module Foreign.CUDA.Runtime.Error (-- Status(..), CUDAException(..),-- cudaError, describe, requireSDK,- resultIfOk, nothingIfOk--) where---- Friends-import Foreign.CUDA.Internal.C2HS---- System-import Foreign.C-import Foreign.Ptr-import Data.Typeable-import Control.Exception-import System.IO.Unsafe--#include "cbits/stubs.h"-{# context lib="cudart" #}-------------------------------------------------------------------------------------- Return Status------------------------------------------------------------------------------------- |--- Return codes from API functions----{# enum cudaError as Status- { cudaSuccess as Success }- with prefix="cudaError" deriving (Eq, Show) #}------------------------------------------------------------------------------------- Exceptions-----------------------------------------------------------------------------------data CUDAException- = ExitCode Status- | UserError String- deriving Typeable--instance Exception CUDAException--instance Show CUDAException where- showsPrec _ (ExitCode s) = showString ("CUDA Exception: " ++ describe s)- showsPrec _ (UserError s) = showString ("CUDA Exception: " ++ s)----- |--- Raise a 'CUDAException' in the IO Monad----cudaError :: String -> IO a-cudaError s = throwIO (UserError s)---- |--- A specially formatted error message----requireSDK :: Double -> String -> IO a-requireSDK v s = cudaError ("'" ++ s ++ "' requires at least cuda-" ++ show v)-------------------------------------------------------------------------------------- Helper Functions------------------------------------------------------------------------------------- |--- Return the descriptive string associated with a particular error code----{# fun pure unsafe cudaGetErrorStringWrapper as describe- { cFromEnum `Status' } -> `String' #}------ Logically, this must be a pure function, returning a pointer to a statically--- defined string constant.-------- |--- Return the results of a function on successful execution, otherwise return--- the error string associated with the return code----{-# INLINE resultIfOk #-}-resultIfOk :: (Status, a) -> IO a-resultIfOk (status, !result) =- case status of- Success -> return result- _ -> throwIO (ExitCode status)----- |--- Return the error string associated with an unsuccessful return code,--- otherwise Nothing----{-# INLINE nothingIfOk #-}-nothingIfOk :: Status -> IO ()-nothingIfOk status =- case status of- Success -> return ()- _ -> throwIO (ExitCode status)-
− Foreign/CUDA/Runtime/Event.chs
@@ -1,147 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE ForeignFunctionInterface #-}------------------------------------------------------------------------------------ |--- Module : Foreign.CUDA.Driver.Event--- Copyright : [2009..2014] Trevor L. McDonell--- License : BSD------ Event management for C-for-CUDA runtime environment--------------------------------------------------------------------------------------module Foreign.CUDA.Runtime.Event (-- -- * Event Management- Event, EventFlag(..), WaitFlag,- create, destroy, elapsedTime, query, record, wait, block--) where--#include "cbits/stubs.h"-{# context lib="cudart" #}---- Friends-import Foreign.CUDA.Types-import Foreign.CUDA.Runtime.Error-import Foreign.CUDA.Internal.C2HS---- System-import Foreign-import Foreign.C-import Control.Monad ( liftM )-import Control.Exception ( throwIO )-import Data.Maybe ( fromMaybe )-------------------------------------------------------------------------------------- Event management------------------------------------------------------------------------------------- |--- Create a new event----{-# INLINEABLE create #-}-create :: [EventFlag] -> IO Event-create !flags = resultIfOk =<< cudaEventCreateWithFlags flags--{-# INLINE cudaEventCreateWithFlags #-}-{# fun unsafe cudaEventCreateWithFlags- { alloca- `Event' peekEvt*- , combineBitMasks `[EventFlag]' } -> `Status' cToEnum #}- where peekEvt = liftM Event . peek----- |--- Destroy an event----{-# INLINEABLE destroy #-}-destroy :: Event -> IO ()-destroy !ev = nothingIfOk =<< cudaEventDestroy ev--{-# INLINE cudaEventDestroy #-}-{# fun unsafe cudaEventDestroy- { useEvent `Event' } -> `Status' cToEnum #}----- |--- Determine the elapsed time (in milliseconds) between two events----{-# INLINEABLE elapsedTime #-}-elapsedTime :: Event -> Event -> IO Float-elapsedTime !ev1 !ev2 = resultIfOk =<< cudaEventElapsedTime ev1 ev2--{-# INLINE cudaEventElapsedTime #-}-{# fun unsafe cudaEventElapsedTime- { alloca- `Float' peekFloatConv*- , useEvent `Event'- , useEvent `Event' } -> `Status' cToEnum #}----- |--- Determines if a event has actually been recorded----{-# INLINEABLE query #-}-query :: Event -> IO Bool-query !ev =- cudaEventQuery ev >>= \rv ->- case rv of- Success -> return True- NotReady -> return False- _ -> throwIO (ExitCode rv)--{-# INLINE cudaEventQuery #-}-{# fun unsafe cudaEventQuery- { useEvent `Event' } -> `Status' cToEnum #}----- |--- Record an event once all operations in the current context (or optionally--- specified stream) have completed. This operation is asynchronous.----{-# INLINEABLE record #-}-record :: Event -> Maybe Stream -> IO ()-record !ev !mst =- nothingIfOk =<< cudaEventRecord ev (maybe defaultStream id mst)--{-# INLINE cudaEventRecord #-}-{# fun unsafe cudaEventRecord- { useEvent `Event'- , useStream `Stream' } -> `Status' cToEnum #}----- |--- Makes all future work submitted to the (optional) stream wait until the given--- event reports completion before beginning execution. Synchronisation is--- performed on the device, including when the event and stream are from--- different device contexts. Requires cuda-3.2.----{-# INLINEABLE wait #-}-wait :: Event -> Maybe Stream -> [WaitFlag] -> IO ()-#if CUDART_VERSION < 3020-wait _ _ _ = requireSDK 3.2 "wait"-#else-wait !ev !mst !flags =- let st = fromMaybe defaultStream mst- in nothingIfOk =<< cudaStreamWaitEvent st ev flags--{-# INLINE cudaStreamWaitEvent #-}-{# fun unsafe cudaStreamWaitEvent- { useStream `Stream'- , useEvent `Event'- , combineBitMasks `[WaitFlag]' } -> `Status' cToEnum #}-#endif---- |--- Wait until the event has been recorded----{-# INLINEABLE block #-}-block :: Event -> IO ()-block !ev = nothingIfOk =<< cudaEventSynchronize ev--{-# INLINE cudaEventSynchronize #-}-{# fun cudaEventSynchronize- { useEvent `Event' } -> `Status' cToEnum #}-
− Foreign/CUDA/Runtime/Exec.chs
@@ -1,274 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE ForeignFunctionInterface #-}-{-# LANGUAGE GADTs #-}------------------------------------------------------------------------------------ |--- Module : Foreign.CUDA.Runtime.Exec--- Copyright : [2009..2014] Trevor L. McDonell--- License : BSD------ Kernel execution control for C-for-CUDA runtime interface--------------------------------------------------------------------------------------module Foreign.CUDA.Runtime.Exec (-- -- * Kernel Execution- Fun, FunAttributes(..), FunParam(..), CacheConfig(..),- attributes, setConfig, setParams, setCacheConfig, launch, launchKernel,--) where--#include "cbits/stubs.h"-{# context lib="cudart" #}---- Friends-import Foreign.CUDA.Runtime.Stream ( Stream(..), defaultStream )-import Foreign.CUDA.Runtime.Error-import Foreign.CUDA.Internal.C2HS---- System-import Foreign-import Foreign.C-import Control.Monad--#c-typedef struct cudaFuncAttributes cudaFuncAttributes;-#endc-------------------------------------------------------------------------------------- Data Types------------------------------------------------------------------------------------- |--- A @__global__@ device function.------ Note that the use of a string naming a function was deprecated in CUDA 4.1--- and removed in CUDA 5.0.----#if CUDART_VERSION >= 5000-type Fun = FunPtr ()-#else-type Fun = String-#endif-------- Function Attributes----{# pointer *cudaFuncAttributes as ^ foreign -> FunAttributes nocode #}--data FunAttributes = FunAttributes- {- constSizeBytes :: !Int64,- localSizeBytes :: !Int64,- sharedSizeBytes :: !Int64,- maxKernelThreadsPerBlock :: !Int, -- ^ maximum block size that can be successively launched (based on register usage)- numRegs :: !Int -- ^ number of registers required for each thread- }- deriving (Show)--instance Storable FunAttributes where- sizeOf _ = {# sizeof cudaFuncAttributes #}- alignment _ = alignment (undefined :: Ptr ())-- poke _ _ = error "Can not poke Foreign.CUDA.Runtime.FunAttributes"- peek p = do- cs <- cIntConv `fmap` {#get cudaFuncAttributes.constSizeBytes#} p- ls <- cIntConv `fmap` {#get cudaFuncAttributes.localSizeBytes#} p- ss <- cIntConv `fmap` {#get cudaFuncAttributes.sharedSizeBytes#} p- tb <- cIntConv `fmap` {#get cudaFuncAttributes.maxThreadsPerBlock#} p- nr <- cIntConv `fmap` {#get cudaFuncAttributes.numRegs#} p-- return FunAttributes- {- constSizeBytes = cs,- localSizeBytes = ls,- sharedSizeBytes = ss,- maxKernelThreadsPerBlock = tb,- numRegs = nr- }--#if CUDART_VERSION < 3000-data CacheConfig-#else--- |--- Cache configuration preference----{# enum cudaFuncCache as CacheConfig- { }- with prefix="cudaFuncCachePrefer" deriving (Eq, Show) #}-#endif---- |--- Kernel function parameters. Doubles will be converted to an internal float--- representation on devices that do not support doubles natively.----data FunParam where- IArg :: !Int -> FunParam- FArg :: !Float -> FunParam- DArg :: !Double -> FunParam- VArg :: Storable a => !a -> FunParam-------------------------------------------------------------------------------------- Execution Control------------------------------------------------------------------------------------- |--- Obtain the attributes of the named @__global__@ device function. This--- itemises the requirements to successfully launch the given kernel.----{-# INLINEABLE attributes #-}-attributes :: Fun -> IO FunAttributes-attributes !fn = resultIfOk =<< cudaFuncGetAttributes fn--{-# INLINE cudaFuncGetAttributes #-}-{# fun unsafe cudaFuncGetAttributes- { alloca- `FunAttributes' peek*- , withFun* `Fun' } -> `Status' cToEnum #}----- |--- Specify the grid and block dimensions for a device call. Used in conjunction--- with 'setParams', this pushes data onto the execution stack that will be--- popped when a function is 'launch'ed.----{-# INLINEABLE setConfig #-}-setConfig :: (Int,Int) -- ^ grid dimensions- -> (Int,Int,Int) -- ^ block dimensions- -> Int64 -- ^ shared memory per block (bytes)- -> Maybe Stream -- ^ associated processing stream- -> IO ()-setConfig (!gx,!gy) (!bx,!by,!bz) !sharedMem !mst =- nothingIfOk =<<- cudaConfigureCallSimple gx gy bx by bz sharedMem (maybe defaultStream id mst)-------- The FFI does not support passing deferenced structures to C functions, as--- this is highly platform/compiler dependent. Wrap our own function stub--- accepting plain integers.----{-# INLINE cudaConfigureCallSimple #-}-{# fun unsafe cudaConfigureCallSimple- { `Int', `Int'- , `Int', `Int', `Int'- , cIntConv `Int64'- , useStream `Stream' } -> `Status' cToEnum #}----- |--- Set the argument parameters that will be passed to the next kernel--- invocation. This is used in conjunction with 'setConfig' to control kernel--- execution.----{-# INLINEABLE setParams #-}-setParams :: [FunParam] -> IO ()-setParams = foldM_ k 0- where- k !offset !arg = do- let s = size arg- set arg s offset >>= nothingIfOk- return (offset + s)-- size (IArg _) = sizeOf (undefined :: Int)- size (FArg _) = sizeOf (undefined :: Float)- size (DArg _) = sizeOf (undefined :: Double)- size (VArg a) = sizeOf a-- set (IArg v) s o = cudaSetupArgument v s o- set (FArg v) s o = cudaSetupArgument v s o- set (VArg v) s o = cudaSetupArgument v s o- set (DArg v) s o =- cudaSetDoubleForDevice v >>= resultIfOk >>= \d ->- cudaSetupArgument d s o---{-# INLINE cudaSetupArgument #-}-{# fun unsafe cudaSetupArgument- `Storable a' =>- { with'* `a'- , `Int'- , `Int' } -> `Status' cToEnum #}- where- with' v a = with v $ \p -> a (castPtr p)--{-# INLINE cudaSetDoubleForDevice #-}-{# fun unsafe cudaSetDoubleForDevice- { with'* `Double' peek'* } -> `Status' cToEnum #}- where- with' v a = with v $ \p -> a (castPtr p)- peek' = peek . castPtr----- |--- On devices where the L1 cache and shared memory use the same hardware--- resources, this sets the preferred cache configuration for the given device--- function. This is only a preference; the driver is free to choose a different--- configuration as required to execute the function.------ Switching between configuration modes may insert a device-side--- synchronisation point for streamed kernel launches----{-# INLINEABLE setCacheConfig #-}-setCacheConfig :: Fun -> CacheConfig -> IO ()-#if CUDART_VERSION < 3000-setCacheConfig _ _ = requireSDK 3.0 "setCacheConfig"-#else-setCacheConfig !fn !pref = nothingIfOk =<< cudaFuncSetCacheConfig fn pref--{-# INLINE cudaFuncSetCacheConfig #-}-{# fun unsafe cudaFuncSetCacheConfig- { withFun* `Fun'- , cFromEnum `CacheConfig' } -> `Status' cToEnum #}-#endif----- |--- Invoke the @__global__@ kernel function on the device. This must be preceded--- by a call to 'setConfig' and (if appropriate) 'setParams'.----{-# INLINEABLE launch #-}-launch :: Fun -> IO ()-launch !fn = nothingIfOk =<< cudaLaunch fn--{-# INLINE cudaLaunch #-}-{# fun unsafe cudaLaunch- { withFun* `Fun' } -> `Status' cToEnum #}----- |--- Invoke a kernel on a @(gx * gy)@ grid of blocks, where each block contains--- @(tx * ty * tz)@ threads and has access to a given number of bytes of shared--- memory. The launch may also be associated with a specific 'Stream'.----{-# INLINEABLE launchKernel #-}-launchKernel- :: Fun -- ^ Device function symbol- -> (Int,Int) -- ^ grid dimensions- -> (Int,Int,Int) -- ^ thread block shape- -> Int64 -- ^ shared memory per block (bytes)- -> Maybe Stream -- ^ (optional) execution stream- -> [FunParam]- -> IO ()-launchKernel !fn !grid !block !sm !mst !args = do- setConfig grid block sm mst- setParams args- launch fn------------------------------------------------------------------------------------- Internals------------------------------------------------------------------------------------- CUDA 5.0 changed the type of a kernel function from char* to void*----withFun :: Fun -> (Ptr a -> IO b) -> IO b-#if CUDART_VERSION >= 5000-withFun fn action = action (castFunPtrToPtr fn)-#else-withFun = withCString-#endif-
− Foreign/CUDA/Runtime/Marshal.chs
@@ -1,647 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE ForeignFunctionInterface #-}------------------------------------------------------------------------------------ |--- Module : Foreign.CUDA.Runtime.Marshal--- Copyright : [2009..2014] Trevor L. McDonell--- License : BSD------ Memory management for CUDA devices--------------------------------------------------------------------------------------module Foreign.CUDA.Runtime.Marshal (-- -- * Host Allocation- AllocFlag(..),- mallocHostArray, freeHost,-- -- * Device Allocation- mallocArray, allocaArray, free,-- -- * Unified Memory Allocation- AttachFlag(..),- mallocManagedArray,-- -- * Marshalling- peekArray, peekArrayAsync, peekArray2D, peekArray2DAsync, peekListArray,- pokeArray, pokeArrayAsync, pokeArray2D, pokeArray2DAsync, pokeListArray,- copyArray, copyArrayAsync, copyArray2D, copyArray2DAsync,-- -- * Combined Allocation and Marshalling- newListArray, newListArrayLen,- withListArray, withListArrayLen,-- -- * Utility- memset--) where--#include "cbits/stubs.h"-{# context lib="cudart" #}---- Friends-import Foreign.CUDA.Ptr-import Foreign.CUDA.Runtime.Error-import Foreign.CUDA.Runtime.Stream-import Foreign.CUDA.Internal.C2HS---- System-import Data.Int-import Data.Maybe-import Control.Exception--import Foreign.C-import Foreign.Ptr-import Foreign.Storable-import qualified Foreign.Marshal as F--#c-typedef enum cudaMemHostAlloc_option_enum {-// CUDA_MEMHOSTALLOC_OPTION_DEFAULT = cudaHostAllocDefault,- CUDA_MEMHOSTALLOC_OPTION_DEVICE_MAPPED = cudaHostAllocMapped,- CUDA_MEMHOSTALLOC_OPTION_PORTABLE = cudaHostAllocPortable,- CUDA_MEMHOSTALLOC_OPTION_WRITE_COMBINED = cudaHostAllocWriteCombined-} cudaMemHostAlloc_option;-#endc--#if CUDART_VERSION >= 6000-#c-typedef enum cudaMemAttachFlags_option_enum {- CUDA_MEM_ATTACH_OPTION_GLOBAL = cudaMemAttachGlobal,- CUDA_MEM_ATTACH_OPTION_HOST = cudaMemAttachHost,- CUDA_MEM_ATTACH_OPTION_SINGLE = cudaMemAttachSingle-} cudaMemAttachFlags_option;-#endc-#endif-------------------------------------------------------------------------------------- Host Allocation------------------------------------------------------------------------------------- |--- Options for host allocation----{# enum cudaMemHostAlloc_option as AllocFlag- { underscoreToCase }- with prefix="CUDA_MEMHOSTALLOC_OPTION" deriving (Eq, Show) #}----- |--- Allocate a section of linear memory on the host which is page-locked and--- directly accessible from the device. The storage is sufficient to hold the--- given number of elements of a storable type. The runtime system automatically--- accelerates calls to functions such as 'peekArrayAsync' and 'pokeArrayAsync'--- that refer to page-locked memory.------ Note that since the amount of pageable memory is thusly reduced, overall--- system performance may suffer. This is best used sparingly to allocate--- staging areas for data exchange----{-# INLINEABLE mallocHostArray #-}-mallocHostArray :: Storable a => [AllocFlag] -> Int -> IO (HostPtr a)-mallocHostArray !flags = doMalloc undefined- where- doMalloc :: Storable a' => a' -> Int -> IO (HostPtr a')- doMalloc x !n = resultIfOk =<< cudaHostAlloc (fromIntegral n * fromIntegral (sizeOf x)) flags--{-# INLINE cudaHostAlloc #-}-{# fun unsafe cudaHostAlloc- { alloca'- `HostPtr a' hptr*- , cIntConv `Int64'- , combineBitMasks `[AllocFlag]' } -> `Status' cToEnum #}- where- alloca' !f = F.alloca $ \ !p -> poke p nullPtr >> f (castPtr p)- hptr !p = (HostPtr . castPtr) `fmap` peek p----- |--- Free page-locked host memory previously allocated with 'mallecHost'----{-# INLINEABLE freeHost #-}-freeHost :: HostPtr a -> IO ()-freeHost !p = nothingIfOk =<< cudaFreeHost p--{-# INLINE cudaFreeHost #-}-{# fun unsafe cudaFreeHost- { hptr `HostPtr a' } -> `Status' cToEnum #}- where hptr = castPtr . useHostPtr-------------------------------------------------------------------------------------- Device Allocation------------------------------------------------------------------------------------- |--- Allocate a section of linear memory on the device, and return a reference to--- it. The memory is sufficient to hold the given number of elements of storable--- type. It is suitable aligned, and not cleared.----{-# INLINEABLE mallocArray #-}-mallocArray :: Storable a => Int -> IO (DevicePtr a)-mallocArray = doMalloc undefined- where- doMalloc :: Storable a' => a' -> Int -> IO (DevicePtr a')- doMalloc x !n = resultIfOk =<< cudaMalloc (fromIntegral n * fromIntegral (sizeOf x))--{-# INLINE cudaMalloc #-}-{# fun unsafe cudaMalloc- { alloca'- `DevicePtr a' dptr*- , cIntConv `Int64' } -> `Status' cToEnum #}- where- -- C-> Haskell doesn't like qualified imports in marshaller specifications- alloca' !f = F.alloca $ \ !p -> poke p nullPtr >> f (castPtr p)- dptr !p = (castDevPtr . DevicePtr) `fmap` peek p----- |--- Execute a computation, passing a pointer to a temporarily allocated block of--- memory sufficient to hold the given number of elements of storable type. The--- memory is freed when the computation terminates (normally or via an--- exception), so the pointer must not be used after this.------ Note that kernel launches can be asynchronous, so you may need to add a--- synchronisation point at the end of the computation.----{-# INLINEABLE allocaArray #-}-allocaArray :: Storable a => Int -> (DevicePtr a -> IO b) -> IO b-allocaArray n = bracket (mallocArray n) free----- |--- Free previously allocated memory on the device----{-# INLINEABLE free #-}-free :: DevicePtr a -> IO ()-free !p = nothingIfOk =<< cudaFree p--{-# INLINE cudaFree #-}-{# fun unsafe cudaFree- { dptr `DevicePtr a' } -> `Status' cToEnum #}- where- dptr = useDevicePtr . castDevPtr-------------------------------------------------------------------------------------- Unified memory allocation------------------------------------------------------------------------------------- |--- Options for unified memory allocations----#if CUDART_VERSION >= 6000-{# enum cudaMemAttachFlags_option as AttachFlag- { underscoreToCase }- with prefix="CUDA_MEM_ATTACH_OPTION" deriving (Eq, Show) #}-#else-data AttachFlag-#endif---- |--- Allocates memory that will be automatically managed by the Unified Memory--- system----{-# INLINEABLE mallocManagedArray #-}-mallocManagedArray :: Storable a => [AttachFlag] -> Int -> IO (DevicePtr a)-#if CUDART_VERSION < 6000-mallocManagedArray _ _ = requireSDK 6.0 "mallocManagedArray"-#else-mallocManagedArray !flags = doMalloc undefined- where- doMalloc :: Storable a' => a' -> Int -> IO (DevicePtr a')- doMalloc x !n = resultIfOk =<< cudaMallocManaged (fromIntegral n * fromIntegral (sizeOf x)) flags--{-# INLINE cudaMallocManaged #-}-{# fun unsafe cudaMallocManaged- { alloca'- `DevicePtr a' dptr*- , cIntConv `Int64'- , combineBitMasks `[AttachFlag]' } -> `Status' cToEnum #}- where- alloca' !f = F.alloca $ \ !p -> poke p nullPtr >> f (castPtr p)- dptr !p = (castDevPtr . DevicePtr) `fmap` peek p-#endif-------------------------------------------------------------------------------------- Marshalling------------------------------------------------------------------------------------- |--- Copy a number of elements from the device to host memory. This is a--- synchronous operation.----{-# INLINEABLE peekArray #-}-peekArray :: Storable a => Int -> DevicePtr a -> Ptr a -> IO ()-peekArray !n !dptr !hptr = memcpy hptr (useDevicePtr dptr) n DeviceToHost----- |--- Copy memory from the device asynchronously, possibly associated with a--- particular stream. The destination memory must be page locked.----{-# INLINEABLE peekArrayAsync #-}-peekArrayAsync :: Storable a => Int -> DevicePtr a -> HostPtr a -> Maybe Stream -> IO ()-peekArrayAsync !n !dptr !hptr !mst =- memcpyAsync (useHostPtr hptr) (useDevicePtr dptr) n DeviceToHost mst----- |--- Copy a 2D memory area from the device to the host. This is a synchronous--- operation.----{-# INLINEABLE peekArray2D #-}-peekArray2D- :: Storable a- => Int -- ^ width to copy (elements)- -> Int -- ^ height to copy (elements)- -> DevicePtr a -- ^ source array- -> Int -- ^ source array width- -> Ptr a -- ^ destination array- -> Int -- ^ destination array width- -> IO ()-peekArray2D !w !h !dptr !dw !hptr !hw =- memcpy2D hptr hw (useDevicePtr dptr) dw w h DeviceToHost----- |--- Copy a 2D memory area from the device to the host asynchronously, possibly--- associated with a particular stream. The destination array must be page--- locked.----{-# INLINEABLE peekArray2DAsync #-}-peekArray2DAsync- :: Storable a- => Int -- ^ width to copy (elements)- -> Int -- ^ height to copy (elements)- -> DevicePtr a -- ^ source array- -> Int -- ^ source array width- -> HostPtr a -- ^ destination array- -> Int -- ^ destination array width- -> Maybe Stream- -> IO ()-peekArray2DAsync !w !h !dptr !dw !hptr !hw !mst =- memcpy2DAsync (useHostPtr hptr) hw (useDevicePtr dptr) dw w h DeviceToHost mst----- |--- Copy a number of elements from the device into a new Haskell list. Note that--- this requires two memory copies: firstly from the device into a heap--- allocated array, and from there marshalled into a list----{-# INLINEABLE peekListArray #-}-peekListArray :: Storable a => Int -> DevicePtr a -> IO [a]-peekListArray !n !dptr =- F.allocaArray n $ \p -> do- peekArray n dptr p- F.peekArray n p----- |--- Copy a number of elements onto the device. This is a synchronous operation.----{-# INLINEABLE pokeArray #-}-pokeArray :: Storable a => Int -> Ptr a -> DevicePtr a -> IO ()-pokeArray !n !hptr !dptr = memcpy (useDevicePtr dptr) hptr n HostToDevice----- |--- Copy memory onto the device asynchronously, possibly associated with a--- particular stream. The source memory must be page-locked.----{-# INLINEABLE pokeArrayAsync #-}-pokeArrayAsync :: Storable a => Int -> HostPtr a -> DevicePtr a -> Maybe Stream -> IO ()-pokeArrayAsync !n !hptr !dptr !mst =- memcpyAsync (useDevicePtr dptr) (useHostPtr hptr) n HostToDevice mst----- |--- Copy a 2D memory area onto the device. This is a synchronous operation.----{-# INLINEABLE pokeArray2D #-}-pokeArray2D- :: Storable a- => Int -- ^ width to copy (elements)- -> Int -- ^ height to copy (elements)- -> Ptr a -- ^ source array- -> Int -- ^ source array width- -> DevicePtr a -- ^ destination array- -> Int -- ^ destination array width- -> IO ()-pokeArray2D !w !h !hptr !dw !dptr !hw =- memcpy2D (useDevicePtr dptr) dw hptr hw w h HostToDevice----- |--- Copy a 2D memory area onto the device asynchronously, possibly associated--- with a particular stream. The source array must be page locked.----{-# INLINEABLE pokeArray2DAsync #-}-pokeArray2DAsync- :: Storable a- => Int -- ^ width to copy (elements)- -> Int -- ^ height to copy (elements)- -> HostPtr a -- ^ source array- -> Int -- ^ source array width- -> DevicePtr a -- ^ destination array- -> Int -- ^ destination array width- -> Maybe Stream- -> IO ()-pokeArray2DAsync !w !h !hptr !hw !dptr !dw !mst =- memcpy2DAsync (useDevicePtr dptr) dw (useHostPtr hptr) hw w h HostToDevice mst---- |--- Write a list of storable elements into a device array. The array must be--- sufficiently large to hold the entire list. This requires two marshalling--- operations----{-# INLINEABLE pokeListArray #-}-pokeListArray :: Storable a => [a] -> DevicePtr a -> IO ()-pokeListArray !xs !dptr = F.withArrayLen xs $ \len p -> pokeArray len p dptr----- |--- Copy the given number of elements from the first device array (source) to the--- second (destination). The copied areas may not overlap. This operation is--- asynchronous with respect to host, but will not overlap other device--- operations.----{-# INLINEABLE copyArray #-}-copyArray :: Storable a => Int -> DevicePtr a -> DevicePtr a -> IO ()-copyArray !n !src !dst = memcpy (useDevicePtr dst) (useDevicePtr src) n DeviceToDevice----- |--- Copy the given number of elements from the first device array (source) to the--- second (destination). The copied areas may not overlap. This operation is--- asynchronous with respect to the host, and may be associated with a--- particular stream.----{-# INLINEABLE copyArrayAsync #-}-copyArrayAsync :: Storable a => Int -> DevicePtr a -> DevicePtr a -> Maybe Stream -> IO ()-copyArrayAsync !n !src !dst !mst =- memcpyAsync (useDevicePtr dst) (useDevicePtr src) n DeviceToDevice mst----- |--- Copy a 2D memory area from the first device array (source) to the second--- (destination). The copied areas may not overlap. This operation is--- asynchronous with respect to the host, but will not overlap other device--- operations.----{-# INLINEABLE copyArray2D #-}-copyArray2D- :: Storable a- => Int -- ^ width to copy (elements)- -> Int -- ^ height to copy (elements)- -> DevicePtr a -- ^ source array- -> Int -- ^ source array width- -> DevicePtr a -- ^ destination array- -> Int -- ^ destination array width- -> IO ()-copyArray2D !w !h !src !sw !dst !dw =- memcpy2D (useDevicePtr dst) dw (useDevicePtr src) sw w h DeviceToDevice----- |--- Copy a 2D memory area from the first device array (source) to the second--- device array (destination). The copied areas may not overlay. This operation--- is asynchronous with respect to the host, and may be associated with a--- particular stream.----{-# INLINEABLE copyArray2DAsync #-}-copyArray2DAsync- :: Storable a- => Int -- ^ width to copy (elements)- -> Int -- ^ height to copy (elements)- -> DevicePtr a -- ^ source array- -> Int -- ^ source array width- -> DevicePtr a -- ^ destination array- -> Int -- ^ destination array width- -> Maybe Stream- -> IO ()-copyArray2DAsync !w !h !src !sw !dst !dw !mst =- memcpy2DAsync (useDevicePtr dst) dw (useDevicePtr src) sw w h DeviceToDevice mst-------- Memory copy kind----{# enum cudaMemcpyKind as CopyDirection {}- with prefix="cudaMemcpy" deriving (Eq, Show) #}---- |--- Copy data between host and device. This is a synchronous operation.----{-# INLINEABLE memcpy #-}-memcpy :: Storable a- => Ptr a -- ^ destination- -> Ptr a -- ^ source- -> Int -- ^ number of elements- -> CopyDirection- -> IO ()-memcpy !dst !src !n !dir = doMemcpy undefined dst- where- doMemcpy :: Storable a' => a' -> Ptr a' -> IO ()- doMemcpy x _ =- nothingIfOk =<< cudaMemcpy dst src (fromIntegral n * fromIntegral (sizeOf x)) dir--{-# INLINE cudaMemcpy #-}-{# fun cudaMemcpy- { castPtr `Ptr a'- , castPtr `Ptr a'- , cIntConv `Int64'- , cFromEnum `CopyDirection' } -> `Status' cToEnum #}----- |--- Copy data between the host and device asynchronously, possibly associated--- with a particular stream. The host-side memory must be page-locked (allocated--- with 'mallocHostArray').----{-# INLINEABLE memcpyAsync #-}-memcpyAsync :: Storable a- => Ptr a -- ^ destination- -> Ptr a -- ^ source- -> Int -- ^ number of elements- -> CopyDirection- -> Maybe Stream- -> IO ()-memcpyAsync !dst !src !n !kind !mst = doMemcpy undefined dst- where- doMemcpy :: Storable a' => a' -> Ptr a' -> IO ()- doMemcpy x _ =- let bytes = fromIntegral n * fromIntegral (sizeOf x) in- nothingIfOk =<< cudaMemcpyAsync dst src bytes kind (fromMaybe defaultStream mst)--{-# INLINE cudaMemcpyAsync #-}-{# fun cudaMemcpyAsync- { castPtr `Ptr a'- , castPtr `Ptr a'- , cIntConv `Int64'- , cFromEnum `CopyDirection'- , useStream `Stream' } -> `Status' cToEnum #}----- |--- Copy a 2D memory area between the host and device. This is a synchronous--- operation.----{-# INLINEABLE memcpy2D #-}-memcpy2D :: Storable a- => Ptr a -- ^ destination- -> Int -- ^ width of destination array- -> Ptr a -- ^ source- -> Int -- ^ width of source array- -> Int -- ^ width to copy- -> Int -- ^ height to copy- -> CopyDirection- -> IO ()-memcpy2D !dst !dw !src !sw !w !h !kind = doCopy undefined dst- where- doCopy :: Storable a' => a' -> Ptr a' -> IO ()- doCopy x _ =- let bytes = fromIntegral (sizeOf x)- dw' = fromIntegral dw * bytes- sw' = fromIntegral sw * bytes- w' = fromIntegral w * bytes- h' = fromIntegral h- in- nothingIfOk =<< cudaMemcpy2D dst dw' src sw' w' h' kind--{-# INLINE cudaMemcpy2D #-}-{# fun cudaMemcpy2D- { castPtr `Ptr a'- , `Int64'- , castPtr `Ptr a'- , `Int64'- , `Int64'- , `Int64'- , cFromEnum `CopyDirection'- }- -> `Status' cToEnum #}----- |--- Copy a 2D memory area between the host and device asynchronously, possibly--- associated with a particular stream. The host-side memory must be--- page-locked.----{-# INLINEABLE memcpy2DAsync #-}-memcpy2DAsync :: Storable a- => Ptr a -- ^ destination- -> Int -- ^ width of destination array- -> Ptr a -- ^ source- -> Int -- ^ width of source array- -> Int -- ^ width to copy- -> Int -- ^ height to copy- -> CopyDirection- -> Maybe Stream- -> IO ()-memcpy2DAsync !dst !dw !src !sw !w !h !kind !mst = doCopy undefined dst- where- doCopy :: Storable a' => a' -> Ptr a' -> IO ()- doCopy x _ =- let bytes = fromIntegral (sizeOf x)- dw' = fromIntegral dw * bytes- sw' = fromIntegral sw * bytes- w' = fromIntegral w * bytes- h' = fromIntegral h- st = fromMaybe defaultStream mst- in- nothingIfOk =<< cudaMemcpy2DAsync dst dw' src sw' w' h' kind st--{-# INLINE cudaMemcpy2DAsync #-}-{# fun cudaMemcpy2DAsync- { castPtr `Ptr a'- , `Int64'- , castPtr `Ptr a'- , `Int64'- , `Int64'- , `Int64'- , cFromEnum `CopyDirection'- , useStream `Stream'- }- -> `Status' cToEnum #}-------------------------------------------------------------------------------------- Combined Allocation and Marshalling------------------------------------------------------------------------------------- |--- Write a list of storable elements into a newly allocated device array,--- returning the device pointer together with the number of elements that were--- written. Note that this requires two copy operations: firstly from a Haskell--- list into a heap-allocated array, and from there into device memory. The--- array should be 'free'd when no longer required.----{-# INLINEABLE newListArrayLen #-}-newListArrayLen :: Storable a => [a] -> IO (DevicePtr a, Int)-newListArrayLen !xs =- F.withArrayLen xs $ \len p ->- bracketOnError (mallocArray len) free $ \d_xs -> do- pokeArray len p d_xs- return (d_xs, len)----- |--- Write a list of storable elements into a newly allocated device array. This--- is 'newListArrayLen' composed with 'fst'.----{-# INLINEABLE newListArray #-}-newListArray :: Storable a => [a] -> IO (DevicePtr a)-newListArray !xs = fst `fmap` newListArrayLen xs----- |--- Temporarily store a list of elements into a newly allocated device array. An--- IO action is applied to the array, the result of which is returned. Similar--- to 'newListArray', this requires two marshalling operations of the data.------ As with 'allocaArray', the memory is freed once the action completes, so you--- should not return the pointer from the action, and be sure that any--- asynchronous operations (such as kernel execution) have completed.----{-# INLINEABLE withListArray #-}-withListArray :: Storable a => [a] -> (DevicePtr a -> IO b) -> IO b-withListArray !xs = withListArrayLen xs . const----- |--- A variant of 'withListArray' which also supplies the number of elements in--- the array to the applied function----{-# INLINEABLE withListArrayLen #-}-withListArrayLen :: Storable a => [a] -> (Int -> DevicePtr a -> IO b) -> IO b-withListArrayLen !xs !f =- bracket (newListArrayLen xs) (free . fst) (uncurry . flip $ f)------ XXX: Will this attempt to double-free the device array on error (together--- with newListArrayLen)?----------------------------------------------------------------------------------------- Utility------------------------------------------------------------------------------------- |--- Initialise device memory to a given 8-bit value----{-# INLINEABLE memset #-}-memset :: DevicePtr a -- ^ The device memory- -> Int64 -- ^ Number of bytes- -> Int8 -- ^ Value to set for each byte- -> IO ()-memset !dptr !bytes !symbol = nothingIfOk =<< cudaMemset dptr symbol bytes--{-# INLINE cudaMemset #-}-{# fun unsafe cudaMemset- { dptr `DevicePtr a'- , cIntConv `Int8'- , cIntConv `Int64' } -> `Status' cToEnum #}- where- dptr = useDevicePtr . castDevPtr-
− Foreign/CUDA/Runtime/Stream.chs
@@ -1,115 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE ForeignFunctionInterface #-}------------------------------------------------------------------------------------ |--- Module : Foreign.CUDA.Runtime.Stream--- Copyright : [2009..2014] Trevor L. McDonell--- License : BSD------ Stream management routines--------------------------------------------------------------------------------------module Foreign.CUDA.Runtime.Stream (-- -- * Stream Management- Stream(..),- create, destroy, finished, block, defaultStream--) where--#include "cbits/stubs.h"-{# context lib="cudart" #}---- Friends-import Foreign.CUDA.Types-import Foreign.CUDA.Runtime.Error-import Foreign.CUDA.Internal.C2HS---- System-import Foreign-import Foreign.C-import Control.Monad ( liftM )-import Control.Exception ( throwIO )-------------------------------------------------------------------------------------- Functions------------------------------------------------------------------------------------- |--- Create a new asynchronous stream----{-# INLINEABLE create #-}-create :: IO Stream-create = resultIfOk =<< cudaStreamCreate--{-# INLINE cudaStreamCreate #-}-{# fun unsafe cudaStreamCreate- { alloca- `Stream' peekStream* } -> `Status' cToEnum #}----- |--- Destroy and clean up an asynchronous stream----{-# INLINEABLE destroy #-}-destroy :: Stream -> IO ()-destroy !s = nothingIfOk =<< cudaStreamDestroy s--{-# INLINE cudaStreamDestroy #-}-{# fun unsafe cudaStreamDestroy- { useStream `Stream' } -> `Status' cToEnum #}----- |--- Determine if all operations in a stream have completed----{-# INLINEABLE finished #-}-finished :: Stream -> IO Bool-finished !s =- cudaStreamQuery s >>= \rv -> do- case rv of- Success -> return True- NotReady -> return False- _ -> throwIO (ExitCode rv)--{-# INLINE cudaStreamQuery #-}-{# fun unsafe cudaStreamQuery- { useStream `Stream' } -> `Status' cToEnum #}----- |--- Block until all operations in a Stream have been completed----{-# INLINEABLE block #-}-block :: Stream -> IO ()-block !s = nothingIfOk =<< cudaStreamSynchronize s--{-# INLINE cudaStreamSynchronize #-}-{# fun cudaStreamSynchronize- { useStream `Stream' } -> `Status' cToEnum #}----- |--- The main execution stream (0)------ {-# INLINE defaultStream #-}--- defaultStream :: Stream--- #if CUDART_VERSION < 3010--- defaultStream = Stream 0--- #else--- defaultStream = Stream nullPtr--- #endif------------------------------------------------------------------------------------- Internal-----------------------------------------------------------------------------------{-# INLINE peekStream #-}-peekStream :: Ptr {#type cudaStream_t#} -> IO Stream-#if CUDART_VERSION < 3010-peekStream = liftM Stream . peekIntConv-#else-peekStream = liftM Stream . peek-#endif-
− Foreign/CUDA/Runtime/Texture.chs
@@ -1,203 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE ForeignFunctionInterface #-}------------------------------------------------------------------------------------ |--- Module : Foreign.CUDA.Runtime.Texture--- Copyright : [2009..2014] Trevor L. McDonell--- License : BSD------ Texture references--------------------------------------------------------------------------------------module Foreign.CUDA.Runtime.Texture (-- -- * Texture Reference Management- Texture(..), FormatKind(..), AddressMode(..), FilterMode(..), FormatDesc(..),- bind, bind2D--) where---- Friends-import Foreign.CUDA.Ptr-import Foreign.CUDA.Runtime.Error-import Foreign.CUDA.Internal.C2HS---- System-import Data.Int-import Foreign-import Foreign.C--#include "cbits/stubs.h"-{# context lib="cudart" #}--#c-typedef struct textureReference textureReference;-typedef struct cudaChannelFormatDesc cudaChannelFormatDesc;-#endc------------------------------------------------------------------------------------- Data Types------------------------------------------------------------------------------------- |A texture reference----{# pointer *textureReference as ^ -> Texture #}--data Texture = Texture- {- normalised :: !Bool, -- ^ access texture using normalised coordinates [0.0,1.0)- filtering :: !FilterMode,- addressing :: !(AddressMode, AddressMode, AddressMode),- format :: !FormatDesc- }- deriving (Eq, Show)---- |Texture channel format kind----{# enum cudaChannelFormatKind as FormatKind- { }- with prefix="cudaChannelFormatKind" deriving (Eq, Show) #}---- |Texture addressing mode----{# enum cudaTextureAddressMode as AddressMode- { }- with prefix="cudaAddressMode" deriving (Eq, Show) #}---- |Texture filtering mode----{# enum cudaTextureFilterMode as FilterMode- { }- with prefix="cudaFilterMode" deriving (Eq, Show) #}----- |A description of how memory read through the texture cache should be--- interpreted, including the kind of data and the number of bits of each--- component (x,y,z and w, respectively).----{# pointer *cudaChannelFormatDesc as ^ foreign -> FormatDesc nocode #}--data FormatDesc = FormatDesc- {- depth :: !(Int,Int,Int,Int),- kind :: !FormatKind- }- deriving (Eq, Show)--instance Storable FormatDesc where- sizeOf _ = {# sizeof cudaChannelFormatDesc #}- alignment _ = alignment (undefined :: Ptr ())-- peek p = do- dx <- cIntConv `fmap` {# get cudaChannelFormatDesc.x #} p- dy <- cIntConv `fmap` {# get cudaChannelFormatDesc.y #} p- dz <- cIntConv `fmap` {# get cudaChannelFormatDesc.z #} p- dw <- cIntConv `fmap` {# get cudaChannelFormatDesc.w #} p- df <- cToEnum `fmap` {# get cudaChannelFormatDesc.f #} p- return $ FormatDesc (dx,dy,dz,dw) df-- poke p (FormatDesc (x,y,z,w) k) = do- {# set cudaChannelFormatDesc.x #} p (cIntConv x)- {# set cudaChannelFormatDesc.y #} p (cIntConv y)- {# set cudaChannelFormatDesc.z #} p (cIntConv z)- {# set cudaChannelFormatDesc.w #} p (cIntConv w)- {# set cudaChannelFormatDesc.f #} p (cFromEnum k)---instance Storable Texture where- sizeOf _ = {# sizeof textureReference #}- alignment _ = alignment (undefined :: Ptr ())-- peek p = do- norm <- cToBool `fmap` {# get textureReference.normalized #} p- fmt <- cToEnum `fmap` {# get textureReference.filterMode #} p- dsc <- peek . castPtr =<< {# get textureReference.channelDesc #} p- [x,y,z] <- peekArrayWith cToEnum 3 =<< {# get textureReference.addressMode #} p- return $ Texture norm fmt (x,y,z) dsc-- poke p (Texture norm fmt (x,y,z) dsc) = do- {# set textureReference.normalized #} p (cFromBool norm)- {# set textureReference.filterMode #} p (cFromEnum fmt)- withArray (map cFromEnum [x,y,z]) ({# set textureReference.addressMode #} p)-- -- c2hs is returning the wrong type for structs-within-structs- dscptr <- {# get textureReference.channelDesc #} p- poke (castPtr dscptr) dsc-------------------------------------------------------------------------------------- Texture References------------------------------------------------------------------------------------- |Bind the memory area associated with the device pointer to a texture--- reference given by the named symbol. Any previously bound references are--- unbound.----{-# INLINEABLE bind #-}-bind :: String -> Texture -> DevicePtr a -> Int64 -> IO ()-bind !name !tex !dptr !bytes = do- ref <- getTex name- poke ref tex- nothingIfOk =<< cudaBindTexture ref dptr (format tex) bytes--{-# INLINE cudaBindTexture #-}-{# fun unsafe cudaBindTexture- { alloca- `Int'- , id `TextureReference'- , dptr `DevicePtr a'- , with_* `FormatDesc'- , `Int64' } -> `Status' cToEnum #}- where dptr = useDevicePtr . castDevPtr---- |Bind the two-dimensional memory area to the texture reference associated--- with the given symbol. The size of the area is constrained by (width,height)--- in texel units, and the row pitch in bytes. Any previously bound references--- are unbound.----{-# INLINEABLE bind2D #-}-bind2D :: String -> Texture -> DevicePtr a -> (Int,Int) -> Int64 -> IO ()-bind2D !name !tex !dptr (!width,!height) !bytes = do- ref <- getTex name- poke ref tex- nothingIfOk =<< cudaBindTexture2D ref dptr (format tex) width height bytes--{-# INLINE cudaBindTexture2D #-}-{# fun unsafe cudaBindTexture2D- { alloca- `Int'- , id `TextureReference'- , dptr `DevicePtr a'- , with_* `FormatDesc'- , `Int'- , `Int'- , `Int64' } -> `Status' cToEnum #}- where dptr = useDevicePtr . castDevPtr----- |Returns the texture reference associated with the given symbol----{-# INLINEABLE getTex #-}-getTex :: String -> IO TextureReference-getTex !name = resultIfOk =<< cudaGetTextureReference name--{-# INLINE cudaGetTextureReference #-}-{# fun unsafe cudaGetTextureReference- { alloca- `Ptr Texture' peek*- , withCString_* `String' } -> `Status' cToEnum #}-------------------------------------------------------------------------------------- Internal-----------------------------------------------------------------------------------{-# INLINE with_ #-}-with_ :: Storable a => a -> (Ptr a -> IO b) -> IO b-with_ = with----- CUDA 5.0 changed the types of some attributes from char* to void*----{-# INLINE withCString_ #-}-withCString_ :: String -> (Ptr a -> IO b) -> IO b-withCString_ !str !fn = withCString str (fn . castPtr)-
− Foreign/CUDA/Runtime/Utils.chs
@@ -1,49 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface #-}------------------------------------------------------------------------------------ |--- Module : Foreign.CUDA.Runtime.Utils--- Copyright : [2009..2014] Trevor L. McDonell--- License : BSD------ Utility functions--------------------------------------------------------------------------------------module Foreign.CUDA.Runtime.Utils (runtimeVersion, driverVersion)- where--#include "cbits/stubs.h"-{# context lib="cudart" #}---- Friends-import Foreign.CUDA.Runtime.Error-import Foreign.CUDA.Internal.C2HS---- System-import Foreign-import Foreign.C----- |--- Return the version number of the installed CUDA driver----{-# INLINEABLE runtimeVersion #-}-runtimeVersion :: IO Int-runtimeVersion = resultIfOk =<< cudaRuntimeGetVersion--{-# INLINE cudaRuntimeGetVersion #-}-{# fun unsafe cudaRuntimeGetVersion- { alloca- `Int' peekIntConv* } -> `Status' cToEnum #}----- |--- Return the version number of the installed CUDA runtime----{-# INLINEABLE driverVersion #-}-driverVersion :: IO Int-driverVersion = resultIfOk =<< cudaDriverGetVersion--{-# INLINE cudaDriverGetVersion #-}-{# fun unsafe cudaDriverGetVersion- { alloca- `Int' peekIntConv* } -> `Status' cToEnum #}-
− Foreign/CUDA/Types.chs
@@ -1,147 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE EmptyDataDecls #-}-#ifdef USE_EMPTY_CASE-{-# LANGUAGE EmptyCase #-}-#endif------------------------------------------------------------------------------------ |--- Module : Foreign.CUDA.Types--- Copyright : [2009..2014] Trevor L. McDonell--- License : BSD------ Data types that are equivalent and can be shared freely between the CUDA--- Runtime and Driver APIs.--------------------------------------------------------------------------------------module Foreign.CUDA.Types (-- -- * Pointers- DevicePtr(..), HostPtr(..),-- -- * Events- Event(..), EventFlag(..), WaitFlag,-- -- * Streams- Stream(..), StreamFlag,- defaultStream,--) where---- system-import Foreign.Ptr-import Foreign.Storable--#include "cbits/stubs.h"-{# context lib="cuda" #}-------------------------------------------------------------------------------------- Data pointers------------------------------------------------------------------------------------- |--- A reference to data stored on the device.----newtype DevicePtr a = DevicePtr { useDevicePtr :: Ptr a }- deriving (Eq,Ord)--instance Show (DevicePtr a) where- showsPrec n (DevicePtr p) = showsPrec n p--instance Storable (DevicePtr a) where- sizeOf _ = sizeOf (undefined :: Ptr a)- alignment _ = alignment (undefined :: Ptr a)- peek p = DevicePtr `fmap` peek (castPtr p)- poke p v = poke (castPtr p) (useDevicePtr v)----- |--- A reference to page-locked host memory.------ A 'HostPtr' is just a plain 'Ptr', but the memory has been allocated by CUDA--- into page locked memory. This means that the data can be copied to the GPU--- via DMA (direct memory access). Note that the use of the system function--- `mlock` is not sufficient here --- the CUDA version ensures that the--- /physical/ address stays this same, not just the virtual address.------ To copy data into a 'HostPtr' array, you may use for example 'withHostPtr'--- together with 'Foreign.Marshal.Array.copyArray' or--- 'Foreign.Marshal.Array.moveArray'.----newtype HostPtr a = HostPtr { useHostPtr :: Ptr a }- deriving (Eq,Ord)--instance Show (HostPtr a) where- showsPrec n (HostPtr p) = showsPrec n p--instance Storable (HostPtr a) where- sizeOf _ = sizeOf (undefined :: Ptr a)- alignment _ = alignment (undefined :: Ptr a)- peek p = HostPtr `fmap` peek (castPtr p)- poke p v = poke (castPtr p) (useHostPtr v)-------------------------------------------------------------------------------------- Events------------------------------------------------------------------------------------- |--- Events are markers that can be inserted into the CUDA execution stream and--- later queried.----newtype Event = Event { useEvent :: {# type CUevent #}}- deriving (Eq, Show)---- |--- Event creation flags----{# enum CUevent_flags as EventFlag- { underscoreToCase }- with prefix="CU_EVENT" deriving (Eq, Show) #}---- |--- Possible option flags for waiting for events----data WaitFlag-instance Enum WaitFlag where-#ifdef USE_EMPTY_CASE- toEnum x = case x of {}- fromEnum x = case x of {}-#endif-------------------------------------------------------------------------------------- Stream management------------------------------------------------------------------------------------- |--- A processing stream. All operations in a stream are synchronous and executed--- in sequence, but operations in different non-default streams may happen--- out-of-order or concurrently with one another.------ Use 'Event's to synchronise operations between streams.----newtype Stream = Stream { useStream :: {# type CUstream #}}- deriving (Eq, Show)---- |--- Possible option flags for stream initialisation. Dummy instance until the API--- exports actual option values.----data StreamFlag-instance Enum StreamFlag where-#ifdef USE_EMPTY_CASE- toEnum x = case x of {}- fromEnum x = case x of {}-#endif---- |--- The main execution stream. No operations overlap with operations in the--- default stream.----{-# INLINE defaultStream #-}-defaultStream :: Stream-defaultStream = Stream nullPtr-
+ README.md view
@@ -0,0 +1,175 @@+Haskell FFI Bindings to CUDA+============================++[](https://github.com/tmcdonell/cuda/actions/workflows/ci-linux.yml)+[](https://github.com/tmcdonell/cuda/actions/workflows/ci-windows.yml)+[](https://stackage.org/lts/package/cuda)+[](https://stackage.org/nightly/package/cuda)+[](https://hackage.haskell.org/package/cuda)++The CUDA library provides a direct, general purpose C-like SPMD programming+model for NVIDIA graphics cards (G8x series onwards). This is a collection of+bindings to allow you to call and control, although not write, such functions+from Haskell-land. You will need to install the CUDA driver and developer+toolkit.++ <http://developer.nvidia.com/object/cuda.html>++The configure step will look for your CUDA installation in the standard places,+and if the `nvcc` compiler is found in your `PATH`, relative to that.++For important information on installing on Windows, see:++ <https://github.com/tmcdonell/cuda/blob/master/WINDOWS.md>+++## Missing functionality++This library is currently in **maintenance mode**. While we are happy to+release updates to keep the existing interface working with newer CUDA versions+(as long as the underlying APIs remain available), no binding of new features+is planned at the moment. Get in touch if you want to contribute.++Here is an incomplete historical list of missing bindings. Pull requests welcome!++### CUDA-9++- cuLaunchCooperativeKernelMultiDevice++### CUDA-10.0++- cuDeviceGetLuid (windows only?)+- cuLaunchHostFunc+- cuGraphHostNode[Get/Set]Params+- cuGraphKernelNode[Get/Set]Params+- cuGraphMemcpyNode[Get/Set]Params+- cuGraphMemsetNode[Get/Set]Params++### CUDA-10.2++- cuDeviceGetNvSciSyncAttributes+- cuMemAddressFree+- cuMemAddressReserve+- cuMemCreate+- cuMemExportToShareableHandle+- cuMemGetAccess+- cuMemGetAllocationGranularity+- cuMemGetAllocationPrepertiesFromHandle+- cuMemImportFromShareableHandle+- cuMemMap+- cuMemRelease+- cuMemSetAccess+- cuMemUnmap+- cuGraphExecHostNodeSetParams+- cuGraphExecMemcpyNodeSetParams+- cuGraphExecMemsetNodeSetParams+- cuGraphExecUpdate++### CUDA-11.0++- cuCtxResetPersistentingL2Cache+- cuMemRetainAllocationHandle+- cuStreamCopyAttributes+- cuStreamGetAttribute+- cuStreamSetAttribute+- cuGraphKernelNodeCopyAttributes+- cuGraphKernelNodeGetAttribute+- cuGraphKernelNodeSetAttribute+- cuOccupancyAvailableDynamicSMemPerBlock++### CUDA-11.1++- cuDeviceGetTexture1DLinearMaxWidth+- cuArrayGetSparseProperties+- cuMipmappedArrayGetSparseProperties+- cuMemMapArrayAsync+- cuEventRecordWithFlags+- cuGraphAddEventRecordNode+- cuGraphAddEventWaitNode+- cuGraphEventRecordNodeGetEvent+- cuGraphEventRecordNodeSetEvent+- cuGraphEventWaitNodeGetEvent+- cuGraphEventWaitNodeSetEvent+- cuGraphExecChildGraphNodeSetParams+- cuGraphExecEventRecordNodeSetEvent+- cuGraphExecEventWaitNodeSetEvent+- cuGraphUpload++### CUDA-11.2++- cuDeviceGetDefaultMemPool+- cuDeviceGetMemPool+- cuDeviceSetMemPool+- cuArrayGetPlane+- cuMemAllocAsync+- cuMemAllocFromPoolAsync+- cuMemFreeAsync+- cuMemPoolCreate+- cuMemPoolDestroy+- cuMemPoolExportPointer+- cuMemPoolExportToShareableHandle+- cuMemPoolGetAccess+- cuMemPoolGetAttribute+- cuMemPoolImportFromShareableHandle+- cuMemPoolImportPointer+- cuMemPoolSetAccess+- cuMemPoolSetAttribute+- cuMemPoolTrimTo+- cuGraphAddExternalSemaphoresSignalNode+- cuGraphAddExternalSemaphoresWaitNode+- cuGraphExecExternalSemaphoresSignalNodeSetParams+- cuGraphExecExternalSemaphoresWaitNodeSetParams+- cuGraphExternalSemaphoresSignalNodeGetParams+- cuGraphExternalSemaphoresSignalNodeSetParams+- cuGraphExternalSemaphoresWaitNodeGetParams+- cuGraphExternalSemaphoresWaitNodeSetParams++### CUDA-11.3++- cuStreamGetCaptureInfo_v2+- cuFuncGetModule+- cuGraphDebugDotPrint+- cuGraphReleaseUserObject+- cuGraphRetainUserObject+- cuUserObjectCreate+- cuUserObjectRelease+- cuUserObjectRetain+- cuGetProcAddress++### CUDA-11.4++- cuDeviceGetUuid_v2+- cuCtxCreate_v3+- cuCtxGetExecAffinity+- cuDeviceGetGraphMemAttribute+- cuDeviceGraphMemTrim+- cuDeviceSetGraphMemAttribute+- cuGraphAddMemAllocNode+- cuGraphAddMemFreeNode+- cuGraphInstantiateWithFlags+- cuGraphMemAllocNodeGetParams+- cuGraphMemFreeNodeGetParams++### CUDA >= 12++A lot. PRs welcome.++- CUDA-12.3+ - Edge data in the driver Graph API (`cuGraphAddDependencies_v2` etc.)+++# Old compatibility notes++The setup script for this package requires at least Cabal-1.24. If you run into trouble with this:++* Cabal users: ensure you are using a new `cabal` executable and have run `cabal update` anywhere in the last few years. If you have previously run `cabal install` on libraries and have a broken environment as a result, remove `~/.ghc/<platfom>/environments/default`.+* Stack users: one may attempt @stack setup --upgrade-cabal@.++Due to an interaction between GHC-8 and unified virtual address spaces in+CUDA, this package does not currently work with GHCi on ghc-8.0.1 (compiled+programs should work). See the following for more details:++* <https://github.com/tmcdonell/cuda/issues/39>+* <https://ghc.haskell.org/trac/ghc/ticket/12573>++The bug should be fixed in ghc-8.0.2 and beyond.
Setup.hs view
@@ -1,51 +1,332 @@-import Distribution.PackageDescription-import Distribution.PackageDescription.Parse-import Distribution.Verbosity-import Distribution.System+-- Decouple from GHC's default language setting, so that it's easier+-- to maintain compatibility with old GHCs.+{-# LANGUAGE Haskell2010 #-}+{-# OPTIONS_GHC -Wall #-}++{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}++-- The MIN_VERSION_Cabal macro was introduced with Cabal-1.24 (??)+#ifndef MIN_VERSION_Cabal+#define MIN_VERSION_Cabal(major1,major2,minor) 0+#endif++import Distribution.PackageDescription hiding ( Flag ) import Distribution.Simple-import Distribution.Simple.Utils-import Distribution.Simple.Setup+import Distribution.Simple.BuildPaths import Distribution.Simple.Command-import Distribution.Simple.Program import Distribution.Simple.LocalBuildInfo-import Distribution.Simple.PreProcess hiding (ppC2hs)--import Distribution.Simple.BuildPaths+import Distribution.Simple.PreProcess hiding ( ppC2hs )+import Distribution.Simple.Program+import Distribution.Simple.Program.Db+import Distribution.Simple.Program.Find+import Distribution.Simple.Setup+import Distribution.Simple.Utils hiding ( isInfixOf )+import Distribution.System+import Distribution.Verbosity -import Data.List hiding (isInfixOf)-import Data.Maybe+#if MIN_VERSION_Cabal(1,25,0)+import Distribution.PackageDescription.PrettyPrint+import Distribution.Version+#endif+#if MIN_VERSION_Cabal(2,2,0)+import Distribution.PackageDescription.Parsec+#else+import Distribution.PackageDescription.Parse+#endif+#if MIN_VERSION_Cabal(3,8,0)+import Distribution.Simple.PackageDescription+#endif+#if MIN_VERSION_Cabal(3,14,0)+-- Note [Cabal 3.14]+--+-- If you change any path stuff, either test that the package still works with+-- Cabal 3.12 or stop declaring support for it in cuda.cabal. (If you do the+-- latter, also remove all of the other conditionals in this file.)+-- Note that supporting old versions of Cabal is useful for being able to run+-- e.g. Accelerate on old GPU clusters, which is nice.+import Distribution.Utils.Path (SymbolicPath, FileOrDir(File, Dir), Lib, Include, Pkg, CWD, makeSymbolicPath, interpretSymbolicPath, makeRelativePathEx)+import qualified Distribution.Types.LocalBuildConfig as LBC+#else+#endif -import Text.Printf import Control.Exception import Control.Monad-import System.Exit hiding (die)-import System.FilePath+import Data.Char (isDigit)+import Data.Function+import Data.List+import Data.Maybe+import Data.String (fromString) import System.Directory import System.Environment-import System.IO.Error hiding (catch)-import Prelude hiding (catch)+import System.FilePath+import System.IO.Error+import Text.Printf+import Prelude -newtype CudaPath = CudaPath {- cudaPath :: String-} deriving (Eq, Ord, Show, Read) +-- Configuration+-- ------------- +customBuildInfoFilePath :: FilePath+customBuildInfoFilePath = "cuda" <.> "buildinfo"++generatedBuildInfoFilePath :: FilePath+generatedBuildInfoFilePath = customBuildInfoFilePath <.> "generated"++defaultCUDAInstallPath :: Platform -> FilePath+defaultCUDAInstallPath _ = "/usr/local/cuda" -- windows?+++-- Build setup+-- -----------++main :: IO ()+main = defaultMainWithHooks customHooks+ where+ -- Be careful changing flags/paths stuff here; see Note [Cabal 3.14].+ readHook get_verbosity a flags = do+ getHookedBuildInfo (flagToMaybe (workingDirFlag flags)) (fromFlag (get_verbosity flags))++ preprocessors = hookedPreProcessors simpleUserHooks++ -- Our readHook implementation uses our getHookedBuildInfo. We can't rely on+ -- cabal's autoconfUserHooks since they don't handle user overwrites to+ -- buildinfo like we do.+ --+ customHooks =+ simpleUserHooks+ { preBuild = preBuildHook -- not using 'readHook' here because 'build' takes; extra args+ , preClean = readHook cleanVerbosity+ , preCopy = readHook copyVerbosity+ , preInst = readHook installVerbosity+ , preHscolour = readHook hscolourVerbosity+ , preHaddock = readHook haddockVerbosity+ , preReg = readHook regVerbosity+ , preUnreg = readHook regVerbosity+ , postConf = postConfHook+ , hookedPreProcessors = (fromString "chs", ppC2hs) : filter (\x -> fst x /= fromString "chs") preprocessors+ }++ -- The hook just loads the HookedBuildInfo generated by postConfHook,+ -- unless there is user-provided info that overwrites it.+ --+ preBuildHook :: Args -> BuildFlags -> IO HookedBuildInfo+ preBuildHook _ flags = getHookedBuildInfo cwd verbosity+ where cwd = flagToMaybe (workingDirFlag flags)+ verbosity = fromFlag (buildVerbosity flags)++ -- The hook scans system in search for CUDA Toolkit. If the toolkit is not+ -- found, an error is raised. Otherwise the toolkit location is used to+ -- create a `cuda.buildinfo.generated` file with all the resulting flags.+ --+ postConfHook :: Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO ()+ postConfHook args flags pkg_descr lbi = do+ let+ cwd = flagToMaybe (workingDirFlag flags)+ verbosity = fromFlagOrDefault normal (configVerbosity flags)+ profile = fromFlagOrDefault False (configProfLib flags)+ currentPlatform = hostPlatform lbi+ compilerId_ = compilerId (compiler lbi)+ --+ generateAndStoreBuildInfo+ cwd+ verbosity+ profile+ currentPlatform+ compilerId_+ (configExtraLibDirs flags)+ (configExtraIncludeDirs flags)+ generatedBuildInfoFilePath+ validateLinker verbosity currentPlatform $ withPrograms lbi+ --+ actualBuildInfoToUse <- getHookedBuildInfo cwd verbosity+ let pkg_descr' = updatePackageDescription actualBuildInfoToUse pkg_descr+ postConf simpleUserHooks args flags pkg_descr' lbi++escBackslash :: FilePath -> FilePath+escBackslash [] = []+escBackslash ('\\':fs) = '\\' : '\\' : escBackslash fs+escBackslash (f:fs) = f : escBackslash fs++-- Generates build info with flags needed for CUDA Toolkit to be properly+-- visible to underlying build tools.+--+libraryBuildInfo+ :: Maybe CWDPath+ -> Verbosity+ -> Bool+ -> FilePath+ -> Platform+ -> Version+ -> [ExtraLibsPath]+ -> [ExtraIncludesPath]+ -> IO HookedBuildInfo+libraryBuildInfo cwd verbosity profile installPath platform@(Platform arch os) ghcVersion extraLibs extraIncludes = do+ let+ -- Be careful changing flags/paths stuff here; see Note [Cabal 3.14].+ libraryPaths = map makeSymbolicPath (cudaLibraryPaths platform installPath) ++ extraLibs+ includePaths = makeSymbolicPath (cudaIncludePath platform installPath) : extraIncludes++ takeFirstExisting paths = do+ existing <- filterM (doesDirectoryExist . interpretSymbolicPath cwd) libraryPaths+ case existing of+ (p0:_) -> return p0+ _ -> die' verbosity $ "Could not find path: " ++ show paths++ -- This can only be defined once, so take the first path which exists+ canonicalLibraryPath <- interpretSymbolicPath cwd <$> takeFirstExisting libraryPaths++ let+ -- OS-specific escaping for -D path defines+ escDefPath | os == Windows = escBackslash+ | otherwise = id+++ -- options for GHC+ extraLibDirs' = libraryPaths+ ccOptions' = [ "-DCUDA_INSTALL_PATH=\"" ++ escDefPath installPath ++ "\""+ , "-DCUDA_LIBRARY_PATH=\"" ++ escDefPath canonicalLibraryPath ++ "\""+ ] ++ map (("-I" ++) . interpretSymbolicPath cwd) includePaths+ ldOptions' = map (("-L" ++) . interpretSymbolicPath cwd) libraryPaths+ ghcOptions = map ("-optc"++) ccOptions'+ ++ map ("-optl"++) ldOptions'+ ++ if os /= Windows && not profile+ then map (("-optl-Wl,-rpath," ++) . interpretSymbolicPath cwd) extraLibDirs'+ else []+ extraLibs' = cudaLibraries platform+ frameworks' = [ makeRelativePathEx "CUDA" | os == OSX ]+ frameworkDirs' = [ makeSymbolicPath "/Library/Frameworks" | os == OSX ]++ -- options or c2hs+ archFlag = case arch of+ I386 -> "-m32"+ X86_64 -> "-m64"+ _ -> ""+ emptyCase = ["-DUSE_EMPTY_CASE" | versionBranch ghcVersion >= [7,8]]+ blocksExtension = [ "-U__BLOCKS__" | os == OSX ]+ c2hsOptions = unwords $ map ("--cppopts="++) ("-E" : archFlag : emptyCase ++ blocksExtension)+ c2hsExtraOptions = ("x-extra-c2hs-options", c2hsOptions)++ addSystemSpecificOptions :: BuildInfo -> IO BuildInfo+ addSystemSpecificOptions bi =+ case os of+ _ -> return bi++ extraGHCiLibs' <- cudaGHCiLibraries platform installPath extraLibs'+ buildInfo' <- addSystemSpecificOptions $ emptyBuildInfo+ { ccOptions = ccOptions'+ , ldOptions = ldOptions'+ , extraLibs = extraLibs'+ , extraGHCiLibs = extraGHCiLibs'+ , extraLibDirs = extraLibDirs'+ , frameworks = frameworks'+ , extraFrameworkDirs = frameworkDirs'+#if MIN_VERSION_Cabal(3,0,0)+ , options = PerCompilerFlavor (if os /= Windows then ghcOptions else []) []+#else+ , options = [(GHC, ghcOptions) | os /= Windows]+#endif+ , customFieldsBI = [c2hsExtraOptions]+ }++ return (Just buildInfo', [])+++-- Return the location of the include directory relative to the base CUDA+-- installation.+--+cudaIncludePath :: Platform -> FilePath -> FilePath+cudaIncludePath _ installPath = installPath </> "include"+++-- Return the potential locations of the libraries relative to the base CUDA installation.+--+cudaLibraryPaths :: Platform -> FilePath -> [FilePath]+cudaLibraryPaths (Platform arch os) installPath = [ installPath </> path | path <- libpaths ]+ where+ libpaths =+ case (os, arch) of+ (Windows, I386) -> ["lib/Win32"]+ (Windows, X86_64) -> ["lib/x64"]+ (OSX, _) -> ["lib"] -- MacOS does not distinguish 32- vs. 64-bit paths+ (_, X86_64) -> ["lib64", "lib"] -- prefer lib64 for 64-bit systems+#if MIN_VERSION_Cabal(2,4,0)+ (_, AArch64) -> ["lib64", "lib"]+#endif+ _ -> ["lib"] -- otherwise+++-- On Windows and OSX we use different libraries depending on whether we are+-- linking statically (executables) or dynamically (ghci).+--+cudaLibraries :: Platform -> [String]+cudaLibraries (Platform _ os) =+ case os of+ OSX -> ["cudadevrt", "cudart_static"]+ _ -> ["cuda"]++cudaGHCiLibraries+ :: Platform+ -> FilePath+ -> [String]+ -> IO [String]+cudaGHCiLibraries platform@(Platform _ os) installPath libraries =+ case os of+ Windows -> cudaGhciLibrariesWindows platform installPath libraries+ OSX -> return ["cuda"]+ _ -> return []+ -- Windows compatibility function. ----- CUDA toolkit uses different names for import libraries and their respective DLLs.--- Eg. `cudart.lib` imports functions from `cudart32_70` (on 32-bit architecture and 7.0 version of toolkit).--- The ghci linker fails to resolve this. Therefore, it needs to be given the DLL filenames--- as `extra-ghci-libraries` option.+-- The function is used to populate the extraGHCiLibs list on Windows+-- platform. It takes libraries directory and .lib filenames and returns+-- their corresponding dll filename. (Both filenames are stripped from+-- extensions) ----- This function takes *a path to* import library and returns name of corresponding DLL.+-- Eg: "C:\cuda\toolkit\lib\x64" -> ["cudart", "cuda"] -> ["cudart64_65", "ncuda"]+--+cudaGhciLibrariesWindows+ :: Platform+ -> FilePath+ -> [FilePath]+ -> IO [FilePath]+cudaGhciLibrariesWindows platform installPath libraries = do+ candidates <- mapM (importLibraryToDLLFileName platform)+ [ libPath </> lib <.> "lib" | libPath <- cudaLibraryPaths platform installPath+ , lib <- libraries ]+ return [ dropExtension dll | Just dll <- candidates ]+++-- Windows compatibility function.+--+-- CUDA toolkit uses different names for import libraries and their+-- respective DLLs. For example, on 32-bit architecture and version 7.0 of+-- toolkit, `cudart.lib` imports functions from `cudart32_70`.+--+-- The ghci linker fails to resolve this. Therefore, it needs to be given+-- the DLL filenames as `extra-ghci-libraries` option.+--+-- This function takes *a path to* import library and returns name of+-- corresponding DLL.+-- -- Eg: "C:/CUDA/Toolkit/Win32/cudart.lib" -> "cudart32_70.dll"--- Internally it assumes that nm tool is present in PATH. This should be always true, as nm is distributed along with GHC. ----- The function is meant to be used on Windows. Other platforms may or may not work.+-- Internally it assumes that 'nm' tool is present in PATH. This should be+-- always true, as 'nm' is distributed along with GHC. ---importLibraryToDllFileName :: FilePath -> IO (Maybe FilePath)-importLibraryToDllFileName importLibPath = do+-- The function is meant to be used on Windows. Other platforms may or may+-- not work.+--+importLibraryToDLLFileName :: Platform -> FilePath -> IO (Maybe FilePath)+importLibraryToDLLFileName platform importLibPath = do -- Sample output nm generates on cudart.lib+ -- -- nvcuda.dll: -- 00000000 i .idata$2 -- 00000000 i .idata$4@@ -55,205 +336,183 @@ -- 00000000 I __IMPORT_DESCRIPTOR_nvcuda -- U __NULL_IMPORT_DESCRIPTOR -- U nvcuda_NULL_THUNK_DATA+ -- nmOutput <- getProgramInvocationOutput normal (simpleProgramInvocation "nm" [importLibPath])- return $ find (isInfixOf ("" <.> dllExtension)) (lines nmOutput)+#if MIN_VERSION_Cabal(2,3,0)+ return $ find (isInfixOf ("" <.> dllExtension platform)) (lines nmOutput)+#else+ return $ find (isInfixOf ("" <.> dllExtension)) (lines nmOutput)+#endif --- Windows compatibility function.------ The function is used to populate the extraGHCiLibs list on Windows platform.--- It takes libraries directory and .lib filenames and returns their corresponding dll filename.--- (Both filenames are stripped from extensions)------ Eg: "C:\cuda\toolkit\lib\x64" -> ["cudart", "cuda"] -> ["cudart64_65", "ncuda"]----additionalGhciLibraries :: FilePath -> [FilePath] -> IO [FilePath]-additionalGhciLibraries libdir importLibs = do- let libsAbsolutePaths = map (\libname -> libdir </> libname <.> "lib") importLibs- candidateNames <- mapM importLibraryToDllFileName libsAbsolutePaths- let dllNames = map (\(Just dllname) -> dropExtension dllname) (filter isJust candidateNames)- return dllNames --- OSX compatibility function+-- Slightly modified version of `words` from base - it takes predicate saying on+-- which characters split. ----- Returns [] or ["U__BLOCKS__"]+splitOn :: (Char -> Bool) -> String -> [String]+splitOn p s =+ case dropWhile p s of+ [] -> []+ s' -> let (w, s'') = break p s'+ in w : splitOn p s''++-- Tries to obtain the version `ld`. Throws an exception if failed. ---getAppleBlocksOption :: IO [String]-getAppleBlocksOption = do- let handler = (\_ -> return "") :: IOError -> IO String- fileContents <- catch (readFile "/usr/include/stdlib.h") handler -- If file does not exist, we'll end up wth an empty string.- return ["-U__BLOCKS__" | "__BLOCKS__" `isInfixOf` fileContents]+getLdVersion :: Verbosity -> FilePath -> IO (Maybe [Int])+getLdVersion verbosity ldPath = do+ -- Version string format is like `GNU ld (GNU Binutils) 2.25.1`+ -- or `GNU ld (GNU Binutils) 2.20.51.20100613`+ ldVersionString <- getProgramInvocationOutput normal (simpleProgramInvocation ldPath ["-v"]) -getCudaIncludePath :: CudaPath -> FilePath-getCudaIncludePath (CudaPath path) = path </> "include"+ let versionText = last $ words ldVersionString -- takes e. g. "2.25.1"+ versionParts = splitOn (== '.') versionText+ versionParsed = Just $ map read versionParts -getCudaLibraryPath :: CudaPath -> Platform -> FilePath-getCudaLibraryPath (CudaPath path) (Platform arch os) = path </> libSubpath- where- libSubpath = case os of- Windows -> "lib" </> case arch of- I386 -> "Win32"- X86_64 -> "x64"- _ -> error $ "Unexpected Windows architecture " ++ show arch ++ ". Please report this issue to https://github.com/tmcdonell/cuda/issues"+ -- last and read above may throw and message would be not understandable+ -- for user, so we'll intercept exception and rethrow it with more useful+ -- message.+ handleError :: SomeException -> IO (Maybe [Int])+ handleError e = do+ warn verbosity $ printf "cannot parse ld version string: `%s`. Parsing exception: `%s`" ldVersionString (show e)+ return Nothing - OSX -> "lib"+ evaluate versionParsed `catch` handleError - -- For now just treat all non-Windows systems similarly- _ -> case arch of- I386 -> "lib"- X86_64 -> "lib64"- _ -> "lib" -- TODO how should this be handled? -getCudaLibraries :: [String]-getCudaLibraries = ["cudart", "cuda"]+-- On Windows GHC package comes with two copies of ld.exe.+--+-- 1. ProgramDb knows about the first one: ghcpath\mingw\bin\ld.exe+-- 2. This function returns the other one: ghcpath\mingw\x86_64-w64-mingw32\bin\ld.exe+--+-- The second one is the one that does actual linking and code generation.+-- See: https://github.com/tmcdonell/cuda/issues/31#issuecomment-149181376+--+-- The function is meant to be used only on 64-bit GHC distributions.+--+getRealLdPath :: Verbosity -> ProgramDb -> IO (Maybe FilePath)+getRealLdPath verbosity programDb =+ -- TODO: This should ideally work `programFindVersion ldProgram` but for some+ -- reason it does not. The issue should be investigated at some time.+ --+ case lookupProgram ghcProgram programDb of+ Nothing -> return Nothing+ Just configuredGhc -> do+ let ghcPath = locationPath $ programLocation configuredGhc+ presumedLdPath = (takeDirectory . takeDirectory) ghcPath </> "mingw" </> "x86_64-w64-mingw32" </> "bin" </> "ld.exe"+ info verbosity $ "Presuming ld location" ++ presumedLdPath+ presumedLdExists <- doesFileExist presumedLdPath+ return $ if presumedLdExists+ then Just presumedLdPath+ else Nothing --- Generates build info with flags needed for CUDA Toolkit to be properly--- visible to underlying build tools.+-- On Windows platform the binutils linker targeting x64 is bugged and cannot+-- properly link with import libraries generated by MS compiler (like the CUDA ones).+-- The programs would correctly compile and crash as soon as the first FFI call is made. ---cudaLibraryBuildInfo :: CudaPath -> Platform -> Version -> IO HookedBuildInfo-cudaLibraryBuildInfo cudaPath platform@(Platform arch os) ghcVersion = do- let cudaLibraryPath = getCudaLibraryPath cudaPath platform- -- Extra lib dirs are not needed on Windows somehow. On Linux their lack would cause an error: /usr/bin/ld: cannot find -lcudart- -- Still, they do not cause harm so let's have them regardless of OS.- let extraLibDirs_ = [cudaLibraryPath]- let includeDirs = [getCudaIncludePath cudaPath]- let ccOptions_ = map ("-I" ++) includeDirs- let ldOptions_ = map ("-L" ++) extraLibDirs_- let ghcOptions = map ("-optc" ++) ccOptions_ ++ map ("-optl" ++ ) ldOptions_- let extraLibs_ = getCudaLibraries+-- Therefore we fail configure process if the linker is too old and provide user+-- with guidelines on how to fix the problem.+--+validateLinker :: Verbosity -> Platform -> ProgramDb -> IO ()+validateLinker verbosity (Platform arch os) db =+ when (arch == X86_64 && os == Windows) $ do+ maybeLdPath <- getRealLdPath verbosity db+ case maybeLdPath of+ Nothing -> warn verbosity $ "Cannot find ld.exe to check if it is new enough. If generated executables crash when making calls to CUDA, please see " ++ windowsHelpPage+ Just ldPath -> do+ debug verbosity $ "Checking if ld.exe at " ++ ldPath ++ " is new enough"+ maybeVersion <- getLdVersion verbosity ldPath+ case maybeVersion of+ Nothing -> warn verbosity $ "Unknown ld.exe version. If generated executables crash when making calls to CUDA, please see " ++ windowsHelpPage+ Just ldVersion -> do+ debug verbosity $ "Found ld.exe version: " ++ show ldVersion+ when (ldVersion < [2,25,1]) $ die' verbosity $ windowsLinkerBugMsg ldPath - -- Options for C2HS- let c2hsArchitectureFlag = case arch of I386 -> ["-m32"]- X86_64 -> ["-m64"]- _ -> []- let c2hsEmptyCaseFlag = ["-DUSE_EMPTY_CASE" | versionBranch ghcVersion >= [7,8]]- let c2hsCppOptions = c2hsArchitectureFlag ++ c2hsEmptyCaseFlag ++ ["-E"] - -- On OSX we might add one more options to c2hs cpp.- appleBlocksOption <- case os of OSX -> getAppleBlocksOption; _ -> return []+windowsHelpPage :: String+windowsHelpPage = "https://github.com/tmcdonell/cuda/blob/master/cuda/WINDOWS.md" - let c2hsOptions = unwords $ map ("--cppopts=" ++) (c2hsCppOptions ++ appleBlocksOption)- let extraOptionsC2Hs = ("x-extra-c2hs-options", c2hsOptions)- let buildInfo = emptyBuildInfo- { ccOptions = ccOptions_- , ldOptions = ldOptions_- , extraLibs = extraLibs_- , extraLibDirs = extraLibDirs_- , options = [(GHC, ghcOptions)] -- Is this needed for anything?- , customFieldsBI = [extraOptionsC2Hs]- }+windowsLinkerBugMsg :: FilePath -> String+windowsLinkerBugMsg ldPath = printf (unlines msg) windowsHelpPage ldPath+ where+ msg =+ [ "********************************************************************************"+ , ""+ , "The installed version of `ld.exe` has version < 2.25.1. This version has known bug on Windows x64 architecture, making it unable to correctly link programs using CUDA. The fix is available and MSys2 released fixed version of `ld.exe` as part of their binutils package (version 2.25.1)."+ , ""+ , "To fix this issue, replace the `ld.exe` in your GHC installation with the correct binary. See the following page for details:"+ , ""+ , " %s"+ , ""+ , "The full path to the outdated `ld.exe` detected in your installation:"+ , ""+ , "> %s"+ , ""+ , "Please download a recent version of binutils `ld.exe`, from, e.g.:"+ , ""+ , " http://repo.msys2.org/mingw/x86_64/mingw-w64-x86_64-binutils-2.25.1-1-any.pkg.tar.xz"+ , ""+ , "********************************************************************************"+ ] - let addSystemSpecificOptions :: Platform -> IO BuildInfo- addSystemSpecificOptions (Platform _ Windows) = do- -- Workaround issue with ghci linker not being able to find DLLs with names different from their import LIBs.- extraGHCiLibs_ <- additionalGhciLibraries cudaLibraryPath extraLibs_- return buildInfo { extraGHCiLibs = extraGHCiLibs buildInfo ++ extraGHCiLibs_ }- addSystemSpecificOptions (Platform _ OSX) = return buildInfo- { customFieldsBI = customFieldsBI buildInfo ++ [("frameworks", "CUDA")]- , ldOptions = ldOptions buildInfo ++ ["-F/Library/Frameworks"]- }- addSystemSpecificOptions _ = return buildInfo - adjustedBuildInfo <-addSystemSpecificOptions platform- return (Just adjustedBuildInfo, [])---- Checks whether given location looks like a valid CUDA toolkit directory+-- Runs CUDA detection procedure and stores .buildinfo to a file. ---validateLocation :: Verbosity -> FilePath -> IO Bool-validateLocation verbosity path = do- -- TODO: Ideally this should check also for cudart.lib and whether cudart exports relevant symbols.- -- This should be achievable with some `nm` trickery- let testedPath = path </> "include" </> "cuda.h"- exists <- doesFileExist testedPath- info verbosity $- if exists- then printf "Path accepted: %s\n" path- else printf "Path rejected: %s\nDoes not exist: %s\n" path testedPath- return exists+generateAndStoreBuildInfo+ :: Maybe CWDPath+ -> Verbosity+ -> Bool+ -> Platform+ -> CompilerId+ -> [ExtraLibsPath]+ -> [ExtraIncludesPath]+ -> FilePath+ -> IO ()+generateAndStoreBuildInfo cwd verbosity profile platform (CompilerId _ghcFlavor ghcVersion) extraLibs extraIncludes path = do+ installPath <- findCUDAInstallPath verbosity platform+ hbi <- libraryBuildInfo cwd verbosity profile installPath platform ghcVersion extraLibs extraIncludes+ storeHookedBuildInfo verbosity path hbi --- Evaluates IO to obtain the path, handling any possible exceptions.--- If path is evaluable and points to valid CUDA toolkit returns True.----validateIOLocation :: Verbosity -> IO FilePath -> IO Bool-validateIOLocation verbosity iopath =- let handler :: IOError -> IO Bool- handler err = do- info verbosity (show err)- return False- in- catch (iopath >>= validateLocation verbosity) handler+storeHookedBuildInfo+ :: Verbosity+ -> FilePath+ -> HookedBuildInfo+ -> IO ()+storeHookedBuildInfo verbosity path hbi = do+ notice verbosity $ "Storing parameters to " ++ path+ writeHookedBuildInfo path hbi --- Function iterates over action yielding possible locations, evaluating them--- and returning the first valid one. Retuns Nothing if no location matches.----findFirstValidLocation :: Verbosity -> [(IO FilePath, String)] -> IO (Maybe FilePath)-findFirstValidLocation _ [] = return Nothing-findFirstValidLocation verbosity ((locate,description):rest) = do- info verbosity $ printf "checking for %s\n" description- found <- validateIOLocation verbosity locate- if found- then Just `fmap` locate- else findFirstValidLocation verbosity rest -nvccProgramName :: String-nvccProgramName = "nvcc"---- NOTE: this function throws an exception when there is no `nvcc` in PATH.--- The exception contains meaningful message.----findProgramLocationThrowing :: String -> IO FilePath-findProgramLocationThrowing execName = do- location <- findProgramLocation normal execName- case location of- Just validLocation -> return validLocation- Nothing -> ioError $ mkIOError doesNotExistErrorType ("not found: " ++ execName) Nothing Nothing---- Returns pairs (action yielding candidate path, String description of that location)+-- Try to locate CUDA installation by checking (in order): ---candidateCudaLocation :: [(IO FilePath, String)]-candidateCudaLocation =- [ env "CUDA_PATH"- , (nvccLocation, "nvcc compiler in PATH")- , defaultPath "/usr/local/cuda"- ]- where- env s = (getEnv s, printf "environment variable %s" s)- defaultPath p = (return p, printf "default location %s" p)- --- nvccLocation :: IO FilePath- nvccLocation = do- nvccPath <- findProgramLocationThrowing nvccProgramName- -- The obtained path is likely TOOLKIT/bin/nvcc- -- We want to extract the TOOLKIT part- let ret = takeDirectory $ takeDirectory nvccPath- return ret----- Try to locate CUDA installation on the drive.--- Currently this means (in order)--- 1) Checking the CUDA_PATH environment variable--- 2) Looking for `nvcc` in `PATH`--- 3) Checking /usr/local/cuda+-- 1. CUDA_PATH environment variable+-- 2. Looking for `nvcc` in `PATH`+-- 3. Checking /usr/local/cuda+-- 4. CUDA_PATH_Vx_y environment variable, for recent CUDA toolkit versions x.y -- -- In case of failure, calls die with the pretty long message from below.-findCudaLocation :: Verbosity -> IO CudaPath-findCudaLocation verbosity = do- firstValidLocation <- findFirstValidLocation verbosity candidateCudaLocation- case firstValidLocation of- Just validLocation -> do- notice verbosity $ "Found CUDA toolkit at: " ++ validLocation- return $ CudaPath validLocation- Nothing -> die longError+--+findCUDAInstallPath+ :: Verbosity+ -> Platform+ -> IO FilePath+findCUDAInstallPath verbosity platform = do+ result <- findFirstValidLocation verbosity platform =<< candidateCUDAInstallPaths verbosity platform+ case result of+ Just installPath -> do+ notice verbosity $ printf "Found CUDA toolkit at: %s (set CUDA_PATH to override this)" installPath+ return installPath+ Nothing -> die' verbosity cudaNotFoundMsg -longError :: String-longError = unlines++cudaNotFoundMsg :: String+cudaNotFoundMsg = unlines [ "********************************************************************************" , "" , "The configuration process failed to locate your CUDA installation. Ensure that you have installed both the developer driver and toolkit, available from:" , "" , "> http://developer.nvidia.com/cuda-downloads" , ""- , "and make sure that `nvcc` is available in your PATH. Check the above output log and run the command directly to ensure it can be located."+ , "and make sure that `nvcc` is available in your PATH, or set the CUDA_PATH environment variable appropriately. Check the above output log and run the command directly to ensure it can be located." , "" , "If you have a non-standard installation, you can add additional search paths using --extra-include-dirs and --extra-lib-dirs. Note that 64-bit Linux flavours often require both `lib64` and `lib` library paths, in that order." , ""@@ -261,93 +520,158 @@ ] --- Runs CUDA detection procedure and stores .buildinfo to a file.+-- Function iterates over action yielding possible locations, evaluating them+-- and returning the first valid one. Returns Nothing if no location matches. ---generateAndStoreBuildInfo :: Verbosity -> Platform -> CompilerId -> FilePath -> IO ()-generateAndStoreBuildInfo verbosity platform (CompilerId ghcFlavor ghcVersion) path = do- cudalocation <- findCudaLocation verbosity- pbi <- cudaLibraryBuildInfo cudalocation platform ghcVersion- storeHookedBuildInfo verbosity path pbi+findFirstValidLocation+ :: Verbosity+ -> Platform+ -> [(IO FilePath, String)]+ -> IO (Maybe FilePath)+findFirstValidLocation verbosity platform = go+ where+ go :: [(IO FilePath, String)] -> IO (Maybe FilePath)+ go [] = return Nothing+ go (x:xs) = do+ let (path,desc) = x+ info verbosity $ printf "checking for %s" desc+ found <- validateIOLocation verbosity platform path+ if found+ then fmap Just $ canonicalizePath =<< path+ else go xs -customBuildinfoFilepath :: FilePath-customBuildinfoFilepath = "cuda" <.> "buildinfo" -generatedBuldinfoFilepath :: FilePath-generatedBuldinfoFilepath = customBuildinfoFilepath <.> "generated"+-- Evaluates IO to obtain the path, handling any possible exceptions.+-- If path is evaluable and points to valid CUDA toolkit returns True.+--+validateIOLocation+ :: Verbosity+ -> Platform+ -> IO FilePath+ -> IO Bool+validateIOLocation verbosity platform iopath =+ let handler :: IOError -> IO Bool+ handler err = do+ info verbosity (show err)+ return False+ in+ (iopath >>= validateLocation verbosity platform) `catch` handler -main :: IO ()-main = defaultMainWithHooks customHooks++-- Checks whether given location looks like a valid CUDA toolkit directory+--+validateLocation+ :: Verbosity+ -> Platform+ -> FilePath+ -> IO Bool+validateLocation verbosity platform path = do+ -- TODO: Ideally this should check for e.g. cuda.lib and whether it exports+ -- relevant symbols. This should be achievable with some `nm` trickery+ --+ let cudaHeader = cudaIncludePath platform path </> "cuda.h"+ --+ exists <- doesFileExist cudaHeader+ info verbosity $+ if exists+ then printf "Path accepted: %s\n" path+ else printf "Path rejected: %s\nDoes not exist: %s\n" path cudaHeader+ return exists++-- Returns pairs of (action yielding candidate path, String description of that location)+--+candidateCUDAInstallPaths+ :: Verbosity+ -> Platform+ -> IO [(IO FilePath, String)]+candidateCUDAInstallPaths verbosity platform = do+ let defaults =+ [ (getEnv "CUDA_PATH", "environment variable CUDA_PATH")+ , (findInPath, "nvcc compiler executable in PATH")+ , (return defaultPath, printf "default install location (%s)" defaultPath)+ ]+ verVars <- versionedVars+ return $ defaults ++ verVars where- readHook :: (a -> Distribution.Simple.Setup.Flag Verbosity) -> Args -> a -> IO HookedBuildInfo- readHook get_verbosity a flags = do- noExtraFlags a- getHookedBuildInfo verbosity- where- verbosity = fromFlag (get_verbosity flags)+ findInPath :: IO FilePath+ findInPath = do+ nvccPath <- findProgramLocationOrError verbosity "nvcc"+ -- The obtained path is likely TOOLKIT/bin/nvcc. We want to extract the+ -- TOOLKIT part+ return (takeDirectory $ takeDirectory nvccPath) - preprocessors = hookedPreProcessors simpleUserHooks+ defaultPath :: FilePath+ defaultPath = defaultCUDAInstallPath platform - -- Our readHook implementation usees our getHookedBuildInfo.- -- We can't rely on cabal's autoconfUserHooks since they don't handle user- -- overwrites to buildinfo like we do.- customHooks = simpleUserHooks- { preBuild = preBuildHook -- not using 'readHook' here because 'build' takes; extra args- , preClean = readHook cleanVerbosity- , preCopy = readHook copyVerbosity- , preInst = readHook installVerbosity- , preHscolour = readHook hscolourVerbosity- , preHaddock = readHook haddockVerbosity- , preReg = readHook regVerbosity- , preUnreg = readHook regVerbosity- , postConf = postConfHook- , hookedPreProcessors = ("chs", ppC2hs) : filter (\x -> fst x /= "chs") preprocessors- }+ versionedVars :: IO [(IO FilePath, String)]+ versionedVars = do+ pairs <- getEnvironment+ let sorted = sort (mapMaybe (\(k, v) -> (,k,v) <$> parseCudaPathVerVar k) pairs)+ return [(return v, "environment variable " ++ k) | (_, k, v) <- sorted] - -- The hook just loads the HookedBuildInfo generated by postConfHook,- -- unless there is user-provided info that overwrites it.- preBuildHook :: Args -> BuildFlags -> IO HookedBuildInfo- preBuildHook _ flags = getHookedBuildInfo $ fromFlag $ buildVerbosity flags+ parseCudaPathVerVar :: String -> Maybe (Int, Int)+ parseCudaPathVerVar var+ | ("CUDA_PATH_V", s1) <- splitAt 11 var+ , (n1, '_':n2) <- span isDigit s1, not (null n1)+ , all isDigit n2, not (null n2)+ = Just (read n1, read n2)+ | otherwise+ = Nothing - -- The hook scans system in search for CUDA Toolkit. If the toolkit is not- -- found, an error is raised. Otherwise the toolkit location is used to- -- create a `cuda.buildinfo.generated` file with all the resulting flags.- postConfHook :: Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO ()- postConfHook args flags pkg_descr lbi- = let verbosity = fromFlag (configVerbosity flags)- currentPlatform = hostPlatform lbi- compilerId_ = (compilerId $ compiler lbi)- in do- noExtraFlags args- generateAndStoreBuildInfo verbosity currentPlatform compilerId_ generatedBuldinfoFilepath - actualBuildInfoToUse <- getHookedBuildInfo verbosity- let pkg_descr' = updatePackageDescription actualBuildInfoToUse pkg_descr- postConf simpleUserHooks args flags pkg_descr' lbi+-- NOTE: this function throws an exception when there is no `nvcc` in PATH.+-- The exception contains a meaningful message.+--+findProgramLocationOrError+ :: Verbosity+ -> String+ -> IO FilePath+findProgramLocationOrError verbosity execName = do+ location <- findProgram verbosity execName+ case location of+ Just path -> return path+ Nothing -> ioError $ mkIOError doesNotExistErrorType ("not found: " ++ execName) Nothing Nothing +findProgram+ :: Verbosity+ -> FilePath+ -> IO (Maybe FilePath)+findProgram verbosity prog = do+ result <- findProgramOnSearchPath verbosity defaultProgramSearchPath prog+#if MIN_VERSION_Cabal(1,25,0)+ return (fmap fst result)+#else+ $( case withinRange cabalVersion (orLaterVersion (Version [1,24] [])) of+ True -> [| return (fmap fst result) |]+ False -> [| return result |]+ )+#endif -storeHookedBuildInfo :: Verbosity -> FilePath -> HookedBuildInfo -> IO ()-storeHookedBuildInfo verbosity path hbi = do- notice verbosity $ "Storing parameters to " ++ path- writeHookedBuildInfo path hbi -- Reads user-provided `cuda.buildinfo` if present, otherwise loads `cuda.buildinfo.generated` -- Outputs message informing about the other possibility. -- Calls die when neither of the files is available. -- (generated one should be always present, as it is created in the post-conf step) ---getHookedBuildInfo :: Verbosity -> IO HookedBuildInfo-getHookedBuildInfo verbosity = do- doesCustomBuildInfoExists <- doesFileExist customBuildinfoFilepath- if doesCustomBuildInfoExists then do- notice verbosity $ "The user-provided buildinfo from file " ++ customBuildinfoFilepath ++ " will be used. To use default settings, delete this file."- readHookedBuildInfo verbosity customBuildinfoFilepath- else do- doesGeneratedBuildInfoExists <- doesFileExist generatedBuldinfoFilepath- if doesGeneratedBuildInfoExists then do- notice verbosity $ printf "Using build information from '%s'.\n" generatedBuldinfoFilepath- notice verbosity $ printf "Provide a '%s' file to override this behaviour.\n" customBuildinfoFilepath- readHookedBuildInfo verbosity generatedBuldinfoFilepath- else die $ "Unexpected failure. Neither the default " ++ generatedBuldinfoFilepath ++ " nor custom " ++ customBuildinfoFilepath ++ " do exist."+getHookedBuildInfo+ :: Maybe CWDPath+ -> Verbosity+ -> IO HookedBuildInfo+getHookedBuildInfo cwd verbosity = do+ doesCustomBuildInfoExists <- doesFileExist (customBuildInfoFilePath)+ if doesCustomBuildInfoExists+ then do+ notice verbosity $ printf "The user-provided buildinfo from file %s will be used. To use default settings, delete this file.\n" customBuildInfoFilePath+ readHookedBuildInfoWithCWD verbosity cwd (makeSymbolicPath customBuildInfoFilePath)+ else do+ doesGeneratedBuildInfoExists <- doesFileExist generatedBuildInfoFilePath+ if doesGeneratedBuildInfoExists+ then do+ notice verbosity $ printf "Using build information from '%s'.\n" generatedBuildInfoFilePath+ notice verbosity $ printf "Provide a '%s' file to override this behaviour.\n" customBuildInfoFilePath+ readHookedBuildInfoWithCWD verbosity cwd (makeSymbolicPath generatedBuildInfoFilePath)+ else+ die' verbosity $ printf "Unexpected failure. Neither the default %s nor custom %s exist.\n" generatedBuildInfoFilePath customBuildInfoFilePath -- Replicate the default C2HS preprocessor hook here, and inject a value for@@ -355,13 +679,21 @@ -- -- Everything below copied from Distribution.Simple.PreProcess --+#if MIN_VERSION_Cabal(1,25,0)+ppC2hs :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor+ppC2hs bi lbi _clbi+#else ppC2hs :: BuildInfo -> LocalBuildInfo -> PreProcessor ppC2hs bi lbi+#endif = PreProcessor { platformIndependent = False,+#if MIN_VERSION_Cabal(3,8,0)+ ppOrdering = unsorted,+#endif runPreProcessor = \(inBaseDir, inRelativeFile) (outBaseDir, outRelativeFile) verbosity ->- rawSystemProgramConf verbosity c2hsProgram (withPrograms lbi) . filter (not . null) $+ runDbProgram verbosity c2hsProgram (withPrograms lbi) . filter (not . null) $ maybe [] words (lookup "x-extra-c2hs-options" (customFieldsBI bi)) ++ ["--include=" ++ outBaseDir] ++ ["--cppopts=" ++ opt | opt <- getCppOptions bi lbi]@@ -373,7 +705,7 @@ getCppOptions :: BuildInfo -> LocalBuildInfo -> [String] getCppOptions bi lbi = hcDefines (compiler lbi)- ++ ["-I" ++ dir | dir <- includeDirs bi]+ ++ ["-I" ++ interpretSymbolicPath (lbiCWD lbi) dir | dir <- includeDirs bi] ++ [opt | opt@('-':c:_) <- ccOptions bi, c `elem` "DIU"] hcDefines :: Compiler -> [String]@@ -390,15 +722,80 @@ -- FIXME: this forces GHC's crazy 4.8.2 -> 408 convention on all the other -- compilers. Check if that's really what they want. versionInt :: Version -> String-versionInt (Version { versionBranch = [] }) = "1"-versionInt (Version { versionBranch = [n] }) = show n-versionInt (Version { versionBranch = n1:n2:_ })- = -- 6.8.x -> 608- -- 6.10.x -> 610- let s1 = show n1- s2 = show n2- middle = case s2 of- _ : _ : _ -> ""- _ -> "0"- in s1 ++ middle ++ s2+versionInt v =+ case versionBranch v of+ [] -> "1"+ [n] -> show n+ n1:n2:_ -> printf "%d%02d" n1 n2+++#if MIN_VERSION_Cabal(1,25,0)+versionBranch :: Version -> [Int]+versionBranch = versionNumbers+#endif++#if !MIN_VERSION_Cabal(2,0,0)+die' :: Verbosity -> String -> IO a+die' _ = die+#endif+++-- Compatibility across Cabal 3.14 symbolic paths.+-- If we want to drop pre-Cabal-3.14 compatibility at some point, this should all be merged in above.++lbiCWD :: LocalBuildInfo -> Maybe CWDPath++#if MIN_VERSION_Cabal(3,14,0)+type ExtraLibsPath = SymbolicPath Pkg ('Dir Lib)+type ExtraIncludesPath = SymbolicPath Pkg ('Dir Include)+type CWDPath = SymbolicPath CWD ('Dir Pkg)++regVerbosity :: RegisterFlags -> Flag Verbosity+regVerbosity = setupVerbosity . registerCommonFlags++workingDirFlag :: HasCommonFlags flags => flags -> Flag CWDPath+workingDirFlag = setupWorkingDir . getCommonFlags++lbiCWD = flagToMaybe . setupWorkingDir . configCommonFlags . LBC.configFlags . LBC.packageBuildDescr . localBuildDescr++-- makeSymbolicPath is an actual useful function in Cabal 3.14+-- makeRelativePathEx is an actual useful function in Cabal 3.14+-- interpretSymbolicPath is an actual useful function in Cabal 3.14++class HasCommonFlags flags where getCommonFlags :: flags -> CommonSetupFlags+instance HasCommonFlags BuildFlags where getCommonFlags = buildCommonFlags+instance HasCommonFlags CleanFlags where getCommonFlags = cleanCommonFlags+instance HasCommonFlags ConfigFlags where getCommonFlags = configCommonFlags+instance HasCommonFlags CopyFlags where getCommonFlags = copyCommonFlags+instance HasCommonFlags InstallFlags where getCommonFlags = installCommonFlags+instance HasCommonFlags HscolourFlags where getCommonFlags = hscolourCommonFlags+instance HasCommonFlags HaddockFlags where getCommonFlags = haddockCommonFlags+instance HasCommonFlags RegisterFlags where getCommonFlags = registerCommonFlags++readHookedBuildInfoWithCWD :: Verbosity -> Maybe CWDPath -> SymbolicPath Pkg 'File -> IO HookedBuildInfo+readHookedBuildInfoWithCWD = readHookedBuildInfo+#else+type ExtraLibsPath = FilePath+type ExtraIncludesPath = FilePath+type CWDPath = ()++-- regVerbosity is still present as an actual field in Cabal 3.12++workingDirFlag :: flags -> Flag CWDPath+workingDirFlag _ = NoFlag++lbiCWD _ = Nothing++makeSymbolicPath :: FilePath -> FilePath+makeSymbolicPath = id++makeRelativePathEx :: FilePath -> FilePath+makeRelativePathEx = id++interpretSymbolicPath :: Maybe CWDPath -> FilePath -> FilePath+interpretSymbolicPath _ = id++readHookedBuildInfoWithCWD :: Verbosity -> Maybe CWDPath -> FilePath -> IO HookedBuildInfo+readHookedBuildInfoWithCWD verb _ path = readHookedBuildInfo verb path+#endif
+ WINDOWS.md view
@@ -0,0 +1,54 @@+Using the CUDA package on Windows+=================================++The CUDA package works on Windows and is actively maintained. If you encounter+any other issues, please report them.++Note that if you build your applications for the Windows 64-bit architecture,+you'll need to update your `ld.exe` as described below.+++Windows 64-bit+--------------++There is a known issue with the version of `ld.exe` that ships with the 64-bit+versions of (at least) GHC-7.8.4 and GHC-7.10.2. The version of `ld.exe` that+ships with these GHC distributions does not properly link against MS-style+dynamic libraries (such as those that ship with the CUDA toolkit), causing the+application to crash at runtime once those library routines are called. The+configure step will fail if it detects an old version of `ld.exe` (< 2.25.1),+which are known to be broken.++If you are using the 64-bit GHC distributions mentioned above, you will need to+apply the following steps. This bug does not affect 32-bit GHC distributions.+The bug has been fixed in MinGW binutils `ld.exe` >= 2.25.1, so it is expected+that newer releases of GHC will not have this issue.++The problem is fixed by replacing the linker binary `ld.exe` with the newer+(patched) version, available as part of the MSys2 binutils package here:++> <http://repo.msys2.org/mingw/x86_64/mingw-w64-x86_64-binutils-2.25.1-1-any.pkg.tar.xz>++The updated `ld.exe` binary must replace the version at the path:++> `GHC_PATH\mingw\x86_64-w64-mingw32\bin\`++Note that there is another copy of `ld.exe` located at `GHC_PATH\mingw\bin\`,+but this version does not seem to be used, so replacing it as well is not+necessary. It is not sufficient to replace whatever version of `ld.exe` appears+first in your `PATH`.++Please note that having another MinGW installation in `PATH` before the one+shipped with GHC may break things, particularly if you mix 32/64-bit+distributions of MinGW and GHC.++For further discussion of the bug, see:++ * [CUDA package issue][cuda31]+ * [GHC issue][ghc10885]+ * [binutils issue][binutils16598]++ [cuda31]: https://github.com/tmcdonell/cuda/issues/31+ [ghc10885]: https://ghc.haskell.org/trac/ghc/ticket/10885+ [binutils16598]: https://sourceware.org/bugzilla/show_bug.cgi?id=16598+
+ cbits/init.c view
@@ -0,0 +1,54 @@+#include "cbits/stubs.h"+#include <stdio.h>++/*+ * Make sure that the linker always touches this module so that it notices the+ * below constructor function. Calling this empty function as part of+ * 'Foreign.CUDA.Driver.initialise' should be sufficient to prevent it from ever+ * being stripped.+ */+void enable_constructors() { }++/*+ * GHC-8 introduced a new (simpler) 64-bit allocator, which on startup 'mmap's+ * 1TB of address space and then commits sub-portions of that memory as needed.+ *+ * The CUDA driver also appears to 'mmap' a large chunk of address space on+ * 'cuInit', probably as the arena for shuffling memory to and from the device,+ * but attempts to do so at a _fixed_ address. If the GHC RTS has already taken+ * that address at the time we call 'cuInit', driver initialisation will fail+ * with an "out of memory" error.+ *+ * The workaround is to call 'cuInit' before initialising the RTS. Then the+ * RTS's allocation will avoid CUDA's allocation, since the RTS doesn't care+ * where in the address space it gets that memory. Embedding the following+ * __attribute__((constructor)) function in the library does the trick nicely,+ * and the linker will ensure that this gets executed when the shared library is+ * loaded (during program startup).+ *+ * Another way around this, without actually calling 'cuInit', would be to just+ * reserve the regions that 'cuInit' requires in the constructor function so+ * that the RTS avoids them, then release them before calling 'cuInit'. However,+ * since the CUDA driver is closed and we don't know exactly which regions to+ * reserve, that approach would be fragile.+ *+ * See: https://github.com/tmcdonell/cuda/issues/39+ */+#ifdef CUDA_PRELOAD+__attribute__((constructor)) void preinitialise_cuda()+{+ CUresult status = cuInit (0);++ if ( status != CUDA_SUCCESS ) {+#if CUDA_VERSION >= 6000+ const char* str = NULL;++ cuGetErrorString(status, &str);+ fprintf(stderr, "Failed to pre-initialise CUDA: %s\n", str);+#else+ fprintf(stderr, "Failed to pre-initialise CUDA (%d)\n", status);+#endif+ }+}+#endif+
cbits/stubs.c view
@@ -3,58 +3,9 @@ */ #include "cbits/stubs.h"---cudaError_t-cudaConfigureCallSimple-(- int gridX, int gridY,- int blockX, int blockY, int blockZ,- size_t sharedMem,- cudaStream_t stream-)-{- dim3 gridDim = {gridX, gridY, 1};- dim3 blockDim = {blockX,blockY,blockZ};-- return cudaConfigureCall(gridDim, blockDim, sharedMem, stream);-}--const char*-cudaGetErrorStringWrapper(cudaError_t error)-{- return cudaGetErrorString(error);-}--CUresult-cuTexRefSetAddress2DSimple-(- CUtexref tex,- CUarray_format format,- unsigned int numChannels,- CUdeviceptr dptr,- size_t width,- size_t height,- size_t pitch-)-{- CUDA_ARRAY_DESCRIPTOR desc;- desc.Format = format;- desc.NumChannels = numChannels;- desc.Width = width;- desc.Height = height;-- return cuTexRefSetAddress2D(tex, &desc, dptr, pitch);-}+#include <string.h> // memset -CUresult-cuMemcpy2DHtoD-(- CUdeviceptr dstDevice, unsigned int dstPitch, unsigned int dstXInBytes, unsigned int dstY,- void* srcHost, unsigned int srcPitch, unsigned int srcXInBytes, unsigned int srcY,- unsigned int widthInBytes,- unsigned int height-)+CUresult cuMemcpy2DHtoD(CUdeviceptr dstDevice, unsigned int dstPitch, unsigned int dstXInBytes, unsigned int dstY, void* srcHost, unsigned int srcPitch, unsigned int srcXInBytes, unsigned int srcY, unsigned int widthInBytes, unsigned int height) { CUDA_MEMCPY2D desc; @@ -81,15 +32,7 @@ return cuMemcpy2D(&desc); } -CUresult-cuMemcpy2DHtoDAsync-(- CUdeviceptr dstDevice, unsigned int dstPitch, unsigned int dstXInBytes, unsigned int dstY,- void* srcHost, unsigned int srcPitch, unsigned int srcXInBytes, unsigned int srcY,- unsigned int widthInBytes,- unsigned int height,- CUstream hStream-)+CUresult cuMemcpy2DHtoDAsync(CUdeviceptr dstDevice, unsigned int dstPitch, unsigned int dstXInBytes, unsigned int dstY, void* srcHost, unsigned int srcPitch, unsigned int srcXInBytes, unsigned int srcY, unsigned int widthInBytes, unsigned int height, CUstream hStream) { CUDA_MEMCPY2D desc; @@ -116,14 +59,7 @@ return cuMemcpy2DAsync(&desc, hStream); } -CUresult-cuMemcpy2DDtoH-(- void* dstHost, unsigned int dstPitch, unsigned int dstXInBytes, unsigned int dstY,- CUdeviceptr srcDevice, unsigned int srcPitch, unsigned int srcXInBytes, unsigned int srcY,- unsigned int widthInBytes,- unsigned int height-)+CUresult cuMemcpy2DDtoH(void* dstHost, unsigned int dstPitch, unsigned int dstXInBytes, unsigned int dstY, CUdeviceptr srcDevice, unsigned int srcPitch, unsigned int srcXInBytes, unsigned int srcY, unsigned int widthInBytes, unsigned int height) { CUDA_MEMCPY2D desc; @@ -150,15 +86,7 @@ return cuMemcpy2D(&desc); } -CUresult-cuMemcpy2DDtoHAsync-(- void* dstHost, unsigned int dstPitch, unsigned int dstXInBytes, unsigned int dstY,- CUdeviceptr srcDevice, unsigned int srcPitch, unsigned int srcXInBytes, unsigned int srcY,- unsigned int widthInBytes,- unsigned int height,- CUstream hStream-)+CUresult cuMemcpy2DDtoHAsync(void* dstHost, unsigned int dstPitch, unsigned int dstXInBytes, unsigned int dstY, CUdeviceptr srcDevice, unsigned int srcPitch, unsigned int srcXInBytes, unsigned int srcY, unsigned int widthInBytes, unsigned int height, CUstream hStream) { CUDA_MEMCPY2D desc; @@ -185,14 +113,7 @@ return cuMemcpy2DAsync(&desc, hStream); } -CUresult-cuMemcpy2DDtoD-(- CUdeviceptr dstDevice, unsigned int dstPitch, unsigned int dstXInBytes, unsigned int dstY,- CUdeviceptr srcDevice, unsigned int srcPitch, unsigned int srcXInBytes, unsigned int srcY,- unsigned int widthInBytes,- unsigned int height-)+CUresult cuMemcpy2DDtoD(CUdeviceptr dstDevice, unsigned int dstPitch, unsigned int dstXInBytes, unsigned int dstY, CUdeviceptr srcDevice, unsigned int srcPitch, unsigned int srcXInBytes, unsigned int srcY, unsigned int widthInBytes, unsigned int height) { CUDA_MEMCPY2D desc; @@ -219,15 +140,7 @@ return cuMemcpy2D(&desc); } -CUresult-cuMemcpy2DDtoDAsync-(- CUdeviceptr dstDevice, unsigned int dstPitch, unsigned int dstXInBytes, unsigned int dstY,- CUdeviceptr srcDevice, unsigned int srcPitch, unsigned int srcXInBytes, unsigned int srcY,- unsigned int widthInBytes,- unsigned int height,- CUstream hStream-)+CUresult cuMemcpy2DDtoDAsync(CUdeviceptr dstDevice, unsigned int dstPitch, unsigned int dstXInBytes, unsigned int dstY, CUdeviceptr srcDevice, unsigned int srcPitch, unsigned int srcXInBytes, unsigned int srcY, unsigned int widthInBytes, unsigned int height, CUstream hStream) { CUDA_MEMCPY2D desc; @@ -266,7 +179,13 @@ CUresult CUDAAPI cuCtxCreate(CUcontext *pctx, unsigned int flags, CUdevice dev) {+#if CUDA_VERSION >= 13000+ CUctxCreateParams params;+ memset(¶ms, 0, sizeof params);+ return cuCtxCreate_v4(pctx, ¶ms, flags, dev);+#else return cuCtxCreate_v2(pctx, flags, dev);+#endif } CUresult CUDAAPI cuModuleGetGlobal(CUdeviceptr *dptr, size_t *bytes, CUmodule hmod, const char *name)@@ -343,11 +262,6 @@ { return cuMemsetD32_v2(dstDevice, ui, N); }--CUresult CUDAAPI cuTexRefSetAddress(size_t *ByteOffset, CUtexref hTexRef, CUdeviceptr dptr, size_t bytes)-{- return cuTexRefSetAddress_v2(ByteOffset, hTexRef, dptr, bytes);-} #endif #if CUDA_VERSION >= 4000@@ -382,5 +296,134 @@ { return cuMemHostRegister_v2(p, bytesize, Flags); }++CUresult CUDAAPI cuLinkCreate(unsigned int numOptions, CUjit_option *options, void **optionValues, CUlinkState *stateOut)+{+ return cuLinkCreate_v2(numOptions, options, optionValues, stateOut);+}++CUresult CUDAAPI cuLinkAddData(CUlinkState state, CUjitInputType type, void *data, size_t size, const char *name, unsigned int numOptions, CUjit_option *options, void **optionValues)+{+ return cuLinkAddData_v2(state, type, data, size, name, numOptions, options, optionValues);+}++CUresult CUDAAPI cuLinkAddFile(CUlinkState state, CUjitInputType type, const char *path, unsigned int numOptions, CUjit_option *options, void **optionValues)+{+ return cuLinkAddFile_v2(state, type, path, numOptions, options, optionValues);+} #endif +#if CUDA_VERSION >= 10000+CUresult CUDAAPI cuGraphAddHostNode_simple(CUgraphNode *phGraphNode, CUgraph hGraph, CUgraphNode *dependencies, size_t numDependencies, CUhostFn fn, void* userData)+{+ CUDA_HOST_NODE_PARAMS nodeParams;+ nodeParams.fn = fn;+ nodeParams.userData = userData;++ return cuGraphAddHostNode(phGraphNode, hGraph, dependencies, numDependencies, &nodeParams);+}++CUresult CUDAAPI cuGraphAddKernelNode_simple(CUgraphNode *phGraphNode, CUgraph hGraph, CUgraphNode *dependencies, size_t numDependencies, CUfunction func, unsigned int gridDimX, unsigned int gridDimY, unsigned int gridDimZ, unsigned int blockDimX, unsigned int blockDimY, unsigned int blockDimZ, unsigned int sharedMemBytes, void** kernelParams)+{+ CUDA_KERNEL_NODE_PARAMS nodeParams;+ nodeParams.func = func;+ nodeParams.gridDimX = gridDimX;+ nodeParams.gridDimY = gridDimY;+ nodeParams.gridDimZ = gridDimZ;+ nodeParams.blockDimX = blockDimX;+ nodeParams.blockDimY = blockDimY;+ nodeParams.blockDimZ = blockDimZ;+ nodeParams.sharedMemBytes = sharedMemBytes;+ nodeParams.kernelParams = kernelParams;+ nodeParams.extra = NULL;++ return cuGraphAddKernelNode(phGraphNode, hGraph, dependencies, numDependencies, &nodeParams);+}++CUresult CUDAAPI cuGraphAddMemcpyNode_simple(CUgraphNode *phGraphNode, CUgraph hGraph, CUgraphNode *dependencies, size_t numDependencies, CUcontext ctx, size_t srcXInBytes, size_t srcY, size_t srcZ, size_t srcLOD, CUmemorytype srcMemoryType, const void *srcPtr, size_t srcPitch, size_t srcHeight, size_t dstXInBytes, size_t dstY, size_t dstZ, size_t dstLOD, CUmemorytype dstMemoryType, void *dstPtr, size_t dstPitch, size_t dstHeight, size_t widthInBytes, size_t height, size_t depth)+{+ CUDA_MEMCPY3D copyParams;++ copyParams.srcXInBytes = srcXInBytes;+ copyParams.srcY = srcY;+ copyParams.srcZ = srcZ;+ copyParams.srcLOD = srcLOD;+ copyParams.srcMemoryType = srcMemoryType;+ copyParams.srcHost = (void*) srcPtr;+ copyParams.srcDevice = (CUdeviceptr) srcPtr;+ copyParams.srcArray = (CUarray) srcPtr;+ copyParams.reserved0 = NULL;+ copyParams.srcPitch = srcPitch;+ copyParams.srcHeight = srcHeight;++ copyParams.dstXInBytes = dstXInBytes;+ copyParams.dstY = dstY;+ copyParams.dstZ = dstZ;+ copyParams.dstLOD = dstLOD;+ copyParams.dstMemoryType = dstMemoryType;+ copyParams.dstHost = (void*) dstPtr;+ copyParams.dstDevice = (CUdeviceptr) dstPtr;+ copyParams.dstArray = (CUarray) dstPtr;+ copyParams.reserved1 = NULL;+ copyParams.dstPitch = dstPitch;+ copyParams.dstHeight = dstHeight;++ copyParams.WidthInBytes = widthInBytes;+ copyParams.Height = height;+ copyParams.Depth = depth;++ return cuGraphAddMemcpyNode(phGraphNode, hGraph, dependencies, numDependencies, ©Params, ctx);+}++CUresult CUDAAPI cuGraphAddMemsetNode_simple(CUgraphNode *phGraphNode, CUgraph hGraph, CUgraphNode *dependencies, size_t numDependencies, CUcontext ctx, CUdeviceptr dst, unsigned int elementSize, size_t height, size_t pitch, unsigned int value, size_t width)+{+ CUDA_MEMSET_NODE_PARAMS memsetParams;+ memsetParams.dst = dst;+ memsetParams.elementSize = elementSize;+ memsetParams.height = height;+ memsetParams.pitch = pitch;+ memsetParams.value = value;+ memsetParams.width = width;++ return cuGraphAddMemsetNode(phGraphNode, hGraph, dependencies, numDependencies, &memsetParams, ctx);+}+#endif++#if CUDA_VERSION >= 10010+CUresult CUDAAPI cuStreamBeginCapture(CUstream hStream, CUstreamCaptureMode mode)+{+ return cuStreamBeginCapture_v2(hStream, mode);+}++CUresult CUDAAPI cuGraphExecKernelNodeSetParams_simple(CUgraphExec hGraphExec, CUgraphNode hNode, CUfunction func, unsigned int gridDimX, unsigned int gridDimY, unsigned int gridDimZ, unsigned int blockDimX, unsigned int blockDimY, unsigned int blockDimZ, unsigned int sharedMemBytes, void** kernelParams)+{+ CUDA_KERNEL_NODE_PARAMS nodeParams;+ nodeParams.func = func;+ nodeParams.gridDimX = gridDimX;+ nodeParams.gridDimY = gridDimY;+ nodeParams.gridDimZ = gridDimZ;+ nodeParams.blockDimX = blockDimX;+ nodeParams.blockDimY = blockDimY;+ nodeParams.blockDimZ = blockDimZ;+ nodeParams.sharedMemBytes = sharedMemBytes;+ nodeParams.kernelParams = kernelParams;+ nodeParams.extra = NULL;++ return cuGraphExecKernelNodeSetParams(hGraphExec, hNode, &nodeParams);+}+#endif++#if CUDA_VERSION >= 13000+// This is the signature of the CUDA <=12 version; much easier to shim here than in Haskell.+CUresult cuMemAdvise_device(CUdeviceptr dptr, size_t count, CUmem_advise advice, CUdevice device)+{+ return cuMemAdvise(dptr, count, advice, (CUmemLocation){.id = device, .type = CU_MEM_LOCATION_TYPE_DEVICE});+}++// This is the signature of the CUDA <=12 version; much easier to shim here than in Haskell.+CUresult cuMemPrefetchAsync_device(CUdeviceptr dptr, size_t count, CUdevice device, CUstream hStream)+{+ // flags is reserved and must be 0 in CUDA 13+ return cuMemPrefetchAsync(dptr, count, (CUmemLocation){.id = device, .type = CU_MEM_LOCATION_TYPE_DEVICE}, 0, hStream);+}+#endif
cbits/stubs.h view
@@ -11,107 +11,23 @@ #define CUDARTAPI __stdcall #endif -// #define __cdecl --/*- * We need to work around some shortcomings in the C parser of c2hs by disabling advanced attributes etc on Apple platforms.- */-#ifdef __APPLE__-#define _ANSI_SOURCE-#define __AVAILABILITY__-#define __OSX_AVAILABLE_STARTING(_mac, _iphone)-#define __OSX_AVAILABLE_BUT_DEPRECATED(_macIntro, _macDep, _iphoneIntro, _iphoneDep)-#define __OSX_AVAILABLE_BUT_DEPRECATED_MSG(_osxIntro, _osxDep, _iosIntro, _iosDep, _msg)-#endif- #include <cuda.h>+#include <cudaProfiler.h> #include <cuda_runtime_api.h> #ifdef __cplusplus extern "C" { #endif -cudaError_t-cudaConfigureCallSimple-(- int gridX, int gridY,- int blockX, int blockY, int blockZ,- size_t sharedMem,- cudaStream_t stream-);--const char*-cudaGetErrorStringWrapper(cudaError_t error);--CUresult-cuTexRefSetAddress2DSimple-(- CUtexref tex,- CUarray_format format,- unsigned int numChannels,- CUdeviceptr dptr,- size_t width,- size_t height,- size_t pitch-);--CUresult-cuMemcpy2DHtoD-(- CUdeviceptr dstDevice, unsigned int dstPitch, unsigned int dstXInBytes, unsigned int dstY,- void* srcHost, unsigned int srcPitch, unsigned int srcXInBytes, unsigned int srcY,- unsigned int widthInBytes,- unsigned int height-);--CUresult-cuMemcpy2DHtoDAsync-(- CUdeviceptr dstDevice, unsigned int dstPitch, unsigned int dstXInBytes, unsigned int dstY,- void* srcHost, unsigned int srcPitch, unsigned int srcXInBytes, unsigned int srcY,- unsigned int widthInBytes,- unsigned int height,- CUstream hStream-);--CUresult-cuMemcpy2DDtoH-(- void* dstHost, unsigned int dstPitch, unsigned int dstXInBytes, unsigned int dstY,- CUdeviceptr srcDevice, unsigned int srcPitch, unsigned int srcXInBytes, unsigned int srcY,- unsigned int widthInBytes,- unsigned int height-);--CUresult-cuMemcpy2DDtoHAsync-(- void* dstHost, unsigned int dstPitch, unsigned int dstXInBytes, unsigned int dstY,- CUdeviceptr srcDevice, unsigned int srcPitch, unsigned int srcXInBytes, unsigned int srcY,- unsigned int widthInBytes,- unsigned int height,- CUstream hStream-);--CUresult-cuMemcpy2DDtoD-(- CUdeviceptr dstDevice, unsigned int dstPitch, unsigned int dstXInBytes, unsigned int dstY,- CUdeviceptr srcDevice, unsigned int srcPitch, unsigned int srcXInBytes, unsigned int srcY,- unsigned int widthInBytes,- unsigned int height-);--CUresult-cuMemcpy2DDtoDAsync-(- CUdeviceptr dstDevice, unsigned int dstPitch, unsigned int dstXInBytes, unsigned int dstY,- CUdeviceptr srcDevice, unsigned int srcPitch, unsigned int srcXInBytes, unsigned int srcY,- unsigned int widthInBytes,- unsigned int height,- CUstream hStream-);+void enable_constructors(); +CUresult cuTexRefSetAddress2D_simple(CUtexref tex, CUarray_format format, unsigned int numChannels, CUdeviceptr dptr, size_t width, size_t height, size_t pitch);+CUresult cuMemcpy2DHtoD(CUdeviceptr dstDevice, unsigned int dstPitch, unsigned int dstXInBytes, unsigned int dstY, void* srcHost, unsigned int srcPitch, unsigned int srcXInBytes, unsigned int srcY, unsigned int widthInBytes, unsigned int height);+CUresult cuMemcpy2DHtoDAsync(CUdeviceptr dstDevice, unsigned int dstPitch, unsigned int dstXInBytes, unsigned int dstY, void* srcHost, unsigned int srcPitch, unsigned int srcXInBytes, unsigned int srcY, unsigned int widthInBytes, unsigned int height, CUstream hStream);+CUresult cuMemcpy2DDtoH(void* dstHost, unsigned int dstPitch, unsigned int dstXInBytes, unsigned int dstY, CUdeviceptr srcDevice, unsigned int srcPitch, unsigned int srcXInBytes, unsigned int srcY, unsigned int widthInBytes, unsigned int height);+CUresult cuMemcpy2DDtoHAsync(void* dstHost, unsigned int dstPitch, unsigned int dstXInBytes, unsigned int dstY, CUdeviceptr srcDevice, unsigned int srcPitch, unsigned int srcXInBytes, unsigned int srcY, unsigned int widthInBytes, unsigned int height, CUstream hStream);+CUresult cuMemcpy2DDtoD(CUdeviceptr dstDevice, unsigned int dstPitch, unsigned int dstXInBytes, unsigned int dstY, CUdeviceptr srcDevice, unsigned int srcPitch, unsigned int srcXInBytes, unsigned int srcY, unsigned int widthInBytes, unsigned int height);+CUresult cuMemcpy2DDtoDAsync(CUdeviceptr dstDevice, unsigned int dstPitch, unsigned int dstXInBytes, unsigned int dstY, CUdeviceptr srcDevice, unsigned int srcPitch, unsigned int srcXInBytes, unsigned int srcY, unsigned int widthInBytes, unsigned int height, CUstream hStream); /* * Need to re-export some symbols as they are now generated by #defines, which@@ -221,8 +137,50 @@ #if CUDA_VERSION >= 6050 #undef cuMemHostRegister+#undef cuLinkCreate+#undef cuLinkAddData+#undef cuLinkAddFile CUresult CUDAAPI cuMemHostRegister(void *p, size_t bytesize, unsigned int Flags);+CUresult CUDAAPI cuLinkCreate(unsigned int numOptions, CUjit_option *options, void **optionValues, CUlinkState *stateOut);+CUresult CUDAAPI cuLinkAddData(CUlinkState state, CUjitInputType type, void *data, size_t size, const char *name, unsigned int numOptions, CUjit_option *options, void **optionValues);+CUresult CUDAAPI cuLinkAddFile(CUlinkState state, CUjitInputType type, const char *path, unsigned int numOptions, CUjit_option *options, void **optionValues);+#endif++#if CUDA_VERSION >= 10000+CUresult CUDAAPI cuGraphAddHostNode_simple(CUgraphNode *phGraphNode, CUgraph hGraph, CUgraphNode *dependencies, size_t numDependencies, CUhostFn fn, void* userData);+CUresult CUDAAPI cuGraphAddKernelNode_simple(CUgraphNode *phGraphNode, CUgraph hGraph, CUgraphNode *dependencies, size_t numDependencies, CUfunction func, unsigned int gridDimX, unsigned int gridDimY, unsigned int gridDimZ, unsigned int blockDimX, unsigned int blockDimY, unsigned int blockDimZ, unsigned int sharedMemBytes, void** kernelParams);+CUresult CUDAAPI cuGraphAddMemcpyNode_simple(CUgraphNode *phGraphNode, CUgraph hGraph, CUgraphNode *dependencies, size_t numDependencies, CUcontext ctx, size_t srcXInBytes, size_t srcY, size_t srcZ, size_t srcLOD, CUmemorytype srcMemoryType, const void *srcPtr, size_t srcPitch, size_t srcHeight, size_t dstXInBytes, size_t dstY, size_t dstZ, size_t dstLOD, CUmemorytype dstMemoryType, void *dstPtr, size_t dstPitch, size_t dstHeight, size_t widthInBytes, size_t height, size_t depth);+CUresult CUDAAPI cuGraphAddMemsetNode_simple(CUgraphNode *phGraphNode, CUgraph hGraph, CUgraphNode *dependencies, size_t numDependencies, CUcontext ctx, CUdeviceptr dst, unsigned int elementSize, size_t height, size_t pitch, unsigned int value, size_t width);+#endif++#if CUDA_VERSION >= 10010+#undef cuStreamBeginCapture++CUresult CUDAAPI cuStreamBeginCapture(CUstream hStream, CUstreamCaptureMode mode);+CUresult CUDAAPI cuGraphExecKernelNodeSetParams_simple(CUgraphExec hGraphExec, CUgraphNode hNode, CUfunction func, unsigned int gridDimX, unsigned int gridDimY, unsigned int gridDimZ, unsigned int blockDimX, unsigned int blockDimY, unsigned int blockDimZ, unsigned int sharedMemBytes, void** kernelParams);+#endif++#if CUDA_VERSION >= 11000+#undef cuGraphInstantiate+#undef cuDevicePrimaryCtxRelease+#undef cuDevicePrimaryCtxReset+#undef cuDevicePrimaryCtxSetFlags++CUresult CUDAAPI cuGraphInstantiate(CUgraphExec *phGraphExec, CUgraph hGraph, CUgraphNode *phErrorNode, char *logBuffer, size_t bufferSize);+CUresult CUDAAPI cuDevicePrimaryCtxRelease(CUdevice dev);+CUresult CUDAAPI cuDevicePrimaryCtxReset(CUdevice dev);+CUresult CUDAAPI cuDevicePrimaryCtxSetFlags(CUdevice dev, unsigned int flags);+#endif++#if CUDA_VERSION >= 11010+#undef cuIpcOpenMemHandle+CUresult CUDAAPI cuIpcOpenMemHandle(CUdeviceptr *pdptr, CUipcMemHandle handle, unsigned int Flags);+#endif++#if CUDA_VERSION >= 13000+CUresult cuMemAdvise_device(CUdeviceptr dptr, size_t count, CUmem_advise advice, CUdevice device);+CUresult cuMemPrefetchAsync_device(CUdeviceptr dptr, size_t count, CUdevice device, CUstream hStream); #endif #ifdef __cplusplus
− changelog.md
@@ -1,34 +0,0 @@-0.6.7.0-- * Add support for building on Windows (thanks to mwu-tow)--0.6.6.2-- * Build fix--0.6.6.1-- * Build fixes for ghc-7.6 and ghc-7.10--0.6.6.0-- * Drop support for CUDA 3.0 and older.-- * Combine the definition of the 'Event' and 'Stream' data types. As of- CUDA-3.1 these data structures are equivalent, and can be safely shared- between runtime and driver API calls and libraries.-- * Mark FFI imports of potentially long-running API functions as safe. This- allows them to be safely called from Haskell threads without blocking the- entire HEC.-- * Add compute-capability data for 3.7, 5.2 devices.--0.6.5.1-- * Build fix for Mac OS X 10.10 (Yosemite)--0.6.5.0-- * Add support for the CUDA-6.5 release-
cuda.cabal view
@@ -1,6 +1,8 @@+cabal-version: 1.24+ Name: cuda-Version: 0.6.7.0-Synopsis: FFI binding to the CUDA interface for programming NVIDIA GPUs+Version: 0.13.0.0+Synopsis: FFI binding to the CUDA driver interface for programming NVIDIA GPUs Description: The CUDA library provides a direct, general purpose C-like SPMD programming model for NVIDIA graphics cards (G8x series onwards). This is a collection@@ -10,89 +12,143 @@ . <http://developer.nvidia.com/cuda-downloads> .- The configure script will look for your CUDA installation in the standard- places, and if the nvcc compiler is found in your PATH, relative to that.+ The setup script will look for your CUDA installation by checking, in the+ following order: .- This release is for version 6.5 of the CUDA toolkit.+ 1. The @CUDA_PATH@ environment variable .- [/NOTE:/]+ 2. Searching for @nvcc@ on the @PATH@ .- Due to a bug in nvcc, this package is not compatible with c2hs-0.18.* or- c2hs-0.19.*. See tmcdonell/cuda#18.+ 3. Checking at @\/usr\/local\/cuda@ .+ 4. Environment variables of the form @CUDA_PATH_Vx_y@ (deprecated)+ .+ This library provides bindings to the CUDA Driver API, not the Runtime API.+ To get started, see "Foreign.CUDA.Driver"; a short tutorial is available+ there.+ .+ Tested with library versions up to and including CUDA-13.0.+ .+ [/NOTES:/]+ .+ For additional notes on installing on Windows, see:+ .+ * <https://github.com/tmcdonell/cuda/blob/master/WINDOWS.md>+ .+ This library is currently in __maintenance mode__. While we are happy to+ release updates to keep the existing interface working with newer CUDA+ versions (as long as the underlying APIs remain available), no binding of+ new features is planned at the moment. Get in touch if you want to+ contribute. License: BSD3 License-file: LICENSE-Copyright: Copyright (c) [2009..2015]. Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>-Author: Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>-Maintainer: Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+Copyright: Copyright (c) [2009..2023]. Trevor L. McDonell <trevor.mcdonell@gmail.com>+Author: Trevor L. McDonell <trevor.mcdonell@gmail.com>+Maintainer: Trevor L. McDonell <trevor.mcdonell@gmail.com>,+ Tom Smeding <tom@tomsmeding.com> Homepage: https://github.com/tmcdonell/cuda Bug-reports: https://github.com/tmcdonell/cuda/issues Category: Foreign-Cabal-version: >= 1.22-Tested-with: GHC >= 7.6-+Tested-with: GHC >= 8.0 Build-type: Custom -Extra-tmp-files: cuda.buildinfo.generated- config.status- config.log+Extra-tmp-files:+ cuda.buildinfo.generated -Extra-source-files: cbits/stubs.h- changelog.md+Extra-source-files:+ cbits/stubs.h +Extra-doc-files:+ CHANGELOG.md+ README.md+ WINDOWS.md++custom-setup+ setup-depends:+ base >= 4.7 && < 5+ , Cabal >= 1.24 && < 3.17+ , directory >= 1.0+ , filepath >= 1.0+ Library- Exposed-Modules: Foreign.CUDA- Foreign.CUDA.Ptr- Foreign.CUDA.Types- Foreign.CUDA.Analysis- Foreign.CUDA.Analysis.Device- Foreign.CUDA.Analysis.Occupancy- Foreign.CUDA.Runtime- Foreign.CUDA.Runtime.Device- Foreign.CUDA.Runtime.Error- Foreign.CUDA.Runtime.Event- Foreign.CUDA.Runtime.Exec- Foreign.CUDA.Runtime.Marshal- Foreign.CUDA.Runtime.Stream- Foreign.CUDA.Runtime.Texture- Foreign.CUDA.Runtime.Utils- Foreign.CUDA.Driver- Foreign.CUDA.Driver.Context- Foreign.CUDA.Driver.Device- Foreign.CUDA.Driver.Error- Foreign.CUDA.Driver.Event- Foreign.CUDA.Driver.Exec- Foreign.CUDA.Driver.Marshal- Foreign.CUDA.Driver.Module- Foreign.CUDA.Driver.Stream- Foreign.CUDA.Driver.Texture- Foreign.CUDA.Driver.Utils+ hs-source-dirs: src+ exposed-modules:+ Foreign.CUDA.Path+ Foreign.CUDA.Ptr - Other-modules: Foreign.CUDA.Internal.C2HS+ -- Kernel and device analysis+ Foreign.CUDA.Analysis+ Foreign.CUDA.Analysis.Device+ Foreign.CUDA.Analysis.Occupancy - Include-dirs: .- C-sources: cbits/stubs.c+ -- Driver API+ Foreign.CUDA.Driver+ Foreign.CUDA.Driver.Context+ Foreign.CUDA.Driver.Context.Base+ Foreign.CUDA.Driver.Context.Config+ Foreign.CUDA.Driver.Context.Peer+ Foreign.CUDA.Driver.Context.Primary+ Foreign.CUDA.Driver.Device+ Foreign.CUDA.Driver.Error+ Foreign.CUDA.Driver.Event+ Foreign.CUDA.Driver.Exec+ Foreign.CUDA.Driver.Graph.Base+ Foreign.CUDA.Driver.Graph.Build+ Foreign.CUDA.Driver.Graph.Capture+ Foreign.CUDA.Driver.Graph.Exec+ Foreign.CUDA.Driver.IPC.Event+ Foreign.CUDA.Driver.IPC.Marshal+ Foreign.CUDA.Driver.Marshal+ Foreign.CUDA.Driver.Module+ Foreign.CUDA.Driver.Module.Base+ Foreign.CUDA.Driver.Module.Link+ Foreign.CUDA.Driver.Module.Query+ Foreign.CUDA.Driver.Profiler+ Foreign.CUDA.Driver.Stream+ Foreign.CUDA.Driver.Unified+ Foreign.CUDA.Driver.Utils - Build-tools: c2hs >= 0.21- Build-depends:- base >= 4 && < 5- , bytestring- , Cabal >= 1.22+ -- Extras+ Foreign.C.Extra+ Foreign.CUDA.Internal.C2HS+ Foreign.CUDA.Internal.Describe + include-dirs: .+ c-sources: cbits/stubs.c+ cbits/init.c++ build-tools: c2hs >= 0.21+ build-depends:+ base >= 4.7 && < 5+ , bytestring >= 0.10.4+ , containers+ , filepath >= 1.0+ , template-haskell+ , uuid-types >= 1.0+ default-language: Haskell98- Extensions:- ghc-options: -Wall -O2 -funbox-strict-fields -fwarn-tabs- ghc-prof-options: -fprof-auto -fprof-cafs + ghc-options:+ -Wall+ -O2+ -funbox-strict-fields+ -fwarn-tabs+ -fno-warn-unused-imports + if impl(ghc == 8.0.1)+ cpp-options: -DCUDA_PRELOAD++ Executable nvidia-device-query- Main-is: DeviceQuery.hs+ main-is: DeviceQuery.hs hs-source-dirs: examples/src/deviceQueryDrv - Build-depends: base >= 4 && < 5,- cuda,- pretty+ build-depends:+ base >= 4 && < 5+ , cuda+ , pretty+ default-language: Haskell98 @@ -100,3 +156,9 @@ type: git location: https://github.com/tmcdonell/cuda +source-repository this+ type: git+ location: https://github.com/tmcdonell/cuda+ tag: v0.13.0.0++-- vim: nospell
examples/src/deviceQueryDrv/DeviceQuery.hs view
@@ -1,21 +1,27 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-} module Main where -import Numeric import Control.Monad-import Text.Printf+import Foreign.Marshal.Utils ( toBool )+import Numeric+import Prelude hiding ( (<>) ) import Text.PrettyPrint+import Text.Printf +import Foreign.CUDA.Driver.Device ( Device(..) ) import Foreign.CUDA.Analysis as CUDA import qualified Foreign.CUDA.Driver as CUDA main :: IO () main = do- version <- CUDA.driverVersion+ version <- CUDA.driverVersion printf "CUDA device query (Driver API, statically linked)\n" printf "CUDA driver version %d.%d\n" (version`div`1000) ((version`mod`100)`div`10)+ printf "CUDA API version %d.%d\n" (CUDA.libraryVersion`div`1000) ((CUDA.libraryVersion`mod`100)`div`10) CUDA.initialise [] numDevices <- CUDA.count@@ -24,68 +30,120 @@ then printf "There are no available devices that support CUDA\n" else printf "Detected %d CUDA capable device%s\n" numDevices (if numDevices > 1 then "s" else "") - forM_ [0 .. numDevices-1] $ \n -> do- deviceProp <- CUDA.props =<< CUDA.device n- printf "\nDevice %d: %s\n" n (deviceName deviceProp)- statDevice deviceProp+ infos <- forM [0 .. numDevices-1] $ \n -> do+ dev <- CUDA.device n+ prp <- CUDA.props dev+ return (n, dev, prp) + forM_ infos $ \(n, dev, prp) -> do+ p2p <- statP2P dev prp infos+ printf "\nDevice %d: %s\n%s\n" n (deviceName prp) (statDevice prp)+ unless (null p2p) $ printf "%s\n" p2p -statDevice :: DeviceProperties -> IO ()++statDevice :: DeviceProperties -> String statDevice dev@DeviceProperties{..} = let DeviceResources{..} = deviceResources dev - pad v = take width $ v ++ repeat ' '- width = maximum $ map (length . fst) props- table = nest 2 $ vcat $ map (\(k,v) -> text (pad k) <+> v) props+ grid (x,y) = int x <+> char 'x' <+> int y+ cube (x,y,z) = int x <+> char 'x' <+> int y <+> char 'x' <+> int z - grid (x,y) = int x <+> char 'x' <+> int y- cube (x,y,z) = int x <+> char 'x' <+> int y <+> char 'x' <+> int z+ props =+ [("CUDA capability:", text $ show computeCapability)+ ,("CUDA cores:", text $ printf "%d cores in %d multiprocessors (%d cores/MP)" (coresPerMP * multiProcessorCount) multiProcessorCount coresPerMP)+ ,("Global memory:", text $ showBytes totalGlobalMem)+ ,("Constant memory:", text $ showBytes totalConstMem)+ ,("Shared memory per block:", text $ showBytes sharedMemPerBlock)+ ,("Registers per block:", int regsPerBlock)+ ,("Warp size:", int warpSize)+ ,("Maximum threads per multiprocessor:", int maxThreadsPerMultiProcessor)+ ,("Maximum threads per block:", int maxThreadsPerBlock)+ ,("Maximum grid dimensions:", cube maxGridSize)+ ,("Maximum block dimensions:", cube maxBlockSize)+ ,("GPU clock rate:", text . showFreq $ clockRate * 1000)+ ,("Memory clock rate:", text . showFreq $ memClockRate * 1000)+ ,("Memory bus width:", int memBusWidth <> text "-bit")+ ,("L2 cache size:", text $ showBytes cacheMemL2)+ ,("Maximum texture dimensions", empty)+ ,(" 1D:", int maxTextureDim1D)+ ,(" 2D:", grid maxTextureDim2D)+ ,(" 3D:", cube maxTextureDim3D)+ ,("Texture alignment:", text $ showBytes textureAlignment)+ ,("Maximum memory pitch:", text $ showBytes memPitch)]++ - bool True = text "Yes"- bool False = text "No"+ $(if CUDA.libraryVersion >= 13000 then [|+ [("Concurrent copy and kernel execution:", bool concurrentKernels <> text (printf " with %d copy engine%s" asyncEngineCount (if asyncEngineCount > 1 then "s" else "")))]+ |] else [|+ [("Concurrent kernel execution:", bool concurrentKernels)+ ,("Concurrent copy and execution:", bool deviceOverlap <> text (printf ", with %d copy engine%s" asyncEngineCount (if asyncEngineCount > 1 then "s" else "")))]+ |])++ - props =- [("CUDA capability:", text $ show computeCapability)- ,("CUDA cores:", text $ printf "%d cores in %d multiprocessors (%d cores/MP)" (coresPerMP * multiProcessorCount) multiProcessorCount coresPerMP)- ,("Global memory:", text $ showBytes totalGlobalMem)- ,("Constant memory:", text $ showBytes totalConstMem)- ,("Shared memory per block:", text $ showBytes sharedMemPerBlock)- ,("Registers per block:", int regsPerBlock)- ,("Warp size:", int warpSize)- ,("Maximum threads per multiprocessor:", int maxThreadsPerMultiProcessor)- ,("Maximum threads per block:", int maxThreadsPerBlock)- ,("Maximum grid dimensions:", cube maxGridSize)- ,("Maximum block dimensions:", cube maxBlockSize)- ,("GPU clock rate:", text . showFreq $ clockRate * 1000)- ,("Memory clock rate:", text . showFreq $ memClockRate * 1000)- ,("Memory bus width:", int memBusWidth <> text "-bit")- ,("L2 cache size:", text $ showBytes cacheMemL2)- ,("Maximum texture dimensions", empty)- ,(" 1D:", int maxTextureDim1D)- ,(" 2D:", grid maxTextureDim2D)- ,(" 3D:", cube maxTextureDim3D)- ,("Texture alignment:", text $ showBytes textureAlignment)- ,("Maximum memory pitch:", text $ showBytes memPitch)- ,("Concurrent kernel execution:", bool concurrentKernels)- ,("Concurrent copy and execution:", bool deviceOverlap <> text (printf ", with %d copy engine%s" asyncEngineCount (if asyncEngineCount > 1 then "s" else "")))- ,("Runtime limit on kernel execution:", bool kernelExecTimeoutEnabled)- ,("Integrated GPU sharing host memory:", bool integrated)- ,("Host page-locked memory mapping:", bool canMapHostMemory)- ,("ECC memory support:", bool eccEnabled)- ,("Unified addressing (UVA):", bool unifiedAddressing)- ,("PCI bus/location:", int (busID pciInfo) <> char '/' <> int (deviceID pciInfo))- ,("Compute mode:", text (show computeMode))+ [("Runtime limit on kernel execution:", bool kernelExecTimeoutEnabled)+ ,("Integrated GPU sharing host memory:", bool integrated)+ ,("Host page-locked memory mapping:", bool canMapHostMemory)+ ,("ECC memory support:", bool eccEnabled)+ ,("Unified addressing (UVA):", bool unifiedAddressing)]++++ $(if CUDA.libraryVersion >= 8000 then [|+ [("Single to double precision performance:", text $ printf "%d : 1" singleToDoublePerfRatio)+ ,("Supports compute pre-emption:", bool preemption)]+ |] else [|[]|])++++ $(if CUDA.libraryVersion >= 9000 then [|+ [("Supports cooperative launch:", bool cooperativeLaunch)]+ |] else [|[]|])++++ $(if CUDA.libraryVersion >= 9000 && CUDA.libraryVersion < 13000 then [|+ [("Supports multi-device cooperative launch:", bool cooperativeLaunchMultiDevice)]+ |] else [|[]|])++++ [("PCI bus/location:", int (busID pciInfo) <> char '/' <> int (deviceID pciInfo))+ ,("Compute mode:", text (show computeMode)) ] in- putStrLn . render- $ hang table 4- $ case computeMode of- Default -> text "Multiple host threads can use the device simultaneously"- Exclusive -> text "Only one host thread in a process is able to use this device"- Prohibited -> text "No host thread can use this device"- ExclusiveProcess -> text "Multiple threads in one process can use the device simultaneously"+ render+ $ hang (table props) 4+ $ text (describe computeMode) ++statP2P :: Device -> DeviceProperties -> [(Int, Device, DeviceProperties)] -> IO String+statP2P dev prp infos+ | CUDA.libraryVersion < 4000 = return []++ -- Only Fermi and later can support P2P+ | computeCapability prp < Compute 2 0 = return []+ | otherwise+ = let+ go [] = return []+ go ((m, peer, pp):is) =+ if dev == peer+ then go is+ else do+ access <- CUDA.accessible dev peer+ rest <- go is+ return $ (printf " Device %d (%s):" m (deviceName pp), bool access) : rest+ in do+ access <- go infos+ return+ $ if null access+ then []+ else render+ $ table (("Peer-to-Peer access to:", empty) : access)+++table :: [(String, Doc)] -> Doc+table kvs+ = nest 2+ $ vcat+ $ map (\(k,v) -> text (pad k) <+> v) kvs+ where+ pad v = take width $ v ++ repeat ' '+ width = maximum $ map (length . fst) kvs++bool :: Bool -> Doc+bool True = text "Yes"+bool False = text "No" showFreq :: Integral i => i -> String showFreq x = showFFloatSIBase Nothing 1000 (fromIntegral x :: Double) "Hz"
+ src/Foreign/C/Extra.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ForeignFunctionInterface #-}+--------------------------------------------------------------------------------+-- |+-- Module : Foreign.C.Extra+-- Copyright : [2018..2023] Trevor L. McDonell+-- License : BSD+--+--------------------------------------------------------------------------------++module Foreign.C.Extra (++ c_strnlen,++) where++import Foreign.C+++#if defined(WIN32)+{-# INLINE c_strnlen' #-}+c_strnlen' :: CString -> CSize -> IO CSize+c_strnlen' str size = do+ str' <- peekCStringLen (str, fromIntegral size)+ return $ stringLen 0 str'+ where+ stringLen acc [] = acc+ stringLen acc ('\0':_) = acc+ stringLen acc (_:xs) = stringLen (acc+1) xs+#else+foreign import ccall unsafe "string.h strnlen" c_strnlen'+ :: CString -> CSize -> IO CSize+#endif++{-# INLINE c_strnlen #-}+c_strnlen :: CString -> Int -> IO Int+c_strnlen str maxlen = fromIntegral `fmap` c_strnlen' str (fromIntegral maxlen)+
+ src/Foreign/CUDA/Analysis.hs view
@@ -0,0 +1,20 @@+--------------------------------------------------------------------------------+-- |+-- Module : Foreign.CUDA.Analysis+-- Copyright : [2009..2023] Trevor L. McDonell+-- License : BSD+--+-- Meta-module exporting CUDA analysis routines+--+--------------------------------------------------------------------------------++module Foreign.CUDA.Analysis (++ module Foreign.CUDA.Analysis.Device,+ module Foreign.CUDA.Analysis.Occupancy++) where++import Foreign.CUDA.Analysis.Device+import Foreign.CUDA.Analysis.Occupancy+
+ src/Foreign/CUDA/Analysis/Device.chs view
@@ -0,0 +1,531 @@+--------------------------------------------------------------------------------+-- |+-- Module : Foreign.CUDA.Analysis.Device+-- Copyright : [2009..2023] Trevor L. McDonell+-- License : BSD+--+-- Common device functions+--+--------------------------------------------------------------------------------++module Foreign.CUDA.Analysis.Device (++ Compute(..), ComputeMode(..),+ DeviceProperties(..), DeviceResources(..), Allocation(..), PCI(..),+ deviceResources,+ describe++) where++#include "cbits/stubs.h"++import qualified Data.Set as Set+import Data.Set (Set)+import Data.Int+import Data.IORef+import Foreign.CUDA.Internal.Describe+import System.IO.Unsafe++import Debug.Trace+++-- |+-- The compute mode the device is currently in+--+#if CUDA_VERSION < 13000+{# enum CUcomputemode as ComputeMode+ { underscoreToCase }+ with prefix="CU_COMPUTEMODE" deriving (Eq, Show) #}+#else+{# enum cudaComputeMode as ComputeMode+ { }+ with prefix="cudaComputeMode" deriving (Eq, Show) #}+#endif++instance Describe ComputeMode where+ describe Default = "Multiple contexts are allowed on the device simultaneously"+#if CUDA_VERSION < 8000 || CUDA_VERSION >= 13000+ describe Exclusive = "Only one context used by a single thread can be present on this device at a time"+#endif+ describe Prohibited = "No contexts can be created on this device at this time"+ describe ExclusiveProcess = "Only one context used by a single process can be present on this device at a time"+++-- |+-- GPU compute capability, major and minor revision number respectively.+--+data Compute = Compute !Int !Int+ deriving Eq++instance Show Compute where+ show (Compute major minor) = show major ++ "." ++ show minor++instance Ord Compute where+ compare (Compute m1 n1) (Compute m2 n2) =+ case compare m1 m2 of+ EQ -> compare n1 n2+ x -> x++{--+cap :: Int -> Int -> Double+cap a 0 = fromIntegral a+cap a b = let a' = fromIntegral a in+ let b' = fromIntegral b in+ a' + b' / max 10 (10^ ((ceiling . logBase 10) b' :: Int))+--}++-- |+-- Some properties of a compute device. Originally, this mirrored+-- @struct cudaDeviceProp@ in CUDA, but since CUDA 13 some fields have been+-- removed from that struct, and this data type keeps them for backwards+-- compatibility.+--+-- There are more device "properties" than those listed in this data type; use+-- 'Foreign.CUDA.Driver.Device.attribute' to query them.+--+data DeviceProperties = DeviceProperties+ {+ deviceName :: !String -- ^ Identifier+ , computeCapability :: !Compute -- ^ Supported compute capability+ , totalGlobalMem :: !Int64 -- ^ Available global memory on the device in bytes+ , totalConstMem :: !Int64 -- ^ Available constant memory on the device in bytes+ , sharedMemPerBlock :: !Int64 -- ^ Available shared memory per block in bytes+ , regsPerBlock :: !Int -- ^ 32-bit registers per block+ , warpSize :: !Int -- ^ Warp size in threads (SIMD width)+ , maxThreadsPerBlock :: !Int -- ^ Maximum number of threads per block+#if CUDA_VERSION >= 4000+ , maxThreadsPerMultiProcessor :: !Int -- ^ Maximum number of threads per multiprocessor+#endif+ , maxBlockSize :: !(Int,Int,Int) -- ^ Maximum size of each dimension of a block+ , maxGridSize :: !(Int,Int,Int) -- ^ Maximum size of each dimension of a grid+#if CUDA_VERSION >= 3000+ , maxTextureDim1D :: !Int -- ^ Maximum texture dimensions+ , maxTextureDim2D :: !(Int,Int)+ , maxTextureDim3D :: !(Int,Int,Int)+#endif+ , clockRate :: !Int -- ^ Clock frequency in kilohertz+ , multiProcessorCount :: !Int -- ^ Number of multiprocessors on the device+ , memPitch :: !Int64 -- ^ Maximum pitch in bytes allowed by memory copies+#if CUDA_VERSION >= 4000+ , memBusWidth :: !Int -- ^ Global memory bus width in bits+ , memClockRate :: !Int -- ^ Peak memory clock frequency in kilohertz+#endif+ , textureAlignment :: !Int64 -- ^ Alignment requirement for textures+ , computeMode :: !ComputeMode+ , deviceOverlap :: !Bool -- ^ Device can concurrently copy memory and execute a kernel+#if CUDA_VERSION >= 3000+ , concurrentKernels :: !Bool -- ^ Device can possibly execute multiple kernels concurrently+ , eccEnabled :: !Bool -- ^ Device supports and has enabled error correction+#endif+#if CUDA_VERSION >= 4000+ , asyncEngineCount :: !Int -- ^ Number of asynchronous engines+ , cacheMemL2 :: !Int -- ^ Size of the L2 cache in bytes+ , pciInfo :: !PCI -- ^ PCI device information for the device+ , tccDriverEnabled :: !Bool -- ^ Whether this is a Tesla device using the TCC driver+#endif+ , kernelExecTimeoutEnabled :: !Bool -- ^ Whether there is a runtime limit on kernels+ , integrated :: !Bool -- ^ As opposed to discrete+ , canMapHostMemory :: !Bool -- ^ Device can use pinned memory+#if CUDA_VERSION >= 4000+ , unifiedAddressing :: !Bool -- ^ Device shares a unified address space with the host+#endif+#if CUDA_VERSION >= 5050+ , streamPriorities :: !Bool -- ^ Device supports stream priorities+#endif+#if CUDA_VERSION >= 6000+ , globalL1Cache :: !Bool -- ^ Device supports caching globals in L1 cache+ , localL1Cache :: !Bool -- ^ Device supports caching locals in L1 cache+ , managedMemory :: !Bool -- ^ Device supports allocating managed memory on this system+ , multiGPUBoard :: !Bool -- ^ Device is on a multi-GPU board+ , multiGPUBoardGroupID :: !Int -- ^ Unique identifier for a group of devices associated with the same board+#endif+#if CUDA_VERSION >= 8000+ , preemption :: !Bool -- ^ Device supports compute pre-emption+ , singleToDoublePerfRatio :: !Int -- ^ Ratio of single precision performance (in floating-point operations per second) to double precision performance+#endif+#if CUDA_VERSION >= 9000+ , cooperativeLaunch :: !Bool -- ^ Device supports launching cooperative kernels+ , cooperativeLaunchMultiDevice :: !Bool -- ^ Device can participate in cooperative multi-device kernels+#endif+ }+ deriving (Show)+++data PCI = PCI+ {+ busID :: !Int, -- ^ PCI bus ID of the device+ deviceID :: !Int, -- ^ PCI device ID+ domainID :: !Int -- ^ PCI domain ID+ }+ deriving (Show)+++-- GPU Hardware Resources+--+-- These are either taken from the CUDA occupancy calculator, or the CUDA+-- wikipedia entry: <https://en.wikipedia.org/wiki/CUDA#Version_features_and_specifications>+--+data Allocation = Warp | Block+ deriving Show++data DeviceResources = DeviceResources+ { threadsPerWarp :: !Int -- ^ Warp size+ , coresPerMP :: !Int -- ^ Number of SIMD arithmetic units per multiprocessor+ , warpsPerMP :: !Int -- ^ Maximum number of in-flight warps per multiprocessor+ , threadsPerMP :: !Int -- ^ Maximum number of in-flight threads on a multiprocessor+ , threadBlocksPerMP :: !Int -- ^ Maximum number of thread blocks resident on a multiprocessor+ , sharedMemPerMP :: !Int -- ^ Total amount of shared memory per multiprocessor (bytes)+ , maxSharedMemPerBlock :: !Int -- ^ Maximum amount of shared memory per thread block (bytes)+ , regFileSizePerMP :: !Int -- ^ Total number of registers in a multiprocessor+ , maxRegPerBlock :: !Int -- ^ Maximum number of registers per block+ , regAllocUnit :: !Int -- ^ Register allocation unit size+ , regAllocationStyle :: !Allocation -- ^ How multiprocessor resources are divided (register allocation granularity)+ , maxRegPerThread :: !Int -- ^ Maximum number of registers per thread+ , sharedMemAllocUnit :: !Int -- ^ Shared memory allocation unit size (bytes)+ , warpAllocUnit :: !Int -- ^ Warp allocation granularity+ , warpRegAllocUnit :: !Int -- ^ Warp register allocation granularity+ , maxGridsPerDevice :: !Int -- ^ Maximum number of resident grids per device (concurrent kernels)+ }+ deriving Show+++-- |+-- Extract some additional hardware resource limitations for a given device.+--+deviceResources :: DeviceProperties -> DeviceResources+deviceResources = resources . computeCapability+ where+ -- Sources:+ -- [1] https://github.com/NVIDIA/cuda-samples/blob/7b60178984e96bc09d066077d5455df71fee2a9f/Common/helper_cuda.h+ -- - for: coresPerMP (line 643 _ConvertSMVer2Cores)+ -- - for: architecture names (line 695 _ConvertSMVer2ArchName)+ -- [2] https://docs.nvidia.com/cuda/cuda-c-programming-guide/index.html#features-and-technical-specifications-technical-specifications-per-compute-capability+ -- - for: maxGridsPerDevice+ -- - archived here: https://web.archive.org/web/20250409220108/https://docs.nvidia.com/cuda/cuda-c-programming-guide/index.html#features-and-technical-specifications-technical-specifications-per-compute-capability+ -- - reproduced here: https://en.wikipedia.org/w/index.php?title=CUDA&oldid=1285775690#Technical_specification (note: link to specific page version)+ -- [3] NVidia Nsight Compute+ -- - for: the other fields+ -- - left top "Start Activity" -> "Occupancy Calculator" -> "Launch"; tab "GPU Data"+ --+ resources compute = case compute of+ Compute 1 0 -> resources (Compute 1 1) -- Tesla G80+ Compute 1 1 -> DeviceResources -- Tesla G8x+ { threadsPerWarp = 32+ , coresPerMP = 8+ , warpsPerMP = 24+ , threadsPerMP = 768+ , threadBlocksPerMP = 8+ , sharedMemPerMP = 16384+ , maxSharedMemPerBlock = 16384+ , regFileSizePerMP = 8192+ , maxRegPerBlock = 8192+ , regAllocUnit = 256+ , regAllocationStyle = Block+ , maxRegPerThread = 124+ , sharedMemAllocUnit = 512+ , warpAllocUnit = 2+ , warpRegAllocUnit = 256+ , maxGridsPerDevice = 1+ }+ Compute 1 2 -> resources (Compute 1 3) -- Tesla G9x+ Compute 1 3 -> (resources (Compute 1 1)) -- Tesla GT200+ { threadsPerMP = 1024+ , warpsPerMP = 32+ , regFileSizePerMP = 16384+ , maxRegPerBlock = 16384+ , regAllocUnit = 512+ }++ Compute 2 0 -> DeviceResources -- Fermi GF100+ { threadsPerWarp = 32+ , coresPerMP = 32+ , warpsPerMP = 48+ , threadsPerMP = 1536+ , threadBlocksPerMP = 8+ , sharedMemPerMP = 49152+ , maxSharedMemPerBlock = 49152+ , regFileSizePerMP = 32768+ , maxRegPerBlock = 32768+ , regAllocUnit = 64+ , regAllocationStyle = Warp+ , maxRegPerThread = 63+ , sharedMemAllocUnit = 128+ , warpAllocUnit = 2+ , warpRegAllocUnit = 64+ , maxGridsPerDevice = 16+ }+ Compute 2 1 -> (resources (Compute 2 0)) -- Fermi GF10x+ { coresPerMP = 48+ }++ Compute 3 0 -> DeviceResources -- Kepler GK10x+ { threadsPerWarp = 32+ , coresPerMP = 192+ , warpsPerMP = 64+ , threadsPerMP = 2048+ , threadBlocksPerMP = 16+ , sharedMemPerMP = 49152+ , maxSharedMemPerBlock = 49152+ , regFileSizePerMP = 65536+ , maxRegPerBlock = 65536+ , regAllocUnit = 256+ , regAllocationStyle = Warp+ , maxRegPerThread = 63+ , sharedMemAllocUnit = 256+ , warpAllocUnit = 4+ , warpRegAllocUnit = 256+ , maxGridsPerDevice = 16+ }+ Compute 3 2 -> (resources (Compute 3 5)) -- Jetson TK1+ { maxRegPerBlock = 32768+ , maxGridsPerDevice = 4+ }+ Compute 3 5 -> (resources (Compute 3 0)) -- Kepler GK11x+ { maxRegPerThread = 255+ , maxGridsPerDevice = 32+ }+ Compute 3 7 -> (resources (Compute 3 5)) -- Kepler GK21x+ { sharedMemPerMP = 114688+ , regFileSizePerMP = 131072+ }++ Compute 5 0 -> DeviceResources -- Maxwell GM10x+ { threadsPerWarp = 32+ , coresPerMP = 128+ , warpsPerMP = 64+ , threadsPerMP = 2048+ , threadBlocksPerMP = 32+ , sharedMemPerMP = 65536+ , maxSharedMemPerBlock = 49152+ , regFileSizePerMP = 65536+ , maxRegPerBlock = 65536+ , regAllocUnit = 256+ , regAllocationStyle = Warp+ , maxRegPerThread = 255+ , sharedMemAllocUnit = 256+ , warpAllocUnit = 4+ , warpRegAllocUnit = 256+ , maxGridsPerDevice = 32+ }+ Compute 5 2 -> (resources (Compute 5 0)) -- Maxwell GM20x+ { sharedMemPerMP = 98304+ , maxRegPerBlock = 32768 -- value from [3], wrong in [2]?+ , warpAllocUnit = 2+ }+ Compute 5 3 -> (resources (Compute 5 0)) -- Maxwell GM20B+ { maxRegPerBlock = 32768+ , warpAllocUnit = 2+ , maxGridsPerDevice = 16+ }++ Compute 6 0 -> DeviceResources -- Pascal GP100+ { threadsPerWarp = 32+ , coresPerMP = 64+ , warpsPerMP = 64+ , threadsPerMP = 2048+ , threadBlocksPerMP = 32+ , sharedMemPerMP = 65536+ , maxSharedMemPerBlock = 49152+ , regFileSizePerMP = 65536+ , maxRegPerBlock = 65536+ , regAllocUnit = 256+ , regAllocationStyle = Warp+ , maxRegPerThread = 255+ , sharedMemAllocUnit = 256+ , warpAllocUnit = 2+ , warpRegAllocUnit = 256+ , maxGridsPerDevice = 128+ }+ Compute 6 1 -> (resources (Compute 6 0)) -- Pascal GP10x+ { coresPerMP = 128+ , sharedMemPerMP = 98304+ , warpAllocUnit = 4+ , maxGridsPerDevice = 32+ }+ Compute 6 2 -> (resources (Compute 6 0)) -- Pascal GP10B+ { coresPerMP = 128+ -- Commit 4f75ea889c2ade2bd3eab377b51bb5bbd28bfbae changed warpsPerMP+ -- to 128, but [2] and [3] say 64 like CC 6.0; reverted back to 64 to+ -- match NVIDIA documentation.+ -- That commit also changed threadsPerMP (later mistakenly translated+ -- to threadBlocksPerMP in 9df19adec8efc9df761deab40cf04d27810d97d3)+ -- from 2048 to 4096, but again [2] and [3] retain 2048 so we keep it+ -- at that.+ , warpsPerMP = 64+ , maxRegPerBlock = 32768 -- value from [2], wrong in [3]?+ , warpAllocUnit = 4+ , maxGridsPerDevice = 16+ }++ Compute 7 0 -> DeviceResources -- Volta GV100+ { threadsPerWarp = 32+ , coresPerMP = 64+ , warpsPerMP = 64+ , threadsPerMP = 2048+ , threadBlocksPerMP = 32+ , sharedMemPerMP = 98304 -- of 128KB+ , maxSharedMemPerBlock = 98304+ , regFileSizePerMP = 65536+ , maxRegPerBlock = 65536+ , regAllocUnit = 256+ , regAllocationStyle = Warp+ , maxRegPerThread = 255+ , sharedMemAllocUnit = 256+ , warpAllocUnit = 4+ , warpRegAllocUnit = 256+ , maxGridsPerDevice = 128+ }++ Compute 7 2 -> (resources (Compute 7 0)) -- Volta GV10B+ { maxGridsPerDevice = 16+ , maxSharedMemPerBlock = 49152 -- unsure why this is here; [2] and [3] say still 98304+ }++ Compute 7 5 -> (resources (Compute 7 0)) -- Turing TU1xx+ { warpsPerMP = 32+ , threadBlocksPerMP = 16+ , threadsPerMP = 1024+ , maxGridsPerDevice = 128+ , sharedMemPerMP = 65536 -- of 96KB+ , maxSharedMemPerBlock = 65536+ }++ Compute 8 0 -> DeviceResources -- Ampere GA100+ { threadsPerWarp = 32+ , coresPerMP = 64+ , warpsPerMP = 64+ , threadsPerMP = 2048+ , threadBlocksPerMP = 32+ , sharedMemPerMP = 167936 -- of 192KB+ , maxSharedMemPerBlock = 167936+ , regFileSizePerMP = 65536+ , maxRegPerBlock = 65536+ , regAllocUnit = 256+ , regAllocationStyle = Warp+ , maxRegPerThread = 255+ , sharedMemAllocUnit = 128+ , warpAllocUnit = 4+ , warpRegAllocUnit = 256+ , maxGridsPerDevice = 128+ }+ Compute 8 6 -> (resources (Compute 8 0)) -- Ampere GA102+ { coresPerMP = 128+ , warpsPerMP = 48+ , threadsPerMP = 1536+ , threadBlocksPerMP = 16+ , sharedMemPerMP = 102400+ , maxSharedMemPerBlock = 102400+ }+ Compute 8 7 -> (resources (Compute 8 0)) -- Ampere+ { coresPerMP = 128+ , warpsPerMP = 48+ , threadsPerMP = 1536+ , threadBlocksPerMP = 16+ }+ Compute 8 9 -> (resources (Compute 8 0)) -- Ada+ { coresPerMP = 128+ , warpsPerMP = 48+ , threadsPerMP = 1536+ , threadBlocksPerMP = 24+ , sharedMemPerMP = 102400+ , maxSharedMemPerBlock = 102400+ }++ Compute 9 0 -> DeviceResources -- Hopper+ { threadsPerWarp = 32+ , coresPerMP = 128+ , warpsPerMP = 64+ , threadsPerMP = 2048+ , threadBlocksPerMP = 32+ , sharedMemPerMP = 233472+ , maxSharedMemPerBlock = 233472+ , regFileSizePerMP = 65536+ , maxRegPerBlock = 65536+ , regAllocUnit = 256+ , regAllocationStyle = Warp+ , maxRegPerThread = 255+ , sharedMemAllocUnit = 128+ , warpAllocUnit = 4+ , warpRegAllocUnit = 256+ , maxGridsPerDevice = 128+ }++ Compute 10 0 -> DeviceResources -- Blackwell+ { threadsPerWarp = 32+ , coresPerMP = 128+ , warpsPerMP = 64+ , threadsPerMP = 2048+ , threadBlocksPerMP = 32+ , sharedMemPerMP = 233472+ , maxSharedMemPerBlock = 233472+ , regFileSizePerMP = 65536+ , maxRegPerBlock = 65536+ , regAllocUnit = 256+ , regAllocationStyle = Warp+ , maxRegPerThread = 255+ , sharedMemAllocUnit = 128+ , warpAllocUnit = 4+ , warpRegAllocUnit = 256+ , maxGridsPerDevice = 128+ }+ Compute 10 1 -> (resources (Compute 10 0)) -- Blackwell+ { warpsPerMP = 48+ , threadsPerMP = 1536+ , threadBlocksPerMP = 24+ }++ Compute 12 0 -> DeviceResources -- Blackwell+ { threadsPerWarp = 32+ , coresPerMP = 128+ , warpsPerMP = 48+ , threadsPerMP = 1536+ , threadBlocksPerMP = 24+ , sharedMemPerMP = 102400+ , maxSharedMemPerBlock = 102400+ , regFileSizePerMP = 65536+ , maxRegPerBlock = 65536+ , regAllocUnit = 256+ , regAllocationStyle = Warp+ , maxRegPerThread = 255+ , sharedMemAllocUnit = 128+ , warpAllocUnit = 4+ , warpRegAllocUnit = 256+ , maxGridsPerDevice = 128+ }+++ -- Something might have gone wrong, or the library just needs to be+ -- updated for the next generation of hardware, in which case we just want+ -- to pick a sensible default and carry on.+ --+ -- This is slightly dodgy as the warning message is coming from pure code.+ -- However, it should be OK because all library functions run in IO, so it+ -- is likely the user code is as well.+ --+ _ -> case warningForCC compute of+ Just warning -> trace warning defaultResources+ Nothing -> defaultResources++ defaultResources = resources (Compute 6 0)++ -- All this logic is to ensure the warning is only shown once per unknown+ -- compute capability. This sounds not worth it, but in practice, it is:+ -- empirically, an unknown compute capability often leads to /screenfuls/+ -- of warnings in accelerate-llvm-ptx otherwise.+ {-# NOINLINE warningForCC #-}+ warningForCC :: Compute -> Maybe String+ warningForCC compute = unsafePerformIO $ do+ unseen <- atomicModifyIORef' warningShown $ \seen ->+ -- This is just one tree traversal; lookup-insert would be two traversals.+ let seen' = Set.insert compute seen+ in (seen', Set.size seen' > Set.size seen)+ return $ if unseen+ then Just $ unlines+ [ "*** Warning: Unknown CUDA device compute capability: " ++ show compute+ , "*** Please submit a bug report at https://github.com/tmcdonell/cuda/issues"+ , "*** (This warning will only be shown once for this compute capability)" ]+ else Nothing++ {-# NOINLINE warningShown #-}+ warningShown :: IORef (Set Compute)+ warningShown = unsafePerformIO $ newIORef mempty
+ src/Foreign/CUDA/Analysis/Occupancy.hs view
@@ -0,0 +1,229 @@+{-# LANGUAGE BangPatterns #-}+--------------------------------------------------------------------------------+-- |+-- Module : Foreign.CUDA.Analysis.Occupancy+-- Copyright : [2009..2023] Trevor L. McDonell+-- License : BSD+--+-- Occupancy calculations for CUDA kernels+--+-- <http://developer.download.nvidia.com/compute/cuda/3_0/sdk/docs/CUDA_Occupancy_calculator.xls>+--+-- /Determining Registers Per Thread and Shared Memory Per Block/+--+-- To determine the number of registers used per thread in your kernel, simply+-- compile the kernel code using the option+--+-- > --ptxas-options=-v+--+-- to nvcc. This will output information about register, local memory, shared+-- memory, and constant memory usage for each kernel in the @.cu@ file.+-- Alternatively, you can compile with the @-cubin@ option to nvcc. This will+-- generate a @.cubin@ file, which you can open in a text editor. Look for the+-- @code@ section with your kernel's name. Within the curly braces (@{ ... }@)+-- for that code block, you will see a line with @reg = X@, where @x@ is the+-- number of registers used by your kernel. You can also see the amount of+-- shared memory used as @smem = Y@. However, if your kernel declares any+-- external shared memory that is allocated dynamically, you will need to add+-- the number in the @.cubin@ file to the amount you dynamically allocate at run+-- time to get the correct shared memory usage.+--+-- __Warning__: Like the official Occupancy Calculator in NVidia Nsight+-- Compute, the calculator in this module does not support or consider Thread+-- Block Clusters+-- (<https://docs.nvidia.com/cuda/cuda-c-programming-guide/#thread-block-clusters>)+-- that have been introduced with compute capability 9.0 (Hopper). If you use+-- thread block clusters in your kernels, the results you get with the+-- functions in this module may not be accurate. Profile and measure.+--+-- /Notes About Occupancy/+--+-- Higher occupancy does not necessarily mean higher performance. If a kernel+-- is not bandwidth bound, then increasing occupancy will not necessarily+-- increase performance. If a kernel invocation is already running at least one+-- thread block per multiprocessor in the GPU, and it is bottlenecked by+-- computation and not by global memory accesses, then increasing occupancy may+-- have no effect. In fact, making changes just to increase occupancy can have+-- other effects, such as additional instructions, spills to local memory (which+-- is off chip), divergent branches, etc. As with any optimization, you should+-- experiment to see how changes affect the *wall clock time* of the kernel+-- execution. For bandwidth bound applications, on the other hand, increasing+-- occupancy can help better hide the latency of memory accesses, and therefore+-- improve performance.+--+--------------------------------------------------------------------------------+++module Foreign.CUDA.Analysis.Occupancy (++ Occupancy(..),+ occupancy, optimalBlockSize, optimalBlockSizeOf, maxResidentBlocks,+ incPow2, incWarp, decPow2, decWarp++) where++import Data.Ord+import Data.List++import Foreign.CUDA.Analysis.Device hiding ( maxSharedMemPerBlock )+++-- GPU Occupancy per multiprocessor+--+data Occupancy = Occupancy+ {+ activeThreads :: !Int, -- ^ Active threads per multiprocessor+ activeThreadBlocks :: !Int, -- ^ Active thread blocks per multiprocessor+ activeWarps :: !Int, -- ^ Active warps per multiprocessor+ occupancy100 :: !Double -- ^ Occupancy of each multiprocessor (percent)+ }+ deriving (Eq, Ord, Show)+++-- |+-- Calculate occupancy data for a given GPU and kernel resource usage+--+{-# INLINEABLE occupancy #-}+occupancy+ :: DeviceProperties -- ^ Properties of the card in question+ -> Int -- ^ Threads per block+ -> Int -- ^ Registers per thread+ -> Int -- ^ Shared memory per block (bytes)+ -> Occupancy+occupancy !dev !threads !regs !smem+ = Occupancy at ab aw oc+ where+ at = ab * threads+ aw = ab * limitWarpsPerBlock+ ab = minimum [limitDueToWarps, limitDueToRegs, limitDueToSMem]+ oc = 100 * fromIntegral aw / fromIntegral (warpsPerMP gpu)++ ceiling' = ceiling :: Double -> Int+ floor' = floor :: Double -> Int+ ceilingBy x s = s * ceiling' (fromIntegral x / fromIntegral s)+ floorBy x s = s * floor' (fromIntegral x / fromIntegral s)++ -- Physical resources+ --+ gpu = deviceResources dev+ maxSharedMemPerBlock = fromIntegral (sharedMemPerBlock dev) -- 2080Ti reports 48KB, but should be 64KB !++ -- Allocated resource limits+ --+ limitWarpsPerBlock = ceiling' (fromIntegral threads / fromIntegral (threadsPerWarp gpu))+ -- limitWarpsPerSM = warpsPerMP gpu++ limitRegsPerBlock = case regAllocationStyle gpu of+ Block -> ((limitWarpsPerBlock `ceilingBy` warpAllocUnit gpu) * regs * threadsPerWarp gpu) `ceilingBy` regAllocUnit gpu+ Warp -> limitWarpsPerBlock+ limitRegsPerSM = case regAllocationStyle gpu of+ Block -> maxRegPerBlock gpu+ Warp -> (maxRegPerBlock gpu `div` ((regs * threadsPerWarp gpu) `ceilingBy` warpRegAllocUnit gpu)) `floorBy` warpAllocUnit gpu++ limitSMemPerBlock = smem `ceilingBy` sharedMemAllocUnit gpu+ -- limitSMemPerSM = maxSharedMemPerBlock gpu++ -- Maximum thread blocks per multiprocessor+ --+ limitDueToWarps = threadBlocksPerMP gpu `min` (warpsPerMP gpu `div` limitWarpsPerBlock)+ limitDueToRegs+ | regs > maxRegPerThread gpu = 0+ | regs > 0 = (limitRegsPerSM `div` limitRegsPerBlock) * (regFileSizePerMP gpu `div` maxRegPerBlock gpu)+ | otherwise = threadBlocksPerMP gpu++ limitDueToSMem+ | smem > maxSharedMemPerBlock = 0+ | smem > 0 = sharedMemPerMP gpu `div` limitSMemPerBlock+ | otherwise = threadBlocksPerMP gpu+++-- |+-- Optimise multiprocessor occupancy as a function of thread block size and+-- resource usage. This returns the smallest satisfying block size in increments+-- of a single warp.+--+{-# INLINEABLE optimalBlockSize #-}+optimalBlockSize+ :: DeviceProperties -- ^ Architecture to optimise for+ -> (Int -> Int) -- ^ Register count as a function of thread block size+ -> (Int -> Int) -- ^ Shared memory usage (bytes) as a function of thread block size+ -> (Int, Occupancy)+optimalBlockSize dev = optimalBlockSizeOf dev (decWarp dev)+++-- |+-- As 'optimalBlockSize', but with a generator that produces the specific thread+-- block sizes that should be tested. The generated list can produce values in+-- any order, but the last satisfying block size will be returned. Hence, values+-- should be monotonically decreasing to return the smallest block size yielding+-- maximum occupancy, and vice-versa.+--+{-# INLINEABLE optimalBlockSizeOf #-}+optimalBlockSizeOf+ :: DeviceProperties -- ^ Architecture to optimise for+ -> [Int] -- ^ Thread block sizes to consider+ -> (Int -> Int) -- ^ Register count as a function of thread block size+ -> (Int -> Int) -- ^ Shared memory usage (bytes) as a function of thread block size+ -> (Int, Occupancy)+optimalBlockSizeOf !dev !threads !freg !fsmem+ = maximumBy (comparing (occupancy100 . snd))+ $ [ (t, occupancy dev t (freg t) (fsmem t)) | t <- threads ]+++-- | Increments in powers-of-two, over the range of supported thread block sizes+-- for the given device.+--+{-# INLINEABLE incPow2 #-}+incPow2 :: DeviceProperties -> [Int]+incPow2 !dev = map ((2::Int)^) [lb, lb+1 .. ub]+ where+ round' = round :: Double -> Int+ lb = round' . logBase 2 . fromIntegral $ warpSize dev+ ub = round' . logBase 2 . fromIntegral $ maxThreadsPerBlock dev++-- | Decrements in powers-of-two, over the range of supported thread block sizes+-- for the given device.+--+{-# INLINEABLE decPow2 #-}+decPow2 :: DeviceProperties -> [Int]+decPow2 !dev = map ((2::Int)^) [ub, ub-1 .. lb]+ where+ round' = round :: Double -> Int+ lb = round' . logBase 2 . fromIntegral $ warpSize dev+ ub = round' . logBase 2 . fromIntegral $ maxThreadsPerBlock dev++-- | Decrements in the warp size of the device, over the range of supported+-- thread block sizes.+--+{-# INLINEABLE decWarp #-}+decWarp :: DeviceProperties -> [Int]+decWarp !dev = [block, block-warp .. warp]+ where+ !warp = warpSize dev+ !block = maxThreadsPerBlock dev++-- | Increments in the warp size of the device, over the range of supported+-- thread block sizes.+--+{-# INLINEABLE incWarp #-}+incWarp :: DeviceProperties -> [Int]+incWarp !dev = [warp, 2*warp .. block]+ where+ warp = warpSize dev+ block = maxThreadsPerBlock dev+++-- |+-- Determine the maximum number of CTAs that can be run simultaneously for a+-- given kernel / device combination.+--+{-# INLINEABLE maxResidentBlocks #-}+maxResidentBlocks+ :: DeviceProperties -- ^ Properties of the card in question+ -> Int -- ^ Threads per block+ -> Int -- ^ Registers per thread+ -> Int -- ^ Shared memory per block (bytes)+ -> Int -- ^ Maximum number of resident blocks+maxResidentBlocks !dev !thds !regs !smem =+ multiProcessorCount dev * activeThreadBlocks (occupancy dev thds regs smem)+
+ src/Foreign/CUDA/Driver.hs view
@@ -0,0 +1,246 @@+--------------------------------------------------------------------------------+-- |+-- Module : Foreign.CUDA.Driver+-- Copyright : [2009..2023] Trevor L. McDonell+-- License : BSD+--+-- This module defines an interface to the CUDA driver API. The Driver API+-- is a lower-level interface to CUDA devices than that provided by the+-- Runtime API. Using the Driver API, the programmer must deal explicitly+-- with operations such as initialisation, context management, and loading+-- (kernel) modules. Although more difficult to use initially, the Driver+-- API provides more control over how CUDA is used. Furthermore, since it+-- does not require compiling and linking the program with 'nvcc', the+-- Driver API provides better inter-language compatibility.+--+-- The following is a short tutorial on using the Driver API. The steps can+-- be copied into a file, or run directly in @ghci@, in which case @ghci@+-- should be launched with the option @-fno-ghci-sandbox@. This is because+-- CUDA maintains CPU-local state, so operations should always be run from+-- a bound thread.+--+--+-- [/Using the Driver API/]+--+-- Before any operation can be performed, the Driver API must be+-- initialised:+--+-- >>> import Foreign.CUDA.Driver+-- >>> initialise []+--+-- Next, we must select a GPU that we will execute operations on. Each GPU+-- is assigned a unique identifier (beginning at zero). We can get a handle+-- to a compute device at a given ordinal using the 'device' operation.+-- Given a device handle, we can query some properties of that device using+-- 'props'. The number of available CUDA-capable devices is given via+-- 'count'. For example:+--+-- >>> count+-- 1+-- >>> dev0 <- device 0+-- >>> props dev0+-- DeviceProperties {deviceName = "GeForce GT 650M", computeCapability = 3.0, ...}+--+-- This package also includes the executable 'nvidia-device-query', which when+-- executed displays the key properties of all available devices. See+-- "Foreign.CUDA.Driver.Device" for additional operations to query the+-- capabilities or status of a device.+--+-- Once you have chosen a device to use, the next step is to create a CUDA+-- context. A context is associated with a particular device, and all+-- operations, such as memory allocation and kernel execution, take place+-- with respect to that context. For example, to 'create' a new execution+-- context on CUDA device 0:+--+-- >>> ctx <- create dev0 []+--+-- The second argument is a set of 'ContextFlag's which control how the+-- context behaves in various situations, for example, whether or not the+-- CPU should actively spin when waiting for results from the GPU+-- ('SchedSpin'), or to yield control to other threads instead+-- ('SchedYield').+--+-- The newly created context is now the /active/ context, and all+-- subsequent operations take place within that context. More than one+-- context can be created per device, but resources, such as memory+-- allocated in the GPU, are unique to each context. The module+-- "Foreign.CUDA.Driver.Context" contains operations for managing multiple+-- contexts. Some devices allow data to be shared between contexts without+-- copying, see "Foreign.CUDA.Driver.Context.Peer" for more information.+--+-- Once the context is no longer needed, it should be 'destroy'ed in order+-- to free up any resources that were allocated to it.+--+-- >>> destroy ctx+--+-- Each device also has a unique context which is used by the Runtime API.+-- This context can be accessed with the module+-- "Foreign.CUDA.Driver.Context.Primary".+--+--+-- [/Executing kernels onto the GPU/]+--+-- Once the Driver API is initialised and an execution context is created+-- on the GPU, we can begin to interact with it.+--+-- At an example, we'll step through executing the CUDA equivalent of the+-- following Haskell function, which element-wise adds the elements of two+-- arrays:+--+-- >>> vecAdd xs ys = zipWith (+) xs ys+--+-- The following CUDA kernel can be used to implement this on the GPU:+--+-- > extern "C" __global__ void vecAdd(float *xs, float *ys, float *zs, int N)+-- > {+-- > int ix = blockIdx.x * blockDim.x + threadIdx.x;+-- >+-- > if ( ix < N ) {+-- > zs[ix] = xs[ix] + ys[ix];+-- > }+-- > }+--+-- Here, the @__global__@ keyword marks the function as a kernel that+-- should be computed on the GPU in data parallel. When we execute this+-- function on the GPU, (at least) /N/ threads will execute /N/ individual+-- instances of the kernel function @vecAdd@. Each thread will operate on+-- a single element of each input array to create a single value in the+-- result. See the CUDA programming guide for more details.+--+-- We can save this to a file @vector_add.cu@, and compile it using @nvcc@+-- into a form that we can then load onto the GPU and execute:+--+-- > $ nvcc --ptx vector_add.cu+--+-- The module "Foreign.CUDA.Driver.Module" contains functions for loading+-- the resulting .ptx file (or .cubin files) into the running program.+--+-- >>> mdl <- loadFile "vector_add.ptx"+--+-- Once finished with the module, it is also a good idea to 'unload' it.+--+-- Modules may export kernel functions, global variables, and texture+-- references. Before we can execute our function, we need to look it up in+-- the module by name.+--+-- >>> vecAdd <- getFun mdl "vecAdd"+--+-- Given this reference to our kernel function, we are almost ready to+-- execute it on the device using 'launchKernel', but first, we must create+-- some data that we can execute the function on.+--+--+-- [/Transferring data to and from the GPU/]+--+-- GPUs typically have their own memory which is separate from the CPU's+-- memory, and we need to explicitly copy data back and forth between these+-- two regions. The module "Foreign.CUDA.Driver.Marshal" provides functions+-- for allocating memory on the GPU, and copying data between the CPU and+-- GPU, as well as directly between multiple GPUs.+--+-- For simplicity, we'll use standard Haskell lists for our input and+-- output data structure. Note however that this will have significantly+-- lower effective bandwidth than reading a single contiguous region of+-- memory, so for most practical purposes you will want to use some kind of+-- unboxed array.+--+-- >>> let xs = [1..1024] :: [Float]+-- >>> let ys = [2,4..2048] :: [Float]+--+-- In CUDA, like C, all memory management is explicit, and arrays on the+-- device must be explicitly allocated and freed. As mentioned previously,+-- data transfer is also explicit. However, we do provide convenience+-- functions for combined allocation and marshalling, as well as bracketed+-- operations.+--+-- >>> xs_dev <- newListArray xs+-- >>> ys_dev <- newListArray ys+-- >>> zs_dev <- mallocArray 1024 :: IO (DevicePtr Float)+--+-- After executing the kernel (see next section), we transfer the result+-- back to the host, and free the memory that was allocated on the GPU.+--+-- >>> zs <- peekListArray 1024 zs_dev+-- >>> free xs_dev+-- >>> free ys_dev+-- >>> free zs_dev+--+--+-- [/Piecing it all together/]+--+-- Finally, we have everything in place to execute our operation on the+-- GPU. Launching a kernel on the GPU consists of creating many threads on+-- the GPU which all execute the same function, and each thread has+-- a unique identifier in the grid/block hierarchy which can be used to+-- identify exactly which element this thread should process (the+-- @blockIdx@ and @threadIdx@ parameters that we saw earlier,+-- respectively).+--+-- To execute our function, we will use a grid of 4 blocks, each containing+-- 256 threads. Thus, a total of 1024 threads will be launched, which will+-- each compute a single element of the output array (recall that our input+-- arrays each have 1024 elements). The module+-- "Foreign.CUDA.Analysis.Occupancy" contains functions to help determine+-- the ideal thread block size for a given kernel and GPU combination.+--+-- >>> launchKernel vecAdd (4,1,1) (256,1,1) 0 Nothing [VArg xs_dev, VArg ys_dev, VArg zs_dev, IArg 1024]+--+-- Note that kernel execution is asynchronous, so we should also wait for+-- the operation to complete before attempting to read the results back.+--+-- >>> sync+--+-- And that's it!+--+--+-- [/Next steps/]+--+-- As mentioned at the end of the previous section, kernels on the GPU are+-- executed asynchronously with respect to the host, and other operations+-- such as data transfers can also be executed asynchronously. This allows+-- the CPU to continue doing other work while the GPU is busy.+-- 'Foreign.CUDA.Driver.Event.Event's can be used to check whether an+-- operation has completed yet.+--+-- It is also possible to execute multiple kernels or data transfers+-- concurrently with each other, by assigning those operations to different+-- execution 'Foreign.CUDA.Driver.Stream.Stream's. Used in conjunction with+-- 'Foreign.CUDA.Driver.Event.Event's, operations will be scheduled+-- efficiently only once all dependencies (in the form of+-- 'Foreign.CUDA.Driver.Event.Event's) have been cleared.+--+-- See "Foreign.CUDA.Driver.Event" and "Foreign.CUDA.Driver.Stream" for+-- more information on this topic.+--+--------------------------------------------------------------------------------++module Foreign.CUDA.Driver (++ module Foreign.CUDA.Ptr,+ module Foreign.CUDA.Driver.Context,+ module Foreign.CUDA.Driver.Device,+ module Foreign.CUDA.Driver.Error,+ module Foreign.CUDA.Driver.Exec,+ module Foreign.CUDA.Driver.Marshal,+ module Foreign.CUDA.Driver.Module,+ module Foreign.CUDA.Driver.Unified,+ module Foreign.CUDA.Driver.Utils++) where++-- If we don't import everything from a module below, the generated haddocks+-- will not have the convenient link to a module, but instead enumerate+-- documentation for everything which was imported. This, unfortunately, looks+-- like garbage, so it would be nice to find a better solution.+-- -- TLM 2018-11-18+--+import Foreign.CUDA.Ptr+import Foreign.CUDA.Driver.Context hiding ( device )+import Foreign.CUDA.Driver.Device+import Foreign.CUDA.Driver.Error+import Foreign.CUDA.Driver.Exec+import Foreign.CUDA.Driver.Marshal+import Foreign.CUDA.Driver.Module+import Foreign.CUDA.Driver.Unified+import Foreign.CUDA.Driver.Utils+
+ src/Foreign/CUDA/Driver/Context.hs view
@@ -0,0 +1,23 @@+--------------------------------------------------------------------------------+-- |+-- Module : Foreign.CUDA.Driver.Context+-- Copyright : [2009..2023] Trevor L. McDonell+-- License : BSD+--+-- Context management for low-level driver interface+--+--------------------------------------------------------------------------------+++module Foreign.CUDA.Driver.Context (++ module Foreign.CUDA.Driver.Context.Base,+ module Foreign.CUDA.Driver.Context.Config,+ module Foreign.CUDA.Driver.Context.Peer,++) where++import Foreign.CUDA.Driver.Context.Base+import Foreign.CUDA.Driver.Context.Config+import Foreign.CUDA.Driver.Context.Peer+
+ src/Foreign/CUDA/Driver/Context/Base.chs view
@@ -0,0 +1,241 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE TemplateHaskell #-}+#ifdef USE_EMPTY_CASE+{-# LANGUAGE EmptyCase #-}+#endif+--------------------------------------------------------------------------------+-- |+-- Module : Foreign.CUDA.Driver.Context.Base+-- Copyright : [2009..2023] Trevor L. McDonell+-- License : BSD+--+-- Context management for the low-level driver interface+--+--------------------------------------------------------------------------------++module Foreign.CUDA.Driver.Context.Base (++ -- * Context Management+ Context(..), ContextFlag(..),+ create, destroy, device, pop, push, sync, get, set,++ -- Deprecated in CUDA-4.0+ attach, detach,++) where++#include "cbits/stubs.h"+{# context lib="cuda" #}++-- Friends+import Foreign.CUDA.Driver.Device ( Device(..) )+import Foreign.CUDA.Driver.Error+import Foreign.CUDA.Internal.C2HS++-- System+import Foreign+import Foreign.C+import Control.Monad ( liftM )+++--------------------------------------------------------------------------------+-- Data Types+--------------------------------------------------------------------------------++-- |+-- A device context+--+newtype Context = Context { useContext :: {# type CUcontext #}}+ deriving (Eq, Show)+++-- |+-- Context creation flags+--+{# enum CUctx_flags as ContextFlag+ { underscoreToCase }+ with prefix="CU_CTX" deriving (Eq, Show, Bounded) #}+++#if CUDA_VERSION >= 4000+{-# DEPRECATED attach, detach "as of CUDA-4.0" #-}+{-# DEPRECATED BlockingSync "use SchedBlockingSync instead" #-}+#endif+++--------------------------------------------------------------------------------+-- Context management+--------------------------------------------------------------------------------++-- |+-- Create a new CUDA context and associate it with the calling thread. The+-- context is created with a usage count of one, and the caller of 'create'+-- must call 'destroy' when done using the context. If a context is already+-- current to the thread, it is supplanted by the newly created context and+-- must be restored by a subsequent call to 'pop'.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__CTX.html#group__CUDA__CTX_1g65dc0012348bc84810e2103a40d8e2cf>+--+{-# INLINEABLE create #-}+create :: Device -> [ContextFlag] -> IO Context+create !dev !flags = resultIfOk =<< cuCtxCreate flags dev++{-# INLINE cuCtxCreate #-}+{# fun unsafe cuCtxCreate+ { alloca- `Context' peekCtx*+ , combineBitMasks `[ContextFlag]'+ , useDevice `Device' } -> `Status' cToEnum #}+ where peekCtx = liftM Context . peek+++-- |+-- Increments the usage count of the context. API: no context flags are+-- currently supported, so this parameter must be empty.+--+{-# INLINEABLE attach #-}+attach :: Context -> [ContextFlag] -> IO ()+attach !ctx !flags = nothingIfOk =<< cuCtxAttach ctx flags++{-# INLINE cuCtxAttach #-}+{# fun unsafe cuCtxAttach+ { withCtx* `Context'+ , combineBitMasks `[ContextFlag]' } -> `Status' cToEnum #}+ where withCtx = with . useContext+++-- |+-- Detach the context, and destroy if no longer used+--+{-# INLINEABLE detach #-}+detach :: Context -> IO ()+detach !ctx = nothingIfOk =<< cuCtxDetach ctx++{-# INLINE cuCtxDetach #-}+{# fun unsafe cuCtxDetach+ { useContext `Context' } -> `Status' cToEnum #}+++-- |+-- Destroy the specified context, regardless of how many threads it is+-- current to. The context will be 'pop'ed from the current thread's+-- context stack, but if it is current on any other threads it will remain+-- current to those threads, and attempts to access it will result in an+-- error.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__CTX.html#group__CUDA__CTX_1g27a365aebb0eb548166309f58a1e8b8e>+--+{-# INLINEABLE destroy #-}+destroy :: Context -> IO ()+destroy !ctx = nothingIfOk =<< cuCtxDestroy ctx++{-# INLINE cuCtxDestroy #-}+{# fun unsafe cuCtxDestroy+ { useContext `Context' } -> `Status' cToEnum #}+++-- |+-- Return the context bound to the calling CPU thread.+--+-- Requires CUDA-4.0.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__CTX.html#group__CUDA__CTX_1g8f13165846b73750693640fb3e8380d0>+--+{-# INLINEABLE get #-}+get :: IO (Maybe Context)+#if CUDA_VERSION < 4000+get = requireSDK 'get 4.0+#else+get = resultIfOk =<< cuCtxGetCurrent++{-# INLINE cuCtxGetCurrent #-}+{# fun unsafe cuCtxGetCurrent+ { alloca- `Maybe Context' peekCtx* } -> `Status' cToEnum #}+ where peekCtx = liftM (nothingIfNull Context) . peek+#endif+++-- |+-- Bind the specified context to the calling thread.+--+-- Requires CUDA-4.0.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__CTX.html#group__CUDA__CTX_1gbe562ee6258b4fcc272ca6478ca2a2f7>+--+{-# INLINEABLE set #-}+set :: Context -> IO ()+#if CUDA_VERSION < 4000+set _ = requireSDK 'set 4.0+#else+set !ctx = nothingIfOk =<< cuCtxSetCurrent ctx++{-# INLINE cuCtxSetCurrent #-}+{# fun unsafe cuCtxSetCurrent+ { useContext `Context' } -> `Status' cToEnum #}+#endif+++-- |+-- Return the device of the currently active context+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__CTX.html#group__CUDA__CTX_1g4e84b109eba36cdaaade167f34ae881e>+--+{-# INLINEABLE device #-}+device :: IO Device+device = resultIfOk =<< cuCtxGetDevice++{-# INLINE cuCtxGetDevice #-}+{# fun unsafe cuCtxGetDevice+ { alloca- `Device' dev* } -> `Status' cToEnum #}+ where dev = liftM Device . peekIntConv+++-- |+-- Pop the current CUDA context from the CPU thread. The context may then+-- be attached to a different CPU thread by calling 'push'.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__CTX.html#group__CUDA__CTX_1g2fac188026a062d92e91a8687d0a7902>+--+{-# INLINEABLE pop #-}+pop :: IO Context+pop = resultIfOk =<< cuCtxPopCurrent++{-# INLINE cuCtxPopCurrent #-}+{# fun unsafe cuCtxPopCurrent+ { alloca- `Context' peekCtx* } -> `Status' cToEnum #}+ where peekCtx = liftM Context . peek+++-- |+-- Push the given context onto the CPU's thread stack of current contexts.+-- The specified context becomes the CPU thread's current context, so all+-- operations that operate on the current context are affected.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__CTX.html#group__CUDA__CTX_1gb02d4c850eb16f861fe5a29682cc90ba>+--+{-# INLINEABLE push #-}+push :: Context -> IO ()+push !ctx = nothingIfOk =<< cuCtxPushCurrent ctx++{-# INLINE cuCtxPushCurrent #-}+{# fun unsafe cuCtxPushCurrent+ { useContext `Context' } -> `Status' cToEnum #}+++-- |+-- Block until the device has completed all preceding requests. If the+-- context was created with the 'SchedBlockingSync' flag, the CPU thread+-- will block until the GPU has finished its work.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__CTX.html#group__CUDA__CTX_1g7a54725f28d34b8c6299f0c6ca579616>+--+{-# INLINEABLE sync #-}+sync :: IO ()+sync = nothingIfOk =<< cuCtxSynchronize++{-# INLINE cuCtxSynchronize #-}+{# fun cuCtxSynchronize+ { } -> `Status' cToEnum #}+
+ src/Foreign/CUDA/Driver/Context/Config.chs view
@@ -0,0 +1,297 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE TemplateHaskell #-}+#ifdef USE_EMPTY_CASE+{-# LANGUAGE EmptyCase #-}+#endif+--------------------------------------------------------------------------------+-- |+-- Module : Foreign.CUDA.Driver.Context.Config+-- Copyright : [2009..2023] Trevor L. McDonell+-- License : BSD+--+-- Context configuration for the low-level driver interface+--+--------------------------------------------------------------------------------++module Foreign.CUDA.Driver.Context.Config (++ -- * Context configuration+ getFlags,++ -- ** Resource limits+ Limit(..),+ getLimit, setLimit,++ -- ** Cache+ Cache(..),+ getCache, setCache,++ -- ** Shared memory+ SharedMem(..),+ getSharedMem, setSharedMem,++ -- ** Streams+ StreamPriority,+ getStreamPriorityRange,++) where++#include "cbits/stubs.h"+{# context lib="cuda" #}++-- Friends+import Foreign.CUDA.Driver.Context.Base+import Foreign.CUDA.Driver.Error+import Foreign.CUDA.Internal.C2HS+import Foreign.CUDA.Driver.Stream ( Stream, StreamPriority )++-- System+import Control.Monad+import Foreign+import Foreign.C+++--------------------------------------------------------------------------------+-- Data Types+--------------------------------------------------------------------------------++-- |+-- Device limits flags+--+#if CUDA_VERSION < 3010+data Limit+#else+{# enum CUlimit_enum as Limit+ { underscoreToCase }+ with prefix="CU_LIMIT" deriving (Eq, Show) #}+#endif+++-- |+-- Device cache configuration preference+--+#if CUDA_VERSION < 3020+data Cache+#else+{# enum CUfunc_cache_enum as Cache+ { underscoreToCase }+ with prefix="CU_FUNC_CACHE" deriving (Eq, Show) #}+#endif+++-- |+-- Device shared memory configuration preference+--+#if CUDA_VERSION < 4020+data SharedMem+#else+{# enum CUsharedconfig as SharedMem+ { underscoreToCase }+ with prefix="CU_SHARED_MEM_CONFIG" deriving (Eq, Show) #}+#endif+++--------------------------------------------------------------------------------+-- Context configuration+--------------------------------------------------------------------------------++-- |+-- Return the flags that were used to create the current context.+--+-- Requires CUDA-7.0+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__CTX.html#group__CUDA__CTX_1gf81eef983c1e3b2ef4f166d7a930c86d>+--+{-# INLINEABLE getFlags #-}+getFlags :: IO [ContextFlag]+#if CUDA_VERSION < 7000+getFlags = requireSDK 'getFlags 7.0+#else+getFlags = resultIfOk =<< cuCtxGetFlags++{-# INLINE cuCtxGetFlags #-}+{# fun unsafe cuCtxGetFlags+ { alloca- `[ContextFlag]' peekFlags* } -> `Status' cToEnum #}+ where+ peekFlags = liftM extractBitMasks . peek+#endif+++-- |+-- Query compute 2.0 call stack limits.+--+-- Requires CUDA-3.1.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__CTX.html#group__CUDA__CTX_1g9f2d47d1745752aa16da7ed0d111b6a8>+--+{-# INLINEABLE getLimit #-}+getLimit :: Limit -> IO Int+#if CUDA_VERSION < 3010+getLimit _ = requireSDK 'getLimit 3.1+#else+getLimit !l = resultIfOk =<< cuCtxGetLimit l++{-# INLINE cuCtxGetLimit #-}+{# fun unsafe cuCtxGetLimit+ { alloca- `Int' peekIntConv*+ , cFromEnum `Limit' } -> `Status' cToEnum #}+#endif+++-- |+-- Specify the size of the call stack, for compute 2.0 devices.+--+-- Requires CUDA-3.1.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__CTX.html#group__CUDA__CTX_1g0651954dfb9788173e60a9af7201e65a>+--+{-# INLINEABLE setLimit #-}+setLimit :: Limit -> Int -> IO ()+#if CUDA_VERSION < 3010+setLimit _ _ = requireSDK 'setLimit 3.1+#else+setLimit !l !n = nothingIfOk =<< cuCtxSetLimit l n++{-# INLINE cuCtxSetLimit #-}+{# fun unsafe cuCtxSetLimit+ { cFromEnum `Limit'+ , `Int' } -> `Status' cToEnum #}+#endif+++-- |+-- On devices where the L1 cache and shared memory use the same hardware+-- resources, this function returns the preferred cache configuration for+-- the current context.+--+-- Requires CUDA-3.2.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__CTX.html#group__CUDA__CTX_1g40b6b141698f76744dea6e39b9a25360>+--+{-# INLINEABLE getCache #-}+getCache :: IO Cache+#if CUDA_VERSION < 3020+getCache = requireSDK 'getCache 3.2+#else+getCache = resultIfOk =<< cuCtxGetCacheConfig++{-# INLINE cuCtxGetCacheConfig #-}+{# fun unsafe cuCtxGetCacheConfig+ { alloca- `Cache' peekEnum* } -> `Status' cToEnum #}+#endif+++-- |+-- On devices where the L1 cache and shared memory use the same hardware+-- resources, this sets the preferred cache configuration for the current+-- context. This is only a preference.+--+-- Any function configuration set via+-- 'Foreign.CUDA.Driver.Exec.setCacheConfigFun' will be preferred over this+-- context-wide setting.+--+-- Requires CUDA-3.2.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__CTX.html#group__CUDA__CTX_1g54699acf7e2ef27279d013ca2095f4a3>+--+{-# INLINEABLE setCache #-}+setCache :: Cache -> IO ()+#if CUDA_VERSION < 3020+setCache _ = requireSDK 'setCache 3.2+#else+setCache !c = nothingIfOk =<< cuCtxSetCacheConfig c++{-# INLINE cuCtxSetCacheConfig #-}+{# fun unsafe cuCtxSetCacheConfig+ { cFromEnum `Cache' } -> `Status' cToEnum #}+#endif+++-- |+-- Return the current size of the shared memory banks in the current+-- context. On devices with configurable shared memory banks,+-- 'setSharedMem' can be used to change the configuration, so that+-- subsequent kernel launches will by default us the new bank size. On+-- devices without configurable shared memory, this function returns the+-- fixed bank size of the hardware.+--+-- Requires CUDA-4.2+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__CTX.html#group__CUDA__CTX_1g17153a1b8b8c756f7ab8505686a4ad74>+--+{-# INLINEABLE getSharedMem #-}+getSharedMem :: IO SharedMem+#if CUDA_VERSION < 4020+getSharedMem = requireSDK 'getSharedMem 4.2+#else+getSharedMem = resultIfOk =<< cuCtxGetSharedMemConfig++{-# INLINE cuCtxGetSharedMemConfig #-}+{# fun unsafe cuCtxGetSharedMemConfig+ { alloca- `SharedMem' peekEnum*+ } -> `Status' cToEnum #}+#endif+++-- |+-- On devices with configurable shared memory banks, this function will set+-- the context's shared memory bank size that will be used by default for+-- subsequent kernel launches.+--+-- Changing the shared memory configuration between launches may insert+-- a device synchronisation.+--+-- Shared memory bank size does not affect shared memory usage or kernel+-- occupancy, but may have major effects on performance. Larger bank sizes+-- allow for greater potential bandwidth to shared memory, but change the+-- kinds of accesses which result in bank conflicts.+--+-- Requires CUDA-4.2+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__CTX.html#group__CUDA__CTX_1g2574235fa643f8f251bf7bc28fac3692>+--+{-# INLINEABLE setSharedMem #-}+setSharedMem :: SharedMem -> IO ()+#if CUDA_VERSION < 4020+setSharedMem _ = requireSDK 'setSharedMem 4.2+#else+setSharedMem !c = nothingIfOk =<< cuCtxSetSharedMemConfig c++{-# INLINE cuCtxSetSharedMemConfig #-}+{# fun unsafe cuCtxSetSharedMemConfig+ { cFromEnum `SharedMem' } -> `Status' cToEnum #}+#endif++++-- |+-- Returns the numerical values that correspond to the greatest and least+-- priority execution streams in the current context respectively. Stream+-- priorities follow the convention that lower numerical numbers correspond+-- to higher priorities. The range of meaningful stream priorities is given+-- by the inclusive range [greatestPriority,leastPriority].+--+-- Requires CUDA-5.5.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__CTX.html#group__CUDA__CTX_1g137920ab61a71be6ce67605b9f294091>+--+{-# INLINEABLE getStreamPriorityRange #-}+getStreamPriorityRange :: IO (StreamPriority, StreamPriority)+#if CUDA_VERSION < 5050+getStreamPriorityRange = requireSDK 'getStreamPriorityRange 5.5+#else+getStreamPriorityRange = do+ (r,l,h) <- cuCtxGetStreamPriorityRange+ resultIfOk (r, (h,l))++{-# INLINE cuCtxGetStreamPriorityRange #-}+{# fun unsafe cuCtxGetStreamPriorityRange+ { alloca- `Int' peekIntConv*+ , alloca- `Int' peekIntConv*+ }+ -> `Status' cToEnum #}+#endif+
+ src/Foreign/CUDA/Driver/Context/Peer.chs view
@@ -0,0 +1,173 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE TemplateHaskell #-}+#ifdef USE_EMPTY_CASE+{-# LANGUAGE EmptyCase #-}+#endif+--------------------------------------------------------------------------------+-- |+-- Module : Foreign.CUDA.Driver.Context.Peer+-- Copyright : [2009..2023] Trevor L. McDonell+-- License : BSD+--+-- Direct peer context access functions for the low-level driver interface.+--+-- Since: CUDA-4.0+--+--------------------------------------------------------------------------------++module Foreign.CUDA.Driver.Context.Peer (++ -- * Peer Access+ PeerFlag, PeerAttribute(..),+ accessible, add, remove, getAttribute,++) where++#include "cbits/stubs.h"+{# context lib="cuda" #}++-- Friends+import Foreign.CUDA.Driver.Context.Base ( Context(..) )+import Foreign.CUDA.Driver.Device ( Device(..) )+import Foreign.CUDA.Driver.Error+import Foreign.CUDA.Internal.C2HS++-- System+import Foreign+import Foreign.C+++--------------------------------------------------------------------------------+-- Data Types+--------------------------------------------------------------------------------++-- |+-- Possible option values for direct peer memory access+--+data PeerFlag+instance Enum PeerFlag where+#ifdef USE_EMPTY_CASE+ toEnum x = error ("PeerFlag.toEnum: Cannot match " ++ show x)+ fromEnum x = case x of {}+#endif+++-- | Peer-to-peer attributes+--+#if CUDA_VERSION < 8000+data PeerAttribute+instance Enum PeerAttribute where+#ifdef USE_EMPTY_CASE+ toEnum x = error ("PeerAttribute.toEnum: Cannot match " ++ show x)+ fromEnum x = case x of {}+#endif+#else+{# enum CUdevice_P2PAttribute as PeerAttribute+ { underscoreToCase }+ with prefix="CU_DEVICE_P2P_ATTRIBUTE" deriving (Eq, Show) #}+#endif+++--------------------------------------------------------------------------------+-- Peer access+--------------------------------------------------------------------------------++-- |+-- Queries if the first device can directly access the memory of the second. If+-- direct access is possible, it can then be enabled with 'add'.+--+-- Requires CUDA-4.0.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__PEER__ACCESS.html#group__CUDA__PEER__ACCESS_1g496bdaae1f632ebfb695b99d2c40f19e>+--+{-# INLINEABLE accessible #-}+accessible :: Device -> Device -> IO Bool+#if CUDA_VERSION < 4000+accessible _ _ = requireSDK 'accessible 4.0+#else+accessible !dev !peer = resultIfOk =<< cuDeviceCanAccessPeer dev peer++{-# INLINE cuDeviceCanAccessPeer #-}+{# fun unsafe cuDeviceCanAccessPeer+ { alloca- `Bool' peekBool*+ , useDevice `Device'+ , useDevice `Device' } -> `Status' cToEnum #}+#endif+++-- |+-- If the devices of both the current and supplied contexts support unified+-- addressing, then enable allocations in the supplied context to be accessible+-- by the current context.+--+-- Note that access is unidirectional, and in order to access memory in the+-- current context from the peer context, a separate symmetric call to+-- 'add' is required.+--+-- Requires CUDA-4.0.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__PEER__ACCESS.html#group__CUDA__PEER__ACCESS_1g0889ec6728e61c05ed359551d67b3f5a>+--+{-# INLINEABLE add #-}+add :: Context -> [PeerFlag] -> IO ()+#if CUDA_VERSION < 4000+add _ _ = requireSDK 'add 4.0+#else+add !ctx !flags = nothingIfOk =<< cuCtxEnablePeerAccess ctx flags++{-# INLINE cuCtxEnablePeerAccess #-}+{# fun unsafe cuCtxEnablePeerAccess+ { useContext `Context'+ , combineBitMasks `[PeerFlag]' } -> `Status' cToEnum #}+#endif+++-- |+-- Disable direct memory access from the current context to the supplied+-- peer context, and unregisters any registered allocations.+--+-- Requires CUDA-4.0.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__PEER__ACCESS.html#group__CUDA__PEER__ACCESS_1g5b4b6936ea868d4954ce4d841a3b4810>+--+{-# INLINEABLE remove #-}+remove :: Context -> IO ()+#if CUDA_VERSION < 4000+remove _ = requireSDK 'remave 4.0+#else+remove !ctx = nothingIfOk =<< cuCtxDisablePeerAccess ctx++{-# INLINE cuCtxDisablePeerAccess #-}+{# fun unsafe cuCtxDisablePeerAccess+ { useContext `Context' } -> `Status' cToEnum #}+#endif+++-- |+-- Queries attributes of the link between two devices+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__PEER__ACCESS.html#group__CUDA__PEER__ACCESS_1g4c55c60508f8eba4546b51f2ee545393>+--+-- Requires CUDA-8.0+--+-- @since 0.9.0.0@+--+{-# INLINEABLE getAttribute #-}+getAttribute :: PeerAttribute -> Device -> Device -> IO Int+#if CUDA_VERSION < 8000+getAttribute _ _ _ = requireSDK 'getAttribute 8.0+#else+getAttribute attrib src dst = resultIfOk =<< cuDeviceGetP2PAttribute attrib src dst++{-# INLINE cuDeviceGetP2PAttribute #-}+{# fun unsafe cuDeviceGetP2PAttribute+ { alloca- `Int' peekIntConv*+ , cFromEnum `PeerAttribute'+ , useDevice `Device'+ , useDevice `Device'+ } -> `Status' cToEnum #}+#endif+
+ src/Foreign/CUDA/Driver/Context/Primary.chs view
@@ -0,0 +1,170 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE TemplateHaskell #-}+--------------------------------------------------------------------------------+-- |+-- Module : Foreign.CUDA.Driver.Context.Primary+-- Copyright : [2009..2023] Trevor L. McDonell+-- License : BSD+--+-- Primary context management for low-level driver interface. The primary+-- context is unique per device and shared with the Runtime API. This+-- allows integration with other libraries using CUDA.+--+-- Since: CUDA-7.0+--+--------------------------------------------------------------------------------++module Foreign.CUDA.Driver.Context.Primary (++ status, setup, reset, retain, release,++) where++#include "cbits/stubs.h"+{# context lib="cuda" #}++-- Friends+import Foreign.CUDA.Driver.Context.Base+import Foreign.CUDA.Driver.Device+import Foreign.CUDA.Driver.Error+import Foreign.CUDA.Internal.C2HS++-- System+import Control.Exception+import Control.Monad+import Foreign+import Foreign.C+++--------------------------------------------------------------------------------+-- Primary context management+--------------------------------------------------------------------------------+++-- |+-- Get the status of the primary context. Returns whether the current+-- context is active, and the flags it was (or will be) created with.+--+-- Requires CUDA-7.0.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__PRIMARY__CTX.html#group__CUDA__PRIMARY__CTX_1g65f3e018721b6d90aa05cfb56250f469>+--+{-# INLINEABLE status #-}+status :: Device -> IO (Bool, [ContextFlag])+#if CUDA_VERSION < 7000+status _ = requireSDK 'status 7.0+#else+status !dev =+ cuDevicePrimaryCtxGetState dev >>= \(rv, !flags, !active) ->+ case rv of+ Success -> return (active, flags)+ _ -> throwIO (ExitCode rv)++{# fun unsafe cuDevicePrimaryCtxGetState+ { useDevice `Device'+ , alloca- `[ContextFlag]' peekFlags*+ , alloca- `Bool' peekBool*+ } -> `Status' cToEnum #}+ where+ peekFlags = liftM extractBitMasks . peek+#endif+++-- |+-- Specify the flags that the primary context should be created with. Note+-- that this is an error if the primary context is already active.+--+-- Requires CUDA-7.0.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__PRIMARY__CTX.html#group__CUDA__PRIMARY__CTX_1gd779a84f17acdad0d9143d9fe719cfdf>+--+{-# INLINEABLE setup #-}+setup :: Device -> [ContextFlag] -> IO ()+#if CUDA_VERSION < 7000+setup _ _ = requireSDK 'setup 7.0+#else+setup !dev !flags = nothingIfOk =<< cuDevicePrimaryCtxSetFlags dev flags++{-# INLINE cuDevicePrimaryCtxSetFlags #-}+{# fun unsafe cuDevicePrimaryCtxSetFlags+ { useDevice `Device'+ , combineBitMasks `[ContextFlag]'+ } -> `Status' cToEnum #}+#endif+++-- |+-- Destroy all allocations and reset all state on the primary context of+-- the given device in the current process. Requires cuda-7.0+--+-- Requires CUDA-7.0.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__PRIMARY__CTX.html#group__CUDA__PRIMARY__CTX_1g5d38802e8600340283958a117466ce12>+--+{-# INLINEABLE reset #-}+reset :: Device -> IO ()+#if CUDA_VERSION < 7000+reset _ = requireSDK 'reset 7.0+#else+reset !dev = nothingIfOk =<< cuDevicePrimaryCtxReset dev++{-# INLINE cuDevicePrimaryCtxReset #-}+{# fun unsafe cuDevicePrimaryCtxReset+ { useDevice `Device' } -> `Status' cToEnum #}+#endif+++-- |+-- Release the primary context on the given device. If there are no more+-- references to the primary context it will be destroyed, regardless of+-- how many threads it is current to.+--+-- Unlike 'Foreign.CUDA.Driver.Context.Base.pop' this does not pop the+-- context from the stack in any circumstances.+--+-- Requires CUDA-7.0.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__PRIMARY__CTX.html#group__CUDA__PRIMARY__CTX_1gf2a8bc16f8df0c88031f6a1ba3d6e8ad>+--+{-# INLINEABLE release #-}+release :: Device -> IO ()+#if CUDA_VERSION < 7000+release _ = requireSDK 'release 7.0+#else+release !dev = nothingIfOk =<< cuDevicePrimaryCtxRelease dev++{-# INLINE cuDevicePrimaryCtxRelease #-}+{# fun unsafe cuDevicePrimaryCtxRelease+ { useDevice `Device' } -> `Status' cToEnum #}+#endif+++-- |+-- Retain the primary context for the given device, creating it if+-- necessary, and increasing its usage count. The caller must call+-- 'release' when done using the context. Unlike+-- 'Foreign.CUDA.Driver.Context.Base.create' the newly retained context is+-- not pushed onto the stack.+--+-- Requires CUDA-7.0.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__PRIMARY__CTX.html#group__CUDA__PRIMARY__CTX_1g9051f2d5c31501997a6cb0530290a300>+--+{-# INLINEABLE retain #-}+retain :: Device -> IO Context+#if CUDA_VERSION < 7000+retain _ = requireSDK 'retain 7.0+#else+retain !dev = resultIfOk =<< cuDevicePrimaryCtxRetain dev++{-# INLINE cuDevicePrimaryCtxRetain #-}+{# fun unsafe cuDevicePrimaryCtxRetain+ { alloca- `Context' peekCtx*+ , useDevice `Device'+ } -> `Status' cToEnum #}+ where+ peekCtx = liftM Context . peek+#endif+
+ src/Foreign/CUDA/Driver/Device.chs view
@@ -0,0 +1,410 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+#ifdef USE_EMPTY_CASE+{-# LANGUAGE EmptyCase #-}+#endif+--------------------------------------------------------------------------------+-- |+-- Module : Foreign.CUDA.Driver.Device+-- Copyright : [2009..2023] Trevor L. McDonell+-- License : BSD+--+-- Device management for low-level driver interface+--+--------------------------------------------------------------------------------++module Foreign.CUDA.Driver.Device (++ -- * Device Management+ Device(..),+ DeviceProperties(..), DeviceAttribute(..), Compute(..), ComputeMode(..), InitFlag,+ initialise, capability, device, attribute, count, name, props, uuid, totalMem,++) where++#include "cbits/stubs.h"+{# context lib="cuda" #}++-- Friends+import Foreign.CUDA.Analysis.Device+import Foreign.CUDA.Driver.Error+import Foreign.CUDA.Internal.C2HS++-- System+import Control.Applicative+import Control.Monad ( liftM )+import Data.Bits+import Data.UUID.Types+import Foreign+import Foreign.C+import Prelude+++--------------------------------------------------------------------------------+-- Data Types+--------------------------------------------------------------------------------++-- |+-- A CUDA device+--+newtype Device = Device { useDevice :: {# type CUdevice #}}+ deriving (Eq, Show)+++-- |+-- Device attributes+--+{# enum CUdevice_attribute as DeviceAttribute+ { underscoreToCase+ , MAX as CU_DEVICE_ATTRIBUTE_MAX } -- ignore+ with prefix="CU_DEVICE_ATTRIBUTE" deriving (Eq, Show) #}+++#if CUDA_VERSION < 5000+{# pointer *CUdevprop as ^ foreign -> CUDevProp nocode #}++--+-- Properties of the compute device (internal helper).+-- Replaced by cuDeviceGetAttribute in CUDA-5.0 and later.+--+data CUDevProp = CUDevProp+ {+ cuMaxThreadsPerBlock :: !Int, -- Maximum number of threads per block+ cuMaxBlockSize :: !(Int,Int,Int), -- Maximum size of each dimension of a block+ cuMaxGridSize :: !(Int,Int,Int), -- Maximum size of each dimension of a grid+ cuSharedMemPerBlock :: !Int64, -- Shared memory available per block in bytes+ cuTotalConstMem :: !Int64, -- Constant memory available on device in bytes+ cuWarpSize :: !Int, -- Warp size in threads (SIMD width)+ cuMemPitch :: !Int64, -- Maximum pitch in bytes allowed by memory copies+ cuRegsPerBlock :: !Int, -- 32-bit registers available per block+ cuClockRate :: !Int, -- Clock frequency in kilohertz+ cuTextureAlignment :: !Int64 -- Alignment requirement for textures+ }+ deriving (Show)+++instance Storable CUDevProp where+ sizeOf _ = {#sizeof CUdevprop#}+ alignment _ = alignment (undefined :: Ptr ())++ poke _ _ = error "no instance for Foreign.Storable.poke DeviceProperties"+ peek p = do+ tb <- fromIntegral `fmap` {#get CUdevprop.maxThreadsPerBlock#} p+ sm <- fromIntegral `fmap` {#get CUdevprop.sharedMemPerBlock#} p+ cm <- fromIntegral `fmap` {#get CUdevprop.totalConstantMemory#} p+ ws <- fromIntegral `fmap` {#get CUdevprop.SIMDWidth#} p+ mp <- fromIntegral `fmap` {#get CUdevprop.memPitch#} p+ rb <- fromIntegral `fmap` {#get CUdevprop.regsPerBlock#} p+ cl <- fromIntegral `fmap` {#get CUdevprop.clockRate#} p+ ta <- fromIntegral `fmap` {#get CUdevprop.textureAlign#} p++ [t1,t2,t3] <- peekArrayWith fromIntegral 3 =<< {#get CUdevprop.maxThreadsDim#} p+ [g1,g2,g3] <- peekArrayWith fromIntegral 3 =<< {#get CUdevprop.maxGridSize#} p++ return CUDevProp+ {+ cuMaxThreadsPerBlock = tb,+ cuMaxBlockSize = (t1,t2,t3),+ cuMaxGridSize = (g1,g2,g3),+ cuSharedMemPerBlock = sm,+ cuTotalConstMem = cm,+ cuWarpSize = ws,+ cuMemPitch = mp,+ cuRegsPerBlock = rb,+ cuClockRate = cl,+ cuTextureAlignment = ta+ }+#endif+++-- |+-- Possible option flags for CUDA initialisation. Dummy instance until the API+-- exports actual option values.+--+data InitFlag+instance Enum InitFlag where+#ifdef USE_EMPTY_CASE+ toEnum x = error ("InitFlag.toEnum: Cannot match " ++ show x)+ fromEnum x = case x of {}+#endif+++--------------------------------------------------------------------------------+-- Initialisation+--------------------------------------------------------------------------------++-- |+-- Initialise the CUDA driver API. This must be called before any other+-- driver function.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__INITIALIZE.html#group__CUDA__INITIALIZE_1g0a2f1517e1bd8502c7194c3a8c134bc3>+--+{-# INLINEABLE initialise #-}+initialise :: [InitFlag] -> IO ()+initialise !flags = do+ enable_constructors+ cuInit flags++{-# INLINE enable_constructors #-}+{# fun unsafe enable_constructors { } -> `()' #}++{-# INLINE cuInit #-}+{# fun unsafe cuInit+ { combineBitMasks `[InitFlag]' } -> `()' checkStatus*- #}+++--------------------------------------------------------------------------------+-- Device Management+--------------------------------------------------------------------------------++-- |+-- Return the compute compatibility revision supported by the device+--+{-# INLINEABLE capability #-}+capability :: Device -> IO Compute+#if CUDA_VERSION >= 5000+capability !dev =+ Compute <$> attribute dev ComputeCapabilityMajor+ <*> attribute dev ComputeCapabilityMinor+#else+-- Deprecated as of CUDA-5.0+--+capability !dev = uncurry Compute <$> cuDeviceComputeCapability dev++{-# INLINE cuDeviceComputeCapability #-}+{# fun unsafe cuDeviceComputeCapability+ { alloca- `Int' peekIntConv*+ , alloca- `Int' peekIntConv*+ , useDevice `Device'+ }+ -> `()' checkStatus*- #}+#endif+++-- |+-- Return a handle to the compute device at the given ordinal.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__DEVICE.html#group__CUDA__DEVICE_1g8bdd1cc7201304b01357b8034f6587cb>+--+{-# INLINEABLE device #-}+{# fun unsafe cuDeviceGet as device+ { alloca- `Device' dev*+ , `Int'+ }+ -> `()' checkStatus*- #}+ where+ dev = liftM Device . peek+++-- |+-- Return the selected attribute for the given device.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__DEVICE.html#group__CUDA__DEVICE_1g9c3e1414f0ad901d3278a4d6645fc266>+--+{-# INLINEABLE attribute #-}+attribute :: Device -> DeviceAttribute -> IO Int+attribute !d !a = cuDeviceGetAttribute a d+ where+ {# fun unsafe cuDeviceGetAttribute+ { alloca- `Int' peekIntConv*+ , cFromEnum `DeviceAttribute'+ , useDevice `Device'+ }+ -> `()' checkStatus*- #}+++-- |+-- Return the number of device with compute capability > 1.0.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__DEVICE.html#group__CUDA__DEVICE_1g52b5ce05cb8c5fb6831b2c0ff2887c74>+--+{-# INLINEABLE count #-}+{# fun unsafe cuDeviceGetCount as count+ { alloca- `Int' peekIntConv*+ }+ -> `()' checkStatus*- #}+++-- |+-- The identifying name of the device.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__DEVICE.html#group__CUDA__DEVICE_1gef75aa30df95446a845f2a7b9fffbb7f>+--+{-# INLINEABLE name #-}+{# fun unsafe cuDeviceGetName as name+ { allocaS- `String'& peekS*+ , useDevice `Device'+ }+ -> `()' checkStatus*- #}+ where+ len = 512+ allocaS a = allocaBytes len $ \p -> a (p, fromIntegral len)+ peekS s _ = peekCString s+++-- | Returns a UUID for the device.+--+-- Since CUDA-13: If the device is in MIG mode, this function returns its MIG+-- UUID which uniquely identifies the subscribed MIG compute instance.+--+-- Requires CUDA-9.2+--+-- <https://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__DEVICE.html#group__CUDA__DEVICE_1g987b46b884c101ed5be414ab4d9e60e4>+--+-- @since 0.10.0.0+--+{-# INLINE uuid #-}+uuid :: Device -> IO UUID+#if CUDA_VERSION < 9020+uuid = requireSDK 'uuid 9.2+#else+uuid !dev =+ allocaBytes 16 $ \ptr -> do+ cuDeviceGetUuid ptr dev+ unpack ptr+ where+ {-# INLINE cuDeviceGetUuid #-}+#if CUDA_VERSION < 13000+ {# fun unsafe cuDeviceGetUuid+ { `Ptr ()'+ , useDevice `Device'+ } -> `()' checkStatus*- #}+#else+ {# fun unsafe cuDeviceGetUuid_v2 as cuDeviceGetUuid+ { `Ptr ()'+ , useDevice `Device'+ } -> `()' checkStatus*- #}+#endif++ {-# INLINE unpack #-}+ unpack :: Ptr () -> IO UUID+ unpack !p = do+ let !q = castPtr p+ a <- word <$> peekElemOff q 0 <*> peekElemOff q 1 <*> peekElemOff q 2 <*> peekElemOff q 3+ b <- word <$> peekElemOff q 4 <*> peekElemOff q 5 <*> peekElemOff q 6 <*> peekElemOff q 7+ c <- word <$> peekElemOff q 8 <*> peekElemOff q 9 <*> peekElemOff q 10 <*> peekElemOff q 11+ d <- word <$> peekElemOff q 12 <*> peekElemOff q 13 <*> peekElemOff q 14 <*> peekElemOff q 15+ return $! fromWords a b c d++ {-# INLINE word #-}+ word :: Word8 -> Word8 -> Word8 -> Word8 -> Word32+ word !a !b !c !d+ = (fromIntegral a `shiftL` 24)+ .|. (fromIntegral b `shiftL` 16)+ .|. (fromIntegral c `shiftL` 8)+ .|. (fromIntegral d )+#endif+++-- |+-- Return the properties of the selected device+--+{-# INLINEABLE props #-}+props :: Device -> IO DeviceProperties+props !d = do++#if CUDA_VERSION < 5000+ -- Old versions of the CUDA API used the separate cuDeviceGetProperties+ -- function to probe some properties, and cuDeviceGetAttribute for+ -- others. As of CUDA-5.0, the former was deprecated and its+ -- functionality subsumed by the latter, which we use below.+ --+ p <- resultIfOk =<< cuDeviceGetProperties d+ let totalConstMem = cuTotalConstMem p+ sharedMemPerBlock = cuSharedMemPerBlock p+ regsPerBlock = cuRegsPerBlock p+ warpSize = cuWarpSize p+ maxThreadsPerBlock = cuMaxThreadsPerBlock p+ maxBlockSize = cuMaxBlockSize p+ maxGridSize = cuMaxGridSize p+ clockRate = cuClockRate p+ memPitch = cuMemPitch p+ textureAlignment = cuTextureAlignment p+#else+ totalConstMem <- fromIntegral <$> attribute d TotalConstantMemory+ sharedMemPerBlock <- fromIntegral <$> attribute d SharedMemoryPerBlock+ memPitch <- fromIntegral <$> attribute d MaxPitch+ textureAlignment <- fromIntegral <$> attribute d TextureAlignment+ clockRate <- attribute d ClockRate+ warpSize <- attribute d WarpSize+ regsPerBlock <- attribute d RegistersPerBlock+ maxThreadsPerBlock <- attribute d MaxThreadsPerBlock+ maxBlockSize <- (,,) <$> attribute d MaxBlockDimX <*> attribute d MaxBlockDimY <*> attribute d MaxBlockDimZ+ maxGridSize <- (,,) <$> attribute d MaxGridDimX <*> attribute d MaxGridDimY <*> attribute d MaxGridDimZ+#endif++ -- The rest of the properties.+ --+ deviceName <- name d+ computeCapability <- capability d+ totalGlobalMem <- totalMem d+ multiProcessorCount <- attribute d MultiprocessorCount+ computeMode <- toEnum <$> attribute d ComputeMode+ deviceOverlap <- toBool <$> attribute d GpuOverlap+ kernelExecTimeoutEnabled <- toBool <$> attribute d KernelExecTimeout+ integrated <- toBool <$> attribute d Integrated+ canMapHostMemory <- toBool <$> attribute d CanMapHostMemory+#if CUDA_VERSION >= 3000+ concurrentKernels <- toBool <$> attribute d ConcurrentKernels+ eccEnabled <- toBool <$> attribute d EccEnabled+ maxTextureDim1D <- attribute d MaximumTexture1dWidth+ maxTextureDim2D <- (,) <$> attribute d MaximumTexture2dWidth <*> attribute d MaximumTexture2dHeight+ maxTextureDim3D <- (,,) <$> attribute d MaximumTexture3dWidth <*> attribute d MaximumTexture3dHeight <*> attribute d MaximumTexture3dDepth+#endif+#if CUDA_VERSION >= 4000+ asyncEngineCount <- attribute d AsyncEngineCount+ cacheMemL2 <- attribute d L2CacheSize+ maxThreadsPerMultiProcessor <- attribute d MaxThreadsPerMultiprocessor+ memBusWidth <- attribute d GlobalMemoryBusWidth+ memClockRate <- attribute d MemoryClockRate+ pciInfo <- PCI <$> attribute d PciBusId <*> attribute d PciDeviceId <*> attribute d PciDomainId+ unifiedAddressing <- toBool <$> attribute d UnifiedAddressing+ tccDriverEnabled <- toBool <$> attribute d TccDriver+#endif+#if CUDA_VERSION >= 5050+ streamPriorities <- toBool <$> attribute d StreamPrioritiesSupported+#endif+#if CUDA_VERSION >= 6000+ globalL1Cache <- toBool <$> attribute d GlobalL1CacheSupported+ localL1Cache <- toBool <$> attribute d LocalL1CacheSupported+ managedMemory <- toBool <$> attribute d ManagedMemory+ multiGPUBoard <- toBool <$> attribute d MultiGpuBoard+ multiGPUBoardGroupID <- attribute d MultiGpuBoardGroupId+#endif+#if CUDA_VERSION >= 8000+ preemption <- toBool <$> attribute d ComputePreemptionSupported+ singleToDoublePerfRatio <- attribute d SingleToDoublePrecisionPerfRatio+#endif+#if CUDA_VERSION >= 9000+ cooperativeLaunch <- toBool <$> attribute d CooperativeLaunch+ cooperativeLaunchMultiDevice <- toBool <$> attribute d CooperativeMultiDeviceLaunch+#endif++ return DeviceProperties{..}+++#if CUDA_VERSION < 5000+-- Deprecated as of CUDA-5.0+{-# INLINE cuDeviceGetProperties #-}+{# fun unsafe cuDeviceGetProperties+ { alloca- `CUDevProp' peek*+ , useDevice `Device' } -> `Status' cToEnum #}+#endif+++-- |+-- The total memory available on the device (bytes).+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__DEVICE.html#group__CUDA__DEVICE_1gc6a0d6551335a3780f9f3c967a0fde5d>+--+{-# INLINEABLE totalMem #-}+{# fun unsafe cuDeviceTotalMem as totalMem+ { alloca- `Int64' peekIntConv*+ , useDevice `Device'+ }+ -> `()' checkStatus*- #}+
+ src/Foreign/CUDA/Driver/Error.chs view
@@ -0,0 +1,216 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ForeignFunctionInterface #-}+--------------------------------------------------------------------------------+-- |+-- Module : Foreign.CUDA.Driver.Error+-- Copyright : [2009..2023] Trevor L. McDonell+-- License : BSD+--+-- Error handling+--+--------------------------------------------------------------------------------++module Foreign.CUDA.Driver.Error (++ -- * CUDA Errors+ Status(..), CUDAException(..),+ describe,+ cudaError, cudaErrorIO, requireSDK,+ resultIfOk, nothingIfOk, checkStatus,++) where++-- Friends+import Foreign.CUDA.Internal.C2HS+import Foreign.CUDA.Internal.Describe++-- System+import Control.Exception+import Control.Monad+import Data.Typeable+import Foreign.C+import Foreign.Marshal+import Foreign.Ptr+import Foreign.Storable+import Language.Haskell.TH+import System.IO.Unsafe+import Text.Printf+++#include "cbits/stubs.h"+{# context lib="cuda" #}+++--------------------------------------------------------------------------------+-- Return Status+--------------------------------------------------------------------------------++--+-- Error Codes+--+{# enum CUresult as Status+ { underscoreToCase+ , CUDA_SUCCESS as Success+ , CUDA_ERROR_NO_BINARY_FOR_GPU as NoBinaryForGPU+ , CUDA_ERROR_INVALID_PTX as InvalidPTX+ , CUDA_ERROR_INVALID_PC as InvalidPC+ }+ with prefix="CUDA_ERROR" deriving (Eq, Show) #}+++-- |+-- Return a descriptive error string associated with a particular error code+--+instance Describe Status where+#if CUDA_VERSION >= 6000+ describe status =+ case cuGetErrorString status of+ (Success, msg) -> msg+ (err, _) -> throw (ExitCode err)++{# fun pure unsafe cuGetErrorString+ { cFromEnum `Status'+ , alloca- `String' ppeek* } -> `Status' cToEnum #}+ where+ ppeek = peek >=> peekCString+#else+ describe Success = "no error"+ describe InvalidValue = "invalid argument"+ describe OutOfMemory = "out of memory"+ describe NotInitialized = "driver not initialised"+ describe Deinitialized = "driver deinitialised"+ describe NoDevice = "no CUDA-capable device is available"+ describe InvalidDevice = "invalid device ordinal"+ describe InvalidImage = "invalid kernel image"+ describe InvalidContext = "invalid context handle"+ describe ContextAlreadyCurrent = "context already current"+ describe MapFailed = "map failed"+ describe UnmapFailed = "unmap failed"+ describe ArrayIsMapped = "array is mapped"+ describe AlreadyMapped = "already mapped"+ describe NoBinaryForGPU = "no binary available for this GPU"+ describe AlreadyAcquired = "resource already acquired"+ describe NotMapped = "not mapped"+ describe InvalidSource = "invalid source"+ describe FileNotFound = "file not found"+ describe InvalidHandle = "invalid handle"+ describe NotFound = "not found"+ describe NotReady = "device not ready"+ describe LaunchFailed = "unspecified launch failure"+ describe LaunchOutOfResources = "too many resources requested for launch"+ describe LaunchTimeout = "the launch timed out and was terminated"+ describe LaunchIncompatibleTexturing = "launch with incompatible texturing"+#if CUDA_VERSION >= 3000+ describe NotMappedAsArray = "mapped resource not available for access as an array"+ describe NotMappedAsPointer = "mapped resource not available for access as a pointer"+ describe EccUncorrectable = "uncorrectable ECC error detected"+#endif+#if CUDA_VERSION >= 3000 && CUDA_VERSION < 3020+ describe PointerIs64bit = "attempt to retrieve a 64-bit pointer via a 32-bit API function"+ describe SizeIs64bit = "attempt to retrieve 64-bit size via a 32-bit API function"+#endif+#if CUDA_VERSION >= 3010+ describe UnsupportedLimit = "limits not supported by device"+ describe SharedObjectSymbolNotFound = "link to a shared object failed to resolve"+ describe SharedObjectInitFailed = "shared object initialisation failed"+#endif+#if CUDA_VERSION >= 3020+ describe OperatingSystem = "operating system call failed"+#endif+#if CUDA_VERSION >= 4000+ describe ProfilerDisabled = "profiling APIs disabled: application running with visual profiler"+ describe ProfilerNotInitialized = "profiler not initialised"+ describe ProfilerAlreadyStarted = "profiler already started"+ describe ProfilerAlreadyStopped = "profiler already stopped"+ describe ContextAlreadyInUse = "context is already bound to a thread and in use"+ describe PeerAccessAlreadyEnabled = "peer access already enabled"+ describe PeerAccessNotEnabled = "peer access has not been enabled"+ describe PrimaryContextActive = "primary context for this device has already been initialised"+ describe ContextIsDestroyed = "context already destroyed"+#endif+#if CUDA_VERSION >= 4010+ describe Assert = "device-side assert triggered"+ describe TooManyPeers = "peer mapping resources exhausted"+ describe HostMemoryAlreadyRegistered = "part or all of the requested memory range is already mapped"+ describe HostMemoryNotRegistered = "pointer does not correspond to a registered memory region"+#endif+#if CUDA_VERSION >= 5000+ describe PeerAccessUnsupported = "peer access is not supported across the given devices"+ describe NotPermitted = "not permitted"+ describe NotSupported = "not supported"+#endif+ describe Unknown = "unknown error"+#endif+++--------------------------------------------------------------------------------+-- Exceptions+--------------------------------------------------------------------------------++data CUDAException+ = ExitCode Status+ | UserError String+ deriving Typeable++instance Exception CUDAException++instance Show CUDAException where+ showsPrec _ (ExitCode s) = showString ("CUDA Exception: " ++ describe s)+ showsPrec _ (UserError s) = showString ("CUDA Exception: " ++ s)+++-- |+-- Raise a CUDAException. Exceptions can be thrown from pure code, but can only+-- be caught in the 'IO' monad.+--+{-# RULES "cudaError/IO" cudaError = cudaErrorIO #-}+{-# NOINLINE [1] cudaError #-}+cudaError :: String -> a+cudaError s = throw (UserError s)++-- |+-- Raise a CUDAException in the IO Monad+--+cudaErrorIO :: String -> IO a+cudaErrorIO s = throwIO (UserError s)++-- |+-- A specially formatted error message+--+requireSDK :: Name -> Double -> a+requireSDK n v = cudaError $ printf "'%s' requires at least cuda-%3.1f\n" (show n) v+++--------------------------------------------------------------------------------+-- Helper Functions+--------------------------------------------------------------------------------+++-- |+-- Return the results of a function on successful execution, otherwise throw an+-- exception with an error string associated with the return code+--+{-# INLINE resultIfOk #-}+resultIfOk :: (Status, a) -> IO a+resultIfOk (status, !result) =+ case status of+ Success -> return result+ _ -> throwIO (ExitCode status)+++-- |+-- Throw an exception with an error string associated with an unsuccessful+-- return code, otherwise return unit.+--+{-# INLINE nothingIfOk #-}+nothingIfOk :: Status -> IO ()+nothingIfOk status =+ case status of+ Success -> return ()+ _ -> throwIO (ExitCode status)++{-# INLINE checkStatus #-}+checkStatus :: CInt -> IO ()+checkStatus = nothingIfOk . cToEnum+
+ src/Foreign/CUDA/Driver/Event.chs view
@@ -0,0 +1,203 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE TemplateHaskell #-}+#ifdef USE_EMPTY_CASE+{-# LANGUAGE EmptyCase #-}+#endif+--------------------------------------------------------------------------------+-- |+-- Module : Foreign.CUDA.Driver.Event+-- Copyright : [2009..2023] Trevor L. McDonell+-- License : BSD+--+-- Event management for low-level driver interface+--+--------------------------------------------------------------------------------++module Foreign.CUDA.Driver.Event (++ -- * Event Management+ Event(..), EventFlag(..), WaitFlag,+ create, destroy, elapsedTime, query, record, wait, block++) where++#include "cbits/stubs.h"+{# context lib="cuda" #}++-- Friends+import Foreign.CUDA.Internal.C2HS+import Foreign.CUDA.Driver.Error+import Foreign.CUDA.Driver.Stream ( Stream(..), defaultStream )++-- System+import Foreign+import Foreign.C+import Data.Maybe+import Control.Monad ( liftM )+import Control.Exception ( throwIO )+++--------------------------------------------------------------------------------+-- Data Types+--------------------------------------------------------------------------------++-- |+-- Events are markers that can be inserted into the CUDA execution stream and+-- later queried.+--+newtype Event = Event { useEvent :: {# type CUevent #}}+ deriving (Eq, Show)++-- |+-- Event creation flags+--+{# enum CUevent_flags as EventFlag+ { underscoreToCase+ }+ with prefix="CU_EVENT" deriving (Eq, Show, Bounded) #}++-- |+-- Possible option flags for waiting for events+--+data WaitFlag+instance Enum WaitFlag where+#ifdef USE_EMPTY_CASE+ toEnum x = error ("WaitFlag.toEnum: Cannot match " ++ show x)+ fromEnum x = case x of {}+#endif+++--------------------------------------------------------------------------------+-- Event management+--------------------------------------------------------------------------------++-- |+-- Create a new event+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__EVENT.html#group__CUDA__EVENT_1g450687e75f3ff992fe01662a43d9d3db>+--+{-# INLINEABLE create #-}+create :: [EventFlag] -> IO Event+create !flags = resultIfOk =<< cuEventCreate flags++{-# INLINE cuEventCreate #-}+{# fun unsafe cuEventCreate+ { alloca- `Event' peekEvt*+ , combineBitMasks `[EventFlag]' } -> `Status' cToEnum #}+ where peekEvt = liftM Event . peek+++-- |+-- Destroy an event+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__EVENT.html#group__CUDA__EVENT_1g593ec73a8ec5a5fc031311d3e4dca1ef>+--+{-# INLINEABLE destroy #-}+destroy :: Event -> IO ()+destroy !ev = nothingIfOk =<< cuEventDestroy ev++{-# INLINE cuEventDestroy #-}+{# fun unsafe cuEventDestroy+ { useEvent `Event' } -> `Status' cToEnum #}+++-- |+-- Determine the elapsed time (in milliseconds) between two events+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__EVENT.html#group__CUDA__EVENT_1gdfb1178807353bbcaa9e245da497cf97>+--+{-# INLINEABLE elapsedTime #-}+elapsedTime :: Event -> Event -> IO Float+elapsedTime !ev1 !ev2 = resultIfOk =<< cuEventElapsedTime ev1 ev2++{-# INLINE cuEventElapsedTime #-}+#if CUDA_VERSION < 13000+{# fun unsafe cuEventElapsedTime+ { alloca- `Float' peekFloatConv*+ , useEvent `Event'+ , useEvent `Event' } -> `Status' cToEnum #}+#else+{# fun unsafe cuEventElapsedTime_v2 as cuEventElapsedTime+ { alloca- `Float' peekFloatConv*+ , useEvent `Event'+ , useEvent `Event' } -> `Status' cToEnum #}+#endif+++-- |+-- Determines if a event has actually been recorded+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__EVENT.html#group__CUDA__EVENT_1g6f0704d755066b0ee705749ae911deef>+--+{-# INLINEABLE query #-}+query :: Event -> IO Bool+query !ev =+ cuEventQuery ev >>= \rv ->+ case rv of+ Success -> return True+ NotReady -> return False+ _ -> throwIO (ExitCode rv)++{-# INLINE cuEventQuery #-}+{# fun unsafe cuEventQuery+ { useEvent `Event' } -> `Status' cToEnum #}+++-- |+-- Record an event once all operations in the current context (or optionally+-- specified stream) have completed. This operation is asynchronous.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__EVENT.html#group__CUDA__EVENT_1g95424d3be52c4eb95d83861b70fb89d1>+--+{-# INLINEABLE record #-}+record :: Event -> Maybe Stream -> IO ()+record !ev !mst =+ nothingIfOk =<< cuEventRecord ev (fromMaybe defaultStream mst)++{-# INLINE cuEventRecord #-}+{# fun unsafe cuEventRecord+ { useEvent `Event'+ , useStream `Stream' } -> `Status' cToEnum #}+++-- |+-- Makes all future work submitted to the (optional) stream wait until the given+-- event reports completion before beginning execution. Synchronisation is+-- performed on the device, including when the event and stream are from+-- different device contexts.+--+-- Requires CUDA-3.2.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__STREAM.html#group__CUDA__STREAM_1g6a898b652dfc6aa1d5c8d97062618b2f>+--+{-# INLINEABLE wait #-}+wait :: Event -> Maybe Stream -> [WaitFlag] -> IO ()+#if CUDA_VERSION < 3020+wait _ _ _ = requireSDK 'wait 3.2+#else+wait !ev !mst !flags =+ nothingIfOk =<< cuStreamWaitEvent (fromMaybe defaultStream mst) ev flags++{-# INLINE cuStreamWaitEvent #-}+{# fun unsafe cuStreamWaitEvent+ { useStream `Stream'+ , useEvent `Event'+ , combineBitMasks `[WaitFlag]' } -> `Status' cToEnum #}+#endif++-- |+-- Wait until the event has been recorded+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__EVENT.html#group__CUDA__EVENT_1g9e520d34e51af7f5375610bca4add99c>+--+{-# INLINEABLE block #-}+block :: Event -> IO ()+block !ev = nothingIfOk =<< cuEventSynchronize ev++{-# INLINE cuEventSynchronize #-}+{# fun cuEventSynchronize+ { useEvent `Event' } -> `Status' cToEnum #}+
+ src/Foreign/CUDA/Driver/Exec.chs view
@@ -0,0 +1,453 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TemplateHaskell #-}+--------------------------------------------------------------------------------+-- |+-- Module : Foreign.CUDA.Driver.Exec+-- Copyright : [2009..2023] Trevor L. McDonell+-- License : BSD+--+-- Kernel execution control for low-level driver interface+--+--------------------------------------------------------------------------------++module Foreign.CUDA.Driver.Exec (++ -- * Kernel Execution+ Fun(..), FunParam(..), FunAttribute(..), SharedMem(..),+ requires,+ setCacheConfigFun,+ setSharedMemConfigFun,+ launchKernel, launchKernel',+ launchKernelCooperative,++ -- Deprecated since CUDA-4.0+ setBlockShape, setSharedSize, setParams, launch,++) where++#include "cbits/stubs.h"+{# context lib="cuda" #}++-- Friends+import Foreign.CUDA.Internal.C2HS+import Foreign.CUDA.Driver.Error+import Foreign.CUDA.Driver.Context ( Cache(..), SharedMem(..) )+import Foreign.CUDA.Driver.Stream ( Stream(..), defaultStream )++-- System+import Foreign+import Foreign.C+import Data.Maybe+import Control.Monad ( zipWithM_ )+++#if CUDA_VERSION >= 4000+{-# DEPRECATED setBlockShape, setSharedSize, setParams, launch+ "use launchKernel instead" #-}+#endif+++--------------------------------------------------------------------------------+-- Data Types+--------------------------------------------------------------------------------++-- |+-- A @\_\_global\_\_@ device function+--+newtype Fun = Fun { useFun :: {# type CUfunction #}}+++-- |+-- Function attributes+--+{# enum CUfunction_attribute as FunAttribute+ { underscoreToCase+ , MAX_THREADS_PER_BLOCK as MaxKernelThreadsPerBlock+ , MAX as CU_FUNC_ATTRIBUTE_MAX } -- ignore+ with prefix="CU_FUNC_ATTRIBUTE" deriving (Eq, Show) #}++-- |+-- Kernel function parameters+--+data FunParam where+ IArg :: !Int32 -> FunParam+ FArg :: !Float -> FunParam+ VArg :: Storable a => !a -> FunParam++instance Storable FunParam where+ sizeOf (IArg _) = sizeOf (undefined :: CUInt)+ sizeOf (FArg _) = sizeOf (undefined :: CFloat)+ sizeOf (VArg v) = sizeOf v++ alignment (IArg _) = alignment (undefined :: CUInt)+ alignment (FArg _) = alignment (undefined :: CFloat)+ alignment (VArg v) = alignment v++ poke p (IArg i) = poke (castPtr p) i+ poke p (FArg f) = poke (castPtr p) f+ poke p (VArg v) = poke (castPtr p) v++ peek _ = error "Can not peek Foreign.CUDA.Driver.FunParam"+++--------------------------------------------------------------------------------+-- Execution Control+--------------------------------------------------------------------------------++-- |+-- Returns the value of the selected attribute requirement for the given kernel.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__EXEC.html#group__CUDA__EXEC_1g5e92a1b0d8d1b82cb00dcfb2de15961b>+--+{-# INLINEABLE requires #-}+requires :: Fun -> FunAttribute -> IO Int+requires !fn !att = resultIfOk =<< cuFuncGetAttribute att fn++{-# INLINE cuFuncGetAttribute #-}+{# fun unsafe cuFuncGetAttribute+ { alloca- `Int' peekIntConv*+ , cFromEnum `FunAttribute'+ , useFun `Fun' } -> `Status' cToEnum #}+++-- |+-- On devices where the L1 cache and shared memory use the same hardware+-- resources, this sets the preferred cache configuration for the given device+-- function. This is only a preference; the driver is free to choose a different+-- configuration as required to execute the function.+--+-- Switching between configuration modes may insert a device-side+-- synchronisation point for streamed kernel launches.+--+-- Requires CUDA-3.0.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__EXEC.html#group__CUDA__EXEC_1g40f8c11e81def95dc0072a375f965681>+--+{-# INLINEABLE setCacheConfigFun #-}+setCacheConfigFun :: Fun -> Cache -> IO ()+#if CUDA_VERSION < 3000+setCacheConfigFun _ _ = requireSDK 'setCacheConfigFun 3.0+#else+setCacheConfigFun !fn !pref = nothingIfOk =<< cuFuncSetCacheConfig fn pref++{-# INLINE cuFuncSetCacheConfig #-}+{# fun unsafe cuFuncSetCacheConfig+ { useFun `Fun'+ , cFromEnum `Cache' } -> `Status' cToEnum #}+#endif+++-- |+-- Set the shared memory configuration of a device function.+--+-- On devices with configurable shared memory banks, this will force all+-- subsequent launches of the given device function to use the specified+-- shared memory bank size configuration. On launch of the function, the+-- shared memory configuration of the device will be temporarily changed if+-- needed to suit the function configuration. Changes in shared memory+-- configuration may introduction a device side synchronisation between+-- kernel launches.+--+-- Any per-function configuration specified by 'setSharedMemConfig' will+-- override the context-wide configuration set with+-- 'Foreign.CUDA.Driver.Context.Config.setSharedMem'.+--+-- Changing the shared memory bank size will not increase shared memory+-- usage or affect occupancy of kernels, but may have major effects on+-- performance. Larger bank sizes will allow for greater potential+-- bandwidth to shared memory, but will change what kinds of accesses to+-- shared memory will result in bank conflicts.+--+-- This function will do nothing on devices with fixed shared memory bank+-- size.+--+-- Requires CUDA-5.0.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__EXEC.html#group__CUDA__EXEC_1g430b913f24970e63869635395df6d9f5>+--+{-# INLINEABLE setSharedMemConfigFun #-}+setSharedMemConfigFun :: Fun -> SharedMem -> IO ()+#if CUDA_VERSION < 5000+setSharedMemConfigFun _ _ = requireSDK 'setSharedMemConfigFun 5.0+#else+setSharedMemConfigFun !fun !pref = nothingIfOk =<< cuFuncSetSharedMemConfig fun pref++{-# INLINE cuFuncSetSharedMemConfig #-}+{# fun unsafe cuFuncSetSharedMemConfig+ { useFun `Fun'+ , cFromEnum `SharedMem'+ }+ -> `Status' cToEnum #}+#endif+++-- |+-- Invoke a kernel on a @(gx * gy * gz)@ grid of blocks, where each block+-- contains @(tx * ty * tz)@ threads and has access to a given number of bytes+-- of shared memory. The launch may also be associated with a specific 'Stream'.+--+-- In 'launchKernel', the number of kernel parameters and their offsets and+-- sizes do not need to be specified, as this information is retrieved directly+-- from the kernel's image. This requires the kernel to have been compiled with+-- toolchain version 3.2 or later.+--+-- The alternative 'launchKernel'' will pass the arguments in directly,+-- requiring the application to know the size and alignment/padding of each+-- kernel parameter.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__EXEC.html#group__CUDA__EXEC_1gb8f3dc3031b40da29d5f9a7139e52e15>+--+{-# INLINEABLE launchKernel #-}+{-# INLINEABLE launchKernel' #-}+launchKernel, launchKernel'+ :: Fun -- ^ function to execute+ -> (Int,Int,Int) -- ^ block grid dimension+ -> (Int,Int,Int) -- ^ thread block shape+ -> Int -- ^ shared memory (bytes)+ -> Maybe Stream -- ^ (optional) stream to execute in+ -> [FunParam] -- ^ list of function parameters+ -> IO ()+#if CUDA_VERSION >= 4000+launchKernel !fn (!gx,!gy,!gz) (!tx,!ty,!tz) !sm !mst !args+ = (=<<) nothingIfOk+ $ withMany withFP args+ $ \pa -> withArray pa+ $ \pp -> cuLaunchKernel fn gx gy gz tx ty tz sm st pp nullPtr+ where+ !st = fromMaybe defaultStream mst++ withFP :: FunParam -> (Ptr FunParam -> IO b) -> IO b+ withFP !p !f = case p of+ IArg v -> with' v (f . castPtr)+ FArg v -> with' v (f . castPtr)+ VArg v -> with' v (f . castPtr)++ -- can't use the standard 'with' because 'alloca' will pass an undefined+ -- dummy argument when determining 'sizeOf' and 'alignment', but sometimes+ -- instances in Accelerate need to evaluate this argument.+ --+ with' :: Storable a => a -> (Ptr a -> IO b) -> IO b+ with' !val !f =+ allocaBytes (sizeOf val) $ \ptr -> do+ poke ptr val+ f ptr+++launchKernel' !fn (!gx,!gy,!gz) (!tx,!ty,!tz) !sm !mst !args+ = (=<<) nothingIfOk+ $ with bytes+ $ \pb -> withArray' args+ $ \pa -> withArray0 nullPtr [buffer, castPtr pa, size, castPtr pb]+ $ \pp -> cuLaunchKernel fn gx gy gz tx ty tz sm st nullPtr pp+ where+ buffer = wordPtrToPtr 0x01 -- CU_LAUNCH_PARAM_BUFFER_POINTER+ size = wordPtrToPtr 0x02 -- CU_LAUNCH_PARAM_BUFFER_SIZE+ bytes = foldl (\a x -> a + sizeOf x) 0 args+ st = fromMaybe defaultStream mst++ -- can't use the standard 'withArray' because 'mallocArray' will pass+ -- 'undefined' to 'sizeOf' when determining how many bytes to allocate, but+ -- our Storable instance for FunParam needs to dispatch on each constructor,+ -- hence evaluating the undefined.+ --+ withArray' !vals !f =+ allocaBytes bytes $ \ptr -> do+ pokeArray ptr vals+ f ptr+++{-# INLINE cuLaunchKernel #-}+{# fun unsafe cuLaunchKernel+ { useFun `Fun'+ , `Int', `Int', `Int'+ , `Int', `Int', `Int'+ , `Int'+ , useStream `Stream'+ , castPtr `Ptr (Ptr FunParam)'+ , castPtr `Ptr (Ptr ())' } -> `Status' cToEnum #}++#else+launchKernel !fn (!gx,!gy,_) (!tx,!ty,!tz) !sm !mst !args = do+ setParams fn args+ setSharedSize fn (toInteger sm)+ setBlockShape fn (tx,ty,tz)+ launch fn (gx,gy) mst++launchKernel' = launchKernel+#endif+++-- |+-- Invoke a kernel on a @(gx * gy * gz)@ grid of blocks, where each block+-- contains @(tx * ty * tz)@ threads and has access to a given number of bytes+-- of shared memory. The launch may also be associated with a specific stream.+--+-- The thread blocks can cooperate and synchronise as they execute.+--+-- The device on which this kernel is invoked must have+-- 'Foreign.CUDA.Driver.Device.attribute'+-- 'Foreign.CUDA.Driver.Device.CooperativeLaunch'.+--+-- The total number of blocks launched can not exceed the maximum number of+-- active thread blocks per multiprocessor+-- ('Foreign.CUDA.Analysis.Device.threadBlocksPerMP'), multiplied by the number+-- of multiprocessors ('Foreign.CUDA.Analysis.Device.multiProcessorCount').+--+-- The kernel can not make use of dynamic parallelism.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__EXEC.html#group__CUDA__EXEC_1g06d753134145c4584c0c62525c1894cb>+--+-- Requires CUDA-9.0+--+-- @since 0.9.0.0@+--+{-# INLINEABLE launchKernelCooperative #-}+launchKernelCooperative+ :: Fun -- ^ function to execute+ -> (Int,Int,Int) -- ^ block grid dimension+ -> (Int,Int,Int) -- ^ thread block shape+ -> Int -- ^ shared memory (bytes)+ -> Maybe Stream -- ^ (optional) stream to execute in+ -> [FunParam] -- ^ list of function parameters+ -> IO ()+#if CUDA_VERSION < 9000+launchKernelCooperative _ _ _ _ _ _ = requireSDK 'launchKernelCooperative 9.0+#else+launchKernelCooperative !fn (!gx,!gy,!gz) (!tx,!ty,!tz) !sm !mst !args+ = (=<<) nothingIfOk+ $ withMany withFP args+ $ \pa -> withArray pa+ $ \pp -> cuLaunchCooperativeKernel fn gx gy gz tx ty tz sm st pp+ where+ !st = fromMaybe defaultStream mst++ withFP :: FunParam -> (Ptr FunParam -> IO b) -> IO b+ withFP !p !f = case p of+ IArg v -> with' v (f . castPtr)+ FArg v -> with' v (f . castPtr)+ VArg v -> with' v (f . castPtr)++ -- can't use the standard 'with' because 'alloca' will pass an undefined+ -- dummy argument when determining 'sizeOf' and 'alignment', but sometimes+ -- instances in Accelerate need to evaluate this argument.+ --+ with' :: Storable a => a -> (Ptr a -> IO b) -> IO b+ with' !val !f =+ allocaBytes (sizeOf val) $ \ptr -> do+ poke ptr val+ f ptr++{-# INLINE cuLaunchCooperativeKernel #-}+{# fun unsafe cuLaunchCooperativeKernel+ { useFun `Fun'+ , `Int', `Int', `Int'+ , `Int', `Int', `Int'+ , `Int'+ , useStream `Stream'+ , castPtr `Ptr (Ptr FunParam)'+ } -> `Status' cToEnum #}+#endif+++--------------------------------------------------------------------------------+-- Deprecated+--------------------------------------------------------------------------------++-- |+-- Invoke the kernel on a size @(w,h)@ grid of blocks. Each block contains the+-- number of threads specified by a previous call to 'setBlockShape'. The launch+-- may also be associated with a specific 'Stream'.+--+{-# INLINEABLE launch #-}+launch :: Fun -> (Int,Int) -> Maybe Stream -> IO ()+launch !fn (!w,!h) mst =+ nothingIfOk =<< cuLaunchGridAsync fn w h (fromMaybe defaultStream mst)++{-# INLINE cuLaunchGridAsync #-}+{# fun unsafe cuLaunchGridAsync+ { useFun `Fun'+ , `Int'+ , `Int'+ , useStream `Stream' } -> `Status' cToEnum #}+++-- |+-- Specify the @(x,y,z)@ dimensions of the thread blocks that are created when+-- the given kernel function is launched.+--+{-# INLINEABLE setBlockShape #-}+setBlockShape :: Fun -> (Int,Int,Int) -> IO ()+setBlockShape !fn (!x,!y,!z) = nothingIfOk =<< cuFuncSetBlockShape fn x y z++{-# INLINE cuFuncSetBlockShape #-}+{# fun unsafe cuFuncSetBlockShape+ { useFun `Fun'+ , `Int'+ , `Int'+ , `Int' } -> `Status' cToEnum #}+++-- |+-- Set the number of bytes of dynamic shared memory to be available to each+-- thread block when the function is launched+--+{-# INLINEABLE setSharedSize #-}+setSharedSize :: Fun -> Integer -> IO ()+setSharedSize !fn !bytes = nothingIfOk =<< cuFuncSetSharedSize fn bytes++{-# INLINE cuFuncSetSharedSize #-}+{# fun unsafe cuFuncSetSharedSize+ { useFun `Fun'+ , fromInteger `Integer' } -> `Status' cToEnum #}+++-- |+-- Set the parameters that will specified next time the kernel is invoked+--+{-# INLINEABLE setParams #-}+setParams :: Fun -> [FunParam] -> IO ()+setParams !fn !prs = do+ zipWithM_ (set fn) offsets prs+ nothingIfOk =<< cuParamSetSize fn (last offsets)+ where+ offsets = scanl (\a b -> a + size b) 0 prs++ size (IArg _) = sizeOf (undefined :: CUInt)+ size (FArg _) = sizeOf (undefined :: CFloat)+ size (VArg v) = sizeOf v++ set f o (IArg v) = nothingIfOk =<< cuParamSeti f o v+ set f o (FArg v) = nothingIfOk =<< cuParamSetf f o v+ set f o (VArg v) = with v $ \p -> (nothingIfOk =<< cuParamSetv f o p (sizeOf v))+++{-# INLINE cuParamSetSize #-}+{# fun unsafe cuParamSetSize+ { useFun `Fun'+ , `Int' } -> `Status' cToEnum #}++{-# INLINE cuParamSeti #-}+{# fun unsafe cuParamSeti+ { useFun `Fun'+ , `Int'+ , `Int32' } -> `Status' cToEnum #}++{-# INLINE cuParamSetf #-}+{# fun unsafe cuParamSetf+ { useFun `Fun'+ , `Int'+ , CFloat `Float' } -> `Status' cToEnum #}++{-# INLINE cuParamSetv #-}+{# fun unsafe cuParamSetv+ `Storable a' =>+ { useFun `Fun'+ , `Int'+ , castPtr `Ptr a'+ , `Int' } -> `Status' cToEnum #}++
+ src/Foreign/CUDA/Driver/Graph/Base.chs view
@@ -0,0 +1,77 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+#ifdef USE_EMPTY_CASE+{-# LANGUAGE EmptyCase #-}+#endif+--------------------------------------------------------------------------------+-- |+-- Module : Foreign.CUDA.Driver.Graph.Base+-- Copyright : [2018..2023] Trevor L. McDonell+-- License : BSD+--+-- Graph execution functions for the low-level driver interface+--+-- Requires CUDA-10+--+--------------------------------------------------------------------------------++module Foreign.CUDA.Driver.Graph.Base+ where++#include "cbits/stubs.h"+{# context lib="cuda" #}++import Foreign.Storable+import Foreign.Ptr+++--------------------------------------------------------------------------------+-- Data Types+--------------------------------------------------------------------------------++#if CUDA_VERSION < 10000+data Graph+#else+newtype Graph = Graph { useGraph :: {# type CUgraph #}}+ deriving (Eq, Show)+#endif++data GraphFlag+instance Enum GraphFlag where+#ifdef USE_EMPTY_CASE+ toEnum x = error ("GraphFlag.toEnum: Cannot match " ++ show x)+ fromEnum x = case x of {}+#endif++#if CUDA_VERSION < 10000+data Node+data NodeType++instance Enum NodeType where+#ifdef USE_EMPTY_CASE+ toEnum x = error ("NodeType.toEnum: Cannot match " ++ show x)+ fromEnum x = case x of {}+#endif+#else+newtype Node = Node { useNode :: {# type CUgraphNode #}}+ deriving (Eq, Show, Storable)++{# enum CUgraphNodeType as NodeType+ { underscoreToCase+ , CU_GRAPH_NODE_TYPE_GRAPH as Subgraph+ }+ with prefix="CU_GRAPH_NODE_TYPE" deriving (Eq, Show, Bounded) #}+#endif+++#if CUDA_VERSION < 10000+data Executable+#else+newtype Executable = Executable { useExecutable :: {# type CUgraphExec #}}+ deriving (Eq, Show)+#endif+
+ src/Foreign/CUDA/Driver/Graph/Build.chs view
@@ -0,0 +1,745 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE TemplateHaskell #-}+--------------------------------------------------------------------------------+-- |+-- Module : Foreign.CUDA.Driver.Graph.Build+-- Copyright : [2018..2023] Trevor L. McDonell+-- License : BSD+--+-- Graph construction functions for the low-level driver interface+--+-- Requires CUDA-10+--+--------------------------------------------------------------------------------++module Foreign.CUDA.Driver.Graph.Build (++ Graph(..), Node(..), NodeType(..), HostCallback,+ create, destroy, clone, remove,++ -- ** Construction+ addChild,+ addEmpty,+ addHost,+ addKernel,+ addMemcpy,+ addMemset,+ addDependencies,+ removeDependencies,++ -- ** Querying+ getType,+ getChildGraph,+ getEdges,+ getNodes,+ getRootNodes,+ getDependencies,+ getDependents,+ findInClone,++) where++#include "cbits/stubs.h"+{# context lib="cuda" #}++import Foreign.CUDA.Driver.Context.Base ( Context(..) )+import Foreign.CUDA.Driver.Error+import Foreign.CUDA.Driver.Exec ( Fun(..), FunParam(..) )+import Foreign.CUDA.Driver.Graph.Base+import Foreign.CUDA.Driver.Marshal ( useDeviceHandle )+import Foreign.CUDA.Driver.Stream ( Stream(..) )+import Foreign.CUDA.Driver.Unified ( MemoryType(..) )+import Foreign.CUDA.Internal.C2HS+import Foreign.CUDA.Ptr ( DevicePtr(..) )++import Control.Monad ( liftM )+import Unsafe.Coerce++import Data.Word+import Foreign+import Foreign.C+import Foreign.Storable+++-- | Callback function executed on the host+--+-- <https://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__TYPES.html#group__CUDA__TYPES_1g262cd3570ff5d396db4e3dabede3c355>+--+-- @since 0.10.0.0+--+#if CUDA_VERSION < 10000+type HostCallback = FunPtr ()+#else+type HostCallback = {# type CUhostFn #}+#endif+++--------------------------------------------------------------------------------+-- Graph creation+--------------------------------------------------------------------------------++-- | Create an empty task graph+--+-- Requires CUDA-10.0+--+-- <https://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__GRAPH.html#group__CUDA__GRAPH_1gd885f719186010727b75c3315f865fdf>+--+-- @since 0.10.0.0+--+{-# INLINEABLE create #-}+#if CUDA_VERSION < 10000+create :: [GraphFlag] -> IO Graph+create = requireSDK 'create 10.0+#else+{# fun unsafe cuGraphCreate as create+ { alloca- `Graph' peekGraph*+ , combineBitMasks `[GraphFlag]'+ }+ -> `()' checkStatus*- #}+#endif+++-- | Destroy a graph, as well as all of its nodes+--+-- Requires CUDA-10.0+--+-- <https://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__GRAPH.html#group__CUDA__GRAPH_1g718cfd9681f078693d4be2426fd689c8>+--+-- @since 0.10.0.0+{-# INLINEABLE destroy #-}+#if CUDA_VERSION < 10000+destroy :: Graph -> IO ()+destroy = requireSDK 'destroy 10.0+#else+{# fun unsafe cuGraphDestroy as destroy+ { useGraph `Graph'+ }+ -> `()' checkStatus*- #}+#endif+++-- | Clone a graph+--+-- Requires CUDA-10.0+--+-- <https://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__GRAPH.html#group__CUDA__GRAPH_1g3603974654e463f2231c71d9b9d1517e>+--+-- @since 0.10.0.0+--+{-# INLINEABLE clone #-}+#if CUDA_VERSION < 10000+clone :: Graph -> IO Graph+clone = requireSDK 'clone 10.0+#else+{# fun unsafe cuGraphClone as clone+ { alloca- `Graph' peekGraph*+ , useGraph `Graph'+ }+ -> `()' checkStatus*- #}+#endif+++-- | Remove a node from the graph+--+-- Requires CUDA-10.0+--+-- <https://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__GRAPH.html#group__CUDA__GRAPH_1g00ed16434d983d8f0011683eacaf19b9>+--+-- @since 0.10.0.0+--+{-# INLINEABLE remove #-}+#if CUDA_VERSION < 10000+remove :: Node -> IO ()+remove = requireSDK 'remove 10.0+#else+{# fun unsafe cuGraphDestroyNode as remove+ { useNode `Node'+ }+ -> `()' checkStatus*- #}+#endif+++-- | Create a child graph node and add it to the graph+--+-- Requires CUDA-10.0+--+-- <https://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__GRAPH.html#group__CUDA__GRAPH_1g3f27c2e56e3d568b09f00d438e61ceb1>+--+-- @since 0.10.0.0+--+{-# INLINEABLE addChild #-}+addChild :: Graph -> Graph -> [Node] -> IO Node+#if CUDA_VERSION < 10000+addChild = requireSDK 'addChild 10.0+#else+addChild parent child dependencies = cuGraphAddChildGraphNode parent dependencies child+ where+ {# fun unsafe cuGraphAddChildGraphNode+ { alloca- `Node' peekNode*+ , useGraph `Graph'+ , withNodeArrayLen* `[Node]'&+ , useGraph `Graph'+ }+ -> `()' checkStatus*- #}+#endif+++-- | Add dependency edges to the graph+--+-- Requires CUDA-10.0+--+-- <https://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__GRAPH.html#group__CUDA__GRAPH_1g81bf1a6965f881be6ad8d21cfe0ee44f>+--+-- @since 0.10.0.0+--+{-# INLINEABLE addDependencies #-}+addDependencies :: Graph -> [(Node,Node)] -> IO ()+#if CUDA_VERSION < 10000+addDependencies = requireSDK 'addDependencies 10.0+#else+addDependencies !g !deps = cuGraphAddDependencies g from to+ where+ (from, to) = unzip deps++#if CUDA_VERSION < 13000+ {# fun unsafe cuGraphAddDependencies+ { useGraph `Graph'+ , withNodeArray* `[Node]'+ , withNodeArrayLen* `[Node]'&+ }+ -> `()' checkStatus*- #}+#else+ cuGraphAddDependencies g' from' to' = cuGraphAddDependencies_v2 g' from' to' (length deps)+ {# fun unsafe cuGraphAddDependencies_v2+ { useGraph `Graph'+ , withNodeArray* `[Node]'+ , withNodeArray* `[Node]'+ , withNullEdgeDataLen* `Int'&+ }+ -> `()' checkStatus*- #}+#endif+#endif+++-- | Remove dependency edges from the graph+--+-- Requires CUDA-10.0+--+-- <https://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__GRAPH.html#group__CUDA__GRAPH_1g8ab696a6b3ccd99db47feba7e97fb579>+--+-- @since 0.10.0.0+--+{-# INLINE removeDependencies #-}+removeDependencies :: Graph -> [(Node,Node)] -> IO ()+#if CUDA_VERSION < 10000+removeDependencies = requireSDK 'removeDependencies 10.0+#else+removeDependencies !g !deps = cuGraphRemoveDependencies g from to+ where+ (from, to) = unzip deps++#if CUDA_VERSION < 13000+ {# fun unsafe cuGraphRemoveDependencies+ { useGraph `Graph'+ , withNodeArray* `[Node]'+ , withNodeArrayLen* `[Node]'&+ }+ -> `()' checkStatus*- #}+#else+ cuGraphRemoveDependencies g' from' to' = cuGraphRemoveDependencies_v2 g' from' to' (length deps)+ {# fun unsafe cuGraphRemoveDependencies_v2+ { useGraph `Graph'+ , withNodeArray* `[Node]'+ , withNodeArray* `[Node]'+ , withNullEdgeDataLen* `Int'&+ }+ -> `()' checkStatus*- #}+#endif+#endif+++-- | Create an empty node and add it to the graph.+--+-- Requires CUDA-10.0+--+-- <https://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__GRAPH.html#group__CUDA__GRAPH_1g8a8681dbe97dbbb236ea5ebf3abe2ada>+--+-- @since 0.10.0.0+--+{-# INLINEABLE addEmpty #-}+#if CUDA_VERSION < 10000+addEmpty :: Graph -> [Node] -> IO Node+addEmpty = requireSDK 'addEmpty 10.0+#else+{# fun unsafe cuGraphAddEmptyNode as addEmpty+ { alloca- `Node' peekNode*+ , useGraph `Graph'+ , withNodeArrayLen* `[Node]'&+ }+ -> `()' checkStatus*- #}+#endif+++-- | Creates a host execution node and adds it to the graph+--+-- Requires CUDA-10.0+--+-- <https://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__GRAPH.html#group__CUDA__GRAPH_1g1ba15c2fe1afb8897091ecec4202b597>+--+-- @since 0.10.0.0+--+{-# INLINEABLE addHost #-}+#if CUDA_VERSION < 10000+addHost :: Graph -> [Node] -> HostCallback -> Ptr () -> IO Node+addHost = requireSDK 'addHost 10.0+#else+{# fun unsafe cuGraphAddHostNode_simple as addHost+ { alloca- `Node' peekNode*+ , useGraph `Graph'+ , withNodeArrayLen* `[Node]'&+ , id `HostCallback'+ , `Ptr ()'+ }+ -> `()' checkStatus*- #}+#endif+++-- | Create a kernel execution node and adds it to the graph+--+-- Requires CUDA-10.0+--+-- <https://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__GRAPH.html#group__CUDA__GRAPH_1g886a9096293238937f2f3bc7f2d57635>+--+-- @since 0.10.0.0+--+{-# INLINEABLE addKernel #-}+addKernel+ :: Graph+ -> [Node]+ -> Fun+ -> (Int, Int, Int) -- ^ grid dimension+ -> (Int, Int, Int) -- ^ thread block dimensions+ -> Int -- ^ shared memory (bytes)+ -> [FunParam]+ -> IO Node+#if CUDA_VERSION < 10000+addKernel = requireSDK 'addKernel 10.0+#else+addKernel !g !ns !fun (!gx,!gy,!gz) (!tx,!ty,!tz) !sm !args+ = withMany withFP args+ $ \pa -> withArray pa+ $ \pp -> cuGraphAddKernelNode_simple g ns fun gx gy gz tx ty tz sm pp+ where+ withFP :: FunParam -> (Ptr () -> IO b) -> IO b+ withFP !p !f = case p of+ IArg v -> with' v (f . castPtr)+ FArg v -> with' v (f . castPtr)+ VArg v -> with' v (f . castPtr)++ -- can't use the standard 'with' because 'alloca' will pass an undefined+ -- dummy argument when determining 'sizeOf' and 'alignment', but sometimes+ -- instances in Accelerate need to evaluate this argument.+ --+ with' :: Storable a => a -> (Ptr a -> IO b) -> IO b+ with' !val !f =+ allocaBytes (sizeOf val) $ \ptr -> do+ poke ptr val+ f ptr++ {# fun unsafe cuGraphAddKernelNode_simple+ { alloca- `Node' peekNode*+ , useGraph `Graph'+ , withNodeArrayLen* `[Node]'&+ , useFun `Fun'+ , `Int'+ , `Int'+ , `Int'+ , `Int'+ , `Int'+ , `Int'+ , `Int'+ , id `Ptr (Ptr ())'+ }+ -> `()' checkStatus*- #}+#endif+++-- | Create a memcpy node and add it to the graph+--+-- Requires CUDA-10.0+--+-- <https://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__GRAPH.html#group__CUDA__GRAPH_1gdd521e1437c1c3ea8822f66a32ff1f94>+--+-- @since 0.10.0.0+--+#if CUDA_VERSION < 10000+addMemcpy :: Graph -> [Node] -> Context -> Int -> Int -> Int -> Int -> MemoryType -> Ptr a -> Int -> Int -> Int -> Int -> Int -> Int -> MemoryType -> Ptr a -> Int -> Int -> Int -> Int -> Int -> IO Node+addMemcpy = requireSDK 'addMemcpy 10.0+#else+{# fun unsafe cuGraphAddMemcpyNode_simple as addMemcpy+ { alloca- `Node' peekNode*+ , useGraph `Graph'+ , withNodeArrayLen* `[Node]'&+ , useContext `Context'+ , `Int' -- ^ srcXInBytes+ , `Int' -- ^ srcY+ , `Int' -- ^ srcZ+ , `Int' -- ^ srcLOD+ , cFromEnum `MemoryType' -- ^ source memory type+ , castPtr `Ptr a' -- ^ source ptr+ , `Int' -- ^ srcPitch+ , `Int' -- ^ srcHeight+ , `Int' -- ^ dstXInBytes+ , `Int' -- ^ dstY+ , `Int' -- ^ dstZ+ , `Int' -- ^ dstLOD+ , cFromEnum `MemoryType' -- ^ destination memory type+ , castPtr `Ptr a' -- ^ destination ptr+ , `Int' -- ^ dstPitch+ , `Int' -- ^ dstHeight+ , `Int' -- ^ widthInBytes+ , `Int' -- ^ height+ , `Int' -- ^ depth+ }+ -> `()' checkStatus*- #}+#endif+++-- | Create a memset node and add it to the graph+--+-- Requires CUDA-10.0+--+-- <https://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__GRAPH.html#group__CUDA__GRAPH_1gac7f59961798f14a9f94f9f6b53cc3b7>+--+-- @since 0.10.0.0+--+{-# INLINEABLE addMemset #-}+addMemset+ :: Storable a+ => Graph+ -> [Node]+ -> Context+ -> DevicePtr a+ -> a+ -> Int -- ^ height+ -> Int -- ^ pitch+ -> Int -- ^ width+ -> IO Node+#if CUDA_VERSION < 10000+addMemset = requireSDK 'addMemset 10.0+#else+addMemset !g !ns !ctx !dptr !val !h !p !w =+ cuGraphAddMemsetNode_simple g ns ctx dptr bytes h p val' w+ where+ bytes = sizeOf val++ val' :: Word32+ val' = case bytes of+ 1 -> fromIntegral (unsafeCoerce val :: Word8)+ 2 -> fromIntegral (unsafeCoerce val :: Word16)+ 4 -> fromIntegral (unsafeCoerce val :: Word32)+ _ -> cudaError "can only memset 8-, 16-, and 32-bit values"++ {# fun unsafe cuGraphAddMemsetNode_simple+ { alloca- `Node' peekNode*+ , useGraph `Graph'+ , withNodeArrayLen* `[Node]'&+ , useContext `Context'+ , useDeviceHandle `DevicePtr a'+ , `Int'+ , `Int'+ , `Int'+ , `Word32'+ , `Int'+ }+ -> `()' checkStatus*- #}+#endif+++--------------------------------------------------------------------------------+-- Query+--------------------------------------------------------------------------------++-- | Return the type of a node+--+-- Requires CUDA-10.0+--+-- <https://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__GRAPH.html#group__CUDA__GRAPH_1gdb1776d97aa1c9d5144774b29e4b8c3e>+--+-- @since 0.10.0.0+--+{-# INLINEABLE getType #-}+#if CUDA_VERSION < 10000+getType :: Node -> IO NodeType+getType = requireSDK 'getType 10.0+#else+{# fun unsafe cuGraphNodeGetType as getType+ { useNode `Node'+ , alloca- `NodeType' peekEnum*+ }+ -> `()' checkStatus*- #}+#endif+++-- | Retrieve the embedded graph of a child sub-graph node+--+-- Requires CUDA-10.0+--+-- <https://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__GRAPH.html#group__CUDA__GRAPH_1gbe9fc9267316b3778ef0db507917b4fd>+--+-- @since 0.10.0.0+--+{-# INLINEABLE getChildGraph #-}+#if CUDA_VERSION < 10000+getChildGraph :: Node -> IO Graph+getChildGraph = requireSDK 'getChildGraph 10.0+#else+{# fun unsafe cuGraphChildGraphNodeGetGraph as getChildGraph+ { useNode `Node'+ , alloca- `Graph' peekGraph*+ }+ -> `()' checkStatus*- #}+#endif+++-- | Return a graph's dependency edges+--+-- Requires CUDA-10.0+--+-- <https://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__GRAPH.html#group__CUDA__GRAPH_1g2b7bd71b0b2b8521f141996e0975a0d7>+--+-- @since 0.10.0.0+--+{-# INLINEABLE getEdges #-}+getEdges :: Graph -> IO [(Node, Node)]+#if CUDA_VERSION < 10000+getEdges = requireSDK 'getEdges 10.0+#else+getEdges !g =+ alloca $ \p_count -> do+ cuGraphGetEdges g nullPtr nullPtr p_count+ count <- peekIntConv p_count+ allocaArray count $ \p_from -> do+ allocaArray count $ \p_to -> do+ cuGraphGetEdges g p_from p_to p_count+ from <- peekArray count p_from+ to <- peekArray count p_to+ return $ zip from to+ where+#if CUDA_VERSION < 13000+ {# fun unsafe cuGraphGetEdges+ { useGraph `Graph'+ , castPtr `Ptr Node'+ , castPtr `Ptr Node'+ , id `Ptr CULong'+ }+ -> `()' checkStatus*- #}+#else+ cuGraphGetEdges g' f t c = cuGraphGetEdges_v2 g' f t nullPtr c+ {# fun unsafe cuGraphGetEdges_v2+ { useGraph `Graph'+ , castPtr `Ptr Node'+ , castPtr `Ptr Node'+ , castPtr `Ptr edgeData'+ , id `Ptr CULong'+ }+ -> `()' checkStatus*- #}+#endif+#endif+++-- | Return a graph's nodes+--+-- Requires CUDA-10.0+--+-- <https://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__GRAPH.html#group__CUDA__GRAPH_1gfa35a8e2d2fc32f48dbd67ba27cf27e5>+--+-- @since 0.10.0.0+--+{-# INLINEABLE getNodes #-}+getNodes :: Graph -> IO [Node]+#if CUDA_VERSION < 10000+getNodes = requireSDK 'getNodes 10.0+#else+getNodes !g =+ alloca $ \p_count -> do+ cuGraphGetNodes g nullPtr p_count+ count <- peekIntConv p_count+ allocaArray count $ \p_nodes -> do+ cuGraphGetNodes g p_nodes p_count+ peekArray count p_nodes+ where+ {# fun unsafe cuGraphGetNodes+ { useGraph `Graph'+ , castPtr `Ptr Node'+ , id `Ptr CULong'+ }+ -> `()' checkStatus*- #}+#endif+++-- | Returns the root nodes of a graph+--+-- Requires CUDA-10.0+--+-- <https://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__GRAPH.html#group__CUDA__GRAPH_1gf8517646bd8b39ab6359f8e7f0edffbd>+--+-- @since 0.10.0.0+--+{-# INLINEABLE getRootNodes #-}+getRootNodes :: Graph -> IO [Node]+#if CUDA_VERSION < 10000+getRootNodes = requireSDK 'getRootNodes 10.0+#else+getRootNodes g =+ alloca $ \p_count -> do+ cuGraphGetRootNodes g nullPtr p_count+ count <- peekIntConv p_count+ allocaArray count $ \p_nodes -> do+ cuGraphGetRootNodes g p_nodes p_count+ peekArray count p_nodes+ where+ {# fun unsafe cuGraphGetRootNodes+ { useGraph `Graph'+ , castPtr `Ptr Node'+ , id `Ptr CULong'+ }+ -> `()' checkStatus*- #}+#endif+++-- | Return the dependencies of a node+--+-- Requires CUDA-10.0+--+-- <https://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__GRAPH.html#group__CUDA__GRAPH_1g048f4c0babcbba64a933fc277cd45083>+--+-- @since 0.10.0.0+--+{-# INLINEABLE getDependencies #-}+getDependencies :: Node -> IO [Node]+#if CUDA_VERSION < 10000+getDependencies = requireSDK 'getDependencies 10.0+#else+getDependencies !n =+ alloca $ \p_count -> do+ cuGraphNodeGetDependencies n nullPtr p_count+ count <- peekIntConv p_count+ allocaArray count $ \p_deps -> do+ cuGraphNodeGetDependencies n p_deps p_count+ peekArray count p_deps+ where+#if CUDA_VERSION < 13000+ {# fun unsafe cuGraphNodeGetDependencies+ { useNode `Node'+ , castPtr `Ptr Node'+ , id `Ptr CULong'+ }+ -> `()' checkStatus*- #}+#else+ cuGraphNodeGetDependencies n' d c = cuGraphNodeGetDependencies_v2 n' d nullPtr c+ {# fun unsafe cuGraphNodeGetDependencies_v2+ { useNode `Node'+ , castPtr `Ptr Node'+ , castPtr `Ptr edgeData'+ , id `Ptr CULong'+ }+ -> `()' checkStatus*- #}+#endif+#endif+++-- | Return a node's dependent nodes+--+-- Requires CUDA-10.0+--+-- <https://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__GRAPH.html#group__CUDA__GRAPH_1g4b73d9e3b386a9c0b094a452b8431f59>+--+-- @since 0.10.0.0+--+{-# INLINEABLE getDependents #-}+getDependents :: Node -> IO [Node]+#if CUDA_VERSION < 10000+getDependents = requireSDK 'getDependents 10.0+#else+getDependents n =+ alloca $ \p_count -> do+ cuGraphNodeGetDependentNodes n nullPtr p_count+ count <- peekIntConv p_count+ allocaArray count $ \p_deps -> do+ cuGraphNodeGetDependentNodes n p_deps p_count+ peekArray count p_deps+ where+#if CUDA_VERSION < 13000+ {# fun unsafe cuGraphNodeGetDependentNodes+ { useNode `Node'+ , castPtr `Ptr Node'+ , id `Ptr CULong'+ }+ -> `()' checkStatus*- #}+#else+ cuGraphNodeGetDependentNodes n' d c = cuGraphNodeGetDependentNodes_v2 n' d nullPtr c+ {# fun unsafe cuGraphNodeGetDependentNodes_v2+ { useNode `Node'+ , castPtr `Ptr Node'+ , castPtr `Ptr edgeData'+ , id `Ptr CULong'+ }+ -> `()' checkStatus*- #}+#endif+#endif+++-- | Find a cloned version of a node+--+-- Requires CUDA-10.0+--+-- <https://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__GRAPH.html#group__CUDA__GRAPH_1gf21f6c968e346f028737c1118bfd41c2>+--+-- @since 0.10.0.0+--+{-# INLINEABLE findInClone #-}+#if CUDA_VERSION < 10000+findInClone :: Node -> Graph -> IO Node+findInClone = requireSDK 'findInClone 10+#else+{# fun unsafe cuGraphNodeFindInClone as findInClone+ { alloca- `Node' peekNode*+ , useNode `Node'+ , useGraph `Graph'+ }+ -> `()' checkStatus*- #}+#endif+++--------------------------------------------------------------------------------+-- Internal+--------------------------------------------------------------------------------++#if CUDA_VERSION >= 10000+{-# INLINE peekGraph #-}+peekGraph :: Ptr {# type CUgraph #} -> IO Graph+peekGraph = liftM Graph . peek++{-# INLINE peekNode #-}+peekNode :: Ptr {# type CUgraphNode #} -> IO Node+peekNode = liftM Node . peek++{-# INLINE withNodeArray #-}+withNodeArray :: [Node] -> (Ptr {# type CUgraphNode #} -> IO a) -> IO a+withNodeArray ns f = withArray ns (f . castPtr)++{-# INLINE withNodeArrayLen #-}+withNodeArrayLen :: [Node] -> ((Ptr {# type CUgraphNode #}, CULong) -> IO a) -> IO a+withNodeArrayLen ns f = withArrayLen ns $ \i p -> f (castPtr p, cIntConv i)+#endif++#if CUDA_VERSION >= 13000+{-# INLINE withNullEdgeDataLen #-}+withNullEdgeDataLen :: Int -> ((Ptr (), CULong) -> IO a) -> IO a+withNullEdgeDataLen len f = f (nullPtr, cIntConv len)+#endif+
+ src/Foreign/CUDA/Driver/Graph/Capture.chs view
@@ -0,0 +1,223 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE TemplateHaskell #-}+#ifdef USE_EMPTY_CASE+{-# LANGUAGE EmptyCase #-}+#endif+--------------------------------------------------------------------------------+-- |+-- Module : Foreign.CUDA.Driver.Graph.Capture+-- Copyright : [2018..2023] Trevor L. McDonell+-- License : BSD+--+-- Requires CUDA-10+--+--------------------------------------------------------------------------------++module Foreign.CUDA.Driver.Graph.Capture (++ Status(..), Mode(..),+ start, stop, status, info, mode,++) where++#include "cbits/stubs.h"+{# context lib="cuda" #}++import Foreign.CUDA.Driver.Error hiding ( Status )+import Foreign.CUDA.Driver.Graph.Base+import Foreign.CUDA.Driver.Stream+import Foreign.CUDA.Internal.C2HS++import Control.Monad ( liftM )++import Foreign+import Foreign.C+++#if CUDA_VERSION < 10000+data Status++instance Enum Status where+#ifdef USE_EMPTY_CASE+ toEnum x = error ("Status.toEnum: Cannot match " ++ show x)+ fromEnum x = case x of {}+#endif++#else+{# enum CUstreamCaptureStatus as Status+ { underscoreToCase }+ with prefix="CU_STREAM_CAPTURE_STATUS" deriving (Eq, Show, Bounded) #}+#endif++#if CUDA_VERSION < 10010+data Mode++instance Enum Mode where+#ifdef USE_EMPTY_CASE+ toEnum x = error ("Mode.toEnum: Cannot match " ++ show x)+ fromEnum x = case x of {}+#endif++#else+{# enum CUstreamCaptureMode as Mode+ { underscoreToCase }+ with prefix="CU_STREAM_CAPTURE_MODE" deriving (Eq, Show, Bounded) #}+#endif+++--------------------------------------------------------------------------------+-- Graph capture+--------------------------------------------------------------------------------++-- | Begin graph capture on a stream+--+-- Requires CUDA-10.0+--+-- <https://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__STREAM.html#group__CUDA__STREAM_1gea22d4496b1c8d02d0607bb05743532f>+--+-- @since 0.10.0.0+--+#if CUDA_VERSION < 10000+start :: Stream -> Mode -> IO ()+start = requireSDK 'start 10.0+#elif CUDA_VERSION < 10010+start :: Stream -> Mode -> IO ()+start s _ = cuStreamBeginCapture s+ where+ {# fun unsafe cuStreamBeginCapture+ { useStream `Stream'+ }+ -> `()' checkStatus*- #}+#else+{# fun unsafe cuStreamBeginCapture as start+ { useStream `Stream'+ , `Mode'+ }+ -> `()' checkStatus*- #}+#endif+++-- | End graph capture on a stream+--+-- Requires CUDA-10.0+--+-- <https://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__STREAM.html#group__CUDA__STREAM_1g03dab8b2ba76b00718955177a929970c>+--+-- @since 0.10.0.0+--+#if CUDA_VERSION < 10000+stop :: Stream -> IO Graph+stop = requireSDK 'stop 10.0+#else+{# fun unsafe cuStreamEndCapture as stop+ { useStream `Stream'+ , alloca- `Graph' peekGraph*+ }+ -> `()' checkStatus*- #}+#endif+++-- | Return a stream's capture status+--+-- Requires CUDA-10.0+--+-- <https://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__STREAM.html#group__CUDA__STREAM_1g37823c49206e3704ae23c7ad78560bca>+--+-- @since 0.10.0.0+--+#if CUDA_VERSION < 10000+status :: Stream -> IO Status+status = requireSDK 'status 10.0+#else+{# fun unsafe cuStreamIsCapturing as status+ { useStream `Stream'+ , alloca- `Status' peekEnum*+ }+ -> `()' checkStatus*- #}+#endif+++-- | Query the capture status of a stream and get an id for the capture+-- sequence, which is unique over the lifetime of the process.+--+-- Since CUDA-13, "edge data" can be associated with an edge in the graph. This+-- function assumes no such data is present (if there is, a CUDA error+-- (@CUDA_ERROR_LOSSY_QUERY@) will be raised).+--+-- Requires CUDA-10.1+--+-- <https://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__STREAM.html#group__CUDA__STREAM_1g13145ece1d79a1d79a1d22abb9663216>+--+-- @since 0.10.1.0+--+#if CUDA_VERSION < 10010+info :: Stream -> IO (Status, Int64)+info = requireSDK 'info 10.1+-- Not another elif because c2hs seems to be buggy+#else+#if CUDA_VERSION < 12000+{# fun unsafe cuStreamGetCaptureInfo as info+ { useStream `Stream'+ , alloca- `Status' peekEnum*+ , alloca- `Int64' peekIntConv*+ }+ -> `()' checkStatus*- #}+#elif CUDA_VERSION < 13000+{# fun unsafe cuStreamGetCaptureInfo_v2 as info+ { useStream `Stream'+ , alloca- `Status' peekEnum*+ , alloca- `Int64' peekIntConv*+ , withNullPtr- `Graph'+ , withNullPtr- `Node'+ , withNullPtr- `CSize'+ }+ -> `()' checkStatus*- #}+#else+{# fun unsafe cuStreamGetCaptureInfo_v3 as info+ { useStream `Stream'+ , alloca- `Status' peekEnum*+ , alloca- `Int64' peekIntConv*+ , withNullPtr- `Graph'+ , withNullPtr- `()'+ , withNullPtr- `Node'+ , withNullPtr- `CSize'+ }+ -> `()' checkStatus*- #}+#endif+#endif+++-- | Set the stream capture interaction mode for this thread. Return the previous value.+--+-- Requires CUDA-10.1+--+-- <https://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__STREAM.html#group__CUDA__STREAM_1g378135b262f02a43a7caeab239ae493d>+--+-- @since 0.10.1.0+--+#if CUDA_VERSION < 10010+mode :: Mode -> IO Mode+mode = requireSDK 'mode 10.1+#else+{# fun unsafe cuThreadExchangeStreamCaptureMode as mode+ { withEnum* `Mode' peekEnum*+ }+ -> `()' checkStatus*- #}+#endif+++--------------------------------------------------------------------------------+-- Internal+--------------------------------------------------------------------------------++#if CUDA_VERSION >= 10000+{-# INLINE peekGraph #-}+peekGraph :: Ptr {# type CUgraph #} -> IO Graph+peekGraph = liftM Graph . peek+#endif++withNullPtr :: (Ptr a -> r) -> r+withNullPtr f = f nullPtr
+ src/Foreign/CUDA/Driver/Graph/Exec.chs view
@@ -0,0 +1,192 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE TemplateHaskell #-}+--------------------------------------------------------------------------------+-- |+-- Module : Foreign.CUDA.Driver.Graph.Exec+-- Copyright : [2018..2023] Trevor L. McDonell+-- License : BSD+--+-- Graph execution functions for the low-level driver interface+--+-- Requires CUDA-10+--+--------------------------------------------------------------------------------++module Foreign.CUDA.Driver.Graph.Exec (++ Executable(..),++ -- ** Execution+ launch,+ instantiate,+ destroy,+ setKernel,++) where++#include "cbits/stubs.h"+{# context lib="cuda" #}++import Foreign.CUDA.Driver.Error+import Foreign.CUDA.Driver.Exec ( Fun(..), FunParam(..) )+import Foreign.CUDA.Driver.Graph.Base+import Foreign.CUDA.Driver.Stream ( Stream(..) )+import Foreign.CUDA.Internal.C2HS++import Foreign+import Foreign.C++import Control.Monad ( liftM )+import Data.ByteString.Char8 ( ByteString )+import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Internal as B+++--------------------------------------------------------------------------------+-- Graph execution+--------------------------------------------------------------------------------++-- | Execute a graph in the given stream. Only one instance may execute at+-- a time; to execute a graph concurrently, it must be 'instantiate'd into+-- multiple executables.+--+-- Requires CUDA-10.0+--+-- <https://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__GRAPH.html#group__CUDA__GRAPH_1g6b2dceb3901e71a390d2bd8b0491e471>+--+-- @since 0.10.0.0+--+{-# INLINEABLE launch #-}+#if CUDA_VERSION < 10000+launch :: Executable -> Stream -> IO ()+launch = requireSDK 'launch 10.0+#else+{# fun unsafe cuGraphLaunch as launch+ { useExecutable `Executable'+ , useStream `Stream'+ }+ -> `()' checkStatus*- #}+#endif+++-- | Instantiate the task graph description of a program into an executable+-- graph.+--+-- Requires CUDA-10.0+--+-- <https://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__GRAPH.html#group__CUDA__GRAPH_1g433ae118a751c9f2087f53d7add7bc2c>+--+-- @since 0.10.0.0+--+{-# INLINEABLE instantiate #-}+instantiate :: Graph -> IO Executable+#if CUDA_VERSION < 10000+instantiate = requireSDK 'instantiate 10.0+#else+instantiate !g = do+ let logSize = 2048+ allocaArray logSize $ \p_elog -> do+ (s, e, n) <- cuGraphInstantiate g p_elog logSize+ --+ case s of+ Success -> return e+ _ -> do+ errLog <- peekCStringLen (p_elog, logSize)+ cudaErrorIO (unlines [describe s, "phErrorNode = " ++ show n, errLog])++{-# INLINE cuGraphInstantiate #-}+{# fun unsafe cuGraphInstantiate+ { alloca- `Executable' peekExecutable*+ , useGraph `Graph'+ , alloca- `Maybe Node' peekErrNode*+ , castPtr `CString'+ , `Int'+ }+ -> `Status' cToEnum #}+ where+ peekExecutable = liftM Executable . peek+ peekErrNode p = if p == nullPtr+ then return Nothing+ else liftM (Just . Node) (peek p)+#endif+++-- | Update the parameters for a kernel node in the given executable graph+--+-- Requires CUDA-10.1+--+-- <https://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__GRAPH.html#group__CUDA__GRAPH_1gd84243569e4c3d6356b9f2eea20ed48c>+--+-- @since 0.10.1.0+--+setKernel+ :: Executable+ -> Node+ -> Fun+ -> (Int, Int, Int) -- ^ grid dimension+ -> (Int, Int, Int) -- ^ thread block dimensions+ -> Int -- ^ shared memory (bytes)+ -> [FunParam]+ -> IO ()+#if CUDA_VERSION < 10010+setKernel = requireSDK 'setKernel 10.1+#else+setKernel !exe !n !fun (!gx,!gy,!gz) (!tx,!ty,!tz) !sm !args+ = withMany withFP args+ $ \pa -> withArray pa+ $ \pp -> cuGraphExecKernelNodeSetParams_simple exe n fun gx gy gz tx ty tz sm pp+ where+ withFP :: FunParam -> (Ptr () -> IO b) -> IO b+ withFP !p !f = case p of+ IArg v -> with' v (f . castPtr)+ FArg v -> with' v (f . castPtr)+ VArg v -> with' v (f . castPtr)++ -- can't use the standard 'with' because 'alloca' will pass an undefined+ -- dummy argument when determining 'sizeOf' and 'alignment', but sometimes+ -- instances in Accelerate need to evaluate this argument.+ --+ with' :: Storable a => a -> (Ptr a -> IO b) -> IO b+ with' !val !f =+ allocaBytes (sizeOf val) $ \ptr -> do+ poke ptr val+ f ptr++ {# fun unsafe cuGraphExecKernelNodeSetParams_simple+ { useExecutable `Executable'+ , useNode `Node'+ , useFun `Fun'+ , `Int'+ , `Int'+ , `Int'+ , `Int'+ , `Int'+ , `Int'+ , `Int'+ , id `Ptr (Ptr ())'+ }+ -> `()' checkStatus*- #}+#endif+++-- | Destroy an executable graph+--+-- Requires CUDA-10.0+--+-- <https://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__GRAPH.html#group__CUDA__GRAPH_1ga32ad4944cc5d408158207c978bc43a7>+--+-- @since 0.10.0.0+--+{-# INLINEABLE destroy #-}+#if CUDA_VERSION < 10000+destroy :: Executable -> IO ()+destroy = requireSDK 'destroy 10.0+#else+{# fun unsafe cuGraphExecDestroy as destroy+ { useExecutable `Executable'+ }+ -> `()' checkStatus*- #}+#endif+
+ src/Foreign/CUDA/Driver/IPC/Event.chs view
@@ -0,0 +1,140 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE TemplateHaskell #-}+--------------------------------------------------------------------------------+-- |+-- Module : Foreign.CUDA.Driver.IPC.Event+-- Copyright : [2009..2023] Trevor L. McDonell+-- License : BSD+--+-- IPC event management for low-level driver interface.+--+-- Restricted to devices which support unified addressing on Linux+-- operating systems.+--+-- Since CUDA-4.1.+--+--------------------------------------------------------------------------------++module Foreign.CUDA.Driver.IPC.Event (++ IPCEvent,+ export, open,++) where++#include "cbits/stubs.h"+{# context lib="cuda" #}++-- Friends+import Foreign.CUDA.Driver.Error+import Foreign.CUDA.Driver.Event+import Foreign.CUDA.Internal.C2HS++-- System+import Control.Monad+import Prelude++import Foreign.C+import Foreign.Ptr+import Foreign.ForeignPtr+import Foreign.Marshal+import Foreign.Storable+++--------------------------------------------------------------------------------+-- Data Types+--------------------------------------------------------------------------------++-- |+-- A CUDA inter-process event handle.+--+newtype IPCEvent = IPCEvent { useIPCEvent :: IPCEventHandle }+ deriving (Eq, Show)+++--------------------------------------------------------------------------------+-- IPC event management+--------------------------------------------------------------------------------++-- |+-- Create an inter-process event handle for a previously allocated event.+-- The event must be created with the 'Interprocess' and 'DisableTiming'+-- event flags. The returned handle may then be sent to another process and+-- 'open'ed to allow efficient hardware synchronisation between GPU work in+-- other processes.+--+-- After the event has been opened in the importing process, 'record',+-- 'block', 'wait', 'query' may be used in either process.+--+-- Performing operations on the imported event after the event has been+-- 'destroy'ed in the exporting process is undefined.+--+-- Requires CUDA-4.0.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__MEM.html#group__CUDA__MEM_1gea02eadd12483de5305878b13288a86c>+--+{-# INLINEABLE export #-}+export :: Event -> IO IPCEvent+#if CUDA_VERSION < 4010+export _ = requireSDK 'create 4.1+#else+export !ev = do+ h <- newIPCEventHandle+ r <- cuIpcGetEventHandle h ev+ resultIfOk (r, IPCEvent h)++{-# INLINE cuIpcGetEventHandle #-}+{# fun unsafe cuIpcGetEventHandle+ { withForeignPtr* `IPCEventHandle'+ , useEvent `Event'+ }+ -> `Status' cToEnum #}+#endif+++-- |+-- Open an inter-process event handle for use in the current process,+-- returning an event that can be used in the current process and behaving+-- as a locally created event with the 'DisableTiming' flag specified.+--+-- The event must be freed with 'destroy'. Performing operations on the+-- imported event after the exported event has been 'destroy'ed in the+-- exporting process is undefined.+--+-- Requires CUDA-4.0.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__MEM.html#group__CUDA__MEM_1gf1d525918b6c643b99ca8c8e42e36c2e>+--+{-# INLINEABLE open #-}+open :: IPCEvent -> IO Event+#if CUDA_VERSION < 4010+open _ = requireSDK 'open 4.1+#else+open !ev = resultIfOk =<< cuIpcOpenEventHandle (useIPCEvent ev)++{-# INLINE cuIpcOpenEventHandle #-}+{# fun unsafe cuIpcOpenEventHandle+ { alloca- `Event' peekEvent*+ , withForeignPtr* `IPCEventHandle'+ }+ -> `Status' cToEnum #}+ where+ peekEvent = liftM Event . peek+#endif+++--------------------------------------------------------------------------------+-- Internal+--------------------------------------------------------------------------------++type IPCEventHandle = ForeignPtr ()++newIPCEventHandle :: IO IPCEventHandle+#if CUDA_VERSION < 4010+newIPCEventHandle = requireSDK 'newIPCEventHandle 4.1+#else+newIPCEventHandle = mallocForeignPtrBytes {#sizeof CUipcEventHandle#}+#endif+
+ src/Foreign/CUDA/Driver/IPC/Marshal.chs view
@@ -0,0 +1,177 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE TemplateHaskell #-}+--------------------------------------------------------------------------------+-- |+-- Module : Foreign.CUDA.Driver.IPC.Marshal+-- Copyright : [2009..2023] Trevor L. McDonell+-- License : BSD+--+-- IPC memory management for low-level driver interface.+--+-- Restricted to devices which support unified addressing on Linux+-- operating systems.+--+-- Since CUDA-4.0.+--+--------------------------------------------------------------------------------++module Foreign.CUDA.Driver.IPC.Marshal (++ -- ** IPC memory management+ IPCDevicePtr, IPCFlag(..),+ export, open, close,++) where++#include "cbits/stubs.h"+{# context lib="cuda" #}++-- Friends+import Foreign.CUDA.Ptr+import Foreign.CUDA.Driver.Error+import Foreign.CUDA.Internal.C2HS+import Foreign.CUDA.Driver.Marshal++-- System+import Control.Monad+import Prelude++import Foreign.C+import Foreign.Ptr+import Foreign.ForeignPtr+import Foreign.Marshal+++--------------------------------------------------------------------------------+-- Data Types+--------------------------------------------------------------------------------++-- |+-- A CUDA memory handle used for inter-process communication.+--+newtype IPCDevicePtr a = IPCDevicePtr { useIPCDevicePtr :: IPCMemHandle }+ deriving (Eq, Show)+++-- |+-- Flags for controlling IPC memory access+--+#if CUDA_VERSION < 4010+data IPCFlag+#else+{# enum CUipcMem_flags as IPCFlag+ { underscoreToCase }+ with prefix="CU_IPC_MEM" deriving (Eq, Show, Bounded) #}+#endif+++--------------------------------------------------------------------------------+-- IPC memory management+--------------------------------------------------------------------------------++-- |+-- Create an inter-process memory handle for an existing device memory+-- allocation. The handle can then be sent to another process and made+-- available to that process via 'open'.+--+-- Requires CUDA-4.1.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__MEM.html#group__CUDA__MEM_1g6f1b5be767b275f016523b2ac49ebec1>+--+{-# INLINEABLE export #-}+export :: DevicePtr a -> IO (IPCDevicePtr a)+#if CUDA_VERSION < 4010+export _ = requireSDK 'export 4.1+#else+export !dptr = do+ h <- newIPCMemHandle+ r <- cuIpcGetMemHandle h dptr+ resultIfOk (r, IPCDevicePtr h)++{-# INLINE cuIpcGetMemHandle #-}+{# fun unsafe cuIpcGetMemHandle+ { withForeignPtr* `IPCMemHandle'+ , useDeviceHandle `DevicePtr a'+ }+ -> `Status' cToEnum #}+#endif+++-- |+-- Open an inter-process memory handle exported from another process,+-- returning a device pointer usable in the current process.+--+-- Maps memory exported by another process with 'export into the current+-- device address space. For contexts on different devices, 'open' can+-- attempt to enable peer access if the user called+-- 'Foreign.CUDA.Driver.Context.Peer.add', and is controlled by the+-- 'LazyEnablePeerAccess' flag.+--+-- Each handle from a given device and context may only be 'open'ed by one+-- context per device per other process. Memory returned by 'open' must be+-- freed via 'close'.+--+-- Requires CUDA-4.1.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__MEM.html#group__CUDA__MEM_1ga8bd126fcff919a0c996b7640f197b79>+--+{-# INLINEABLE open #-}+open :: IPCDevicePtr a -> [IPCFlag]-> IO (DevicePtr a)+#if CUDA_VERSION < 4010+open _ _ = requireSDK 'open 4.1+#else+open !hdl !flags = resultIfOk =<< cuIpcOpenMemHandle (useIPCDevicePtr hdl) flags++{-# INLINE cuIpcOpenMemHandle #-}+{# fun unsafe cuIpcOpenMemHandle+ { alloca- `DevicePtr a' peekDeviceHandle*+ , withForeignPtr* `IPCMemHandle'+ , combineBitMasks `[IPCFlag]'+ }+ -> `Status' cToEnum #}+#endif+++-- |+-- Close and unmap memory returned by 'open'. The original allocation in+-- the exporting process as well as imported mappings in other processes+-- are unaffected.+--+-- Any resources used to enable peer access will be freed if this is the+-- last mapping using them.+--+-- Requires CUDA-4.1.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__MEM.html#group__CUDA__MEM_1gd6f5d5bcf6376c6853b64635b0157b9e>+--+{-# INLINEABLE close #-}+close :: DevicePtr a -> IO ()+#if CUDA_VERSION < 4010+close _ = requireSDK 'close 4.1+#else+close !dptr = nothingIfOk =<< cuIpcCloseMemHandle dptr++{-# INLINE cuIpcCloseMemHandle #-}+{# fun unsafe cuIpcCloseMemHandle+ { useDeviceHandle `DevicePtr a'+ }+ -> `Status' cToEnum #}+#endif+++--------------------------------------------------------------------------------+-- Internal+--------------------------------------------------------------------------------++type IPCMemHandle = ForeignPtr ()++newIPCMemHandle :: IO IPCMemHandle+#if CUDA_VERSION < 4010+newIPCMemHandle = requireSDK 'newIPCMemHandle 4.1+#else+newIPCMemHandle = mallocForeignPtrBytes {#sizeof CUipcMemHandle#}+#endif+
+ src/Foreign/CUDA/Driver/Marshal.chs view
@@ -0,0 +1,1197 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_HADDOCK prune #-}+--------------------------------------------------------------------------------+-- |+-- Module : Foreign.CUDA.Driver.Marshal+-- Copyright : [2009..2023] Trevor L. McDonell+-- License : BSD+--+-- Memory management for low-level driver interface+--+--------------------------------------------------------------------------------++module Foreign.CUDA.Driver.Marshal (++ -- * Host Allocation+ AllocFlag(..),+ mallocHostArray, mallocHostForeignPtr, freeHost,+ registerArray, unregisterArray,++ -- * Device Allocation+ mallocArray, allocaArray, free,++ -- * Unified Memory Allocation+ AttachFlag(..),+ mallocManagedArray,+ prefetchArrayAsync,+ attachArrayAsync,++ -- * Marshalling+ peekArray, peekArrayAsync, peekArray2D, peekArray2DAsync, peekListArray,+ pokeArray, pokeArrayAsync, pokeArray2D, pokeArray2DAsync, pokeListArray,+ copyArray, copyArrayAsync, copyArray2D, copyArray2DAsync,+ copyArrayPeer, copyArrayPeerAsync,++ -- * Combined Allocation and Marshalling+ newListArray, newListArrayLen,+ withListArray, withListArrayLen,++ -- * Utility+ memset, memsetAsync,+ getDevicePtr, getBasePtr, getMemInfo,++ -- Internal+ useDeviceHandle, peekDeviceHandle++) where++#include "cbits/stubs.h"+{# context lib="cuda" #}++-- Friends+import Foreign.CUDA.Ptr+import Foreign.CUDA.Driver.Device+import Foreign.CUDA.Driver.Error+import Foreign.CUDA.Driver.Stream ( Stream(..), defaultStream )+import Foreign.CUDA.Driver.Context.Base ( Context(..) )+import Foreign.CUDA.Internal.C2HS++-- System+import Data.Int+import Data.Maybe+import Data.Word+import Unsafe.Coerce+import Control.Applicative+import Control.Exception+import Prelude++import Foreign.C+import Foreign.Ptr+import Foreign.ForeignPtr+import Foreign.Storable+import qualified Foreign.Marshal as F++import GHC.Ptr+import GHC.Word+import GHC.Base++#c+typedef enum CUmemhostalloc_option_enum {+ CU_MEMHOSTALLOC_OPTION_PORTABLE = CU_MEMHOSTALLOC_PORTABLE,+ CU_MEMHOSTALLOC_OPTION_DEVICE_MAPPED = CU_MEMHOSTALLOC_DEVICEMAP,+ CU_MEMHOSTALLOC_OPTION_WRITE_COMBINED = CU_MEMHOSTALLOC_WRITECOMBINED+} CUmemhostalloc_option;+#endc+++--------------------------------------------------------------------------------+-- Host Allocation+--------------------------------------------------------------------------------++-- |+-- Options for host allocation+--+{# enum CUmemhostalloc_option as AllocFlag+ { underscoreToCase }+ with prefix="CU_MEMHOSTALLOC_OPTION" deriving (Eq, Show, Bounded) #}++-- |+-- Allocate a section of linear memory on the host which is page-locked and+-- directly accessible from the device. The storage is sufficient to hold the+-- given number of elements of a storable type.+--+-- Note that since the amount of pageable memory is thusly reduced, overall+-- system performance may suffer. This is best used sparingly to allocate+-- staging areas for data exchange.+--+-- Host memory allocated in this way is automatically and immediately+-- accessible to all contexts on all devices which support unified+-- addressing.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__MEM.html#group__CUDA__MEM_1gdd8311286d2c2691605362c689bc64e0>+--+{-# INLINEABLE mallocHostArray #-}+mallocHostArray :: Storable a => [AllocFlag] -> Int -> IO (HostPtr a)+mallocHostArray !flags = doMalloc undefined+ where+ doMalloc :: Storable a' => a' -> Int -> IO (HostPtr a')+ doMalloc x !n = resultIfOk =<< cuMemHostAlloc (n * sizeOf x) flags++-- |+-- As 'mallocHostArray', but return a 'ForeignPtr' instead. The array will be+-- deallocated automatically once the last reference to the 'ForeignPtr' is+-- dropped.+--+{-# INLINEABLE mallocHostForeignPtr #-}+{-# SPECIALISE mallocHostForeignPtr :: [AllocFlag] -> Int -> IO (ForeignPtr Word8) #-}+mallocHostForeignPtr :: Storable a => [AllocFlag] -> Int -> IO (ForeignPtr a)+mallocHostForeignPtr !flags !size = do+ HostPtr ptr <- mallocHostArray flags size+ newForeignPtr finalizerMemFreeHost ptr++{-# INLINE cuMemHostAlloc #-}+{# fun unsafe cuMemHostAlloc+ { alloca'- `HostPtr a' peekHP*+ , `Int'+ , combineBitMasks `[AllocFlag]' } -> `Status' cToEnum #}+ where+ alloca' !f = F.alloca $ \ !p -> poke p nullPtr >> f (castPtr p)+ peekHP !p = HostPtr . castPtr <$> peek p++-- Pointer to the foreign function to release host arrays, which may be used as+-- a finalizer. Technically this function has a non-void return type, but I am+-- hoping that that doesn't matter...+--+foreign import ccall "&cuMemFreeHost" finalizerMemFreeHost :: FinalizerPtr a++-- |+-- Free a section of page-locked host memory.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__MEM.html#group__CUDA__MEM_1g62e0fdbe181dab6b1c90fa1a51c7b92c>+--+{-# INLINEABLE freeHost #-}+freeHost :: HostPtr a -> IO ()+freeHost !p = nothingIfOk =<< cuMemFreeHost p++{-# INLINE cuMemFreeHost #-}+{# fun unsafe cuMemFreeHost+ { useHP `HostPtr a' } -> `Status' cToEnum #}+ where+ useHP = castPtr . useHostPtr+++-- |+-- Page-locks the specified array (on the host) and maps it for the device(s) as+-- specified by the given allocation flags. Subsequently, the memory is accessed+-- directly by the device so can be read and written with much higher bandwidth+-- than pageable memory that has not been registered. The memory range is added+-- to the same tracking mechanism as 'mallocHostArray' to automatically+-- accelerate calls to functions such as 'pokeArray'.+--+-- Note that page-locking excessive amounts of memory may degrade system+-- performance, since it reduces the amount of pageable memory available. This+-- is best used sparingly to allocate staging areas for data exchange.+--+-- This function has limited support on Mac OS X. OS 10.7 or later is+-- required.+--+-- Requires CUDA-4.0.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__MEM.html#group__CUDA__MEM_1gf0a9fe11544326dabd743b7aa6b54223>+--+{-# INLINEABLE registerArray #-}+registerArray :: Storable a => [AllocFlag] -> Int -> Ptr a -> IO (HostPtr a)+#if CUDA_VERSION < 4000+registerArray _ _ _ = requireSDK 'registerArray 4.0+#else+registerArray !flags !n = go undefined+ where+ go :: Storable b => b -> Ptr b -> IO (HostPtr b)+ go x !p = do+ status <- cuMemHostRegister p (n * sizeOf x) flags+ resultIfOk (status,HostPtr p)++{-# INLINE cuMemHostRegister #-}+{# fun unsafe cuMemHostRegister+ { castPtr `Ptr a'+ , `Int'+ , combineBitMasks `[AllocFlag]' } -> `Status' cToEnum #}+#endif+++-- |+-- Unmaps the memory from the given pointer, and makes it pageable again.+--+-- Requires CUDA-4.0.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__MEM.html#group__CUDA__MEM_1g63f450c8125359be87b7623b1c0b2a14>+--+{-# INLINEABLE unregisterArray #-}+unregisterArray :: HostPtr a -> IO (Ptr a)+#if CUDA_VERSION < 4000+unregisterArray _ = requireSDK 'unregisterArray 4.0+#else+unregisterArray (HostPtr !p) = do+ status <- cuMemHostUnregister p+ resultIfOk (status,p)++{-# INLINE cuMemHostUnregister #-}+{# fun unsafe cuMemHostUnregister+ { castPtr `Ptr a' } -> `Status' cToEnum #}+#endif+++--------------------------------------------------------------------------------+-- Device Allocation+--------------------------------------------------------------------------------++-- |+-- Allocate a section of linear memory on the device, and return a reference to+-- it. The memory is sufficient to hold the given number of elements of storable+-- type. It is suitably aligned for any type, and is not cleared.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__MEM.html#group__CUDA__MEM_1gb82d2a09844a58dd9e744dc31e8aa467>+--+{-# INLINEABLE mallocArray #-}+mallocArray :: Storable a => Int -> IO (DevicePtr a)+mallocArray = doMalloc undefined+ where+ doMalloc :: Storable a' => a' -> Int -> IO (DevicePtr a')+ doMalloc x !n = resultIfOk =<< cuMemAlloc (n * sizeOf x)++{-# INLINE cuMemAlloc #-}+{# fun unsafe cuMemAlloc+ { alloca'- `DevicePtr a' peekDeviceHandle*+ , `Int' } -> `Status' cToEnum #}+ where+ alloca' !f = F.alloca $ \ !p -> poke p nullPtr >> f (castPtr p)+++-- |+-- Execute a computation on the device, passing a pointer to a temporarily+-- allocated block of memory sufficient to hold the given number of elements of+-- storable type. The memory is freed when the computation terminates (normally+-- or via an exception), so the pointer must not be used after this.+--+-- Note that kernel launches can be asynchronous, so you may want to add a+-- synchronisation point using 'Foreign.CUDA.Driver.Context.sync' as part+-- of the continuation.+--+{-# INLINEABLE allocaArray #-}+allocaArray :: Storable a => Int -> (DevicePtr a -> IO b) -> IO b+allocaArray !n = bracket (mallocArray n) free+++-- |+-- Release a section of device memory.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__MEM.html#group__CUDA__MEM_1g89b3f154e17cc89b6eea277dbdf5c93a>+--+{-# INLINEABLE free #-}+free :: DevicePtr a -> IO ()+free !dp = nothingIfOk =<< cuMemFree dp++{-# INLINE cuMemFree #-}+{# fun unsafe cuMemFree+ { useDeviceHandle `DevicePtr a' } -> `Status' cToEnum #}+++--------------------------------------------------------------------------------+-- Unified memory allocations+--------------------------------------------------------------------------------++-- |+-- Options for unified memory allocations+--+#if CUDA_VERSION < 6000+data AttachFlag+#else+{# enum CUmemAttach_flags as AttachFlag+ { underscoreToCase }+ with prefix="CU_MEM_ATTACH_OPTION" deriving (Eq, Show, Bounded) #}+#endif++-- |+-- Allocates memory that will be automatically managed by the Unified Memory+-- system. The returned pointer is valid on the CPU and on all GPUs which+-- supported managed memory. All accesses to this pointer must obey the+-- Unified Memory programming model.+--+-- On a multi-GPU system with peer-to-peer support, where multiple GPUs+-- support managed memory, the physical storage is created on the GPU which+-- is active at the time 'mallocManagedArray' is called. All other GPUs+-- will access the array at reduced bandwidth via peer mapping over the+-- PCIe bus. The Unified Memory system does not migrate memory between+-- GPUs.+--+-- On a multi-GPU system where multiple GPUs support managed memory, but+-- not all pairs of such GPUs have peer-to-peer support between them, the+-- physical storage is allocated in system memory (zero-copy memory) and+-- all GPUs will access the data at reduced bandwidth over the PCIe bus.+--+-- Requires CUDA-6.0+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__MEM.html#group__CUDA__MEM_1gb347ded34dc326af404aa02af5388a32>+--+{-# INLINEABLE mallocManagedArray #-}+mallocManagedArray :: Storable a => [AttachFlag] -> Int -> IO (DevicePtr a)+#if CUDA_VERSION < 6000+mallocManagedArray _ _ = requireSDK 'mallocManagedArray 6.0+#else+mallocManagedArray !flags = doMalloc undefined+ where+ doMalloc :: Storable a' => a' -> Int -> IO (DevicePtr a')+ doMalloc x !n = resultIfOk =<< cuMemAllocManaged (n * sizeOf x) flags++{-# INLINE cuMemAllocManaged #-}+{# fun unsafe cuMemAllocManaged+ { alloca'- `DevicePtr a' peekDeviceHandle*+ , `Int'+ , combineBitMasks `[AttachFlag]' } -> `Status' cToEnum #}+ where+ alloca' !f = F.alloca $ \ !p -> poke p nullPtr >> f (castPtr p)+#endif+++-- | Pre-fetches the given number of elements to the specified destination+-- device. If the specified device is Nothing, the data is pre-fetched to host+-- memory. The pointer must refer to a memory range allocated with+-- 'mallocManagedArray'.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__UNIFIED.html#group__CUDA__UNIFIED_1gfe94f8b7fb56291ebcea44261aa4cb84>+--+-- Requires CUDA-8.0.+--+prefetchArrayAsync :: Storable a => DevicePtr a -> Int -> Maybe Device -> Maybe Stream -> IO ()+#if CUDA_VERSION < 8000+prefetchArrayAsync _ _ _ _ = requireSDK 'prefetchArrayAsync 8.0+#else+prefetchArrayAsync ptr n mdev mst = go undefined ptr+ where+ go :: Storable a' => a' -> DevicePtr a' -> IO ()+ go x _ = nothingIfOk =<< cuMemPrefetchAsync ptr (n * sizeOf x) (maybe (-1) useDevice mdev) (fromMaybe defaultStream mst)++{-# INLINE cuMemPrefetchAsync #-}+#if CUDA_VERSION < 13000+{# fun unsafe cuMemPrefetchAsync+ { useDeviceHandle `DevicePtr a'+ , `Int'+ , id `CInt'+ , useStream `Stream'+ }+ -> `Status' cToEnum #}+#else+{# fun unsafe cuMemPrefetchAsync_device as cuMemPrefetchAsync+ { useDeviceHandle `DevicePtr a'+ , `Int'+ , id `CInt'+ , useStream `Stream'+ }+ -> `Status' cToEnum #}+#endif+#endif+++-- | Attach an array of the given number of elements to a stream asynchronously+--+-- <https://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__STREAM.html#group__CUDA__STREAM_1g6e468d680e263e7eba02a56643c50533>+--+-- @since 0.10.0.0+--+{-# INLINEABLE attachArrayAsync #-}+attachArrayAsync :: forall a. Storable a => [AttachFlag] -> Stream -> DevicePtr a -> Int -> IO ()+attachArrayAsync !flags !stream !ptr !n = cuStreamAttachMemAsync stream ptr (n * sizeOf (undefined::a)) flags+ where+ {# fun unsafe cuStreamAttachMemAsync+ { useStream `Stream'+ , useDeviceHandle `DevicePtr a'+ , `Int'+ , combineBitMasks `[AttachFlag]'+ }+ -> `()' checkStatus*- #}+++--------------------------------------------------------------------------------+-- Marshalling+--------------------------------------------------------------------------------++-- Device -> Host+-- --------------++-- |+-- Copy a number of elements from the device to host memory. This is a+-- synchronous operation.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__MEM.html#group__CUDA__MEM_1g3480368ee0208a98f75019c9a8450893>+--+{-# INLINEABLE peekArray #-}+peekArray :: Storable a => Int -> DevicePtr a -> Ptr a -> IO ()+peekArray !n !dptr !hptr = doPeek undefined dptr+ where+ doPeek :: Storable a' => a' -> DevicePtr a' -> IO ()+ doPeek x _ = nothingIfOk =<< cuMemcpyDtoH hptr dptr (n * sizeOf x)++{-# INLINE cuMemcpyDtoH #-}+{# fun cuMemcpyDtoH+ { castPtr `Ptr a'+ , useDeviceHandle `DevicePtr a'+ , `Int' } -> `Status' cToEnum #}+++-- |+-- Copy memory from the device asynchronously, possibly associated with a+-- particular stream. The destination host memory must be page-locked.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__MEM.html#group__CUDA__MEM_1g56f30236c7c5247f8e061b59d3268362>+--+{-# INLINEABLE peekArrayAsync #-}+peekArrayAsync :: Storable a => Int -> DevicePtr a -> HostPtr a -> Maybe Stream -> IO ()+peekArrayAsync !n !dptr !hptr !mst = doPeek undefined dptr+ where+ doPeek :: Storable a' => a' -> DevicePtr a' -> IO ()+ doPeek x _ = nothingIfOk =<< cuMemcpyDtoHAsync hptr dptr (n * sizeOf x) (fromMaybe defaultStream mst)++{-# INLINE cuMemcpyDtoHAsync #-}+{# fun cuMemcpyDtoHAsync+ { useHP `HostPtr a'+ , useDeviceHandle `DevicePtr a'+ , `Int'+ , useStream `Stream' } -> `Status' cToEnum #}+ where+ useHP = castPtr . useHostPtr+++-- |+-- Copy a 2D array from the device to the host.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__MEM.html#group__CUDA__MEM_1g27f885b30c34cc20a663a671dbf6fc27>+--+{-# INLINEABLE peekArray2D #-}+peekArray2D+ :: Storable a+ => Int -- ^ width to copy (elements)+ -> Int -- ^ height to copy (elements)+ -> DevicePtr a -- ^ source array+ -> Int -- ^ source array width+ -> Int -- ^ source x-coordinate+ -> Int -- ^ source y-coordinate+ -> Ptr a -- ^ destination array+ -> Int -- ^ destination array width+ -> Int -- ^ destination x-coordinate+ -> Int -- ^ destination y-coordinate+ -> IO ()+peekArray2D !w !h !dptr !dw !dx !dy !hptr !hw !hx !hy = doPeek undefined dptr+ where+ doPeek :: Storable a' => a' -> DevicePtr a' -> IO ()+ doPeek x _ =+ let bytes = sizeOf x+ w' = w * bytes+ hw' = hw * bytes+ hx' = hx * bytes+ dw' = dw * bytes+ dx' = dx * bytes+ in+ nothingIfOk =<< cuMemcpy2DDtoH hptr hw' hx' hy dptr dw' dx' dy w' h++{-# INLINE cuMemcpy2DDtoH #-}+{# fun cuMemcpy2DDtoH+ { castPtr `Ptr a'+ , `Int'+ , `Int'+ , `Int'+ , useDeviceHandle `DevicePtr a'+ , `Int'+ , `Int'+ , `Int'+ , `Int'+ , `Int'+ }+ -> `Status' cToEnum #}+++-- |+-- Copy a 2D array from the device to the host asynchronously, possibly+-- associated with a particular execution stream. The destination host memory+-- must be page-locked.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__MEM.html#group__CUDA__MEM_1g4acf155faeb969d9d21f5433d3d0f274>+--+{-# INLINEABLE peekArray2DAsync #-}+peekArray2DAsync+ :: Storable a+ => Int -- ^ width to copy (elements)+ -> Int -- ^ height to copy (elements)+ -> DevicePtr a -- ^ source array+ -> Int -- ^ source array width+ -> Int -- ^ source x-coordinate+ -> Int -- ^ source y-coordinate+ -> HostPtr a -- ^ destination array+ -> Int -- ^ destination array width+ -> Int -- ^ destination x-coordinate+ -> Int -- ^ destination y-coordinate+ -> Maybe Stream -- ^ stream to associate to+ -> IO ()+peekArray2DAsync !w !h !dptr !dw !dx !dy !hptr !hw !hx !hy !mst = doPeek undefined dptr+ where+ doPeek :: Storable a' => a' -> DevicePtr a' -> IO ()+ doPeek x _ =+ let bytes = sizeOf x+ w' = w * bytes+ hw' = hw * bytes+ hx' = hx * bytes+ dw' = dw * bytes+ dx' = dx * bytes+ st = fromMaybe defaultStream mst+ in+ nothingIfOk =<< cuMemcpy2DDtoHAsync hptr hw' hx' hy dptr dw' dx' dy w' h st++{-# INLINE cuMemcpy2DDtoHAsync #-}+{# fun cuMemcpy2DDtoHAsync+ { useHP `HostPtr a'+ , `Int'+ , `Int'+ , `Int'+ , useDeviceHandle `DevicePtr a'+ , `Int'+ , `Int'+ , `Int'+ , `Int'+ , `Int'+ , useStream `Stream'+ }+ -> `Status' cToEnum #}+ where+ useHP = castPtr . useHostPtr+++-- |+-- Copy a number of elements from the device into a new Haskell list. Note that+-- this requires two memory copies: firstly from the device into a heap+-- allocated array, and from there marshalled into a list.+--+{-# INLINEABLE peekListArray #-}+peekListArray :: Storable a => Int -> DevicePtr a -> IO [a]+peekListArray !n !dptr =+ F.allocaArray n $ \p -> do+ peekArray n dptr p+ F.peekArray n p+++-- Host -> Device+-- --------------++-- |+-- Copy a number of elements onto the device. This is a synchronous operation.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__MEM.html#group__CUDA__MEM_1g4d32266788c440b0220b1a9ba5795169>+--+{-# INLINEABLE pokeArray #-}+pokeArray :: Storable a => Int -> Ptr a -> DevicePtr a -> IO ()+pokeArray !n !hptr !dptr = doPoke undefined dptr+ where+ doPoke :: Storable a' => a' -> DevicePtr a' -> IO ()+ doPoke x _ = nothingIfOk =<< cuMemcpyHtoD dptr hptr (n * sizeOf x)++{-# INLINE cuMemcpyHtoD #-}+{# fun cuMemcpyHtoD+ { useDeviceHandle `DevicePtr a'+ , castPtr `Ptr a'+ , `Int' } -> `Status' cToEnum #}+++-- |+-- Copy memory onto the device asynchronously, possibly associated with a+-- particular stream. The source host memory must be page-locked.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__MEM.html#group__CUDA__MEM_1g1572263fe2597d7ba4f6964597a354a3>+--+{-# INLINEABLE pokeArrayAsync #-}+pokeArrayAsync :: Storable a => Int -> HostPtr a -> DevicePtr a -> Maybe Stream -> IO ()+pokeArrayAsync !n !hptr !dptr !mst = dopoke undefined dptr+ where+ dopoke :: Storable a' => a' -> DevicePtr a' -> IO ()+ dopoke x _ = nothingIfOk =<< cuMemcpyHtoDAsync dptr hptr (n * sizeOf x) (fromMaybe defaultStream mst)++{-# INLINE cuMemcpyHtoDAsync #-}+{# fun cuMemcpyHtoDAsync+ { useDeviceHandle `DevicePtr a'+ , useHP `HostPtr a'+ , `Int'+ , useStream `Stream' } -> `Status' cToEnum #}+ where+ useHP = castPtr . useHostPtr+++-- |+-- Copy a 2D array from the host to the device.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__MEM.html#group__CUDA__MEM_1g27f885b30c34cc20a663a671dbf6fc27>+--+{-# INLINEABLE pokeArray2D #-}+pokeArray2D+ :: Storable a+ => Int -- ^ width to copy (elements)+ -> Int -- ^ height to copy (elements)+ -> Ptr a -- ^ source array+ -> Int -- ^ source array width+ -> Int -- ^ source x-coordinate+ -> Int -- ^ source y-coordinate+ -> DevicePtr a -- ^ destination array+ -> Int -- ^ destination array width+ -> Int -- ^ destination x-coordinate+ -> Int -- ^ destination y-coordinate+ -> IO ()+pokeArray2D !w !h !hptr !hw !hx !hy !dptr !dw !dx !dy = doPoke undefined dptr+ where+ doPoke :: Storable a' => a' -> DevicePtr a' -> IO ()+ doPoke x _ =+ let bytes = sizeOf x+ w' = w * bytes+ hw' = hw * bytes+ hx' = hx * bytes+ dw' = dw * bytes+ dx' = dx * bytes+ in+ nothingIfOk =<< cuMemcpy2DHtoD dptr dw' dx' dy hptr hw' hx' hy w' h++{-# INLINE cuMemcpy2DHtoD #-}+{# fun cuMemcpy2DHtoD+ { useDeviceHandle `DevicePtr a'+ , `Int'+ , `Int'+ , `Int'+ , castPtr `Ptr a'+ , `Int'+ , `Int'+ , `Int'+ , `Int'+ , `Int'+ }+ -> `Status' cToEnum #}+++-- |+-- Copy a 2D array from the host to the device asynchronously, possibly+-- associated with a particular execution stream. The source host memory must be+-- page-locked.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__MEM.html#group__CUDA__MEM_1g4acf155faeb969d9d21f5433d3d0f274>+--+{-# INLINEABLE pokeArray2DAsync #-}+pokeArray2DAsync+ :: Storable a+ => Int -- ^ width to copy (elements)+ -> Int -- ^ height to copy (elements)+ -> HostPtr a -- ^ source array+ -> Int -- ^ source array width+ -> Int -- ^ source x-coordinate+ -> Int -- ^ source y-coordinate+ -> DevicePtr a -- ^ destination array+ -> Int -- ^ destination array width+ -> Int -- ^ destination x-coordinate+ -> Int -- ^ destination y-coordinate+ -> Maybe Stream -- ^ stream to associate to+ -> IO ()+pokeArray2DAsync !w !h !hptr !hw !hx !hy !dptr !dw !dx !dy !mst = doPoke undefined dptr+ where+ doPoke :: Storable a' => a' -> DevicePtr a' -> IO ()+ doPoke x _ =+ let bytes = sizeOf x+ w' = w * bytes+ hw' = hw * bytes+ hx' = hx * bytes+ dw' = dw * bytes+ dx' = dx * bytes+ st = fromMaybe defaultStream mst+ in+ nothingIfOk =<< cuMemcpy2DHtoDAsync dptr dw' dx' dy hptr hw' hx' hy w' h st++{-# INLINE cuMemcpy2DHtoDAsync #-}+{# fun cuMemcpy2DHtoDAsync+ { useDeviceHandle `DevicePtr a'+ , `Int'+ , `Int'+ , `Int'+ , useHP `HostPtr a'+ , `Int'+ , `Int'+ , `Int'+ , `Int'+ , `Int'+ , useStream `Stream'+ }+ -> `Status' cToEnum #}+ where+ useHP = castPtr . useHostPtr+++-- |+-- Write a list of storable elements into a device array. The device array must+-- be sufficiently large to hold the entire list. This requires two marshalling+-- operations.+--+{-# INLINEABLE pokeListArray #-}+pokeListArray :: Storable a => [a] -> DevicePtr a -> IO ()+pokeListArray !xs !dptr = F.withArrayLen xs $ \ !len !p -> pokeArray len p dptr+++-- Device -> Device+-- ----------------++-- |+-- Copy the given number of elements from the first device array (source) to the+-- second device (destination). The copied areas may not overlap. This operation+-- is asynchronous with respect to the host, but will never overlap with kernel+-- execution.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__MEM.html#group__CUDA__MEM_1g1725774abf8b51b91945f3336b778c8b>+--+{-# INLINEABLE copyArray #-}+copyArray :: Storable a => Int -> DevicePtr a -> DevicePtr a -> IO ()+copyArray !n = docopy undefined+ where+ docopy :: Storable a' => a' -> DevicePtr a' -> DevicePtr a' -> IO ()+ docopy x src dst = nothingIfOk =<< cuMemcpyDtoD dst src (n * sizeOf x)++{-# INLINE cuMemcpyDtoD #-}+{# fun unsafe cuMemcpyDtoD+ { useDeviceHandle `DevicePtr a'+ , useDeviceHandle `DevicePtr a'+ , `Int' } -> `Status' cToEnum #}+++-- |+-- Copy the given number of elements from the first device array (source) to the+-- second device array (destination). The copied areas may not overlap. The+-- operation is asynchronous with respect to the host, and can be asynchronous+-- to other device operations by associating it with a particular stream.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__MEM.html#group__CUDA__MEM_1g39ea09ba682b8eccc9c3e0c04319b5c8>+--+{-# INLINEABLE copyArrayAsync #-}+copyArrayAsync :: Storable a => Int -> DevicePtr a -> DevicePtr a -> Maybe Stream -> IO ()+copyArrayAsync !n !src !dst !mst = docopy undefined src+ where+ docopy :: Storable a' => a' -> DevicePtr a' -> IO ()+ docopy x _ = nothingIfOk =<< cuMemcpyDtoDAsync dst src (n * sizeOf x) (fromMaybe defaultStream mst)++{-# INLINE cuMemcpyDtoDAsync #-}+{# fun unsafe cuMemcpyDtoDAsync+ { useDeviceHandle `DevicePtr a'+ , useDeviceHandle `DevicePtr a'+ , `Int'+ , useStream `Stream' } -> `Status' cToEnum #}+++-- |+-- Copy a 2D array from the first device array (source) to the second device+-- array (destination). The copied areas must not overlap. This operation is+-- asynchronous with respect to the host, but will never overlap with kernel+-- execution.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__MEM.html#group__CUDA__MEM_1g27f885b30c34cc20a663a671dbf6fc27>+--+{-# INLINEABLE copyArray2D #-}+copyArray2D+ :: Storable a+ => Int -- ^ width to copy (elements)+ -> Int -- ^ height to copy (elements)+ -> DevicePtr a -- ^ source array+ -> Int -- ^ source array width+ -> Int -- ^ source x-coordinate+ -> Int -- ^ source y-coordinate+ -> DevicePtr a -- ^ destination array+ -> Int -- ^ destination array width+ -> Int -- ^ destination x-coordinate+ -> Int -- ^ destination y-coordinate+ -> IO ()+copyArray2D !w !h !src !hw !hx !hy !dst !dw !dx !dy = doCopy undefined dst+ where+ doCopy :: Storable a' => a' -> DevicePtr a' -> IO ()+ doCopy x _ =+ let bytes = sizeOf x+ w' = w * bytes+ hw' = hw * bytes+ hx' = hx * bytes+ dw' = dw * bytes+ dx' = dx * bytes+ in+ nothingIfOk =<< cuMemcpy2DDtoD dst dw' dx' dy src hw' hx' hy w' h++{-# INLINE cuMemcpy2DDtoD #-}+{# fun unsafe cuMemcpy2DDtoD+ { useDeviceHandle `DevicePtr a'+ , `Int'+ , `Int'+ , `Int'+ , useDeviceHandle `DevicePtr a'+ , `Int'+ , `Int'+ , `Int'+ , `Int'+ , `Int'+ }+ -> `Status' cToEnum #}+++-- |+-- Copy a 2D array from the first device array (source) to the second device+-- array (destination). The copied areas may not overlap. The operation is+-- asynchronous with respect to the host, and can be asynchronous to other+-- device operations by associating it with a particular execution stream.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__MEM.html#group__CUDA__MEM_1g4acf155faeb969d9d21f5433d3d0f274>+--+{-# INLINEABLE copyArray2DAsync #-}+copyArray2DAsync+ :: Storable a+ => Int -- ^ width to copy (elements)+ -> Int -- ^ height to copy (elements)+ -> DevicePtr a -- ^ source array+ -> Int -- ^ source array width+ -> Int -- ^ source x-coordinate+ -> Int -- ^ source y-coordinate+ -> DevicePtr a -- ^ destination array+ -> Int -- ^ destination array width+ -> Int -- ^ destination x-coordinate+ -> Int -- ^ destination y-coordinate+ -> Maybe Stream -- ^ stream to associate to+ -> IO ()+copyArray2DAsync !w !h !src !hw !hx !hy !dst !dw !dx !dy !mst = doCopy undefined dst+ where+ doCopy :: Storable a' => a' -> DevicePtr a' -> IO ()+ doCopy x _ =+ let bytes = sizeOf x+ w' = w * bytes+ hw' = hw * bytes+ hx' = hx * bytes+ dw' = dw * bytes+ dx' = dx * bytes+ st = fromMaybe defaultStream mst+ in+ nothingIfOk =<< cuMemcpy2DDtoDAsync dst dw' dx' dy src hw' hx' hy w' h st++{-# INLINE cuMemcpy2DDtoDAsync #-}+{# fun unsafe cuMemcpy2DDtoDAsync+ { useDeviceHandle `DevicePtr a'+ , `Int'+ , `Int'+ , `Int'+ , useDeviceHandle `DevicePtr a'+ , `Int'+ , `Int'+ , `Int'+ , `Int'+ , `Int'+ , useStream `Stream'+ }+ -> `Status' cToEnum #}++++-- Context -> Context+-- ------------------++-- |+-- Copies an array from device memory in one context to device memory in another+-- context. Note that this function is asynchronous with respect to the host,+-- but serialised with respect to all pending and future asynchronous work in+-- the source and destination contexts. To avoid this synchronisation, use+-- 'copyArrayPeerAsync' instead.+--+-- Requires CUDA-4.0.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__MEM.html#group__CUDA__MEM_1ge1f5c7771544fee150ada8853c7cbf4a>+--+{-# INLINEABLE copyArrayPeer #-}+copyArrayPeer :: Storable a+ => Int -- ^ number of array elements+ -> DevicePtr a -> Context -- ^ source array and context+ -> DevicePtr a -> Context -- ^ destination array and context+ -> IO ()+#if CUDA_VERSION < 4000+copyArrayPeer _ _ _ _ _ = requireSDK 'copyArrayPeer 4.0+#else+copyArrayPeer !n !src !srcCtx !dst !dstCtx = go undefined src dst+ where+ go :: Storable b => b -> DevicePtr b -> DevicePtr b -> IO ()+ go x _ _ = nothingIfOk =<< cuMemcpyPeer dst dstCtx src srcCtx (n * sizeOf x)++{-# INLINE cuMemcpyPeer #-}+{# fun unsafe cuMemcpyPeer+ { useDeviceHandle `DevicePtr a'+ , useContext `Context'+ , useDeviceHandle `DevicePtr a'+ , useContext `Context'+ , `Int' } -> `Status' cToEnum #}+#endif+++-- |+-- Copies from device memory in one context to device memory in another context.+-- Note that this function is asynchronous with respect to the host and all work+-- in other streams and devices.+--+-- Requires CUDA-4.0.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__MEM.html#group__CUDA__MEM_1g82fcecb38018e64b98616a8ac30112f2>+--+{-# INLINEABLE copyArrayPeerAsync #-}+copyArrayPeerAsync :: Storable a+ => Int -- ^ number of array elements+ -> DevicePtr a -> Context -- ^ source array and context+ -> DevicePtr a -> Context -- ^ destination array and device context+ -> Maybe Stream -- ^ stream to associate with+ -> IO ()+#if CUDA_VERSION < 4000+copyArrayPeerAsync _ _ _ _ _ _ = requireSDK 'copyArrayPeerAsync 4.0+#else+copyArrayPeerAsync !n !src !srcCtx !dst !dstCtx !st = go undefined src dst+ where+ go :: Storable b => b -> DevicePtr b -> DevicePtr b -> IO ()+ go x _ _ = nothingIfOk =<< cuMemcpyPeerAsync dst dstCtx src srcCtx (n * sizeOf x) stream+ stream = fromMaybe defaultStream st++{-# INLINE cuMemcpyPeerAsync #-}+{# fun unsafe cuMemcpyPeerAsync+ { useDeviceHandle `DevicePtr a'+ , useContext `Context'+ , useDeviceHandle `DevicePtr a'+ , useContext `Context'+ , `Int'+ , useStream `Stream' } -> `Status' cToEnum #}+#endif+++--------------------------------------------------------------------------------+-- Combined Allocation and Marshalling+--------------------------------------------------------------------------------++-- |+-- Write a list of storable elements into a newly allocated device array,+-- returning the device pointer together with the number of elements that were+-- written. Note that this requires two memory copies: firstly from a Haskell+-- list to a heap allocated array, and from there onto the graphics device. The+-- memory should be 'free'd when no longer required.+--+{-# INLINEABLE newListArrayLen #-}+newListArrayLen :: Storable a => [a] -> IO (DevicePtr a, Int)+newListArrayLen xs =+ F.withArrayLen xs $ \len p ->+ bracketOnError (mallocArray len) free $ \d_xs -> do+ pokeArray len p d_xs+ return (d_xs, len)+++-- |+-- Write a list of storable elements into a newly allocated device array. This+-- is 'newListArrayLen' composed with 'fst'.+--+{-# INLINEABLE newListArray #-}+newListArray :: Storable a => [a] -> IO (DevicePtr a)+newListArray xs = fst `fmap` newListArrayLen xs+++-- |+-- Temporarily store a list of elements into a newly allocated device array. An+-- IO action is applied to to the array, the result of which is returned.+-- Similar to 'newListArray', this requires copying the data twice.+--+-- As with 'allocaArray', the memory is freed once the action completes, so you+-- should not return the pointer from the action, and be wary of asynchronous+-- kernel execution.+--+{-# INLINEABLE withListArray #-}+withListArray :: Storable a => [a] -> (DevicePtr a -> IO b) -> IO b+withListArray xs = withListArrayLen xs . const+++-- |+-- A variant of 'withListArray' which also supplies the number of elements in+-- the array to the applied function+--+{-# INLINEABLE withListArrayLen #-}+withListArrayLen :: Storable a => [a] -> (Int -> DevicePtr a -> IO b) -> IO b+withListArrayLen xs f =+ bracket (newListArrayLen xs) (free . fst) (uncurry . flip $ f)+--+-- XXX: Will this attempt to double-free the device array on error (together+-- with newListArrayLen)?+--+++--------------------------------------------------------------------------------+-- Utility+--------------------------------------------------------------------------------++-- |+-- Set a number of data elements to the specified value, which may be either 8-,+-- 16-, or 32-bits wide.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__MEM.html#group__CUDA__MEM_1g6e582bf866e9e2fb014297bfaf354d7b>+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__MEM.html#group__CUDA__MEM_1g7d805e610054392a4d11e8a8bf5eb35c>+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__MEM.html#group__CUDA__MEM_1g983e8d8759acd1b64326317481fbf132>+--+{-# INLINEABLE memset #-}+memset :: Storable a => DevicePtr a -> Int -> a -> IO ()+memset !dptr !n !val = case sizeOf val of+ 1 -> nothingIfOk =<< cuMemsetD8 dptr val n+ 2 -> nothingIfOk =<< cuMemsetD16 dptr val n+ 4 -> nothingIfOk =<< cuMemsetD32 dptr val n+ _ -> cudaErrorIO "can only memset 8-, 16-, and 32-bit values"++--+-- We use unsafe coerce below to reinterpret the bits of the value to memset as,+-- into the integer type required by the setting functions.+--+{-# INLINE cuMemsetD8 #-}+{# fun unsafe cuMemsetD8+ { useDeviceHandle `DevicePtr a'+ , unsafeCoerce `a'+ , `Int' } -> `Status' cToEnum #}++{-# INLINE cuMemsetD16 #-}+{# fun unsafe cuMemsetD16+ { useDeviceHandle `DevicePtr a'+ , unsafeCoerce `a'+ , `Int' } -> `Status' cToEnum #}++{-# INLINE cuMemsetD32 #-}+{# fun unsafe cuMemsetD32+ { useDeviceHandle `DevicePtr a'+ , unsafeCoerce `a'+ , `Int' } -> `Status' cToEnum #}+++-- |+-- Set the number of data elements to the specified value, which may be either+-- 8-, 16-, or 32-bits wide. The operation is asynchronous and may optionally be+-- associated with a stream.+--+-- Requires CUDA-3.2.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__MEM.html#group__CUDA__MEM_1gaef08a7ccd61112f94e82f2b30d43627>+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__MEM.html#group__CUDA__MEM_1gf731438877dd8ec875e4c43d848c878c>+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__MEM.html#group__CUDA__MEM_1g58229da5d30f1c0cdf667b320ec2c0f5>+--+{-# INLINEABLE memsetAsync #-}+memsetAsync :: Storable a => DevicePtr a -> Int -> a -> Maybe Stream -> IO ()+#if CUDA_VERSION < 3020+memsetAsync _ _ _ _ = requireSDK 'memsetAsync 3.2+#else+memsetAsync !dptr !n !val !mst = case sizeOf val of+ 1 -> nothingIfOk =<< cuMemsetD8Async dptr val n stream+ 2 -> nothingIfOk =<< cuMemsetD16Async dptr val n stream+ 4 -> nothingIfOk =<< cuMemsetD32Async dptr val n stream+ _ -> cudaErrorIO "can only memset 8-, 16-, and 32-bit values"+ where+ stream = fromMaybe defaultStream mst++{-# INLINE cuMemsetD8Async #-}+{# fun unsafe cuMemsetD8Async+ { useDeviceHandle `DevicePtr a'+ , unsafeCoerce `a'+ , `Int'+ , useStream `Stream' } -> `Status' cToEnum #}++{-# INLINE cuMemsetD16Async #-}+{# fun unsafe cuMemsetD16Async+ { useDeviceHandle `DevicePtr a'+ , unsafeCoerce `a'+ , `Int'+ , useStream `Stream' } -> `Status' cToEnum #}++{-# INLINE cuMemsetD32Async #-}+{# fun unsafe cuMemsetD32Async+ { useDeviceHandle `DevicePtr a'+ , unsafeCoerce `a'+ , `Int'+ , useStream `Stream' } -> `Status' cToEnum #}+#endif+++-- |+-- Return the device pointer associated with a mapped, pinned host buffer, which+-- was allocated with the 'DeviceMapped' option by 'mallocHostArray'.+--+-- Currently, no options are supported and this must be empty.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__MEM.html#group__CUDA__MEM_1g57a39e5cba26af4d06be67fc77cc62f0>+--+{-# INLINEABLE getDevicePtr #-}+getDevicePtr :: [AllocFlag] -> HostPtr a -> IO (DevicePtr a)+getDevicePtr !flags !hp = resultIfOk =<< cuMemHostGetDevicePointer hp flags++{-# INLINE cuMemHostGetDevicePointer #-}+{# fun unsafe cuMemHostGetDevicePointer+ { alloca'- `DevicePtr a' peekDeviceHandle*+ , useHP `HostPtr a'+ , combineBitMasks `[AllocFlag]' } -> `Status' cToEnum #}+ where+ alloca' = F.alloca+ useHP = castPtr . useHostPtr+++-- |+-- Return the base address and allocation size of the given device pointer.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__MEM.html#group__CUDA__MEM_1g64fee5711274a2a0573a789c94d8299b>+--+{-# INLINEABLE getBasePtr #-}+getBasePtr :: DevicePtr a -> IO (DevicePtr a, Int64)+getBasePtr !dptr = do+ (status,base,size) <- cuMemGetAddressRange dptr+ resultIfOk (status, (base,size))++{-# INLINE cuMemGetAddressRange #-}+{# fun unsafe cuMemGetAddressRange+ { alloca'- `DevicePtr a' peekDeviceHandle*+ , alloca'- `Int64' peekIntConv*+ , useDeviceHandle `DevicePtr a' } -> `Status' cToEnum #}+ where+ alloca' :: Storable a => (Ptr a -> IO b) -> IO b+ alloca' = F.alloca++-- |+-- Return the amount of free and total memory respectively available to the+-- current context (bytes).+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__MEM.html#group__CUDA__MEM_1g808f555540d0143a331cc42aa98835c0>+--+{-# INLINEABLE getMemInfo #-}+getMemInfo :: IO (Int64, Int64)+getMemInfo = do+ (!status,!f,!t) <- cuMemGetInfo+ resultIfOk (status,(f,t))++{-# INLINE cuMemGetInfo #-}+{# fun unsafe cuMemGetInfo+ { alloca'- `Int64' peekIntConv*+ , alloca'- `Int64' peekIntConv* } -> `Status' cToEnum #}+ where+ alloca' = F.alloca+++--------------------------------------------------------------------------------+-- Internal+--------------------------------------------------------------------------------++type DeviceHandle = {# type CUdeviceptr #}++-- Lift an opaque handle to a typed DevicePtr representation. This occasions+-- arcane distinctions for the different driver versions and Tesla (compute 1.x)+-- and Fermi (compute 2.x) class architectures on 32- and 64-bit hosts.+--+{-# INLINE peekDeviceHandle #-}+peekDeviceHandle :: Ptr DeviceHandle -> IO (DevicePtr a)+peekDeviceHandle !p = do+ CULLong (W64# w#) <- peek p+ return $! DevicePtr (Ptr (int2Addr# (word2Int# (word64ToWord# w#))))++-- Use a device pointer as an opaque handle type+--+{-# INLINE useDeviceHandle #-}+useDeviceHandle :: DevicePtr a -> DeviceHandle+useDeviceHandle (DevicePtr (Ptr addr#)) =+ CULLong (W64# (wordToWord64# (int2Word# (addr2Int# addr#))))++#if __GLASGOW_HASKELL__ < 904+{-# INLINE word64ToWord# #-}+word64ToWord# :: Word# -> Word#+word64ToWord# x = x++{-# INLINE wordToWord64# #-}+wordToWord64# :: Word# -> Word#+wordToWord64# x = x+#endif+
+ src/Foreign/CUDA/Driver/Module.hs view
@@ -0,0 +1,20 @@+--------------------------------------------------------------------------------+-- |+-- Module : Foreign.CUDA.Driver.Module+-- Copyright : [2009..2023] Trevor L. McDonell+-- License : BSD+--+-- Module management for low-level driver interface+--+--------------------------------------------------------------------------------++module Foreign.CUDA.Driver.Module (++ module Foreign.CUDA.Driver.Module.Base,+ module Foreign.CUDA.Driver.Module.Query,++) where++import Foreign.CUDA.Driver.Module.Base hiding ( JITOptionInternal(..), useModule, jitOptionUnpack, jitTargetOfCompute )+import Foreign.CUDA.Driver.Module.Query+
+ src/Foreign/CUDA/Driver/Module/Base.chs view
@@ -0,0 +1,283 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_HADDOCK prune #-}+--------------------------------------------------------------------------------+-- |+-- Module : Foreign.CUDA.Driver.Module.Base+-- Copyright : [2009..2023] Trevor L. McDonell+-- License : BSD+--+-- Module loading for low-level driver interface+--+--------------------------------------------------------------------------------++module Foreign.CUDA.Driver.Module.Base (++ -- * Module Management+ Module(..),+ JITOption(..), JITTarget(..), JITResult(..), JITFallback(..), JITInputType(..),+ JITOptionInternal(..),++ -- ** Loading and unloading modules+ loadFile,+ loadData, loadDataFromPtr,+ loadDataEx, loadDataFromPtrEx,+ unload,++ -- Internal+ jitOptionUnpack, jitTargetOfCompute,++) where++#include "cbits/stubs.h"+{# context lib="cuda" #}++-- Friends+import Foreign.CUDA.Analysis.Device+import Foreign.CUDA.Driver.Error+import Foreign.CUDA.Internal.C2HS+import Foreign.C.Extra++-- System+import Foreign+import Foreign.C+import Unsafe.Coerce++import Control.Monad ( liftM )+import Data.ByteString.Char8 ( ByteString )+import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Internal as B+++--------------------------------------------------------------------------------+-- Data Types+--------------------------------------------------------------------------------++-- |+-- A reference to a Module object, containing collections of device functions+--+newtype Module = Module { useModule :: {# type CUmodule #}}+ deriving (Eq, Show)++-- |+-- Just-in-time compilation and linking options+--+data JITOption+ = MaxRegisters !Int -- ^ maximum number of registers per thread+ | ThreadsPerBlock !Int -- ^ number of threads per block to target for+ | OptimisationLevel !Int -- ^ level of optimisation to apply (1-4, default 4)+ | Target !Compute -- ^ compilation target, otherwise determined from context+ | FallbackStrategy !JITFallback -- ^ fallback strategy if matching cubin not found+ | GenerateDebugInfo -- ^ generate debug info (-g) (requires cuda >= 5.5)+ | GenerateLineInfo -- ^ generate line number information (-lineinfo) (requires cuda >= 5.5)+ | Verbose -- ^ verbose log messages (requires cuda >= 5.5)+ deriving (Show)++-- |+-- Results of online compilation+--+data JITResult = JITResult+ {+ jitTime :: !Float, -- ^ milliseconds spent compiling PTX+ jitInfoLog :: !ByteString, -- ^ information about PTX assembly+ jitModule :: !Module -- ^ the compiled module+ }+ deriving (Show)+++-- |+-- Online compilation target architecture+--+{# enum CUjit_target as JITTarget+ { underscoreToCase }+ with prefix="CU_TARGET" deriving (Eq, Show) #}++-- |+-- Online compilation fallback strategy+--+{# enum CUjit_fallback as JITFallback+ { underscoreToCase+ , CU_PREFER_PTX as PreferPTX }+ with prefix="CU" deriving (Eq, Show) #}++-- |+-- Device code formats that can be used for online linking+--+#if CUDA_VERSION < 5050+data JITInputType+#else+{# enum CUjitInputType as JITInputType+ { underscoreToCase+ , CU_JIT_INPUT_PTX as PTX }+ with prefix="CU_JIT_INPUT" deriving (Eq, Show) #}+#endif++{# enum CUjit_option as JITOptionInternal+ { }+ with prefix="CU" deriving (Eq, Show) #}+++--------------------------------------------------------------------------------+-- Module management+--------------------------------------------------------------------------------++-- |+-- Load the contents of the specified file (either a ptx or cubin file) to+-- create a new module, and load that module into the current context.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__MODULE.html#group__CUDA__MODULE_1g366093bd269dafd0af21f1c7d18115d3>+--+{-# INLINEABLE loadFile #-}+loadFile :: FilePath -> IO Module+loadFile !ptx = resultIfOk =<< cuModuleLoad ptx++{-# INLINE cuModuleLoad #-}+{# fun unsafe cuModuleLoad+ { alloca- `Module' peekMod*+ , withCString* `FilePath' } -> `Status' cToEnum #}+++-- |+-- Load the contents of the given image into a new module, and load that module+-- into the current context. The image is (typically) the contents of a cubin or+-- PTX file.+--+-- Note that the 'ByteString' will be copied into a temporary staging area so+-- that it can be passed to C.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__MODULE.html#group__CUDA__MODULE_1g04ce266ce03720f479eab76136b90c0b>+--+{-# INLINEABLE loadData #-}+loadData :: ByteString -> IO Module+loadData !img =+ B.useAsCString img (\p -> loadDataFromPtr (castPtr p))++-- |+-- As 'loadData', but read the image data from the given pointer. The image is a+-- NULL-terminated sequence of bytes.+--+{-# INLINEABLE loadDataFromPtr #-}+loadDataFromPtr :: Ptr Word8 -> IO Module+loadDataFromPtr !img = resultIfOk =<< cuModuleLoadData img++{-# INLINE cuModuleLoadData #-}+{# fun unsafe cuModuleLoadData+ { alloca- `Module' peekMod*+ , castPtr `Ptr Word8' } -> ` Status' cToEnum #}+++-- |+-- Load the contents of the given image into a module with online compiler+-- options, and load the module into the current context. The image is+-- (typically) the contents of a cubin or PTX file. The actual attributes of the+-- compiled kernel can be probed using 'requires'.+--+-- Note that the 'ByteString' will be copied into a temporary staging area so+-- that it can be passed to C.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__MODULE.html#group__CUDA__MODULE_1g9e8047e9dbf725f0cd7cafd18bfd4d12>+--+{-# INLINEABLE loadDataEx #-}+loadDataEx :: ByteString -> [JITOption] -> IO JITResult+loadDataEx !img !options =+ B.useAsCString img (\p -> loadDataFromPtrEx (castPtr p) options)++-- |+-- As 'loadDataEx', but read the image data from the given pointer. The image is+-- a NULL-terminated sequence of bytes.+--+{-# INLINEABLE loadDataFromPtrEx #-}+loadDataFromPtrEx :: Ptr Word8 -> [JITOption] -> IO JITResult+loadDataFromPtrEx !img !options = do+ let logSize = 2048++ fp_ilog <- B.mallocByteString logSize++ allocaArray logSize $ \p_elog -> do+ withForeignPtr fp_ilog $ \p_ilog -> do++ let (opt,val) = unzip $+ [ (JIT_WALL_TIME, 0) -- must be first, this is extracted below+ , (JIT_INFO_LOG_BUFFER_SIZE_BYTES, logSize)+ , (JIT_ERROR_LOG_BUFFER_SIZE_BYTES, logSize)+ , (JIT_INFO_LOG_BUFFER, unsafeCoerce (p_ilog :: CString))+ , (JIT_ERROR_LOG_BUFFER, unsafeCoerce (p_elog :: CString))+ ]+ +++ map jitOptionUnpack options++ withArrayLen (map cFromEnum opt) $ \i p_opts -> do+ withArray (map unsafeCoerce val) $ \ p_vals -> do++ (s,mdl) <- cuModuleLoadDataEx img i p_opts p_vals++ case s of+ Success -> do+ time <- peek (castPtr p_vals)+ bytes <- c_strnlen p_ilog logSize+ let infoLog | bytes == 0 = B.empty+ | otherwise = B.fromForeignPtr (castForeignPtr fp_ilog) 0 bytes+ return $! JITResult time infoLog mdl++ _ -> do+ errLog <- peekCString p_elog+ cudaErrorIO (unlines [describe s, errLog])+++{-# INLINE cuModuleLoadDataEx #-}+{# fun unsafe cuModuleLoadDataEx+ { alloca- `Module' peekMod*+ , castPtr `Ptr Word8'+ , `Int'+ , id `Ptr CInt'+ , id `Ptr (Ptr ())' } -> `Status' cToEnum #}+++-- |+-- Unload a module from the current context.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__MODULE.html#group__CUDA__MODULE_1g8ea3d716524369de3763104ced4ea57b>+--+{-# INLINEABLE unload #-}+unload :: Module -> IO ()+unload !m = nothingIfOk =<< cuModuleUnload m++{-# INLINE cuModuleUnload #-}+{# fun unsafe cuModuleUnload+ { useModule `Module' } -> `Status' cToEnum #}+++--------------------------------------------------------------------------------+-- Internal+--------------------------------------------------------------------------------++{-# INLINE peekMod #-}+peekMod :: Ptr {# type CUmodule #} -> IO Module+peekMod = liftM Module . peek+++{-# INLINE jitOptionUnpack #-}+jitOptionUnpack :: JITOption -> (JITOptionInternal, Int)+jitOptionUnpack (MaxRegisters x) = (JIT_MAX_REGISTERS, x)+jitOptionUnpack (ThreadsPerBlock x) = (JIT_THREADS_PER_BLOCK, x)+jitOptionUnpack (OptimisationLevel x) = (JIT_OPTIMIZATION_LEVEL, x)+jitOptionUnpack (Target x) = (JIT_TARGET, fromEnum (jitTargetOfCompute x))+jitOptionUnpack (FallbackStrategy x) = (JIT_FALLBACK_STRATEGY, fromEnum x)+#if CUDA_VERSION >= 5050+jitOptionUnpack GenerateDebugInfo = (JIT_GENERATE_DEBUG_INFO, fromEnum True)+jitOptionUnpack GenerateLineInfo = (JIT_GENERATE_LINE_INFO, fromEnum True)+jitOptionUnpack Verbose = (JIT_LOG_VERBOSE, fromEnum True)+#else+jitOptionUnpack GenerateDebugInfo = requireSDK 'GenerateDebugInfo 5.5+jitOptionUnpack GenerateLineInfo = requireSDK 'GenerateLineInfo 5.5+jitOptionUnpack Verbose = requireSDK 'Verbose 5.5+#endif+++{-# INLINE jitTargetOfCompute #-}+jitTargetOfCompute :: Compute -> JITTarget+jitTargetOfCompute (Compute x y) = toEnum (10*x + y)+
+ src/Foreign/CUDA/Driver/Module/Link.chs view
@@ -0,0 +1,227 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE TemplateHaskell #-}+--------------------------------------------------------------------------------+-- |+-- Module : Foreign.CUDA.Driver.Module.Link+-- Copyright : [2009..2023] Trevor L. McDonell+-- License : BSD+--+-- Module linking for low-level driver interface+--+-- Since CUDA-5.5+--+--------------------------------------------------------------------------------++module Foreign.CUDA.Driver.Module.Link (++ -- ** JIT module linking+ LinkState, JITOption(..), JITInputType(..),++ create, destroy, complete,+ addFile,+ addData, addDataFromPtr,++) where++#include "cbits/stubs.h"+{# context lib="cuda" #}++-- Friends+import Foreign.CUDA.Driver.Error+import Foreign.CUDA.Driver.Module.Base+import Foreign.CUDA.Internal.C2HS++-- System+import Control.Monad ( liftM )+import Foreign+import Foreign.C+import Unsafe.Coerce++import GHC.Ptr+import Data.ByteString.Char8 ( ByteString )+import qualified Data.ByteString.Char8 as B+++--------------------------------------------------------------------------------+-- Data Types+--------------------------------------------------------------------------------++-- |+-- A pending JIT linker state+--+#if CUDA_VERSION < 5050+data LinkState+#else+newtype LinkState = LinkState { useLinkState :: {# type CUlinkState #} }+ deriving (Show)+#endif+++--------------------------------------------------------------------------------+-- JIT linking+--------------------------------------------------------------------------------++-- |+-- Create a pending JIT linker invocation. The returned 'LinkState' should+-- be 'destroy'ed once no longer needed. The device code machine size will+-- match the calling application.+--+-- Requires CUDA-5.5.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__MODULE.html#group__CUDA__MODULE_1g86ca4052a2fab369cb943523908aa80d>+--+{-# INLINEABLE create #-}+create :: [JITOption] -> IO LinkState+#if CUDA_VERSION < 5050+create _ = requireSDK 'create 5.5+#else+create !options =+ let (opt,val) = unzip $ map jitOptionUnpack options+ in+ withArray (map cFromEnum opt) $ \p_opts ->+ withArray (map unsafeCoerce val) $ \p_vals ->+ resultIfOk =<< cuLinkCreate (length opt) p_opts p_vals++{-# INLINE cuLinkCreate #-}+{# fun unsafe cuLinkCreate+ { `Int'+ , id `Ptr CInt'+ , id `Ptr (Ptr ())'+ , alloca- `LinkState' peekLS* } -> `Status' cToEnum #}+ where+ peekLS = liftM LinkState . peek+#endif+++-- |+-- Destroy the state of a JIT linker invocation.+--+-- Requires CUDA-5.5.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__MODULE.html#group__CUDA__MODULE_1g01b7ae2a34047b05716969af245ce2d9>+--+{-# INLINEABLE destroy #-}+destroy :: LinkState -> IO ()+#if CUDA_VERSION < 5050+destroy _ = requireSDK 'destroy 5.5+#else+destroy !s = nothingIfOk =<< cuLinkDestroy s++{-# INLINE cuLinkDestroy #-}+{# fun unsafe cuLinkDestroy+ { useLinkState `LinkState' } -> `Status' cToEnum #}+#endif+++-- |+-- Complete a pending linker invocation and load the current module. The+-- link state will be destroyed.+--+-- Requires CUDA-5.5.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__MODULE.html#group__CUDA__MODULE_1g818fcd84a4150a997c0bba76fef4e716>+--+{-# INLINEABLE complete #-}+complete :: LinkState -> IO Module+#if CUDA_VERSION < 5050+complete _ = requireSDK 'complete 5.5+#else+complete !ls = do+ cubin <- resultIfOk =<< cuLinkComplete ls nullPtr+ mdl <- loadDataFromPtr (castPtr cubin)+ destroy ls+ return mdl++{-# INLINE cuLinkComplete #-}+{# fun unsafe cuLinkComplete+ { useLinkState `LinkState'+ , alloca- `Ptr ()' peek*+ , castPtr `Ptr Int'+ }+ -> `Status' cToEnum #}+#endif+++-- |+-- Add an input file to a pending linker invocation.+--+-- Requires CUDA-5.5.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__MODULE.html#group__CUDA__MODULE_1g1224c0fd48d4a683f3ce19997f200a8c>+--+{-# INLINEABLE addFile #-}+addFile :: LinkState -> FilePath -> JITInputType -> [JITOption] -> IO ()+#if CUDA_VERSION < 5050+addFile _ _ _ _ = requireSDK 'addFile 5.5+#else+addFile !ls !fp !t !options =+ let (opt,val) = unzip $ map jitOptionUnpack options+ in+ withArrayLen (map cFromEnum opt) $ \i p_opts ->+ withArray (map unsafeCoerce val) $ \ p_vals ->+ nothingIfOk =<< cuLinkAddFile ls t fp i p_opts p_vals++{-# INLINE cuLinkAddFile #-}+{# fun unsafe cuLinkAddFile+ { useLinkState `LinkState'+ , cFromEnum `JITInputType'+ , withCString* `FilePath'+ , `Int'+ , id `Ptr CInt'+ , id `Ptr (Ptr ())'+ }+ -> `Status' cToEnum #}+#endif+++-- |+-- Add an input to a pending linker invocation.+--+-- Requires CUDA-5.5.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__MODULE.html#group__CUDA__MODULE_1g3ebcd2ccb772ba9c120937a2d2831b77>+--+{-# INLINEABLE addData #-}+addData :: LinkState -> ByteString -> JITInputType -> [JITOption] -> IO ()+#if CUDA_VERSION < 5050+addData _ _ _ = requireSDK 'addData 5.5+#else+addData !ls !img !k !options =+ B.useAsCStringLen img (\(p, n) -> addDataFromPtr ls n (castPtr p) k options)+#endif++-- |+-- As 'addData', but read the specified number of bytes of image data from+-- the given pointer.+--+{-# INLINEABLE addDataFromPtr #-}+addDataFromPtr :: LinkState -> Int -> Ptr Word8 -> JITInputType -> [JITOption] -> IO ()+#if CUDA_VERSION < 5050+addDataFromPtr _ _ _ _ = requireSDK 'addDataFromPtr 5.5+#else+addDataFromPtr !ls !n !img !t !options =+ let (opt,val) = unzip $ map jitOptionUnpack options+ name = Ptr "<unknown>"#+ in+ withArrayLen (map cFromEnum opt) $ \i p_opts ->+ withArray (map unsafeCoerce val) $ \ p_vals ->+ nothingIfOk =<< cuLinkAddData ls t img n name i p_opts p_vals++{-# INLINE cuLinkAddData #-}+{# fun unsafe cuLinkAddData+ { useLinkState `LinkState'+ , cFromEnum `JITInputType'+ , castPtr `Ptr Word8'+ , `Int'+ , id `Ptr CChar'+ , `Int'+ , id `Ptr CInt'+ , id `Ptr (Ptr ())'+ }+ -> `Status' cToEnum #}+#endif+
+ src/Foreign/CUDA/Driver/Module/Query.chs view
@@ -0,0 +1,139 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+--------------------------------------------------------------------------------+-- |+-- Module : Foreign.CUDA.Driver.Module.Query+-- Copyright : [2009..2023] Trevor L. McDonell+-- License : BSD+--+-- Querying module attributes for low-level driver interface+--+--------------------------------------------------------------------------------++module Foreign.CUDA.Driver.Module.Query (++ -- ** Querying module inhabitants+ getFun, getPtr,++) where++#include "cbits/stubs.h"+{# context lib="cuda" #}++-- Friends+import Foreign.CUDA.Driver.Error+import Foreign.CUDA.Driver.Exec+import Foreign.CUDA.Driver.Marshal ( peekDeviceHandle )+import Foreign.CUDA.Driver.Module.Base+import Foreign.CUDA.Internal.C2HS+import Foreign.CUDA.Ptr++-- System+import Foreign+import Foreign.C+import Control.Exception ( throwIO )+import Control.Monad ( liftM )+import Data.ByteString.Short ( ShortByteString )+import qualified Data.ByteString.Short as BS+import qualified Data.ByteString.Short.Internal as BI+import qualified Data.ByteString.Internal as BI+import Prelude as P++import GHC.Exts+import GHC.Base ( IO(..) )+++--------------------------------------------------------------------------------+-- Querying module attributes+--------------------------------------------------------------------------------++-- |+-- Returns a function handle.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__MODULE.html#group__CUDA__MODULE_1ga52be009b0d4045811b30c965e1cb2cf>+--+{-# INLINEABLE getFun #-}+getFun :: Module -> ShortByteString -> IO Fun+getFun !mdl !fn = resultIfFound "function" fn =<< cuModuleGetFunction mdl fn++{-# INLINE cuModuleGetFunction #-}+{# fun unsafe cuModuleGetFunction+ { alloca- `Fun' peekFun*+ , useModule `Module'+ , useAsCString* `ShortByteString'+ }+ -> `Status' cToEnum #}+ where+ peekFun = liftM Fun . peek+++-- |+-- Return a global pointer, and size of the global (in bytes).+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__MODULE.html#group__CUDA__MODULE_1gf3e43672e26073b1081476dbf47a86ab>+--+{-# INLINEABLE getPtr #-}+getPtr :: Module -> ShortByteString -> IO (DevicePtr a, Int)+getPtr !mdl !name = do+ (!status,!dptr,!bytes) <- cuModuleGetGlobal mdl name+ resultIfFound "global" name (status,(dptr,bytes))++{-# INLINE cuModuleGetGlobal #-}+{# fun unsafe cuModuleGetGlobal+ { alloca- `DevicePtr a' peekDeviceHandle*+ , alloca- `Int' peekIntConv*+ , useModule `Module'+ , useAsCString* `ShortByteString'+ }+ -> `Status' cToEnum #}+++--------------------------------------------------------------------------------+-- Internal+--------------------------------------------------------------------------------++{-# INLINE resultIfFound #-}+resultIfFound :: String -> ShortByteString -> (Status, a) -> IO a+resultIfFound kind name (!status,!result) =+ case status of+ Success -> return result+ NotFound -> cudaErrorIO (kind ++ ' ' : describe status ++ ": " ++ unpack name)+ _ -> throwIO (ExitCode status)+++-- Utilities+-- ---------++-- [Short]ByteStrings are not null-terminated, so can't be passed directly to C.+--+-- unsafeUseAsCString :: ShortByteString -> CString+-- unsafeUseAsCString (BI.SBS ba#) = Ptr (byteArrayContents# ba#)++{-# INLINE useAsCString #-}+useAsCString :: ShortByteString -> (CString -> IO a) -> IO a+useAsCString (BI.SBS ba#) action = IO $ \s0 ->+ case sizeofByteArray# ba# of { n# ->+ case newPinnedByteArray# (n# +# 1#) s0 of { (# s1, mba# #) ->+ case byteArrayContents# (unsafeCoerce# mba#) of { addr# ->+ case copyByteArrayToAddr# ba# 0# addr# n# s1 of { s2 ->+ case writeWord8OffAddr# addr# n# (wordToWord8# 0##) s2 of { s3 ->+ case action (Ptr addr#) of { IO action' ->+ case action' s3 of { (# s4, r #) ->+ case touch# mba# s4 of { s5 ->+ (# s5, r #)+ }}}}}}}}+++{-# INLINE unpack #-}+unpack :: ShortByteString -> [Char]+unpack = P.map BI.w2c . BS.unpack++#if __GLASGOW_HASKELL__ < 902+{-# INLINE wordToWord8# #-}+wordToWord8# :: Word# -> Word#+wordToWord8# x = x+#endif+
+ src/Foreign/CUDA/Driver/Profiler.chs view
@@ -0,0 +1,100 @@+{-# LANGUAGE ForeignFunctionInterface #-}+--------------------------------------------------------------------------------+-- |+-- Module : Foreign.CUDA.Driver.Profiler+-- Copyright : [2009..2023] Trevor L. McDonell+-- License : BSD+--+-- Profiler control for low-level driver interface+--+--------------------------------------------------------------------------------++module Foreign.CUDA.Driver.Profiler (++ OutputMode(..),+ initialise,+ start, stop,++) where++#include "cbits/stubs.h"+{# context lib="cuda" #}++-- friends+import Foreign.CUDA.Driver.Error+import Foreign.CUDA.Internal.C2HS++-- system+import Foreign+import Foreign.C+++-- | Profiler output mode+--+{# enum CUoutput_mode as OutputMode+ { underscoreToCase+ , CU_OUT_CSV as CSV }+ with prefix="CU_OUT" deriving (Eq, Show) #}+++-- | Initialise the CUDA profiler.+--+-- The configuration file is used to specify profiling options and profiling+-- counters. Refer to the "Compute Command Line Profiler User Guide" for+-- supported profiler options and counters.+--+-- Note that the CUDA profiler can not be initialised with this function if+-- another profiling tool is already active.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__PROFILER.html#group__CUDA__PROFILER>+--+{-# INLINEABLE initialise #-}+initialise+ :: FilePath -- ^ configuration file that itemises which counters and/or options to profile+ -> FilePath -- ^ output file where profiling results will be stored+ -> OutputMode+ -> IO ()+initialise config output mode+ = nothingIfOk =<< cuProfilerInitialize config output mode++{-# INLINE cuProfilerInitialize #-}+{# fun unsafe cuProfilerInitialize+ { `String'+ , `String'+ , cFromEnum `OutputMode'+ }+ -> `Status' cToEnum #}+++-- | Begin profiling collection by the active profiling tool for the current+-- context. If profiling is already enabled, then this has no effect.+--+-- 'start' and 'stop' can be used to programatically control profiling+-- granularity, by allowing profiling to be done only on selected pieces of+-- code.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__PROFILER.html#group__CUDA__PROFILER_1g8a5314de2292c2efac83ac7fcfa9190e>+--+{-# INLINEABLE start #-}+start :: IO ()+start = nothingIfOk =<< cuProfilerStart++{-# INLINE cuProfilerStart #-}+{# fun unsafe cuProfilerStart+ { } -> `Status' cToEnum #}+++-- | Stop profiling collection by the active profiling tool for the current+-- context, and force all pending profiler events to be written to the output+-- file. If profiling is already inactive, this has no effect.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__PROFILER.html#group__CUDA__PROFILER_1g4d8edef6174fd90165e6ac838f320a5f>+--+{-# INLINEABLE stop #-}+stop :: IO ()+stop = nothingIfOk =<< cuProfilerStop++{-# INLINE cuProfilerStop #-}+{# fun unsafe cuProfilerStop+ { } -> `Status' cToEnum #}+
+ src/Foreign/CUDA/Driver/Stream.chs view
@@ -0,0 +1,523 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE TemplateHaskell #-}+#ifdef USE_EMPTY_CASE+{-# LANGUAGE EmptyCase #-}+#endif+--------------------------------------------------------------------------------+-- |+-- Module : Foreign.CUDA.Driver.Stream+-- Copyright : [2009..2023] Trevor L. McDonell+-- License : BSD+--+-- Stream management for low-level driver interface+--+--------------------------------------------------------------------------------++module Foreign.CUDA.Driver.Stream (++ -- * Stream Management+ Stream(..), StreamPriority, StreamCallback,+ StreamFlag(..), StreamWriteFlag(..), StreamWaitFlag(..), StreamCallbackFlag,++ create, createWithPriority, destroy, finished, block, callback,+ getFlags, getPriority, getContext,+ write, wait,++ defaultStream,+ defaultStreamLegacy,+ defaultStreamPerThread,++) where++#include "cbits/stubs.h"+{# context lib="cuda" #}++-- Friends+import Foreign.CUDA.Ptr+import Foreign.CUDA.Driver.Error+import Foreign.CUDA.Driver.Context.Base ( Context(..) )+import Foreign.CUDA.Internal.C2HS++-- System+import Control.Exception ( throwIO )+import Control.Monad ( liftM )+import Foreign+import Foreign.C+import Unsafe.Coerce++import GHC.Base+import GHC.Ptr+import GHC.Word+++--------------------------------------------------------------------------------+-- Data Types+--------------------------------------------------------------------------------++-- |+-- A processing stream. All operations in a stream are synchronous and executed+-- in sequence, but operations in different non-default streams may happen+-- out-of-order or concurrently with one another.+--+-- Use 'Event's to synchronise operations between streams.+--+newtype Stream = Stream { useStream :: {# type CUstream #}}+ deriving (Eq, Show)++-- |+-- Priority of an execution stream. Work submitted to a higher priority+-- stream may preempt execution of work already executing in a lower+-- priority stream. Lower numbers represent higher priorities.+--+type StreamPriority = Int++-- |+-- Execution stream creation flags+--+#if CUDA_VERSION < 8000+data StreamFlag+data StreamWriteFlag+data StreamWaitFlag++instance Enum StreamFlag where+#ifdef USE_EMPTY_CASE+ toEnum x = error ("StreamFlag.toEnum: Cannot match " ++ show x)+ fromEnum x = case x of {}+#endif++instance Enum StreamWriteFlag where+#ifdef USE_EMPTY_CASE+ toEnum x = error ("StreamWriteFlag.toEnum: Cannot match " ++ show x)+ fromEnum x = case x of {}+#endif++instance Enum StreamWaitFlag where+#ifdef USE_EMPTY_CASE+ toEnum x = error ("StreamWaitFlag.toEnum: Cannot match " ++ show x)+ fromEnum x = case x of {}+#endif++#else+{# enum CUstream_flags as StreamFlag+ { underscoreToCase }+ with prefix="CU_STREAM" deriving (Eq, Show, Bounded) #}++{# enum CUstreamWriteValue_flags as StreamWriteFlag+ { underscoreToCase }+ with prefix="CU_STREAM" deriving (Eq, Show, Bounded) #}++{# enum CUstreamWaitValue_flags as StreamWaitFlag+ { underscoreToCase }+ with prefix="CU_STREAM" deriving (Eq, Show, Bounded) #}+#endif+++-- | A 'Stream' callback function+--+-- <https://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__TYPES.html#group__CUDA__TYPES_1ge5743a8c48527f1040107a68205c5ba9>+--+-- @since 0.10.0.0+--+type StreamCallback = {# type CUstreamCallback #}++data StreamCallbackFlag+instance Enum StreamCallbackFlag where+#ifdef USE_EMPTY_CASE+ toEnum x = error ("StreamCallbackFlag.toEnum: Cannot match " ++ show x)+ fromEnum x = case x of {}+#endif+++--------------------------------------------------------------------------------+-- Stream management+--------------------------------------------------------------------------------++-- |+-- Create a new stream.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__STREAM.html#group__CUDA__STREAM_1ga581f0c5833e21ded8b5a56594e243f4>+--+{-# INLINEABLE create #-}+create :: [StreamFlag] -> IO Stream+create !flags = resultIfOk =<< cuStreamCreate flags++{-# INLINE cuStreamCreate #-}+{# fun unsafe cuStreamCreate+ { alloca- `Stream' peekStream*+ , combineBitMasks `[StreamFlag]' } -> `Status' cToEnum #}+ where+ peekStream = liftM Stream . peek+++-- |+-- Create a stream with the given priority. Work submitted to+-- a higher-priority stream may preempt work already executing in a lower+-- priority stream.+--+-- The convention is that lower numbers represent higher priorities. The+-- default priority is zero. The range of meaningful numeric priorities can+-- be queried using 'Foreign.CUDA.Driver.Context.Config.getStreamPriorityRange'.+-- If the specified priority is outside the supported numerical range, it+-- will automatically be clamped to the highest or lowest number in the+-- range+--+-- Requires CUDA-5.5.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__STREAM.html#group__CUDA__STREAM_1g95c1a8c7c3dacb13091692dd9c7f7471>+--+{-# INLINEABLE createWithPriority #-}+createWithPriority :: StreamPriority -> [StreamFlag] -> IO Stream+#if CUDA_VERSION < 5050+createWithPriority _ _ = requireSDK 'createWithPriority 5.5+#else+createWithPriority !priority !flags = resultIfOk =<< cuStreamCreateWithPriority flags priority++{-# INLINE cuStreamCreateWithPriority #-}+{# fun unsafe cuStreamCreateWithPriority+ { alloca- `Stream' peekStream*+ , combineBitMasks `[StreamFlag]'+ , fromIntegral `StreamPriority'+ }+ -> `Status' cToEnum #}+ where+ peekStream = liftM Stream . peek+#endif+++-- |+-- Destroy a stream. If the device is still doing work in the stream when+-- 'destroy' is called, the function returns immediately and the resources+-- associated with the stream will be released automatically once the+-- device has completed all work.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__STREAM.html#group__CUDA__STREAM_1g244c8833de4596bcd31a06cdf21ee758>+--+{-# INLINEABLE destroy #-}+destroy :: Stream -> IO ()+destroy !st = nothingIfOk =<< cuStreamDestroy st++{-# INLINE cuStreamDestroy #-}+{# fun unsafe cuStreamDestroy+ { useStream `Stream' } -> `Status' cToEnum #}+++-- |+-- Check if all operations in the stream have completed.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__STREAM.html#group__CUDA__STREAM_1g1b0d24bbe97fa68e4bc511fb6adfeb0b>+--+{-# INLINEABLE finished #-}+finished :: Stream -> IO Bool+finished !st =+ cuStreamQuery st >>= \rv ->+ case rv of+ Success -> return True+ NotReady -> return False+ _ -> throwIO (ExitCode rv)++{-# INLINE cuStreamQuery #-}+{# fun unsafe cuStreamQuery+ { useStream `Stream' } -> `Status' cToEnum #}+++-- |+-- Wait until the device has completed all operations in the Stream.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__STREAM.html#group__CUDA__STREAM_1g15e49dd91ec15991eb7c0a741beb7dad>+--+{-# INLINEABLE block #-}+block :: Stream -> IO ()+block !st = nothingIfOk =<< cuStreamSynchronize st++{-# INLINE cuStreamSynchronize #-}+{# fun cuStreamSynchronize+ { useStream `Stream' } -> `Status' cToEnum #}+++-- |+-- Query the priority of a stream.+--+-- Requires CUDA-5.5.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__STREAM.html#group__CUDA__STREAM_1g5bd5cb26915a2ecf1921807339488484>+--+{-# INLINEABLE getPriority #-}+getPriority :: Stream -> IO StreamPriority+#if CUDA_VERSION < 5050+getPriority _ = requireSDK 'getPriority 5.5+#else+getPriority !st = resultIfOk =<< cuStreamGetPriority st++{-# INLINE cuStreamGetPriority #-}+{# fun unsafe cuStreamGetPriority+ { useStream `Stream'+ , alloca- `StreamPriority' peekIntConv*+ }+ -> `Status' cToEnum #}+#endif+++-- | Query the flags of a given stream+--+-- <https://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__STREAM.html#group__CUDA__STREAM_1g4d39786855a6bed01215c1907fbbfbb7>+--+-- @since 0.10.0.0+--+{-# INLINEABLE getFlags #-}+{# fun unsafe cuStreamGetFlags as getFlags+ { useStream `Stream'+ , alloca- `[StreamFlag]' extract*+ }+ -> `()' checkStatus*- #}+ where+#if CUDA_VERSION < 8000+ extract _ = return []+#else+ extract p = extractBitMasks `fmap` peek p+#endif+++-- |+-- Query the context associated with a stream+--+-- Requires CUDA-9.2.+--+-- <https://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__STREAM.html#group__CUDA__STREAM_1g5bd5cb26915a2ecf1921807339488484>+--+-- @since 0.10.0.0+--+{-# INLINEABLE getContext #-}+getContext :: Stream -> IO Context+#if CUDA_VERSION < 9020+getContext _ = requireSDK 'getContext 9.2+#else+getContext !st = resultIfOk =<< cuStreamGetCtx st++{-# INLINE cuStreamGetCtx #-}+{# fun unsafe cuStreamGetCtx+ { useStream `Stream'+ , alloca- `Context' peekCtx* } -> `Status' cToEnum #}+ where+ peekCtx = liftM Context . peek+#endif+++-- | Write a value to memory, (presumably) after all preceding work in the+-- stream has completed. Unless the option 'WriteValueNoMemoryBarrier' is+-- supplied, the write is preceded by a system-wide memory fence.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__EVENT.html#group__CUDA__EVENT_1g091455366d56dc2f1f69726aafa369b0>+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__EVENT.html#group__CUDA__EVENT_1gc8af1e8b96d7561840affd5217dd6830>+--+-- Requires CUDA-8.0 for 32-bit values.+--+-- Requires CUDA-9.0 for 64-bit values.+--+{-# INLINEABLE write #-}+write :: Storable a => DevicePtr a -> a -> Stream -> [StreamWriteFlag] -> IO ()+write ptr val stream flags =+ case sizeOf val of+ 4 -> write32 (castDevPtr ptr) (unsafeCoerce val) stream flags+ 8 -> write64 (castDevPtr ptr) (unsafeCoerce val) stream flags+ _ -> cudaErrorIO "Stream.write: can only write 32- and 64-bit values"++{-# INLINE write32 #-}+write32 :: DevicePtr Word32 -> Word32 -> Stream -> [StreamWriteFlag] -> IO ()+#if CUDA_VERSION < 8000+write32 _ _ _ _ = requireSDK 'write32 8.0+#else+write32 ptr val stream flags = nothingIfOk =<< cuStreamWriteValue32 stream ptr val flags++{-# INLINE cuStreamWriteValue32 #-}+#if CUDA_VERSION < 12000+{# fun unsafe cuStreamWriteValue32+ { useStream `Stream'+ , useDeviceHandle `DevicePtr Word32'+ , `Word32'+ , combineBitMasks `[StreamWriteFlag]'+ }+ -> `Status' cToEnum #}+#else+{# fun unsafe cuStreamWriteValue32_v2 as cuStreamWriteValue32+ { useStream `Stream'+ , useDeviceHandle `DevicePtr Word32'+ , `Word32'+ , combineBitMasks `[StreamWriteFlag]'+ }+ -> `Status' cToEnum #}+#endif+#endif++{-# INLINE write64 #-}+write64 :: DevicePtr Word64 -> Word64 -> Stream -> [StreamWriteFlag] -> IO ()+#if CUDA_VERSION < 9000+write64 _ _ _ _ = requireSDK 'write64 9.0+#else+write64 ptr val stream flags = nothingIfOk =<< cuStreamWriteValue64 stream ptr val flags++{-# INLINE cuStreamWriteValue64 #-}+#if CUDA_VERSION < 12000+{# fun unsafe cuStreamWriteValue64+ { useStream `Stream'+ , useDeviceHandle `DevicePtr Word64'+ , `Word64'+ , combineBitMasks `[StreamWriteFlag]'+ }+ -> `Status' cToEnum #}+#else+{# fun unsafe cuStreamWriteValue64_v2 as cuStreamWriteValue64+ { useStream `Stream'+ , useDeviceHandle `DevicePtr Word64'+ , `Word64'+ , combineBitMasks `[StreamWriteFlag]'+ }+ -> `Status' cToEnum #}+#endif+#endif+++-- | Wait on a memory location. Work ordered after the operation will block+-- until the given condition on the memory is satisfied.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__EVENT.html#group__CUDA__EVENT_1g629856339de7bc6606047385addbb398>+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__EVENT.html#group__CUDA__EVENT_1g6910c1258c5f15aa5d699f0fd60d6933>+--+-- Requires CUDA-8.0 for 32-bit values.+--+-- Requires CUDA-9.0 for 64-bit values.+--+{-# INLINEABLE wait #-}+wait :: Storable a => DevicePtr a -> a -> Stream -> [StreamWaitFlag] -> IO ()+wait ptr val stream flags =+ case sizeOf val of+ 4 -> wait32 (castDevPtr ptr) (unsafeCoerce val) stream flags+ 8 -> wait64 (castDevPtr ptr) (unsafeCoerce val) stream flags+ _ -> cudaErrorIO "Stream.wait: can only wait on 32- and 64-bit values"++{-# INLINE wait32 #-}+wait32 :: DevicePtr Word32 -> Word32 -> Stream -> [StreamWaitFlag] -> IO ()+#if CUDA_VERSION < 8000+wait32 _ _ _ _ = requireSDK 'wait32 8.0+#else+wait32 ptr val stream flags = nothingIfOk =<< cuStreamWaitValue32 stream ptr val flags++{-# INLINE cuStreamWaitValue32 #-}+#if CUDA_VERSION < 12000+{# fun unsafe cuStreamWaitValue32+ { useStream `Stream'+ , useDeviceHandle `DevicePtr Word32'+ , `Word32'+ , combineBitMasks `[StreamWaitFlag]'+ } -> `Status' cToEnum #}+#else+{# fun unsafe cuStreamWaitValue32_v2 as cuStreamWaitValue32+ { useStream `Stream'+ , useDeviceHandle `DevicePtr Word32'+ , `Word32'+ , combineBitMasks `[StreamWaitFlag]'+ } -> `Status' cToEnum #}+#endif+#endif++{-# INLINE wait64 #-}+wait64 :: DevicePtr Word64 -> Word64 -> Stream -> [StreamWaitFlag] -> IO ()+#if CUDA_VERSION < 9000+wait64 _ _ _ _ = requireSDK 'wait64 9.0+#else+wait64 ptr val stream flags = nothingIfOk =<< cuStreamWaitValue64 stream ptr val flags++{-# INLINE cuStreamWaitValue64 #-}+#if CUDA_VERSION < 12000+{# fun unsafe cuStreamWaitValue64+ { useStream `Stream'+ , useDeviceHandle `DevicePtr Word64'+ , `Word64'+ , combineBitMasks `[StreamWaitFlag]'+ } -> `Status' cToEnum #}+#else+{# fun unsafe cuStreamWaitValue64_v2 as cuStreamWaitValue64+ { useStream `Stream'+ , useDeviceHandle `DevicePtr Word64'+ , `Word64'+ , combineBitMasks `[StreamWaitFlag]'+ } -> `Status' cToEnum #}+#endif+#endif+++-- | Add a callback to a compute stream. This function will be executed on the+-- host after all currently queued items in the stream have completed.+--+-- <https://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__STREAM.html#group__CUDA__STREAM_1g613d97a277d7640f4cb1c03bd51c2483>+--+-- @since 0.10.0.0+--+{-# INLINEABLE callback #-}+{# fun unsafe cuStreamAddCallback as callback+ { useStream `Stream'+ , id `StreamCallback'+ , id `Ptr ()'+ , combineBitMasks `[StreamCallbackFlag]'+ } -> `()' checkStatus*- #}+++-- | The default execution stream. This can be configured to have either+-- 'defaultStreamLegacy' or 'defaultStreamPerThread' synchronisation behaviour.+--+-- <https://docs.nvidia.com/cuda/cuda-driver-api/stream-sync-behavior.html#stream-sync-behavior__default-stream>+--+{-# INLINE defaultStream #-}+defaultStream :: Stream+defaultStream = Stream (Ptr (int2Addr# 0#))+++-- | The legacy default stream is an implicit stream which synchronises with all+-- other streams in the same 'Context', except for non-blocking streams.+--+-- <https://docs.nvidia.com/cuda/cuda-driver-api/stream-sync-behavior.html#stream-sync-behavior__default-stream>+--+-- @since 0.10.0.0+--+{-# INLINE defaultStreamLegacy #-}+defaultStreamLegacy :: Stream+defaultStreamLegacy = Stream (Ptr (int2Addr# 0x1#))+++-- | The per-thread default stream is an implicit stream local to both the+-- thread and the calling 'Context', and which does not synchronise with other+-- streams (just like explicitly created streams). The per-thread default stream+-- is not a non-blocking stream and will synchronise with the legacy default+-- stream if both are used in the same program.+--+-- <file:///Developer/NVIDIA/CUDA-9.2/doc/html/cuda-driver-api/stream-sync-behavior.html#stream-sync-behavior__default-stream>+--+-- @since 0.10.0.0+--+{-# INLINE defaultStreamPerThread #-}+defaultStreamPerThread :: Stream+defaultStreamPerThread = Stream (Ptr (int2Addr# 0x2#))+++--------------------------------------------------------------------------------+-- Internal+--------------------------------------------------------------------------------++-- Use a device pointer as an opaque handle type+--+{-# INLINE useDeviceHandle #-}+useDeviceHandle :: DevicePtr a -> {# type CUdeviceptr #}+useDeviceHandle (DevicePtr (Ptr addr#)) =+ CULLong (W64# (wordToWord64# (int2Word# (addr2Int# addr#))))++#if __GLASGOW_HASKELL__ < 904+{-# INLINE wordToWord64# #-}+wordToWord64# :: Word# -> Word#+wordToWord64# x = x+#endif+
+ src/Foreign/CUDA/Driver/Unified.chs view
@@ -0,0 +1,280 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_HADDOCK prune #-}+--------------------------------------------------------------------------------+-- |+-- Module : Foreign.CUDA.Driver.Unified+-- Copyright : [2017..2023] Trevor L. McDonell+-- License : BSD+--+-- Unified addressing functions for the low-level driver interface+--+-- [/Overview/]+--+-- CUDA devices can share a unified address space with the host. For these+-- devices, there is no distinction between a device pointer and a host+-- pointer---the same pointer value may be used to access memory from the host+-- program and from a kernel running on the device (with exceptions enumerated+-- below).+--+-- [/Support/]+--+-- Whether or not a device supports unified addressing may be queried by calling+-- 'Foreign.CUDA.Driver.Device.attribute' with the+-- 'Foreign.CUDA.Driver.Device.UnifiedAddressing' attribute.+--+-- Unified addressing is automatically enabled in 64-bit processes on devices+-- with compute capability at leas 2.0.+--+-- [/Looking up information about pointers/]+--+-- It is possible to look up information about the memory which backs a pointer;+-- that is, whether the memory resides on the host or the device (and in+-- particular, which device).+--+-- [/Automatic mapping of host memory/]+--+-- All host memory allocated in all contexts using+-- 'Foreign.CUDA.Driver.Marshal.mallocHostArray' or+-- 'Foreign.CUDA.Driver.Marshal.mallocHostForeignPtr' is always directly+-- accessible from all contexts on all devices which support unified addressing.+-- This is the case whether or not the flags+-- 'Foreign.CUDA.Driver.Marshal.Portable' or+-- 'Foreign.CUDA.Driver.Marshal.DeviceMapped' are specified.+--+-- The pointer value through which allocated host memory may be accessed in+-- kernels on all devices which support unified addressing is the same as the+-- pointer value as on the host; that is, it is not necessary to call+-- 'Foreign.CUDA.Driver.Marshal.getDevicePtr' for these allocations.+--+-- Note that this is not the case for memory allocated using the+-- 'Foreign.CUDA.Driver.Marshal.WriteCombined' option; see below.+--+-- [/Automatic registration of peer memory/]+--+-- Upon enabling direct access from a context which supports unified addressing+-- to another peer context which supports unified addressing using+-- 'Foreign.CUDA.Driver.Context.Peer.add', all memory allocated in the peer+-- context will immediately be accessible by the current context. The device+-- pointer values are the same on both contexts.+--+-- [/Exceptions (disjoint addressing/]+--+-- Not all memory may be accessed on devices through the same pointer value+-- as they are accessed with on the host. These exceptions are host arrays+-- registered with 'Foreign.CUDA.Driver.Marshal.registerArray', and those+-- allocated with the flag 'Foreign.CUDA.Driver.Marshal.WriteCombined'. In these+-- cases, the host and device arrays have distinct addresses (pointer values).+-- However, the device address is guaranteed to not overlap with any valid host+-- pointer range and is guaranteed to have the same value across all contexts+-- which support unified addressing.+--+-- The value of the device pointer may be queried with+-- 'Foreign.CUDA.Driver.Marshal.getDevicePtr' from any context supporting+-- unified addressing.+--+--------------------------------------------------------------------------------++module Foreign.CUDA.Driver.Unified (++ -- ** Querying pointer attributes+ PointerAttributes(..), MemoryType(..),+ getAttributes,++ -- ** Setting pointer attributes+ Advice(..),+ setSyncMemops,+ advise,++) where++#include "cbits/stubs.h"+{# context lib="cuda" #}++-- Friends+import Foreign.CUDA.Driver.Context+import Foreign.CUDA.Driver.Device+import Foreign.CUDA.Driver.Error+import Foreign.CUDA.Driver.Marshal+import Foreign.CUDA.Internal.C2HS+import Foreign.CUDA.Ptr++-- System+import Control.Applicative+import Control.Monad+import Data.Maybe+import Foreign+import Foreign.C+import Foreign.Storable+import Prelude+++#if CUDA_VERSION < 7000+data PointerAttributes a+data MemoryType+#else+-- | Information about a pointer+--+data PointerAttributes a = PointerAttributes+ { ptrContext :: {-# UNPACK #-} !Context+ , ptrDevice :: {-# UNPACK #-} !(DevicePtr a)+ , ptrHost :: {-# UNPACK #-} !(HostPtr a)+ , ptrBufferID :: {-# UNPACK #-} !CULLong+ , ptrMemoryType :: !MemoryType+ , ptrSyncMemops :: !Bool+ , ptrIsManaged :: !Bool+ }+ deriving Show++{# enum CUmemorytype as MemoryType+ { underscoreToCase+ , DEVICE as DeviceMemory+ , HOST as HostMemory+ , ARRAY as ArrayMemory+ , UNIFIED as UnifiedMemory }+ with prefix="CU_MEMORYTYPE" deriving (Eq, Show, Bounded) #}++{# enum CUpointer_attribute as PointerAttribute+ { underscoreToCase }+ with prefix="CU_POINTER" deriving (Eq, Show, Bounded) #}+#endif++#if CUDA_VERSION < 8000+data Advice+#else+{# enum CUmem_advise as Advice+ { underscoreToCase }+ with prefix="CU_MEM_ADVISE" deriving (Eq, Show, Bounded) #}+#endif+++-- Return information about a pointer.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__UNIFIED.html#group__CUDA__UNIFIED_1g0c28ed0aff848042bc0533110e45820c>+--+-- Requires CUDA-7.0.+--+{-# INLINEABLE getAttributes #-}+getAttributes :: Ptr a -> IO (PointerAttributes a)+#if CUDA_VERSION < 7000+getAttributes _ = requireSDK 'getAttributes 7.0+#else+getAttributes ptr =+ alloca $ \p_ctx ->+ alloca $ \p_dptr ->+ alloca $ \p_hptr ->+ alloca $ \(p_bid :: Ptr CULLong) ->+ alloca $ \(p_mt :: Ptr CUInt) ->+ alloca $ \(p_sm :: Ptr CInt) ->+ alloca $ \(p_im :: Ptr CInt) -> do+ let n = length as+ (as,ps) = unzip [ (AttributeContext, castPtr p_ctx)+ , (AttributeDevicePointer, castPtr p_dptr)+ , (AttributeHostPointer, castPtr p_hptr)+ , (AttributeBufferId, castPtr p_bid)+ , (AttributeMemoryType, castPtr p_mt)+ , (AttributeSyncMemops, castPtr p_sm)+ , (AttributeIsManaged, castPtr p_im)+ ]+ --+ nothingIfOk =<< cuPointerGetAttributes n as ps ptr+ PointerAttributes+ <$> liftM Context (peek p_ctx)+ <*> liftM DevicePtr (peek p_dptr)+ <*> liftM HostPtr (peek p_hptr)+ <*> peek p_bid+ <*> liftM cToEnum (peek p_mt)+ <*> liftM cToBool (peek p_sm)+ <*> liftM cToBool (peek p_im)++{-# INLINE cuPointerGetAttributes #-}+{# fun unsafe cuPointerGetAttributes+ { `Int'+ , withAttrs* `[PointerAttribute]'+ , withArray* `[Ptr ()]'+ , useHandle `Ptr a'+ }+ -> `Status' cToEnum #}+ where+ withAttrs as = withArray (map cFromEnum as)+ useHandle = fromIntegral . ptrToIntPtr+#endif+++-- Set whether or not the given memory region is guaranteed to always+-- synchronise memory operations that are synchronous. If there are some+-- previously initiated synchronous memory operations that are pending when this+-- attribute is set, the function does not return until those memory operations+-- are complete. See+-- <http://docs.nvidia.com/cuda/cuda-driver-api/api-sync-behavior.html API+-- synchronisation behaviour> for more information on cases where synchronous+-- memory operations can exhibit asynchronous behaviour.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__UNIFIED.html#group__CUDA__UNIFIED_1g89f7ad29a657e574fdea2624b74d138e>+--+-- Requires CUDA-7.0.+--+{-# INLINE setSyncMemops #-}+setSyncMemops :: Ptr a -> Bool -> IO ()+#if CUDA_VERSION < 7000+setSyncMemops _ _ = requireSDK 'setSyncMemops 7.0+#else+setSyncMemops ptr val = nothingIfOk =<< cuPointerSetAttribute val AttributeSyncMemops ptr++{-# INLINE cuPointerSetAttribute #-}+{# fun unsafe cuPointerSetAttribute+ { withBool'* `Bool'+ , cFromEnum `PointerAttribute'+ , useHandle `Ptr a'+ }+ -> `Status' cToEnum #}+ where+ withBool' :: Bool -> (Ptr () -> IO b) -> IO b+ withBool' v k = with (fromBool v :: CUInt) (k . castPtr)++ useHandle = fromIntegral . ptrToIntPtr+#endif+++-- | Advise about the usage of a given range of memory. If the supplied device+-- is Nothing, then the preferred location is taken to mean the CPU.+--+-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__UNIFIED.html#group__CUDA__UNIFIED_1g27608c857a9254789c13f3e3b72029e2>+--+-- Requires CUDA-8.0.+--+{-# INLINEABLE advise #-}+advise :: Storable a => Ptr a -> Int -> Advice -> Maybe Device -> IO ()+#if CUDA_VERSION < 8000+advise _ _ _ _ = requireSDK 'advise 8.0+#else+advise ptr n a mdev = go undefined ptr+ where+ go :: Storable a' => a' -> Ptr a' -> IO ()+ go x _ = nothingIfOk =<< cuMemAdvise ptr (n * sizeOf x) a (maybe (-1) useDevice mdev)++{-# INLINE cuMemAdvise #-}+#if CUDA_VERSION < 13000+{# fun unsafe cuMemAdvise+ { useHandle `Ptr a'+ , `Int'+ , cFromEnum `Advice'+ , `CInt'+ }+ -> `Status' cToEnum #}+#else+{# fun unsafe cuMemAdvise_device as cuMemAdvise+ { useHandle `Ptr a'+ , `Int'+ , cFromEnum `Advice'+ , `CInt'+ }+ -> `Status' cToEnum #}+#endif+ where+ useHandle = fromIntegral . ptrToIntPtr+#endif
+ src/Foreign/CUDA/Driver/Utils.chs view
@@ -0,0 +1,50 @@+{-# LANGUAGE ForeignFunctionInterface #-}+--------------------------------------------------------------------------------+-- |+-- Module : Foreign.CUDA.Driver.Utils+-- Copyright : [2009..2023] Trevor L. McDonell+-- License : BSD+--+-- Utility functions+--+--------------------------------------------------------------------------------++module Foreign.CUDA.Driver.Utils (++ driverVersion,+ libraryVersion,++) where++#include "cbits/stubs.h"+{# context lib="cuda" #}++-- Friends+import Foreign.CUDA.Driver.Error+import Foreign.CUDA.Internal.C2HS++-- System+import Foreign+import Foreign.C+++-- |+-- Return the version number of the installed CUDA driver.+--+{-# INLINEABLE driverVersion #-}+driverVersion :: IO Int+driverVersion = resultIfOk =<< cuDriverGetVersion++{-# INLINE cuDriverGetVersion #-}+{# fun unsafe cuDriverGetVersion+ { alloca- `Int' peekIntConv* } -> `Status' cToEnum #}+++-- |+-- Return the version number of the CUDA library (API) that this package was+-- compiled against.+--+{-# INLINEABLE libraryVersion #-}+libraryVersion :: Int+libraryVersion = {#const CUDA_VERSION #}+
+ src/Foreign/CUDA/Internal/C2HS.hs view
@@ -0,0 +1,277 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- C->Haskell Compiler: Marshalling library+--+-- Copyright (c) [1999...2005] Manuel M T Chakravarty+--+-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions are met:+--+-- 1. Redistributions of source code must retain the above copyright notice,+-- this list of conditions and the following disclaimer.+-- 2. Redistributions in binary form must reproduce the above copyright+-- notice, this list of conditions and the following disclaimer in the+-- documentation and/or other materials provided with the distribution.+-- 3. The name of the author may not be used to endorse or promote products+-- derived from this software without specific prior written permission.+--+-- THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR+-- IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES+-- OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN+-- NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+-- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED+-- TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR+-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING+-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+--+--- Description ---------------------------------------------------------------+--+-- Language: Haskell 98+--+-- This module provides the marshaling routines for Haskell files produced by+-- C->Haskell for binding to C library interfaces. It exports all of the+-- low-level FFI (language-independent plus the C-specific parts) together+-- with the C->HS-specific higher-level marshalling routines.+--++module Foreign.CUDA.Internal.C2HS (++ -- * Composite marshalling functions+ withCStringLenIntConv, peekCStringLenIntConv, withIntConv, withFloatConv,+ peekIntConv, peekFloatConv, withBool, peekBool, withEnum, peekEnum,+ peekArrayWith,++ -- * Conditional results using 'Maybe'+ nothingIf, nothingIfNull,++ -- * Bit masks+ combineBitMasks, containsBitMask, extractBitMasks,++ -- * Conversion between C and Haskell types+ cIntConv, cFloatConv, cToBool, cFromBool, cToEnum, cFromEnum+) where+++import Foreign+import Foreign.C+import Control.Monad ( liftM )++import GHC.Int+import GHC.Word+import GHC.Base+++-- Composite marshalling functions+-- -------------------------------++-- Strings with explicit length+--+withCStringLenIntConv :: String -> (CStringLen -> IO a) -> IO a+withCStringLenIntConv s f = withCStringLen s $ \(p, n) -> f (p, cIntConv n)++peekCStringLenIntConv :: CStringLen -> IO String+peekCStringLenIntConv (s, n) = peekCStringLen (s, cIntConv n)++-- Marshalling of numerals+--++withIntConv :: (Storable b, Integral a, Integral b) => a -> (Ptr b -> IO c) -> IO c+withIntConv = with . cIntConv++withFloatConv :: (Storable b, RealFloat a, RealFloat b) => a -> (Ptr b -> IO c) -> IO c+withFloatConv = with . cFloatConv++peekIntConv :: (Storable a, Integral a, Integral b) => Ptr a -> IO b+peekIntConv = liftM cIntConv . peek++peekFloatConv :: (Storable a, RealFloat a, RealFloat b) => Ptr a -> IO b+peekFloatConv = liftM cFloatConv . peek++-- Passing Booleans by reference+--++withBool :: (Integral a, Storable a) => Bool -> (Ptr a -> IO b) -> IO b+withBool = with . fromBool++peekBool :: (Integral a, Storable a) => Ptr a -> IO Bool+peekBool = liftM toBool . peek+++-- Read and marshal array elements+--++peekArrayWith :: Storable a => (a -> b) -> Int -> Ptr a -> IO [b]+peekArrayWith f n p = map f `fmap` peekArray n p+++-- Passing enums by reference+--++withEnum :: (Enum a, Integral b, Storable b) => a -> (Ptr b -> IO c) -> IO c+withEnum = with . cFromEnum++peekEnum :: (Enum a, Integral b, Storable b) => Ptr b -> IO a+peekEnum = liftM cToEnum . peek+++{-+-- Storing of 'Maybe' values+-- -------------------------++instance Storable a => Storable (Maybe a) where+ sizeOf _ = sizeOf (undefined :: Ptr ())+ alignment _ = alignment (undefined :: Ptr ())++ peek p = do+ ptr <- peek (castPtr p)+ if ptr == nullPtr+ then return Nothing+ else liftM Just $ peek ptr++ poke p v = do+ ptr <- case v of+ Nothing -> return nullPtr+ Just v' -> new v'+ poke (castPtr p) ptr+-}+++-- Conditional results using 'Maybe'+-- ---------------------------------++-- Wrap the result into a 'Maybe' type.+--+-- * the predicate determines when the result is considered to be non-existing,+-- ie, it is represented by `Nothing'+--+-- * the second argument allows to map a result wrapped into `Just' to some+-- other domain+--+nothingIf :: (a -> Bool) -> (a -> b) -> a -> Maybe b+nothingIf p f x = if p x then Nothing else Just $ f x++-- |Instance for special casing null pointers.+--+nothingIfNull :: (Ptr a -> b) -> Ptr a -> Maybe b+nothingIfNull = nothingIf (== nullPtr)+++-- Support for bit masks+-- ---------------------++-- Given a list of enumeration values that represent bit masks, combine these+-- masks using bitwise disjunction.+--+combineBitMasks :: (Enum a, Num b, Bits b) => [a] -> b+combineBitMasks = foldl (.|.) 0 . map (fromIntegral . fromEnum)++-- Tests whether the given bit mask is contained in the given bit pattern+-- (i.e., all bits set in the mask are also set in the pattern).+--+containsBitMask :: (Num a, Bits a, Enum b) => a -> b -> Bool+bits `containsBitMask` bm = let bm' = fromIntegral . fromEnum $ bm+ in+ bm' .&. bits == bm'++-- |Given a bit pattern, yield all bit masks that it contains.+--+-- * This does *not* attempt to compute a minimal set of bit masks that when+-- combined yield the bit pattern, instead all contained bit masks are+-- produced.+--+extractBitMasks :: (Num a, Bits a, Enum b, Bounded b) => a -> [b]+extractBitMasks bits =+ [bm | bm <- [minBound..maxBound], bits `containsBitMask` bm]+++-- Conversion routines+-- -------------------++-- |Integral conversion+--+{-# INLINE [1] cIntConv #-}+cIntConv :: (Integral a, Integral b) => a -> b+cIntConv = fromIntegral++-- This is enough to fix the missing specialisation for mallocArray, but perhaps+-- we should implement a more general solution which avoids the use of+-- fromIntegral entirely (in particular, without relying on orphan instances).+--+{-# RULES+ "fromIntegral/Int->CInt" fromIntegral = \(I# i#) -> CInt (I32# (intToInt32# i#)) ;+ "fromIntegral/Int->CLLong" fromIntegral = \(I# i#) -> CLLong (I64# (intToInt64# i#)) ;+ #-}+{-# RULES+ "fromIntegral/Int->CUInt" fromIntegral = \(I# i#) -> CUInt (W32# (wordToWord32# (int2Word# i#))) ;+ "fromIntegral/Int->CULLong" fromIntegral = \(I# i#) -> CULLong (W64# (wordToWord64# (int2Word# i#))) ;+ #-}++ -- The C 'long' type might be 32- or 64-bits wide+ --+ -- "fromIntegral/Int->CLong" fromIntegral = \(I# i#) -> CLong (I64# i#) ;+ -- "fromIntegral/Int->CULong" fromIntegral = \(I# i#) -> CULong (W64# (int2Word# i#)) ;++-- |Floating conversion+--+{-# INLINE [1] cFloatConv #-}+cFloatConv :: (RealFloat a, RealFloat b) => a -> b+cFloatConv = realToFrac++-- As this conversion by default goes via `Rational', it can be very slow...+{-# RULES+ "realToFrac/Float->Float" realToFrac = \(x::Float) -> x ;+ "realToFrac/Float->CFloat" realToFrac = \(x::Float) -> CFloat x ;+ "realToFrac/CFloat->Float" realToFrac = \(CFloat x) -> x ;+ #-}+{-# RULES+ "realToFrac/Double->Double" realToFrac = \(x::Double) -> x;+ "realToFrac/Double->CDouble" realToFrac = \(x::Double) -> CDouble x ;+ "realToFrac/CDouble->Double" realToFrac = \(CDouble x) -> x ;+ #-}++-- |Obtain C value from Haskell 'Bool'.+--+{-# INLINE [1] cFromBool #-}+cFromBool :: Num a => Bool -> a+cFromBool = fromBool++-- |Obtain Haskell 'Bool' from C value.+--+{-# INLINE [1] cToBool #-}+cToBool :: (Eq a, Num a) => a -> Bool+cToBool = toBool++-- |Convert a C enumeration to Haskell.+--+{-# INLINE [1] cToEnum #-}+cToEnum :: (Integral i, Enum e) => i -> e+cToEnum = toEnum . cIntConv++-- |Convert a Haskell enumeration to C.+--+{-# INLINE [1] cFromEnum #-}+cFromEnum :: (Enum e, Integral i) => e -> i+cFromEnum = cIntConv . fromEnum++#if __GLASGOW_HASKELL__ < 902+{-# INLINE intToInt32# #-}+intToInt32# :: Int# -> Int#+intToInt32# = narrow32Int#++{-# INLINE wordToWord32# #-}+wordToWord32# :: Word# -> Word#+wordToWord32# = narrow32Word#+#endif+#if __GLASGOW_HASKELL__ < 904+{-# INLINE intToInt64# #-}+intToInt64# :: Int# -> Int#+intToInt64# x = x++{-# INLINE wordToWord64# #-}+wordToWord64# :: Word# -> Word#+wordToWord64# x = x+#endif+
+ src/Foreign/CUDA/Internal/Describe.hs view
@@ -0,0 +1,18 @@+--------------------------------------------------------------------------------+-- |+-- Module : Foreign.CUDA.Internal.Describe+-- Copyright : [2016..2023] Trevor L. McDonell+-- License : BSD+--+--------------------------------------------------------------------------------++module Foreign.CUDA.Internal.Describe+ where+++-- | Like 'Text.Show.Show', but focuses on providing a more detailed description+-- of the value rather than a 'Text.Read.read'able representation.+--+class Describe a where+ describe :: a -> String+
+ src/Foreign/CUDA/Path.chs view
@@ -0,0 +1,41 @@+{-# LANGUAGE CPP #-}+--------------------------------------------------------------------------------+-- |+-- Module : Foreign.CUDA.Path+-- Copyright : [2017..2023] Trevor L. McDonell+-- License : BSD+--+--------------------------------------------------------------------------------++module Foreign.CUDA.Path (++ cudaInstallPath,+ cudaBinPath, cudaLibraryPath, cudaIncludePath,++) where++import System.FilePath++-- | The base path to the CUDA toolkit installation that this package was+-- compiled against.+--+cudaInstallPath :: FilePath+cudaInstallPath = {#const CUDA_INSTALL_PATH#}++-- | The path where the CUDA toolkit executables, such as @nvcc@ and @ptxas@,+-- can be found.+--+cudaBinPath :: FilePath+cudaBinPath = cudaInstallPath </> "bin"++-- | The path where the CUDA libraries this package was linked against are+-- located+--+cudaLibraryPath :: FilePath+cudaLibraryPath = {#const CUDA_LIBRARY_PATH#}++-- | The path where the CUDA headers this package was built against are located+--+cudaIncludePath :: FilePath+cudaIncludePath = cudaInstallPath </> "include"+
+ src/Foreign/CUDA/Ptr.hs view
@@ -0,0 +1,222 @@+{-# LANGUAGE BangPatterns #-}+--------------------------------------------------------------------------------+-- |+-- Module : Foreign.CUDA.Ptr+-- Copyright : [2009..2023] Trevor L. McDonell+-- License : BSD+--+-- Data pointers on the host and device. These can be shared freely between the+-- CUDA runtime and Driver APIs.+--+--------------------------------------------------------------------------------++module Foreign.CUDA.Ptr (++ -- * Device pointers+ DevicePtr(..),+ withDevicePtr,+ devPtrToWordPtr,+ wordPtrToDevPtr,+ nullDevPtr,+ castDevPtr,+ plusDevPtr,+ alignDevPtr,+ minusDevPtr,+ advanceDevPtr,++ -- * Host pointers+ HostPtr(..),+ withHostPtr,+ nullHostPtr,+ castHostPtr,+ plusHostPtr,+ alignHostPtr,+ minusHostPtr,+ advanceHostPtr,++) where++import Foreign.Ptr+import Foreign.Storable+++--------------------------------------------------------------------------------+-- Device Pointer+--------------------------------------------------------------------------------++-- |+-- A reference to data stored on the device.+--+newtype DevicePtr a = DevicePtr { useDevicePtr :: Ptr a }+ deriving (Eq,Ord)++instance Show (DevicePtr a) where+ showsPrec n (DevicePtr p) = showsPrec n p++instance Storable (DevicePtr a) where+ sizeOf _ = sizeOf (undefined :: Ptr a)+ alignment _ = alignment (undefined :: Ptr a)+ peek p = DevicePtr `fmap` peek (castPtr p)+ poke p v = poke (castPtr p) (useDevicePtr v)+++-- |+-- Look at the contents of device memory. This takes an IO action that will be+-- applied to that pointer, the result of which is returned. It would be silly+-- to return the pointer from the action.+--+{-# INLINEABLE withDevicePtr #-}+withDevicePtr :: DevicePtr a -> (Ptr a -> IO b) -> IO b+withDevicePtr !p !f = f (useDevicePtr p)++-- |+-- Return a unique handle associated with the given device pointer+--+{-# INLINEABLE devPtrToWordPtr #-}+devPtrToWordPtr :: DevicePtr a -> WordPtr+devPtrToWordPtr = ptrToWordPtr . useDevicePtr++-- |+-- Return a device pointer from the given handle+--+{-# INLINEABLE wordPtrToDevPtr #-}+wordPtrToDevPtr :: WordPtr -> DevicePtr a+wordPtrToDevPtr = DevicePtr . wordPtrToPtr++-- |+-- The constant 'nullDevPtr' contains the distinguished memory location that is+-- not associated with a valid memory location+--+{-# INLINEABLE nullDevPtr #-}+nullDevPtr :: DevicePtr a+nullDevPtr = DevicePtr nullPtr++-- |+-- Cast a device pointer from one type to another+--+{-# INLINEABLE castDevPtr #-}+castDevPtr :: DevicePtr a -> DevicePtr b+castDevPtr (DevicePtr !p) = DevicePtr (castPtr p)++-- |+-- Advance the pointer address by the given offset in bytes.+--+{-# INLINEABLE plusDevPtr #-}+plusDevPtr :: DevicePtr a -> Int -> DevicePtr a+plusDevPtr (DevicePtr !p) !d = DevicePtr (p `plusPtr` d)++-- |+-- Given an alignment constraint, align the device pointer to the next highest+-- address satisfying the constraint+--+{-# INLINEABLE alignDevPtr #-}+alignDevPtr :: DevicePtr a -> Int -> DevicePtr a+alignDevPtr (DevicePtr !p) !i = DevicePtr (p `alignPtr` i)++-- |+-- Compute the difference between the second and first argument. This fulfils+-- the relation+--+-- > p2 == p1 `plusDevPtr` (p2 `minusDevPtr` p1)+--+{-# INLINEABLE minusDevPtr #-}+minusDevPtr :: DevicePtr a -> DevicePtr a -> Int+minusDevPtr (DevicePtr !a) (DevicePtr !b) = a `minusPtr` b++-- |+-- Advance a pointer into a device array by the given number of elements+--+{-# INLINEABLE advanceDevPtr #-}+advanceDevPtr :: Storable a => DevicePtr a -> Int -> DevicePtr a+advanceDevPtr = doAdvance undefined+ where+ doAdvance :: Storable a' => a' -> DevicePtr a' -> Int -> DevicePtr a'+ doAdvance x !p !i = p `plusDevPtr` (i * sizeOf x)+++--------------------------------------------------------------------------------+-- Host Pointer+--------------------------------------------------------------------------------++-- |+-- A reference to page-locked host memory.+--+-- A 'HostPtr' is just a plain 'Ptr', but the memory has been allocated by CUDA+-- into page locked memory. This means that the data can be copied to the GPU+-- via DMA (direct memory access). Note that the use of the system function+-- `mlock` is not sufficient here --- the CUDA version ensures that the+-- /physical/ address stays this same, not just the virtual address.+--+-- To copy data into a 'HostPtr' array, you may use for example 'withHostPtr'+-- together with 'Foreign.Marshal.Array.copyArray' or+-- 'Foreign.Marshal.Array.moveArray'.+--+newtype HostPtr a = HostPtr { useHostPtr :: Ptr a }+ deriving (Eq,Ord)++instance Show (HostPtr a) where+ showsPrec n (HostPtr p) = showsPrec n p++instance Storable (HostPtr a) where+ sizeOf _ = sizeOf (undefined :: Ptr a)+ alignment _ = alignment (undefined :: Ptr a)+ peek p = HostPtr `fmap` peek (castPtr p)+ poke p v = poke (castPtr p) (useHostPtr v)+++-- |+-- Apply an IO action to the memory reference living inside the host pointer+-- object. All uses of the pointer should be inside the 'withHostPtr' bracket.+--+{-# INLINEABLE withHostPtr #-}+withHostPtr :: HostPtr a -> (Ptr a -> IO b) -> IO b+withHostPtr !p !f = f (useHostPtr p)+++-- |+-- The constant 'nullHostPtr' contains the distinguished memory location that is+-- not associated with a valid memory location+--+{-# INLINEABLE nullHostPtr #-}+nullHostPtr :: HostPtr a+nullHostPtr = HostPtr nullPtr++-- |+-- Cast a host pointer from one type to another+--+{-# INLINEABLE castHostPtr #-}+castHostPtr :: HostPtr a -> HostPtr b+castHostPtr (HostPtr !p) = HostPtr (castPtr p)++-- |+-- Advance the pointer address by the given offset in bytes+--+{-# INLINEABLE plusHostPtr #-}+plusHostPtr :: HostPtr a -> Int -> HostPtr a+plusHostPtr (HostPtr !p) !d = HostPtr (p `plusPtr` d)++-- |+-- Given an alignment constraint, align the host pointer to the next highest+-- address satisfying the constraint+--+{-# INLINEABLE alignHostPtr #-}+alignHostPtr :: HostPtr a -> Int -> HostPtr a+alignHostPtr (HostPtr !p) !i = HostPtr (p `alignPtr` i)++-- |+-- Compute the difference between the second and first argument+--+{-# INLINEABLE minusHostPtr #-}+minusHostPtr :: HostPtr a -> HostPtr a -> Int+minusHostPtr (HostPtr !a) (HostPtr !b) = a `minusPtr` b++-- |+-- Advance a pointer into a host array by a given number of elements+--+{-# INLINEABLE advanceHostPtr #-}+advanceHostPtr :: Storable a => HostPtr a -> Int -> HostPtr a+advanceHostPtr = doAdvance undefined+ where+ doAdvance :: Storable a' => a' -> HostPtr a' -> Int -> HostPtr a'+ doAdvance x !p !i = p `plusHostPtr` (i * sizeOf x)+