diff --git a/Foreign/CUDA.hs b/Foreign/CUDA.hs deleted file mode 100644 --- a/Foreign/CUDA.hs +++ /dev/null @@ -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 - diff --git a/Foreign/CUDA/Analysis.hs b/Foreign/CUDA/Analysis.hs deleted file mode 100644 --- a/Foreign/CUDA/Analysis.hs +++ /dev/null @@ -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 - diff --git a/Foreign/CUDA/Analysis/Device.chs b/Foreign/CUDA/Analysis/Device.chs deleted file mode 100644 --- a/Foreign/CUDA/Analysis/Device.chs +++ /dev/null @@ -1,181 +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 -- ^ 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 - } - 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 - 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 - Compute 5 3 -> DeviceResources 32 2048 32 64 128 65536 256 65536 256 4 255 Warp -- Maxwell GM20B - - -- 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" ] - diff --git a/Foreign/CUDA/Analysis/Occupancy.hs b/Foreign/CUDA/Analysis/Occupancy.hs deleted file mode 100644 --- a/Foreign/CUDA/Analysis/Occupancy.hs +++ /dev/null @@ -1,207 +0,0 @@ -{-# LANGUAGE BangPatterns #-} --------------------------------------------------------------------------------- --- | --- Module : Foreign.CUDA.Analysis.Occupancy --- Copyright : [2009..2014] Trevor L. McDonell --- License : BSD --- --- Occupancy calculations for CUDA kernels --- --- --- --- /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, optimalBlockSizeOf, 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 - - 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` (warpsPerMP gpu `div` warps) - limitRegMP = threadBlocksPerMP gpu `min` (regFileSize gpu `div` registers) - limitSMemMP = threadBlocksPerMP gpu `min` (sharedMemPerMP gpu `div` 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 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) - diff --git a/Foreign/CUDA/Driver.hs b/Foreign/CUDA/Driver.hs deleted file mode 100644 --- a/Foreign/CUDA/Driver.hs +++ /dev/null @@ -1,238 +0,0 @@ --------------------------------------------------------------------------------- --- | --- Module : Foreign.CUDA.Driver --- Copyright : [2009..2015] 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 the 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.Utils - -) where - -import Foreign.CUDA.Ptr -import Foreign.CUDA.Driver.Context hiding ( useContext, device ) -import Foreign.CUDA.Driver.Device hiding ( useDevice ) -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 - diff --git a/Foreign/CUDA/Driver/Context.hs b/Foreign/CUDA/Driver/Context.hs deleted file mode 100644 --- a/Foreign/CUDA/Driver/Context.hs +++ /dev/null @@ -1,23 +0,0 @@ --------------------------------------------------------------------------------- --- | --- Module : Foreign.CUDA.Driver.Context --- Copyright : [2009..2015] 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 - diff --git a/Foreign/CUDA/Driver/Context/Base.chs b/Foreign/CUDA/Driver/Context/Base.chs deleted file mode 100644 --- a/Foreign/CUDA/Driver/Context/Base.chs +++ /dev/null @@ -1,241 +0,0 @@ -{-# 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..2015] 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'. --- --- --- -{-# 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. --- --- --- -{-# 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 (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. --- --- --- -{-# 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 --- --- --- -{-# 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'. --- --- --- -{-# 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. --- --- --- -{-# 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. --- --- --- -{-# INLINEABLE sync #-} -sync :: IO () -sync = nothingIfOk =<< cuCtxSynchronize - -{-# INLINE cuCtxSynchronize #-} -{# fun cuCtxSynchronize - { } -> `Status' cToEnum #} - diff --git a/Foreign/CUDA/Driver/Context/Config.chs b/Foreign/CUDA/Driver/Context/Config.chs deleted file mode 100644 --- a/Foreign/CUDA/Driver/Context/Config.chs +++ /dev/null @@ -1,297 +0,0 @@ -{-# 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..2015] 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.Types - --- 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 --- --- --- -{-# 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. --- --- --- -{-# 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. --- --- --- -{-# 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' - , cIntConv `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. --- --- --- -{-# 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. --- --- --- -{-# 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 --- --- --- -{-# 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 --- --- --- -{-# 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. --- --- --- -{-# 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 - diff --git a/Foreign/CUDA/Driver/Context/Peer.chs b/Foreign/CUDA/Driver/Context/Peer.chs deleted file mode 100644 --- a/Foreign/CUDA/Driver/Context/Peer.chs +++ /dev/null @@ -1,131 +0,0 @@ -{-# 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..2015] 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, - accessible, add, remove, - -) 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 = case x of {} - fromEnum x = case x of {} -#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. --- --- --- -{-# 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. --- --- --- -{-# 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. --- --- --- -{-# 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 - diff --git a/Foreign/CUDA/Driver/Context/Primary.chs b/Foreign/CUDA/Driver/Context/Primary.chs deleted file mode 100644 --- a/Foreign/CUDA/Driver/Context/Primary.chs +++ /dev/null @@ -1,170 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE TemplateHaskell #-} --------------------------------------------------------------------------------- --- | --- Module : Foreign.CUDA.Driver.Context.Primary --- Copyright : [2009..2014] 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. --- --- --- -{-# 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. --- --- --- -{-# 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. --- --- --- -{-# 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. --- --- --- -{-# 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. --- --- --- -{-# 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 - diff --git a/Foreign/CUDA/Driver/Device.chs b/Foreign/CUDA/Driver/Device.chs deleted file mode 100644 --- a/Foreign/CUDA/Driver/Device.chs +++ /dev/null @@ -1,403 +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(..), - 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 ) -import Control.Applicative -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 <- 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 - } -#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 = case x of {} - fromEnum x = case x of {} -#endif - - --------------------------------------------------------------------------------- --- Initialisation --------------------------------------------------------------------------------- - --- | --- Initialise the CUDA driver API. This must be called before any other --- driver function. --- --- --- -{-# INLINEABLE initialise #-} -initialise :: [InitFlag] -> IO () -initialise !flags = nothingIfOk =<< cuInit flags <* enable_constructors - -{-# INLINE enable_constructors #-} -{# fun unsafe enable_constructors { } -> `()' #} - -{-# 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 -#if CUDA_VERSION >= 5000 -capability !dev = - Compute <$> attribute dev ComputeCapabilityMajor - <*> attribute dev ComputeCapabilityMinor -#else --- Deprecated as of CUDA-5.0 --- -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 #} -#endif - - --- | --- Return a handle to the compute device at the given ordinal. --- --- --- -{-# 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 #} - - --- | --- The identifying 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 --- -{-# 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 cm = cuTotalConstMem p - sm = cuSharedMemPerBlock p - rb = cuRegsPerBlock p - ws = cuWarpSize p - tb = cuMaxThreadsPerBlock p - bs = cuMaxBlockSize p - gs = cuMaxGridSize p - cl = cuClockRate p - mp = cuMemPitch p - ta = cuTextureAlignment p -#else - cm <- fromIntegral <$> attribute d TotalConstantMemory - sm <- fromIntegral <$> attribute d SharedMemoryPerBlock - mp <- fromIntegral <$> attribute d MaxPitch - ta <- fromIntegral <$> attribute d TextureAlignment - cl <- attribute d ClockRate - ws <- attribute d WarpSize - rb <- attribute d RegistersPerBlock - tb <- attribute d MaxThreadsPerBlock - bs <- (,,) <$> attribute d MaxBlockDimX - <*> attribute d MaxBlockDimY - <*> attribute d MaxBlockDimZ - gs <- (,,) <$> attribute d MaxGridDimX - <*> attribute d MaxGridDimY - <*> attribute d MaxGridDimZ -#endif - - -- The rest of the 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 -#if CUDA_VERSION >= 5050 - sp <- toBool `fmap` attribute d StreamPrioritiesSupported -#endif -#if CUDA_VERSION >= 6000 - gl1 <- toBool `fmap` attribute d GlobalL1CacheSupported - ll1 <- toBool `fmap` attribute d LocalL1CacheSupported - mm <- toBool `fmap` attribute d ManagedMemory - mg <- toBool `fmap` attribute d MultiGpuBoard - mid <- attribute d MultiGpuBoardGroupId -#endif - - return DeviceProperties - { - deviceName = n - , computeCapability = cc - , totalGlobalMem = gm - , totalConstMem = cm - , sharedMemPerBlock = sm - , regsPerBlock = rb - , warpSize = ws - , maxThreadsPerBlock = tb - , maxBlockSize = bs - , maxGridSize = gs - , clockRate = cl - , multiProcessorCount = pc - , memPitch = mp - , textureAlignment = ta - , computeMode = md - , deviceOverlap = ov - , kernelExecTimeoutEnabled = ke - , integrated = tg - , canMapHostMemory = hm -#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 -#if CUDA_VERSION >= 5050 - , streamPriorities = sp -#endif -#if CUDA_VERSION >= 6000 - , globalL1Cache = gl1 - , localL1Cache = ll1 - , managedMemory = mm - , multiGPUBoard = mg - , multiGPUBoardGroupID = mid -#endif - } - -#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). --- --- --- -{-# INLINEABLE totalMem #-} -totalMem :: Device -> IO Int64 -totalMem !d = resultIfOk =<< cuDeviceTotalMem d - -{-# INLINE cuDeviceTotalMem #-} -{# fun unsafe cuDeviceTotalMem - { alloca- `Int64' peekIntConv* - , useDevice `Device' } -> `Status' cToEnum #} - diff --git a/Foreign/CUDA/Driver/Error.chs b/Foreign/CUDA/Driver/Error.chs deleted file mode 100644 --- a/Foreign/CUDA/Driver/Error.chs +++ /dev/null @@ -1,210 +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 ( - - -- * CUDA Errors - Status(..), CUDAException(..), - describe, - cudaError, cudaErrorIO, requireSDK, - resultIfOk, nothingIfOk, - -) where - --- Friends -import Foreign.CUDA.Internal.C2HS - --- 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 --- -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. 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) - diff --git a/Foreign/CUDA/Driver/Event.chs b/Foreign/CUDA/Driver/Event.chs deleted file mode 100644 --- a/Foreign/CUDA/Driver/Event.chs +++ /dev/null @@ -1,163 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE TemplateHaskell #-} --------------------------------------------------------------------------------- --- | --- 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 '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 --- --- --- -{-# INLINEABLE block #-} -block :: Event -> IO () -block !ev = nothingIfOk =<< cuEventSynchronize ev - -{-# INLINE cuEventSynchronize #-} -{# fun cuEventSynchronize - { useEvent `Event' } -> `Status' cToEnum #} - diff --git a/Foreign/CUDA/Driver/Exec.chs b/Foreign/CUDA/Driver/Exec.chs deleted file mode 100644 --- a/Foreign/CUDA/Driver/Exec.chs +++ /dev/null @@ -1,380 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE TemplateHaskell #-} --------------------------------------------------------------------------------- --- | --- 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(..), SharedMem(..), - requires, - setCacheConfigFun, - setSharedMemConfigFun, - launchKernel, launchKernel', - - -- 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. --- --- --- -{-# 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. --- --- --- -{-# 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. --- --- --- -{-# 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. --- --- --- -{-# 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 - - --------------------------------------------------------------------------------- --- 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' - , cIntConv `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' - , `Float' } -> `Status' cToEnum #} - -{-# INLINE cuParamSetv #-} -{# fun unsafe cuParamSetv - `Storable a' => - { useFun `Fun' - , `Int' - , castPtr `Ptr a' - , `Int' } -> `Status' cToEnum #} - - diff --git a/Foreign/CUDA/Driver/IPC/Event.chs b/Foreign/CUDA/Driver/IPC/Event.chs deleted file mode 100644 --- a/Foreign/CUDA/Driver/IPC/Event.chs +++ /dev/null @@ -1,140 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE TemplateHaskell #-} --------------------------------------------------------------------------------- --- | --- Module : Foreign.CUDA.Driver.IPC.Event --- Copyright : [2009..2015] 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. --- --- --- -{-# 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. --- --- --- -{-# 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 - diff --git a/Foreign/CUDA/Driver/IPC/Marshal.chs b/Foreign/CUDA/Driver/IPC/Marshal.chs deleted file mode 100644 --- a/Foreign/CUDA/Driver/IPC/Marshal.chs +++ /dev/null @@ -1,177 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE TemplateHaskell #-} --------------------------------------------------------------------------------- --- | --- Module : Foreign.CUDA.Driver.IPC.Marshal --- Copyright : [2009..2015] 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. --- --- --- -{-# 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 'create' 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. --- --- --- -{-# 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. --- --- --- -{-# 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 - diff --git a/Foreign/CUDA/Driver/Marshal.chs b/Foreign/CUDA/Driver/Marshal.chs deleted file mode 100644 --- a/Foreign/CUDA/Driver/Marshal.chs +++ /dev/null @@ -1,1117 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE TemplateHaskell #-} -{-# 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, mallocHostForeignPtr, 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.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 - -#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. --- --- --- -{-# 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. --- --- --- -{-# 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. --- --- --- -{-# 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. --- --- --- -{-# 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. --- --- --- -{-# 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. --- --- --- -{-# 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 --- --- --- -{-# 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 - - --------------------------------------------------------------------------------- --- 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. --- --- Requires CUDA-4.0. --- --- --- -{-# 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. --- --- --- -{-# 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. --- --- --- --- --- --- --- -{-# 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 '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 - _ -> 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 - diff --git a/Foreign/CUDA/Driver/Module.hs b/Foreign/CUDA/Driver/Module.hs deleted file mode 100644 --- a/Foreign/CUDA/Driver/Module.hs +++ /dev/null @@ -1,20 +0,0 @@ --------------------------------------------------------------------------------- --- | --- 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 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 - diff --git a/Foreign/CUDA/Driver/Module/Base.chs b/Foreign/CUDA/Driver/Module/Base.chs deleted file mode 100644 --- a/Foreign/CUDA/Driver/Module/Base.chs +++ /dev/null @@ -1,322 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_HADDOCK prune #-} --------------------------------------------------------------------------------- --- | --- Module : Foreign.CUDA.Driver.Module.Base --- Copyright : [2009..2014] 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 - --- 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. --- --- --- -{-# 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 - 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 - cudaError (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. --- --- --- -{-# 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 1 0) = Compute10 -jitTargetOfCompute (Compute 1 1) = Compute11 -jitTargetOfCompute (Compute 1 2) = Compute12 -jitTargetOfCompute (Compute 1 3) = Compute13 -jitTargetOfCompute (Compute 2 0) = Compute20 -jitTargetOfCompute (Compute 2 1) = Compute21 -#if CUDA_VERSION >= 5000 -jitTargetOfCompute (Compute 3 0) = Compute30 -jitTargetOfCompute (Compute 3 5) = Compute35 -#endif -#if CUDA_VERSION >= 6000 -jitTargetOfCompute (Compute 3 2) = Compute32 -jitTargetOfCompute (Compute 5 0) = Compute50 -#endif -#if CUDA_VERSION >= 6050 -jitTargetOfCompute (Compute 3 7) = Compute37 -#endif -#if CUDA_VERSION >= 7000 -jitTargetOfCompute (Compute 5 2) = Compute52 -#endif -jitTargetOfCompute compute = error ("Unknown JIT Target for Compute " ++ show compute) - - -#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 = cIntConv `fmap` c_strnlen' str (cIntConv maxlen) - diff --git a/Foreign/CUDA/Driver/Module/Link.chs b/Foreign/CUDA/Driver/Module/Link.chs deleted file mode 100644 --- a/Foreign/CUDA/Driver/Module/Link.chs +++ /dev/null @@ -1,224 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE TemplateHaskell #-} --------------------------------------------------------------------------------- --- | --- Module : Foreign.CUDA.Driver.Module.Link --- Copyright : [2009..2014] 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 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. --- --- --- -{-# 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. --- --- --- -{-# 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. --- --- --- -{-# 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. --- --- --- -{-# 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. --- --- --- -{-# 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 - in - withArrayLen (map cFromEnum opt) $ \i p_opts -> - withArray (map unsafeCoerce val) $ \ p_vals -> - nothingIfOk =<< cuLinkAddData ls t img n "" i p_opts p_vals - -{-# INLINE cuLinkAddData #-} -{# fun unsafe cuLinkAddData - { useLinkState `LinkState' - , cFromEnum `JITInputType' - , castPtr `Ptr Word8' - , `Int' - , `String' - , `Int' - , id `Ptr CInt' - , id `Ptr (Ptr ())' - } - -> `Status' cToEnum #} -#endif - diff --git a/Foreign/CUDA/Driver/Module/Query.chs b/Foreign/CUDA/Driver/Module/Query.chs deleted file mode 100644 --- a/Foreign/CUDA/Driver/Module/Query.chs +++ /dev/null @@ -1,108 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ForeignFunctionInterface #-} --------------------------------------------------------------------------------- --- | --- Module : Foreign.CUDA.Driver.Module.Query --- Copyright : [2009..2014] Trevor L. McDonell --- License : BSD --- --- Querying module attributes for low-level driver interface --- --------------------------------------------------------------------------------- - -module Foreign.CUDA.Driver.Module.Query ( - - -- ** Querying module inhabitants - getFun, getPtr, getTex, - -) 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.Driver.Texture -import Foreign.CUDA.Internal.C2HS -import Foreign.CUDA.Ptr - --- System -import Foreign -import Foreign.C -import Control.Exception ( throwIO ) -import Control.Monad ( liftM ) - - --------------------------------------------------------------------------------- --- Querying module attributes --------------------------------------------------------------------------------- - --- | --- 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. This texture reference handle --- should not be destroyed, as the texture will be destroyed automatically --- when the module is unloaded. --- --- --- -{-# 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 #} - - --------------------------------------------------------------------------------- --- 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) - diff --git a/Foreign/CUDA/Driver/Profiler.chs b/Foreign/CUDA/Driver/Profiler.chs deleted file mode 100644 --- a/Foreign/CUDA/Driver/Profiler.chs +++ /dev/null @@ -1,100 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface #-} --------------------------------------------------------------------------------- --- | --- Module : Foreign.CUDA.Driver.Profiler --- Copyright : [2009..2014] 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. --- --- --- -{-# 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. --- --- --- -{-# 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. --- --- --- -{-# INLINEABLE stop #-} -stop :: IO () -stop = nothingIfOk =<< cuProfilerStop - -{-# INLINE cuProfilerStop #-} -{# fun unsafe cuProfilerStop - { } -> `Status' cToEnum #} - diff --git a/Foreign/CUDA/Driver/Stream.chs b/Foreign/CUDA/Driver/Stream.chs deleted file mode 100644 --- a/Foreign/CUDA/Driver/Stream.chs +++ /dev/null @@ -1,167 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE TemplateHaskell #-} --------------------------------------------------------------------------------- --- | --- 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, createWithPriority, destroy, finished, block, getPriority, - - 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 - - --- | --- 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. --- --- --- -{-# 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]' - , cIntConv `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. --- --- --- -{-# 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 #} - - --- | --- Query the priority of a stream. --- --- Requires CUDA-5.5. --- --- --- -{-# 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 - diff --git a/Foreign/CUDA/Driver/Texture.chs b/Foreign/CUDA/Driver/Texture.chs deleted file mode 100644 --- a/Foreign/CUDA/Driver/Texture.chs +++ /dev/null @@ -1,308 +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(..), - bind, bind2D, - getAddressMode, getFilterMode, getFormat, - setAddressMode, setFilterMode, setFormat, setReadMode, - - -- Deprecated - create, destroy, - - -- 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 - diff --git a/Foreign/CUDA/Driver/Utils.chs b/Foreign/CUDA/Driver/Utils.chs deleted file mode 100644 --- a/Foreign/CUDA/Driver/Utils.chs +++ /dev/null @@ -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 #} - diff --git a/Foreign/CUDA/Internal/C2HS.hs b/Foreign/CUDA/Internal/C2HS.hs deleted file mode 100644 --- a/Foreign/CUDA/Internal/C2HS.hs +++ /dev/null @@ -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 - diff --git a/Foreign/CUDA/Ptr.hs b/Foreign/CUDA/Ptr.hs deleted file mode 100644 --- a/Foreign/CUDA/Ptr.hs +++ /dev/null @@ -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) - diff --git a/Foreign/CUDA/Runtime.hs b/Foreign/CUDA/Runtime.hs deleted file mode 100644 --- a/Foreign/CUDA/Runtime.hs +++ /dev/null @@ -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 - diff --git a/Foreign/CUDA/Runtime/Device.chs b/Foreign/CUDA/Runtime/Device.chs deleted file mode 100644 --- a/Foreign/CUDA/Runtime/Device.chs +++ /dev/null @@ -1,464 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE TemplateHaskell #-} -{-# 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, Bounded) #} - - -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 -#if CUDART_VERSION >= 5050 - sp <- cToBool `fmap` {#get cudaDeviceProp.streamPrioritiesSupported#} p -#endif -#if CUDART_VERSION >= 6000 - gl1 <- cToBool `fmap` {#get cudaDeviceProp.globalL1CacheSupported#} p - ll1 <- cToBool `fmap` {#get cudaDeviceProp.localL1CacheSupported#} p - mm <- cToBool `fmap` {#get cudaDeviceProp.managedMemory#} p - mg <- cToBool `fmap` {#get cudaDeviceProp.isMultiGpuBoard#} p - mid <- cIntConv `fmap` {#get cudaDeviceProp.multiGpuBoardGroupID#} 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 - , kernelExecTimeoutEnabled = ke - , integrated = tg - , canMapHostMemory = hm -#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 CUDA runtime API 3.0 - , 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 -#if CUDA_VERSION >= 5050 - , streamPriorities = sp -#endif -#if CUDA_VERSION >= 6000 - , globalL1Cache = gl1 - , localL1Cache = ll1 - , managedMemory = mm - , multiGPUBoard = mg - , multiGPUBoardGroupID = mid -#endif - } - - --------------------------------------------------------------------------------- --- 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 'accessible 4.0 -#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 'add 4.0 -#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 'remove 4.0 -#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 'getLimit 3.1 -#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 'setLimit 3.1 -#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 - diff --git a/Foreign/CUDA/Runtime/Error.chs b/Foreign/CUDA/Runtime/Error.chs deleted file mode 100644 --- a/Foreign/CUDA/Runtime/Error.chs +++ /dev/null @@ -1,116 +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 Control.Exception -import Data.Typeable -import Foreign.C -import Foreign.Ptr -import Language.Haskell.TH -import System.IO.Unsafe -import Text.Printf - -#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 :: Name -> Double -> IO a -requireSDK n v = cudaError $ printf "'%s' requires at least cuda-%3.1f\n" (show n) v - - --------------------------------------------------------------------------------- --- Helper Functions --------------------------------------------------------------------------------- - --- | --- Return the descriptive string associated with a particular error code --- -{# fun pure unsafe cudaGetErrorString 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) - diff --git a/Foreign/CUDA/Runtime/Event.chs b/Foreign/CUDA/Runtime/Event.chs deleted file mode 100644 --- a/Foreign/CUDA/Runtime/Event.chs +++ /dev/null @@ -1,148 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE TemplateHaskell #-} --------------------------------------------------------------------------------- --- | --- 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 'wait 3.2 -#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 #} - diff --git a/Foreign/CUDA/Runtime/Exec.chs b/Foreign/CUDA/Runtime/Exec.chs deleted file mode 100644 --- a/Foreign/CUDA/Runtime/Exec.chs +++ /dev/null @@ -1,276 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE TemplateHaskell #-} --------------------------------------------------------------------------------- --- | --- 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 'setCacheConfig 3.0 -#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* --- -#if CUDART_VERSION >= 5000 -withFun :: Fun -> (Ptr a -> IO b) -> IO b -withFun fn action = action (castFunPtrToPtr fn) -#else -withFun :: Fun -> (Ptr CChar -> IO a) -> IO a -withFun = withCString -#endif - diff --git a/Foreign/CUDA/Runtime/Marshal.chs b/Foreign/CUDA/Runtime/Marshal.chs deleted file mode 100644 --- a/Foreign/CUDA/Runtime/Marshal.chs +++ /dev/null @@ -1,648 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE TemplateHaskell #-} --------------------------------------------------------------------------------- --- | --- 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, 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. 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, Bounded) #} -#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 'mallocManagedArray 6.0 -#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 - diff --git a/Foreign/CUDA/Runtime/Stream.chs b/Foreign/CUDA/Runtime/Stream.chs deleted file mode 100644 --- a/Foreign/CUDA/Runtime/Stream.chs +++ /dev/null @@ -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 - diff --git a/Foreign/CUDA/Runtime/Texture.chs b/Foreign/CUDA/Runtime/Texture.chs deleted file mode 100644 --- a/Foreign/CUDA/Runtime/Texture.chs +++ /dev/null @@ -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) - diff --git a/Foreign/CUDA/Runtime/Utils.chs b/Foreign/CUDA/Runtime/Utils.chs deleted file mode 100644 --- a/Foreign/CUDA/Runtime/Utils.chs +++ /dev/null @@ -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 #} - diff --git a/Foreign/CUDA/Types.chs b/Foreign/CUDA/Types.chs deleted file mode 100644 --- a/Foreign/CUDA/Types.chs +++ /dev/null @@ -1,155 +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(..), StreamPriority, 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, Bounded) #} - --- | --- 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) - - --- | --- 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 - --- | --- 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 - diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,18 +1,32 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +-- 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 import Distribution.PackageDescription.Parse import Distribution.Simple import Distribution.Simple.BuildPaths import Distribution.Simple.Command -import Distribution.Simple.Program.Db import Distribution.Simple.LocalBuildInfo 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 +import Distribution.Simple.Utils hiding ( isInfixOf ) import Distribution.System import Distribution.Verbosity +#if MIN_VERSION_Cabal(1,25,0) +import Distribution.PackageDescription.PrettyPrint +import Distribution.Version +#endif + import Control.Exception import Control.Monad import Data.Function @@ -473,9 +487,14 @@ findProgram :: Verbosity -> FilePath -> IO (Maybe FilePath) findProgram verbosity prog = do result <- findProgramOnSearchPath verbosity defaultProgramSearchPath prog - case result of - Nothing -> return Nothing - Just (path,_) -> return (Just path) +#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 -- Reads user-provided `cuda.buildinfo` if present, otherwise loads `cuda.buildinfo.generated` @@ -506,8 +525,13 @@ -- -- 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, runPreProcessor = \(inBaseDir, inRelativeFile) @@ -541,7 +565,15 @@ -- 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:_ }) = printf "%d%02d" n1 n2 +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 diff --git a/cuda.cabal b/cuda.cabal --- a/cuda.cabal +++ b/cuda.cabal @@ -1,5 +1,5 @@ Name: cuda -Version: 0.7.5.0 +Version: 0.7.5.1 Synopsis: FFI binding to the CUDA interface for programming NVIDIA GPUs Description: The CUDA library provides a direct, general purpose C-like SPMD programming @@ -24,10 +24,10 @@ . [/NOTES:/] . - The setup script for this package requires at least Cabal-1.24. To upgrade, + The setup script for this package requires at least Cabal-1.22. To upgrade, execute one of: . - * cabal users: @cabal install Cabal --constraint="Cabal >= 1.24"@ + * cabal users: @cabal install Cabal --constraint="Cabal >= 1.22"@ . * stack users: @stack setup --upgrade-cabal@ . @@ -52,7 +52,7 @@ Homepage: https://github.com/tmcdonell/cuda Bug-reports: https://github.com/tmcdonell/cuda/issues Category: Foreign -Cabal-version: >= 1.24 +Cabal-version: >= 1.22 Tested-with: GHC >= 7.6 Build-type: Custom @@ -67,11 +67,12 @@ custom-setup setup-depends: base >= 4.6 - , Cabal >= 1.24 + , Cabal >= 1.22 , directory >= 1.0 , filepath >= 1.0 Library + hs-source-dirs: src Exposed-Modules: Foreign.CUDA Foreign.CUDA.Ptr Foreign.CUDA.Types @@ -110,6 +111,7 @@ Foreign.CUDA.Driver.Utils Other-modules: Foreign.CUDA.Internal.C2HS + Text.Show.Describe Include-dirs: . C-sources: cbits/stubs.c @@ -147,7 +149,7 @@ source-repository this type: git location: https://github.com/tmcdonell/cuda - tag: 0.7.5.0 + tag: 0.7.5.1 -- vim: nospell diff --git a/examples/src/deviceQueryDrv/DeviceQuery.hs b/examples/src/deviceQueryDrv/DeviceQuery.hs --- a/examples/src/deviceQueryDrv/DeviceQuery.hs +++ b/examples/src/deviceQueryDrv/DeviceQuery.hs @@ -80,11 +80,7 @@ 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" + $ text (describe computeMode) showFreq :: Integral i => i -> String diff --git a/src/Foreign/CUDA.hs b/src/Foreign/CUDA.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/CUDA.hs @@ -0,0 +1,19 @@ +-------------------------------------------------------------------------------- +-- | +-- 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 + diff --git a/src/Foreign/CUDA/Analysis.hs b/src/Foreign/CUDA/Analysis.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/CUDA/Analysis.hs @@ -0,0 +1,20 @@ +-------------------------------------------------------------------------------- +-- | +-- 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 + diff --git a/src/Foreign/CUDA/Analysis/Device.chs b/src/Foreign/CUDA/Analysis/Device.chs new file mode 100644 --- /dev/null +++ b/src/Foreign/CUDA/Analysis/Device.chs @@ -0,0 +1,196 @@ +-------------------------------------------------------------------------------- +-- | +-- 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, + describe + +) where + +#include "cbits/stubs.h" + +import Data.Int +import Text.Show.Describe + +import Debug.Trace + + +-- | +-- The compute mode the device is currently in +-- +{# enum CUcomputemode as ComputeMode + { underscoreToCase } + with prefix="CU_COMPUTEMODE" deriving (Eq, Show) #} + +instance Describe ComputeMode where + describe Default = "Multiple contexts are allowed on the device simultaneously" +#if CUDA_VERSION < 8000 + 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)) +--} + +-- | +-- 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 -- ^ 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 + } + 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 + 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 + Compute 5 3 -> DeviceResources 32 2048 32 64 128 65536 256 65536 256 4 255 Warp -- Maxwell GM20B + Compute 6 0 -> DeviceResources 32 2048 32 64 64 65536 256 65536 256 4 255 Warp -- Pascal GP100 (?) + Compute 6 1 -> DeviceResources 32 2048 32 64 128 98304 256 65536 256 4 255 Warp -- Pascal GP10x (?) + Compute 6 2 -> DeviceResources 32 2048 32 64 128 65536 256 65536 256 4 255 Warp -- Pascal (?) + + -- 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" ] + diff --git a/src/Foreign/CUDA/Analysis/Occupancy.hs b/src/Foreign/CUDA/Analysis/Occupancy.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/CUDA/Analysis/Occupancy.hs @@ -0,0 +1,207 @@ +{-# LANGUAGE BangPatterns #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Foreign.CUDA.Analysis.Occupancy +-- Copyright : [2009..2014] Trevor L. McDonell +-- License : BSD +-- +-- Occupancy calculations for CUDA kernels +-- +-- +-- +-- /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, optimalBlockSizeOf, 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 + + 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` (warpsPerMP gpu `div` warps) + limitRegMP = threadBlocksPerMP gpu `min` (regFileSize gpu `div` registers) + limitSMemMP = threadBlocksPerMP gpu `min` (sharedMemPerMP gpu `div` 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 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) + diff --git a/src/Foreign/CUDA/Driver.hs b/src/Foreign/CUDA/Driver.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/CUDA/Driver.hs @@ -0,0 +1,238 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Foreign.CUDA.Driver +-- Copyright : [2009..2015] 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 the 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.Utils + +) where + +import Foreign.CUDA.Ptr +import Foreign.CUDA.Driver.Context hiding ( useContext, device ) +import Foreign.CUDA.Driver.Device hiding ( useDevice ) +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 + diff --git a/src/Foreign/CUDA/Driver/Context.hs b/src/Foreign/CUDA/Driver/Context.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/CUDA/Driver/Context.hs @@ -0,0 +1,23 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Foreign.CUDA.Driver.Context +-- Copyright : [2009..2015] 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 + diff --git a/src/Foreign/CUDA/Driver/Context/Base.chs b/src/Foreign/CUDA/Driver/Context/Base.chs new file mode 100644 --- /dev/null +++ b/src/Foreign/CUDA/Driver/Context/Base.chs @@ -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..2015] 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'. +-- +-- +-- +{-# 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. +-- +-- +-- +{-# 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 (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. +-- +-- +-- +{-# 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 +-- +-- +-- +{-# 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'. +-- +-- +-- +{-# 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. +-- +-- +-- +{-# 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. +-- +-- +-- +{-# INLINEABLE sync #-} +sync :: IO () +sync = nothingIfOk =<< cuCtxSynchronize + +{-# INLINE cuCtxSynchronize #-} +{# fun cuCtxSynchronize + { } -> `Status' cToEnum #} + diff --git a/src/Foreign/CUDA/Driver/Context/Config.chs b/src/Foreign/CUDA/Driver/Context/Config.chs new file mode 100644 --- /dev/null +++ b/src/Foreign/CUDA/Driver/Context/Config.chs @@ -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..2015] 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.Types + +-- 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 +-- +-- +-- +{-# 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. +-- +-- +-- +{-# 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. +-- +-- +-- +{-# 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' + , cIntConv `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. +-- +-- +-- +{-# 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. +-- +-- +-- +{-# 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 +-- +-- +-- +{-# 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 +-- +-- +-- +{-# 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. +-- +-- +-- +{-# 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 + diff --git a/src/Foreign/CUDA/Driver/Context/Peer.chs b/src/Foreign/CUDA/Driver/Context/Peer.chs new file mode 100644 --- /dev/null +++ b/src/Foreign/CUDA/Driver/Context/Peer.chs @@ -0,0 +1,131 @@ +{-# 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..2015] 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, + accessible, add, remove, + +) 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 = case x of {} + fromEnum x = case x of {} +#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. +-- +-- +-- +{-# 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. +-- +-- +-- +{-# 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. +-- +-- +-- +{-# 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 + diff --git a/src/Foreign/CUDA/Driver/Context/Primary.chs b/src/Foreign/CUDA/Driver/Context/Primary.chs new file mode 100644 --- /dev/null +++ b/src/Foreign/CUDA/Driver/Context/Primary.chs @@ -0,0 +1,170 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Foreign.CUDA.Driver.Context.Primary +-- Copyright : [2009..2014] 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. +-- +-- +-- +{-# 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. +-- +-- +-- +{-# 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. +-- +-- +-- +{-# 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. +-- +-- +-- +{-# 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. +-- +-- +-- +{-# 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 + diff --git a/src/Foreign/CUDA/Driver/Device.chs b/src/Foreign/CUDA/Driver/Device.chs new file mode 100644 --- /dev/null +++ b/src/Foreign/CUDA/Driver/Device.chs @@ -0,0 +1,403 @@ +{-# 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(..), + 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 ) +import Control.Applicative +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 <- 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 + } +#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 = case x of {} + fromEnum x = case x of {} +#endif + + +-------------------------------------------------------------------------------- +-- Initialisation +-------------------------------------------------------------------------------- + +-- | +-- Initialise the CUDA driver API. This must be called before any other +-- driver function. +-- +-- +-- +{-# INLINEABLE initialise #-} +initialise :: [InitFlag] -> IO () +initialise !flags = nothingIfOk =<< cuInit flags <* enable_constructors + +{-# INLINE enable_constructors #-} +{# fun unsafe enable_constructors { } -> `()' #} + +{-# 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 +#if CUDA_VERSION >= 5000 +capability !dev = + Compute <$> attribute dev ComputeCapabilityMajor + <*> attribute dev ComputeCapabilityMinor +#else +-- Deprecated as of CUDA-5.0 +-- +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 #} +#endif + + +-- | +-- Return a handle to the compute device at the given ordinal. +-- +-- +-- +{-# 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 #} + + +-- | +-- The identifying 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 +-- +{-# 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 cm = cuTotalConstMem p + sm = cuSharedMemPerBlock p + rb = cuRegsPerBlock p + ws = cuWarpSize p + tb = cuMaxThreadsPerBlock p + bs = cuMaxBlockSize p + gs = cuMaxGridSize p + cl = cuClockRate p + mp = cuMemPitch p + ta = cuTextureAlignment p +#else + cm <- fromIntegral <$> attribute d TotalConstantMemory + sm <- fromIntegral <$> attribute d SharedMemoryPerBlock + mp <- fromIntegral <$> attribute d MaxPitch + ta <- fromIntegral <$> attribute d TextureAlignment + cl <- attribute d ClockRate + ws <- attribute d WarpSize + rb <- attribute d RegistersPerBlock + tb <- attribute d MaxThreadsPerBlock + bs <- (,,) <$> attribute d MaxBlockDimX + <*> attribute d MaxBlockDimY + <*> attribute d MaxBlockDimZ + gs <- (,,) <$> attribute d MaxGridDimX + <*> attribute d MaxGridDimY + <*> attribute d MaxGridDimZ +#endif + + -- The rest of the 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 +#if CUDA_VERSION >= 5050 + sp <- toBool `fmap` attribute d StreamPrioritiesSupported +#endif +#if CUDA_VERSION >= 6000 + gl1 <- toBool `fmap` attribute d GlobalL1CacheSupported + ll1 <- toBool `fmap` attribute d LocalL1CacheSupported + mm <- toBool `fmap` attribute d ManagedMemory + mg <- toBool `fmap` attribute d MultiGpuBoard + mid <- attribute d MultiGpuBoardGroupId +#endif + + return DeviceProperties + { + deviceName = n + , computeCapability = cc + , totalGlobalMem = gm + , totalConstMem = cm + , sharedMemPerBlock = sm + , regsPerBlock = rb + , warpSize = ws + , maxThreadsPerBlock = tb + , maxBlockSize = bs + , maxGridSize = gs + , clockRate = cl + , multiProcessorCount = pc + , memPitch = mp + , textureAlignment = ta + , computeMode = md + , deviceOverlap = ov + , kernelExecTimeoutEnabled = ke + , integrated = tg + , canMapHostMemory = hm +#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 +#if CUDA_VERSION >= 5050 + , streamPriorities = sp +#endif +#if CUDA_VERSION >= 6000 + , globalL1Cache = gl1 + , localL1Cache = ll1 + , managedMemory = mm + , multiGPUBoard = mg + , multiGPUBoardGroupID = mid +#endif + } + +#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). +-- +-- +-- +{-# INLINEABLE totalMem #-} +totalMem :: Device -> IO Int64 +totalMem !d = resultIfOk =<< cuDeviceTotalMem d + +{-# INLINE cuDeviceTotalMem #-} +{# fun unsafe cuDeviceTotalMem + { alloca- `Int64' peekIntConv* + , useDevice `Device' } -> `Status' cToEnum #} + diff --git a/src/Foreign/CUDA/Driver/Error.chs b/src/Foreign/CUDA/Driver/Error.chs new file mode 100644 --- /dev/null +++ b/src/Foreign/CUDA/Driver/Error.chs @@ -0,0 +1,212 @@ +{-# 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 ( + + -- * CUDA Errors + Status(..), CUDAException(..), + describe, + cudaError, cudaErrorIO, requireSDK, + resultIfOk, nothingIfOk, + +) where + +-- Friends +import Foreign.CUDA.Internal.C2HS +import Text.Show.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) + diff --git a/src/Foreign/CUDA/Driver/Event.chs b/src/Foreign/CUDA/Driver/Event.chs new file mode 100644 --- /dev/null +++ b/src/Foreign/CUDA/Driver/Event.chs @@ -0,0 +1,163 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +-- | +-- 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 '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 +-- +-- +-- +{-# INLINEABLE block #-} +block :: Event -> IO () +block !ev = nothingIfOk =<< cuEventSynchronize ev + +{-# INLINE cuEventSynchronize #-} +{# fun cuEventSynchronize + { useEvent `Event' } -> `Status' cToEnum #} + diff --git a/src/Foreign/CUDA/Driver/Exec.chs b/src/Foreign/CUDA/Driver/Exec.chs new file mode 100644 --- /dev/null +++ b/src/Foreign/CUDA/Driver/Exec.chs @@ -0,0 +1,380 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +-- | +-- 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(..), SharedMem(..), + requires, + setCacheConfigFun, + setSharedMemConfigFun, + launchKernel, launchKernel', + + -- 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. +-- +-- +-- +{-# 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. +-- +-- +-- +{-# 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. +-- +-- +-- +{-# 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. +-- +-- +-- +{-# 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 + + +-------------------------------------------------------------------------------- +-- 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' + , cIntConv `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' + , `Float' } -> `Status' cToEnum #} + +{-# INLINE cuParamSetv #-} +{# fun unsafe cuParamSetv + `Storable a' => + { useFun `Fun' + , `Int' + , castPtr `Ptr a' + , `Int' } -> `Status' cToEnum #} + + diff --git a/src/Foreign/CUDA/Driver/IPC/Event.chs b/src/Foreign/CUDA/Driver/IPC/Event.chs new file mode 100644 --- /dev/null +++ b/src/Foreign/CUDA/Driver/IPC/Event.chs @@ -0,0 +1,140 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Foreign.CUDA.Driver.IPC.Event +-- Copyright : [2009..2015] 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. +-- +-- +-- +{-# 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. +-- +-- +-- +{-# 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 + diff --git a/src/Foreign/CUDA/Driver/IPC/Marshal.chs b/src/Foreign/CUDA/Driver/IPC/Marshal.chs new file mode 100644 --- /dev/null +++ b/src/Foreign/CUDA/Driver/IPC/Marshal.chs @@ -0,0 +1,177 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Foreign.CUDA.Driver.IPC.Marshal +-- Copyright : [2009..2015] 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. +-- +-- +-- +{-# 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 'create' 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. +-- +-- +-- +{-# 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. +-- +-- +-- +{-# 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 + diff --git a/src/Foreign/CUDA/Driver/Marshal.chs b/src/Foreign/CUDA/Driver/Marshal.chs new file mode 100644 --- /dev/null +++ b/src/Foreign/CUDA/Driver/Marshal.chs @@ -0,0 +1,1117 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE TemplateHaskell #-} +{-# 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, mallocHostForeignPtr, 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.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 + +#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. +-- +-- +-- +{-# 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. +-- +-- +-- +{-# 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. +-- +-- +-- +{-# 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. +-- +-- +-- +{-# 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. +-- +-- +-- +{-# 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. +-- +-- +-- +{-# 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 +-- +-- +-- +{-# 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 + + +-------------------------------------------------------------------------------- +-- 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. +-- +-- Requires CUDA-4.0. +-- +-- +-- +{-# 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. +-- +-- +-- +{-# 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. +-- +-- +-- +-- +-- +-- +-- +{-# 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 '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 + _ -> 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 + diff --git a/src/Foreign/CUDA/Driver/Module.hs b/src/Foreign/CUDA/Driver/Module.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/CUDA/Driver/Module.hs @@ -0,0 +1,20 @@ +-------------------------------------------------------------------------------- +-- | +-- 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 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 + diff --git a/src/Foreign/CUDA/Driver/Module/Base.chs b/src/Foreign/CUDA/Driver/Module/Base.chs new file mode 100644 --- /dev/null +++ b/src/Foreign/CUDA/Driver/Module/Base.chs @@ -0,0 +1,322 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_HADDOCK prune #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Foreign.CUDA.Driver.Module.Base +-- Copyright : [2009..2014] 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 + +-- 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. +-- +-- +-- +{-# 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 + 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 + cudaError (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. +-- +-- +-- +{-# 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 1 0) = Compute10 +jitTargetOfCompute (Compute 1 1) = Compute11 +jitTargetOfCompute (Compute 1 2) = Compute12 +jitTargetOfCompute (Compute 1 3) = Compute13 +jitTargetOfCompute (Compute 2 0) = Compute20 +jitTargetOfCompute (Compute 2 1) = Compute21 +#if CUDA_VERSION >= 5000 +jitTargetOfCompute (Compute 3 0) = Compute30 +jitTargetOfCompute (Compute 3 5) = Compute35 +#endif +#if CUDA_VERSION >= 6000 +jitTargetOfCompute (Compute 3 2) = Compute32 +jitTargetOfCompute (Compute 5 0) = Compute50 +#endif +#if CUDA_VERSION >= 6050 +jitTargetOfCompute (Compute 3 7) = Compute37 +#endif +#if CUDA_VERSION >= 7000 +jitTargetOfCompute (Compute 5 2) = Compute52 +#endif +jitTargetOfCompute compute = error ("Unknown JIT Target for Compute " ++ show compute) + + +#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 = cIntConv `fmap` c_strnlen' str (cIntConv maxlen) + diff --git a/src/Foreign/CUDA/Driver/Module/Link.chs b/src/Foreign/CUDA/Driver/Module/Link.chs new file mode 100644 --- /dev/null +++ b/src/Foreign/CUDA/Driver/Module/Link.chs @@ -0,0 +1,224 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Foreign.CUDA.Driver.Module.Link +-- Copyright : [2009..2014] 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 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. +-- +-- +-- +{-# 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. +-- +-- +-- +{-# 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. +-- +-- +-- +{-# 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. +-- +-- +-- +{-# 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. +-- +-- +-- +{-# 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 + in + withArrayLen (map cFromEnum opt) $ \i p_opts -> + withArray (map unsafeCoerce val) $ \ p_vals -> + nothingIfOk =<< cuLinkAddData ls t img n "" i p_opts p_vals + +{-# INLINE cuLinkAddData #-} +{# fun unsafe cuLinkAddData + { useLinkState `LinkState' + , cFromEnum `JITInputType' + , castPtr `Ptr Word8' + , `Int' + , `String' + , `Int' + , id `Ptr CInt' + , id `Ptr (Ptr ())' + } + -> `Status' cToEnum #} +#endif + diff --git a/src/Foreign/CUDA/Driver/Module/Query.chs b/src/Foreign/CUDA/Driver/Module/Query.chs new file mode 100644 --- /dev/null +++ b/src/Foreign/CUDA/Driver/Module/Query.chs @@ -0,0 +1,108 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ForeignFunctionInterface #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Foreign.CUDA.Driver.Module.Query +-- Copyright : [2009..2014] Trevor L. McDonell +-- License : BSD +-- +-- Querying module attributes for low-level driver interface +-- +-------------------------------------------------------------------------------- + +module Foreign.CUDA.Driver.Module.Query ( + + -- ** Querying module inhabitants + getFun, getPtr, getTex, + +) 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.Driver.Texture +import Foreign.CUDA.Internal.C2HS +import Foreign.CUDA.Ptr + +-- System +import Foreign +import Foreign.C +import Control.Exception ( throwIO ) +import Control.Monad ( liftM ) + + +-------------------------------------------------------------------------------- +-- Querying module attributes +-------------------------------------------------------------------------------- + +-- | +-- 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. This texture reference handle +-- should not be destroyed, as the texture will be destroyed automatically +-- when the module is unloaded. +-- +-- +-- +{-# 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 #} + + +-------------------------------------------------------------------------------- +-- 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) + diff --git a/src/Foreign/CUDA/Driver/Profiler.chs b/src/Foreign/CUDA/Driver/Profiler.chs new file mode 100644 --- /dev/null +++ b/src/Foreign/CUDA/Driver/Profiler.chs @@ -0,0 +1,100 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Foreign.CUDA.Driver.Profiler +-- Copyright : [2009..2014] 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. +-- +-- +-- +{-# 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. +-- +-- +-- +{-# 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. +-- +-- +-- +{-# INLINEABLE stop #-} +stop :: IO () +stop = nothingIfOk =<< cuProfilerStop + +{-# INLINE cuProfilerStop #-} +{# fun unsafe cuProfilerStop + { } -> `Status' cToEnum #} + diff --git a/src/Foreign/CUDA/Driver/Stream.chs b/src/Foreign/CUDA/Driver/Stream.chs new file mode 100644 --- /dev/null +++ b/src/Foreign/CUDA/Driver/Stream.chs @@ -0,0 +1,167 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +-- | +-- 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, createWithPriority, destroy, finished, block, getPriority, + + 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 + + +-- | +-- 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. +-- +-- +-- +{-# 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]' + , cIntConv `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. +-- +-- +-- +{-# 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 #} + + +-- | +-- Query the priority of a stream. +-- +-- Requires CUDA-5.5. +-- +-- +-- +{-# 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 + diff --git a/src/Foreign/CUDA/Driver/Texture.chs b/src/Foreign/CUDA/Driver/Texture.chs new file mode 100644 --- /dev/null +++ b/src/Foreign/CUDA/Driver/Texture.chs @@ -0,0 +1,308 @@ +{-# 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(..), + bind, bind2D, + getAddressMode, getFilterMode, getFormat, + setAddressMode, setFilterMode, setFormat, setReadMode, + + -- Deprecated + create, destroy, + + -- 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 + diff --git a/src/Foreign/CUDA/Driver/Utils.chs b/src/Foreign/CUDA/Driver/Utils.chs new file mode 100644 --- /dev/null +++ b/src/Foreign/CUDA/Driver/Utils.chs @@ -0,0 +1,40 @@ +{-# 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 #} + diff --git a/src/Foreign/CUDA/Internal/C2HS.hs b/src/Foreign/CUDA/Internal/C2HS.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/CUDA/Internal/C2HS.hs @@ -0,0 +1,230 @@ +-- 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 + diff --git a/src/Foreign/CUDA/Ptr.hs b/src/Foreign/CUDA/Ptr.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/CUDA/Ptr.hs @@ -0,0 +1,184 @@ +{-# 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) + diff --git a/src/Foreign/CUDA/Runtime.hs b/src/Foreign/CUDA/Runtime.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/CUDA/Runtime.hs @@ -0,0 +1,28 @@ +-------------------------------------------------------------------------------- +-- | +-- 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 + diff --git a/src/Foreign/CUDA/Runtime/Device.chs b/src/Foreign/CUDA/Runtime/Device.chs new file mode 100644 --- /dev/null +++ b/src/Foreign/CUDA/Runtime/Device.chs @@ -0,0 +1,464 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE TemplateHaskell #-} +{-# 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, Bounded) #} + + +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 +#if CUDART_VERSION >= 5050 + sp <- cToBool `fmap` {#get cudaDeviceProp.streamPrioritiesSupported#} p +#endif +#if CUDART_VERSION >= 6000 + gl1 <- cToBool `fmap` {#get cudaDeviceProp.globalL1CacheSupported#} p + ll1 <- cToBool `fmap` {#get cudaDeviceProp.localL1CacheSupported#} p + mm <- cToBool `fmap` {#get cudaDeviceProp.managedMemory#} p + mg <- cToBool `fmap` {#get cudaDeviceProp.isMultiGpuBoard#} p + mid <- cIntConv `fmap` {#get cudaDeviceProp.multiGpuBoardGroupID#} 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 + , kernelExecTimeoutEnabled = ke + , integrated = tg + , canMapHostMemory = hm +#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 CUDA runtime API 3.0 + , 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 +#if CUDA_VERSION >= 5050 + , streamPriorities = sp +#endif +#if CUDA_VERSION >= 6000 + , globalL1Cache = gl1 + , localL1Cache = ll1 + , managedMemory = mm + , multiGPUBoard = mg + , multiGPUBoardGroupID = mid +#endif + } + + +-------------------------------------------------------------------------------- +-- 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 'accessible 4.0 +#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 'add 4.0 +#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 'remove 4.0 +#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 'getLimit 3.1 +#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 'setLimit 3.1 +#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 + diff --git a/src/Foreign/CUDA/Runtime/Error.chs b/src/Foreign/CUDA/Runtime/Error.chs new file mode 100644 --- /dev/null +++ b/src/Foreign/CUDA/Runtime/Error.chs @@ -0,0 +1,119 @@ +{-# 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 +import Text.Show.Describe + +-- System +import Control.Exception +import Data.Typeable +import Foreign.C +import Foreign.Ptr +import Language.Haskell.TH +import System.IO.Unsafe +import Text.Printf + +#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 :: Name -> Double -> IO a +requireSDK n v = cudaError $ printf "'%s' requires at least cuda-%3.1f\n" (show n) v + + +-------------------------------------------------------------------------------- +-- Helper Functions +-------------------------------------------------------------------------------- + +-- | +-- Return the descriptive string associated with a particular error code +-- +instance Describe Status where + describe = cudaGetErrorString + +-- Logically, this must be a pure function, returning a pointer to a statically +-- defined string constant. +-- +{# fun pure unsafe cudaGetErrorString + { cFromEnum `Status' } -> `String' #} + + +-- | +-- 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) + diff --git a/src/Foreign/CUDA/Runtime/Event.chs b/src/Foreign/CUDA/Runtime/Event.chs new file mode 100644 --- /dev/null +++ b/src/Foreign/CUDA/Runtime/Event.chs @@ -0,0 +1,148 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +-- | +-- 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 'wait 3.2 +#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 #} + diff --git a/src/Foreign/CUDA/Runtime/Exec.chs b/src/Foreign/CUDA/Runtime/Exec.chs new file mode 100644 --- /dev/null +++ b/src/Foreign/CUDA/Runtime/Exec.chs @@ -0,0 +1,276 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +-- | +-- 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 'setCacheConfig 3.0 +#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* +-- +#if CUDART_VERSION >= 5000 +withFun :: Fun -> (Ptr a -> IO b) -> IO b +withFun fn action = action (castFunPtrToPtr fn) +#else +withFun :: Fun -> (Ptr CChar -> IO a) -> IO a +withFun = withCString +#endif + diff --git a/src/Foreign/CUDA/Runtime/Marshal.chs b/src/Foreign/CUDA/Runtime/Marshal.chs new file mode 100644 --- /dev/null +++ b/src/Foreign/CUDA/Runtime/Marshal.chs @@ -0,0 +1,648 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +-- | +-- 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, 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. 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, Bounded) #} +#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 'mallocManagedArray 6.0 +#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 + diff --git a/src/Foreign/CUDA/Runtime/Stream.chs b/src/Foreign/CUDA/Runtime/Stream.chs new file mode 100644 --- /dev/null +++ b/src/Foreign/CUDA/Runtime/Stream.chs @@ -0,0 +1,115 @@ +{-# 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 + diff --git a/src/Foreign/CUDA/Runtime/Texture.chs b/src/Foreign/CUDA/Runtime/Texture.chs new file mode 100644 --- /dev/null +++ b/src/Foreign/CUDA/Runtime/Texture.chs @@ -0,0 +1,203 @@ +{-# 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) + diff --git a/src/Foreign/CUDA/Runtime/Utils.chs b/src/Foreign/CUDA/Runtime/Utils.chs new file mode 100644 --- /dev/null +++ b/src/Foreign/CUDA/Runtime/Utils.chs @@ -0,0 +1,53 @@ +{-# 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 #} + diff --git a/src/Foreign/CUDA/Types.chs b/src/Foreign/CUDA/Types.chs new file mode 100644 --- /dev/null +++ b/src/Foreign/CUDA/Types.chs @@ -0,0 +1,155 @@ +{-# 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(..), StreamPriority, 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, Bounded) #} + +-- | +-- 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) + + +-- | +-- 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 + +-- | +-- 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 + diff --git a/src/Text/Show/Describe.hs b/src/Text/Show/Describe.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Describe.hs @@ -0,0 +1,18 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Text.Show.Describe +-- Copyright : [2016] Trevor L. McDonell +-- License : BSD +-- +-------------------------------------------------------------------------------- + +module Text.Show.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 +