diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -4,6 +4,24 @@ The format is based on [Keep a Changelog](http://keepachangelog.com/). +## [0.10.0.0] - 2018-10-02 +### Added + * Device properties for SM7 + * Functions from CUDA-9.2 + * `Device.uuid` + * `Stream.getContext` + + * Functions from CUDA-10.0 + * `Foreign.CUDA.Driver.Graph*` + + * Additional bindings from older CUDA releases + +### Changed + * Replace uses of `String` with `ShortByteString` + +### Removed + * Support for ghc-7.6 + ## [0.9.0.3] - 2018-03-12 ### Fixed * Build fix for Cabal-2.2 (ghc-8.4) @@ -115,6 +133,7 @@ * Add functions from CUDA-6.5 +[0.10.0.0]: https://github.com/tmcdonell/cuda/compare/0.9.0.3...v0.10.0.0 [0.9.0.3]: https://github.com/tmcdonell/cuda/compare/0.9.0.2...0.9.0.3 [0.9.0.2]: https://github.com/tmcdonell/cuda/compare/0.9.0.1...0.9.0.2 [0.9.0.1]: https://github.com/tmcdonell/cuda/compare/0.9.0.0...0.9.0.1 diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -259,7 +259,7 @@ -> [FilePath] -> IO [FilePath] cudaGhciLibrariesWindows platform installPath libraries = do - candidates <- mapM importLibraryToDLLFileName [ cudaLibraryPath platform installPath lib <.> "lib" | lib <- libraries ] + candidates <- mapM (importLibraryToDLLFileName platform) [ cudaLibraryPath platform installPath lib <.> "lib" | lib <- libraries ] return [ dropExtension dll | Just dll <- candidates ] @@ -283,8 +283,8 @@ -- The function is meant to be used on Windows. Other platforms may or may -- not work. -- -importLibraryToDLLFileName :: FilePath -> IO (Maybe FilePath) -importLibraryToDLLFileName importLibPath = do +importLibraryToDLLFileName :: Platform -> FilePath -> IO (Maybe FilePath) +importLibraryToDLLFileName platform importLibPath = do -- Sample output nm generates on cudart.lib -- -- nvcuda.dll: @@ -298,7 +298,11 @@ -- U nvcuda_NULL_THUNK_DATA -- nmOutput <- getProgramInvocationOutput normal (simpleProgramInvocation "nm" [importLibPath]) - return $ find (isInfixOf ("" <.> dllExtension)) (lines nmOutput) +#if MIN_VERSION_Cabal(2,3,0) + return $ find (isInfixOf ("" <.> dllExtension platform)) (lines nmOutput) +#else + return $ find (isInfixOf ("" <.> dllExtension)) (lines nmOutput) +#endif -- Slightly modified version of `words` from base - it takes predicate saying on diff --git a/cbits/stubs.c b/cbits/stubs.c --- a/cbits/stubs.c +++ b/cbits/stubs.c @@ -393,3 +393,79 @@ } #endif +#if CUDA_VERSION >= 10000 +CUresult CUDAAPI cuGraphAddHostNode_simple(CUgraphNode *phGraphNode, CUgraph hGraph, CUgraphNode *dependencies, size_t numDependencies, CUhostFn fn, void* userData) +{ + CUDA_HOST_NODE_PARAMS nodeParams; + nodeParams.fn = fn; + nodeParams.userData = userData; + + return cuGraphAddHostNode(phGraphNode, hGraph, dependencies, numDependencies, &nodeParams); +} + +CUresult CUDAAPI cuGraphAddKernelNode_simple(CUgraphNode *phGraphNode, CUgraph hGraph, CUgraphNode *dependencies, size_t numDependencies, CUfunction func, unsigned int gridDimX, unsigned int gridDimY, unsigned int gridDimZ, unsigned int blockDimX, unsigned int blockDimY, unsigned int blockDimZ, unsigned int sharedMemBytes, void** kernelParams) +{ + CUDA_KERNEL_NODE_PARAMS nodeParams; + nodeParams.func = func; + nodeParams.gridDimX = gridDimX; + nodeParams.gridDimY = gridDimY; + nodeParams.gridDimZ = gridDimZ; + nodeParams.blockDimX = blockDimX; + nodeParams.blockDimY = blockDimY; + nodeParams.blockDimZ = blockDimZ; + nodeParams.sharedMemBytes = sharedMemBytes; + nodeParams.kernelParams = kernelParams; + nodeParams.extra = NULL; + + return cuGraphAddKernelNode(phGraphNode, hGraph, dependencies, numDependencies, &nodeParams); +} + +CUresult CUDAAPI cuGraphAddMemcpyNode_simple(CUgraphNode *phGraphNode, CUgraph hGraph, CUgraphNode *dependencies, size_t numDependencies, CUcontext ctx, size_t srcXInBytes, size_t srcY, size_t srcZ, size_t srcLOD, CUmemorytype srcMemoryType, const void *srcPtr, size_t srcPitch, size_t srcHeight, size_t dstXInBytes, size_t dstY, size_t dstZ, size_t dstLOD, CUmemorytype dstMemoryType, void *dstPtr, size_t dstPitch, size_t dstHeight, size_t widthInBytes, size_t height, size_t depth) +{ + CUDA_MEMCPY3D copyParams; + + copyParams.srcXInBytes = srcXInBytes; + copyParams.srcY = srcY; + copyParams.srcZ = srcZ; + copyParams.srcLOD = srcLOD; + copyParams.srcMemoryType = srcMemoryType; + copyParams.srcHost = (void*) srcPtr; + copyParams.srcDevice = (CUdeviceptr) srcPtr; + copyParams.srcArray = (CUarray) srcPtr; + copyParams.reserved0 = NULL; + copyParams.srcPitch = srcPitch; + copyParams.srcHeight = srcHeight; + + copyParams.dstXInBytes = dstXInBytes; + copyParams.dstY = dstY; + copyParams.dstZ = dstZ; + copyParams.dstLOD = dstLOD; + copyParams.dstMemoryType = dstMemoryType; + copyParams.dstHost = (void*) dstPtr; + copyParams.dstDevice = (CUdeviceptr) dstPtr; + copyParams.dstArray = (CUarray) dstPtr; + copyParams.reserved1 = NULL; + copyParams.dstPitch = dstPitch; + copyParams.dstHeight = dstHeight; + + copyParams.WidthInBytes = widthInBytes; + copyParams.Height = height; + copyParams.Depth = depth; + + return cuGraphAddMemcpyNode(phGraphNode, hGraph, dependencies, numDependencies, ©Params, ctx); +} + +CUresult CUDAAPI cuGraphAddMemsetNode_simple(CUgraphNode *phGraphNode, CUgraph hGraph, CUgraphNode *dependencies, size_t numDependencies, CUcontext ctx, CUdeviceptr dst, unsigned int elementSize, size_t height, size_t pitch, unsigned int value, size_t width) +{ + CUDA_MEMSET_NODE_PARAMS memsetParams; + memsetParams.dst = dst; + memsetParams.elementSize = elementSize; + memsetParams.height = height; + memsetParams.pitch = pitch; + memsetParams.value = value; + memsetParams.width = width; + + return cuGraphAddMemsetNode(phGraphNode, hGraph, dependencies, numDependencies, &memsetParams, ctx); +} +#endif + diff --git a/cbits/stubs.h b/cbits/stubs.h --- a/cbits/stubs.h +++ b/cbits/stubs.h @@ -218,6 +218,13 @@ CUresult CUDAAPI cuLinkAddFile(CUlinkState state, CUjitInputType type, const char *path, unsigned int numOptions, CUjit_option *options, void **optionValues); #endif +#if CUDA_VERSION >= 10000 +CUresult CUDAAPI cuGraphAddHostNode_simple(CUgraphNode *phGraphNode, CUgraph hGraph, CUgraphNode *dependencies, size_t numDependencies, CUhostFn fn, void* userData); +CUresult CUDAAPI cuGraphAddKernelNode_simple(CUgraphNode *phGraphNode, CUgraph hGraph, CUgraphNode *dependencies, size_t numDependencies, CUfunction func, unsigned int gridDimX, unsigned int gridDimY, unsigned int gridDimZ, unsigned int blockDimX, unsigned int blockDimY, unsigned int blockDimZ, unsigned int sharedMemBytes, void** kernelParams); +CUresult CUDAAPI cuGraphAddMemcpyNode_simple(CUgraphNode *phGraphNode, CUgraph hGraph, CUgraphNode *dependencies, size_t numDependencies, CUcontext ctx, size_t srcXInBytes, size_t srcY, size_t srcZ, size_t srcLOD, CUmemorytype srcMemoryType, const void *srcPtr, size_t srcPitch, size_t srcHeight, size_t dstXInBytes, size_t dstY, size_t dstZ, size_t dstLOD, CUmemorytype dstMemoryType, void *dstPtr, size_t dstPitch, size_t dstHeight, size_t widthInBytes, size_t height, size_t depth); +CUresult CUDAAPI cuGraphAddMemsetNode_simple(CUgraphNode *phGraphNode, CUgraph hGraph, CUgraphNode *dependencies, size_t numDependencies, CUcontext ctx, CUdeviceptr dst, unsigned int elementSize, size_t height, size_t pitch, unsigned int value, size_t width); +#endif + #ifdef __cplusplus } #endif diff --git a/cuda.cabal b/cuda.cabal --- a/cuda.cabal +++ b/cuda.cabal @@ -1,5 +1,5 @@ Name: cuda -Version: 0.9.0.3 +Version: 0.10.0.0 Synopsis: FFI binding to the CUDA interface for programming NVIDIA GPUs Description: The CUDA library provides a direct, general purpose C-like SPMD programming @@ -28,8 +28,9 @@ . * "Foreign.CUDA.Runtime" . - See the build matrix - for tested CUDA library versions. + Tested with library versions up to CUDA-9.2. See also the + build matrix for + version compatibility. . [/NOTES:/] . @@ -57,14 +58,14 @@ License: BSD3 License-file: LICENSE -Copyright: Copyright (c) [2009..2017]. Trevor L. McDonell -Author: Trevor L. McDonell -Maintainer: Trevor L. McDonell +Copyright: Copyright (c) [2009..2018]. Trevor L. McDonell +Author: Trevor L. McDonell +Maintainer: Trevor L. McDonell Homepage: https://github.com/tmcdonell/cuda Bug-reports: https://github.com/tmcdonell/cuda/issues Category: Foreign Cabal-version: >= 1.24 -Tested-with: GHC >= 7.6 +Tested-with: GHC >= 7.8 Build-type: Custom @@ -77,7 +78,7 @@ custom-setup setup-depends: - base >= 4.6 + base >= 4.7 , Cabal >= 1.24 , directory >= 1.0 , filepath >= 1.0 @@ -88,7 +89,6 @@ Foreign.CUDA Foreign.CUDA.Path Foreign.CUDA.Ptr - Foreign.CUDA.Types -- Kernel and device analysis Foreign.CUDA.Analysis @@ -106,6 +106,10 @@ Foreign.CUDA.Driver.Error Foreign.CUDA.Driver.Event Foreign.CUDA.Driver.Exec + Foreign.CUDA.Driver.Graph.Base + Foreign.CUDA.Driver.Graph.Build + Foreign.CUDA.Driver.Graph.Capture + Foreign.CUDA.Driver.Graph.Exec Foreign.CUDA.Driver.IPC.Event Foreign.CUDA.Driver.IPC.Marshal Foreign.CUDA.Driver.Marshal @@ -130,6 +134,9 @@ Foreign.CUDA.Runtime.Texture Foreign.CUDA.Runtime.Utils + -- Extras + Foreign.C.Extra + Other-modules: Foreign.CUDA.Internal.C2HS Text.Show.Describe @@ -140,10 +147,11 @@ Build-tools: c2hs >= 0.21 Build-depends: - base >= 4 && < 5 - , bytestring + base >= 4.7 && < 5 + , bytestring >= 0.10.4 , filepath >= 1.0 , template-haskell + , uuid-types >= 1.0 default-language: Haskell98 Extensions: @@ -181,6 +189,6 @@ source-repository this type: git location: https://github.com/tmcdonell/cuda - tag: 0.9.0.3 + tag: v0.10.0.0 -- 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 @@ -1,13 +1,16 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} module Main where -import Numeric import Control.Monad -import Text.Printf -import Text.PrettyPrint +import Numeric import Prelude hiding ( (<>) ) +import Text.PrettyPrint +import Text.Printf +import Foreign.CUDA.Driver.Device ( Device(..) ) import Foreign.CUDA.Analysis as CUDA import qualified Foreign.CUDA.Driver as CUDA @@ -26,64 +29,108 @@ then printf "There are no available devices that support CUDA\n" else printf "Detected %d CUDA capable device%s\n" numDevices (if numDevices > 1 then "s" else "") - forM_ [0 .. numDevices-1] $ \n -> do - deviceProp <- CUDA.props =<< CUDA.device n - printf "\nDevice %d: %s\n" n (deviceName deviceProp) - statDevice deviceProp + infos <- forM [0 .. numDevices-1] $ \n -> do + dev <- CUDA.device n + prp <- CUDA.props dev + return (n, dev, prp) + forM_ infos $ \(n, dev, prp) -> do + p2p <- statP2P dev prp infos + printf "\nDevice %d: %s\n%s\n" n (deviceName prp) (statDevice prp) + unless (null p2p) $ printf "%s\n" p2p -statDevice :: DeviceProperties -> IO () + +statDevice :: DeviceProperties -> String statDevice dev@DeviceProperties{..} = let DeviceResources{..} = deviceResources dev - pad v = take width $ v ++ repeat ' ' - width = maximum $ map (length . fst) props - table = nest 2 $ vcat $ map (\(k,v) -> text (pad k) <+> v) props - - grid (x,y) = int x <+> char 'x' <+> int y - cube (x,y,z) = int x <+> char 'x' <+> int y <+> char 'x' <+> int z - - bool True = text "Yes" - bool False = text "No" + grid (x,y) = int x <+> char 'x' <+> int y + cube (x,y,z) = int x <+> char 'x' <+> int y <+> char 'x' <+> int z props = - [("CUDA capability:", text $ show computeCapability) - ,("CUDA cores:", text $ printf "%d cores in %d multiprocessors (%d cores/MP)" (coresPerMP * multiProcessorCount) multiProcessorCount coresPerMP) - ,("Global memory:", text $ showBytes totalGlobalMem) - ,("Constant memory:", text $ showBytes totalConstMem) - ,("Shared memory per block:", text $ showBytes sharedMemPerBlock) - ,("Registers per block:", int regsPerBlock) - ,("Warp size:", int warpSize) - ,("Maximum threads per multiprocessor:", int maxThreadsPerMultiProcessor) - ,("Maximum threads per block:", int maxThreadsPerBlock) - ,("Maximum grid dimensions:", cube maxGridSize) - ,("Maximum block dimensions:", cube maxBlockSize) - ,("GPU clock rate:", text . showFreq $ clockRate * 1000) - ,("Memory clock rate:", text . showFreq $ memClockRate * 1000) - ,("Memory bus width:", int memBusWidth <> text "-bit") - ,("L2 cache size:", text $ showBytes cacheMemL2) - ,("Maximum texture dimensions", empty) - ,(" 1D:", int maxTextureDim1D) - ,(" 2D:", grid maxTextureDim2D) - ,(" 3D:", cube maxTextureDim3D) - ,("Texture alignment:", text $ showBytes textureAlignment) - ,("Maximum memory pitch:", text $ showBytes memPitch) - ,("Concurrent kernel execution:", bool concurrentKernels) - ,("Concurrent copy and execution:", bool deviceOverlap <> text (printf ", with %d copy engine%s" asyncEngineCount (if asyncEngineCount > 1 then "s" else ""))) - ,("Runtime limit on kernel execution:", bool kernelExecTimeoutEnabled) - ,("Integrated GPU sharing host memory:", bool integrated) - ,("Host page-locked memory mapping:", bool canMapHostMemory) - ,("ECC memory support:", bool eccEnabled) - ,("Unified addressing (UVA):", bool unifiedAddressing) - ,("PCI bus/location:", int (busID pciInfo) <> char '/' <> int (deviceID pciInfo)) - ,("Compute mode:", text (show computeMode)) + [("CUDA capability:", text $ show computeCapability) + ,("CUDA cores:", text $ printf "%d cores in %d multiprocessors (%d cores/MP)" (coresPerMP * multiProcessorCount) multiProcessorCount coresPerMP) + ,("Global memory:", text $ showBytes totalGlobalMem) + ,("Constant memory:", text $ showBytes totalConstMem) + ,("Shared memory per block:", text $ showBytes sharedMemPerBlock) + ,("Registers per block:", int regsPerBlock) + ,("Warp size:", int warpSize) + ,("Maximum threads per multiprocessor:", int maxThreadsPerMultiProcessor) + ,("Maximum threads per block:", int maxThreadsPerBlock) + ,("Maximum grid dimensions:", cube maxGridSize) + ,("Maximum block dimensions:", cube maxBlockSize) + ,("GPU clock rate:", text . showFreq $ clockRate * 1000) + ,("Memory clock rate:", text . showFreq $ memClockRate * 1000) + ,("Memory bus width:", int memBusWidth <> text "-bit") + ,("L2 cache size:", text $ showBytes cacheMemL2) + ,("Maximum texture dimensions", empty) + ,(" 1D:", int maxTextureDim1D) + ,(" 2D:", grid maxTextureDim2D) + ,(" 3D:", cube maxTextureDim3D) + ,("Texture alignment:", text $ showBytes textureAlignment) + ,("Maximum memory pitch:", text $ showBytes memPitch) + ,("Concurrent kernel execution:", bool concurrentKernels) + ,("Concurrent copy and execution:", bool deviceOverlap <> text (printf ", with %d copy engine%s" asyncEngineCount (if asyncEngineCount > 1 then "s" else ""))) + ,("Runtime limit on kernel execution:", bool kernelExecTimeoutEnabled) + ,("Integrated GPU sharing host memory:", bool integrated) + ,("Host page-locked memory mapping:", bool canMapHostMemory) + ,("ECC memory support:", bool eccEnabled) + ,("Unified addressing (UVA):", bool unifiedAddressing)]++ +#if __GLASGOW_HASKELL__ > 710 + $(if CUDA.libraryVersion >= 8000 then [| + [("Single to double precision performance:", text $ printf "%d : 1" singleToDoublePerfRatio) + ,("Supports compute pre-emption:", bool preemption)]|] else [|[]|])++ + $(if CUDA.libraryVersion >= 9000 then [| + [("Supports cooperative launch:", bool cooperativeLaunch) + ,("Supports multi-device cooperative launch:", bool cooperativeLaunchMultiDevice)]|] else [|[]|])++ +#endif + [("PCI bus/location:", int (busID pciInfo) <> char '/' <> int (deviceID pciInfo)) + ,("Compute mode:", text (show computeMode)) ] in - putStrLn . render - $ hang table 4 + render + $ hang (table props) 4 $ text (describe computeMode) + +statP2P :: Device -> DeviceProperties -> [(Int, Device, DeviceProperties)] -> IO String +statP2P dev prp infos + | CUDA.libraryVersion < 4000 = return [] + + -- Only Fermi and later can support P2P + | computeCapability prp < Compute 2 0 = return [] + | otherwise + = let + go [] = return [] + go ((m, peer, pp):is) = + if dev == peer + then go is + else do + access <- CUDA.accessible dev peer + rest <- go is + return $ (printf " Device %d (%s):" m (deviceName pp), bool access) : rest + in do + access <- go infos + return + $ if null access + then [] + else render + $ table (("Peer-to-Peer access to:", empty) : access) + + +table :: [(String, Doc)] -> Doc +table kvs + = nest 2 + $ vcat + $ map (\(k,v) -> text (pad k) <+> v) kvs + where + pad v = take width $ v ++ repeat ' ' + width = maximum $ map (length . fst) kvs + +bool :: Bool -> Doc +bool True = text "Yes" +bool False = text "No" showFreq :: Integral i => i -> String showFreq x = showFFloatSIBase Nothing 1000 (fromIntegral x :: Double) "Hz" diff --git a/src/Foreign/C/Extra.hs b/src/Foreign/C/Extra.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/C/Extra.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ForeignFunctionInterface #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Foreign.C.Extra +-- Copyright : [2018] Trevor L. McDonell +-- License : BSD +-- +-------------------------------------------------------------------------------- + +module Foreign.C.Extra ( + + c_strnlen, + +) where + +import Foreign.C + + +#if defined(WIN32) +{-# INLINE c_strnlen' #-} +c_strnlen' :: CString -> CSize -> IO CSize +c_strnlen' str size = do + str' <- peekCStringLen (str, fromIntegral size) + return $ stringLen 0 str' + where + stringLen acc [] = acc + stringLen acc ('\0':_) = acc + stringLen acc (_:xs) = stringLen (acc+1) xs +#else +foreign import ccall unsafe "string.h strnlen" c_strnlen' + :: CString -> CSize -> IO CSize +#endif + +{-# INLINE c_strnlen #-} +c_strnlen :: CString -> Int -> IO Int +c_strnlen str maxlen = fromIntegral `fmap` c_strnlen' str (fromIntegral maxlen) + diff --git a/src/Foreign/CUDA/Analysis.hs b/src/Foreign/CUDA/Analysis.hs --- a/src/Foreign/CUDA/Analysis.hs +++ b/src/Foreign/CUDA/Analysis.hs @@ -1,7 +1,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Analysis --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2018] Trevor L. McDonell -- License : BSD -- -- Meta-module exporting CUDA analysis routines diff --git a/src/Foreign/CUDA/Analysis/Device.chs b/src/Foreign/CUDA/Analysis/Device.chs --- a/src/Foreign/CUDA/Analysis/Device.chs +++ b/src/Foreign/CUDA/Analysis/Device.chs @@ -1,7 +1,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Analysis.Device --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2018] Trevor L. McDonell -- License : BSD -- -- Common device functions @@ -69,69 +69,77 @@ -- 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 + 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 + , 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 + , 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) + , 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 + , 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 + , 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 + , 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 + , 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 + , 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 + , 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 + , unifiedAddressing :: !Bool -- ^ Device shares a unified address space with the host #endif #if CUDA_VERSION >= 5050 - , streamPriorities :: !Bool -- ^ Device supports stream priorities + , 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 + , globalL1Cache :: !Bool -- ^ Device supports caching globals in L1 cache + , localL1Cache :: !Bool -- ^ Device supports caching locals in L1 cache + , managedMemory :: !Bool -- ^ Device supports allocating managed memory on this system + , multiGPUBoard :: !Bool -- ^ Device is on a multi-GPU board + , multiGPUBoardGroupID :: !Int -- ^ Unique identifier for a group of devices associated with the same board #endif +#if CUDA_VERSION >= 8000 + , preemption :: !Bool -- ^ Device supports compute pre-emption + , singleToDoublePerfRatio :: !Int -- ^ Ratio of single precision performance (in floating-point operations per second) to double precision performance +#endif +#if CUDA_VERSION >= 9000 + , cooperativeLaunch :: !Bool -- ^ Device supports launching cooperative kernels + , cooperativeLaunchMultiDevice :: !Bool -- ^ Device can participate in cooperative multi-device kernels +#endif } deriving (Show) data PCI = PCI { - busID :: !Int, -- ^ PCI bus ID of the device - deviceID :: !Int, -- ^ PCI device ID - domainID :: !Int -- ^ PCI domain ID + busID :: !Int, -- ^ PCI bus ID of the device + deviceID :: !Int, -- ^ PCI device ID + domainID :: !Int -- ^ PCI domain ID } deriving (Show) @@ -158,6 +166,7 @@ , sharedMemAllocUnit :: !Int -- ^ Shared memory allocation unit size (bytes) , warpAllocUnit :: !Int -- ^ Warp allocation granularity , warpRegAllocUnit :: !Int -- ^ Warp register allocation granularity + , maxGridsPerDevice :: !Int -- ^ Maximum number of resident grids per device (concurrent kernels) } @@ -187,6 +196,7 @@ , sharedMemAllocUnit = 512 , warpAllocUnit = 2 , warpRegAllocUnit = 256 + , maxGridsPerDevice = 1 } Compute 1 2 -> resources (Compute 1 3) -- Tesla G9x Compute 1 3 -> (resources (Compute 1 1)) -- Tesla GT200 @@ -213,12 +223,13 @@ , sharedMemAllocUnit = 128 , warpAllocUnit = 2 , warpRegAllocUnit = 64 + , maxGridsPerDevice = 16 } Compute 2 1 -> (resources (Compute 2 0)) -- Fermi GF10x { coresPerMP = 48 } - Compute 3 0 -> DeviceResources + Compute 3 0 -> DeviceResources -- Kepler GK10x { threadsPerWarp = 32 , coresPerMP = 192 , warpsPerMP = 64 @@ -234,10 +245,15 @@ , sharedMemAllocUnit = 256 , warpAllocUnit = 4 , warpRegAllocUnit = 256 + , maxGridsPerDevice = 16 } Compute 3 2 -> (resources (Compute 3 5)) -- Jetson TK1 + { maxRegPerBlock = 32768 + , maxGridsPerDevice = 4 + } Compute 3 5 -> (resources (Compute 3 0)) -- Kepler GK11x { maxRegPerThread = 255 + , maxGridsPerDevice = 32 } Compute 3 7 -> (resources (Compute 3 5)) -- Kepler GK21x { sharedMemPerMP = 114688 @@ -260,6 +276,7 @@ , sharedMemAllocUnit = 256 , warpAllocUnit = 4 , warpRegAllocUnit = 256 + , maxGridsPerDevice = 32 } Compute 5 2 -> (resources (Compute 5 0)) -- Maxwell GM20x { sharedMemPerMP = 98304 @@ -269,6 +286,7 @@ Compute 5 3 -> (resources (Compute 5 0)) -- Maxwell GM20B { maxRegPerBlock = 32768 , warpAllocUnit = 2 + , maxGridsPerDevice = 16 } Compute 6 0 -> DeviceResources -- Pascal GP100 @@ -287,17 +305,40 @@ , sharedMemAllocUnit = 256 , warpAllocUnit = 2 , warpRegAllocUnit = 256 + , maxGridsPerDevice = 128 } Compute 6 1 -> (resources (Compute 6 0)) -- Pascal GP10x { coresPerMP = 128 , sharedMemPerMP = 98304 , warpAllocUnit = 4 + , maxGridsPerDevice = 32 } - Compute 6 2 -> (resources (Compute 6 0)) -- Pascal ?? + Compute 6 2 -> (resources (Compute 6 0)) -- Pascal GP10B { coresPerMP = 128 , warpsPerMP = 128 , threadBlocksPerMP = 4096 + , maxRegPerBlock = 32768 , warpAllocUnit = 4 + , maxGridsPerDevice = 16 + } + + Compute 7 _ -> DeviceResources -- Volta GV100 + { threadsPerWarp = 32 + , coresPerMP = 64 + , warpsPerMP = 64 + , threadsPerMP = 2048 + , threadBlocksPerMP = 32 + , sharedMemPerMP = 98304 + , maxSharedMemPerBlock = 49152 -- XXX: or 96KB? + , regFileSizePerMP = 65536 + , maxRegPerBlock = 65536 + , regAllocUnit = 256 + , regAllocationStyle = Warp + , maxRegPerThread = 255 + , sharedMemAllocUnit = 256 + , warpAllocUnit = 2 + , warpRegAllocUnit = 256 + , maxGridsPerDevice = 128 } -- Something might have gone wrong, or the library just needs to be diff --git a/src/Foreign/CUDA/Analysis/Occupancy.hs b/src/Foreign/CUDA/Analysis/Occupancy.hs --- a/src/Foreign/CUDA/Analysis/Occupancy.hs +++ b/src/Foreign/CUDA/Analysis/Occupancy.hs @@ -2,7 +2,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Analysis.Occupancy --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2018] Trevor L. McDonell -- License : BSD -- -- Occupancy calculations for CUDA kernels diff --git a/src/Foreign/CUDA/Driver.hs b/src/Foreign/CUDA/Driver.hs --- a/src/Foreign/CUDA/Driver.hs +++ b/src/Foreign/CUDA/Driver.hs @@ -1,7 +1,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Driver --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2018] Trevor L. McDonell -- License : BSD -- -- This module defines an interface to the CUDA driver API. The Driver API @@ -232,7 +232,7 @@ 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.Exec hiding ( useFun ) import Foreign.CUDA.Driver.Marshal hiding ( useDeviceHandle, peekDeviceHandle ) import Foreign.CUDA.Driver.Module import Foreign.CUDA.Driver.Unified diff --git a/src/Foreign/CUDA/Driver/Context.hs b/src/Foreign/CUDA/Driver/Context.hs --- a/src/Foreign/CUDA/Driver/Context.hs +++ b/src/Foreign/CUDA/Driver/Context.hs @@ -1,7 +1,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Driver.Context --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2018] Trevor L. McDonell -- License : BSD -- -- Context management for low-level driver interface diff --git a/src/Foreign/CUDA/Driver/Context/Base.chs b/src/Foreign/CUDA/Driver/Context/Base.chs --- a/src/Foreign/CUDA/Driver/Context/Base.chs +++ b/src/Foreign/CUDA/Driver/Context/Base.chs @@ -9,7 +9,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Driver.Context.Base --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2018] Trevor L. McDonell -- License : BSD -- -- Context management for the low-level driver interface diff --git a/src/Foreign/CUDA/Driver/Context/Config.chs b/src/Foreign/CUDA/Driver/Context/Config.chs --- a/src/Foreign/CUDA/Driver/Context/Config.chs +++ b/src/Foreign/CUDA/Driver/Context/Config.chs @@ -9,7 +9,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Driver.Context.Config --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2018] Trevor L. McDonell -- License : BSD -- -- Context configuration for the low-level driver interface @@ -46,7 +46,7 @@ import Foreign.CUDA.Driver.Context.Base import Foreign.CUDA.Driver.Error import Foreign.CUDA.Internal.C2HS -import Foreign.CUDA.Types +import Foreign.CUDA.Driver.Stream ( Stream, StreamPriority ) -- System import Control.Monad @@ -158,7 +158,7 @@ {-# INLINE cuCtxSetLimit #-} {# fun unsafe cuCtxSetLimit { cFromEnum `Limit' - , cIntConv `Int' } -> `Status' cToEnum #} + , `Int' } -> `Status' cToEnum #} #endif diff --git a/src/Foreign/CUDA/Driver/Context/Peer.chs b/src/Foreign/CUDA/Driver/Context/Peer.chs --- a/src/Foreign/CUDA/Driver/Context/Peer.chs +++ b/src/Foreign/CUDA/Driver/Context/Peer.chs @@ -9,7 +9,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Driver.Context.Peer --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2018] Trevor L. McDonell -- License : BSD -- -- Direct peer context access functions for the low-level driver interface. @@ -50,7 +50,7 @@ data PeerFlag instance Enum PeerFlag where #ifdef USE_EMPTY_CASE - toEnum x = case x of {} + toEnum x = error ("PeerFlag.toEnum: Cannot match " ++ show x) fromEnum x = case x of {} #endif @@ -61,7 +61,7 @@ data PeerAttribute instance Enum PeerAttribute where #ifdef USE_EMPTY_CASE - toEnum x = case x of {} + toEnum x = error ("PeerAttribute.toEnum: Cannot match " ++ show x) fromEnum x = case x of {} #endif #else diff --git a/src/Foreign/CUDA/Driver/Context/Primary.chs b/src/Foreign/CUDA/Driver/Context/Primary.chs --- a/src/Foreign/CUDA/Driver/Context/Primary.chs +++ b/src/Foreign/CUDA/Driver/Context/Primary.chs @@ -5,7 +5,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Driver.Context.Primary --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2018] Trevor L. McDonell -- License : BSD -- -- Primary context management for low-level driver interface. The primary diff --git a/src/Foreign/CUDA/Driver/Device.chs b/src/Foreign/CUDA/Driver/Device.chs --- a/src/Foreign/CUDA/Driver/Device.chs +++ b/src/Foreign/CUDA/Driver/Device.chs @@ -2,13 +2,15 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} #ifdef USE_EMPTY_CASE {-# LANGUAGE EmptyCase #-} #endif -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Driver.Device --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2018] Trevor L. McDonell -- License : BSD -- -- Device management for low-level driver interface @@ -20,7 +22,7 @@ -- * Device Management Device(..), DeviceProperties(..), DeviceAttribute(..), Compute(..), ComputeMode(..), InitFlag, - initialise, capability, device, attribute, count, name, props, totalMem + initialise, capability, device, attribute, count, name, props, uuid, totalMem, ) where @@ -33,10 +35,12 @@ import Foreign.CUDA.Internal.C2HS -- System +import Control.Applicative +import Control.Monad ( liftM ) +import Data.Bits +import Data.UUID.Types import Foreign import Foreign.C -import Control.Monad ( liftM ) -import Control.Applicative import Prelude @@ -89,17 +93,17 @@ 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 + tb <- fromIntegral `fmap` {#get CUdevprop.maxThreadsPerBlock#} p + sm <- fromIntegral `fmap` {#get CUdevprop.sharedMemPerBlock#} p + cm <- fromIntegral `fmap` {#get CUdevprop.totalConstantMemory#} p + ws <- fromIntegral `fmap` {#get CUdevprop.SIMDWidth#} p + mp <- fromIntegral `fmap` {#get CUdevprop.memPitch#} p + rb <- fromIntegral `fmap` {#get CUdevprop.regsPerBlock#} p + cl <- fromIntegral `fmap` {#get CUdevprop.clockRate#} p + ta <- fromIntegral `fmap` {#get CUdevprop.textureAlign#} p - [t1,t2,t3] <- peekArrayWith cIntConv 3 =<< {#get CUdevprop.maxThreadsDim#} p - [g1,g2,g3] <- peekArrayWith cIntConv 3 =<< {#get CUdevprop.maxGridSize#} p + [t1,t2,t3] <- peekArrayWith fromIntegral 3 =<< {#get CUdevprop.maxThreadsDim#} p + [g1,g2,g3] <- peekArrayWith fromIntegral 3 =<< {#get CUdevprop.maxGridSize#} p return CUDevProp { @@ -124,7 +128,7 @@ data InitFlag instance Enum InitFlag where #ifdef USE_EMPTY_CASE - toEnum x = case x of {} + toEnum x = error ("InitFlag.toEnum: Cannot match " ++ show x) fromEnum x = case x of {} #endif @@ -141,14 +145,16 @@ -- {-# INLINEABLE initialise #-} initialise :: [InitFlag] -> IO () -initialise !flags = nothingIfOk =<< cuInit flags <* enable_constructors +initialise !flags = do + enable_constructors + cuInit flags {-# INLINE enable_constructors #-} {# fun unsafe enable_constructors { } -> `()' #} {-# INLINE cuInit #-} {# fun unsafe cuInit - { combineBitMasks `[InitFlag]' } -> `Status' cToEnum #} + { combineBitMasks `[InitFlag]' } -> `()' checkStatus*- #} -------------------------------------------------------------------------------- @@ -167,14 +173,15 @@ #else -- Deprecated as of CUDA-5.0 -- -capability !dev = - (\(!s,!a,!b) -> resultIfOk (s,Compute a b)) =<< cuDeviceComputeCapability dev +capability !dev = uncurry Compute <$> cuDeviceComputeCapability dev {-# INLINE cuDeviceComputeCapability #-} {# fun unsafe cuDeviceComputeCapability { alloca- `Int' peekIntConv* , alloca- `Int' peekIntConv* - , useDevice `Device' } -> `Status' cToEnum #} + , useDevice `Device' + } + -> `()' checkStatus*- #} #endif @@ -184,14 +191,13 @@ -- -- {-# INLINEABLE device #-} -device :: Int -> IO Device -device !d = resultIfOk =<< cuDeviceGet d - -{-# INLINE cuDeviceGet #-} -{# fun unsafe cuDeviceGet +{# fun unsafe cuDeviceGet as device { alloca- `Device' dev* - , cIntConv `Int' } -> `Status' cToEnum #} - where dev = liftM Device . peek + , `Int' + } + -> `()' checkStatus*- #} + where + dev = liftM Device . peek -- | @@ -201,13 +207,14 @@ -- {-# 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 #} +attribute !d !a = cuDeviceGetAttribute a d + where + {# fun unsafe cuDeviceGetAttribute + { alloca- `Int' peekIntConv* + , cFromEnum `DeviceAttribute' + , useDevice `Device' + } + -> `()' checkStatus*- #} -- | @@ -216,12 +223,10 @@ -- -- {-# INLINEABLE count #-} -count :: IO Int -count = resultIfOk =<< cuDeviceGetCount - -{-# INLINE cuDeviceGetCount #-} -{# fun unsafe cuDeviceGetCount - { alloca- `Int' peekIntConv* } -> `Status' cToEnum #} +{# fun unsafe cuDeviceGetCount as count + { alloca- `Int' peekIntConv* + } + -> `()' checkStatus*- #} -- | @@ -230,19 +235,63 @@ -- -- {-# INLINEABLE name #-} -name :: Device -> IO String -name !d = resultIfOk =<< cuDeviceGetName d - -{-# INLINE cuDeviceGetName #-} -{# fun unsafe cuDeviceGetName +{# fun unsafe cuDeviceGetName as name { allocaS- `String'& peekS* - , useDevice `Device' } -> `Status' cToEnum #} + , useDevice `Device' + } + -> `()' checkStatus*- #} where len = 512 - allocaS a = allocaBytes len $ \p -> a (p, cIntConv len) + allocaS a = allocaBytes len $ \p -> a (p, fromIntegral len) peekS s _ = peekCString s +-- | Returns a UUID for the device +-- +-- Requires CUDA-9.2 +-- +-- +-- +-- @since 0.10.0.0 +-- +{-# INLINE uuid #-} +uuid :: Device -> IO UUID +#if CUDA_VERSION < 9020 +uuid = requireSDK 'uuid 9.2 +#else +uuid !dev = + allocaBytes 16 $ \ptr -> do + cuDeviceGetUuid ptr dev + unpack ptr + where + {-# INLINE cuDeviceGetUuid #-} + {# fun unsafe cuDeviceGetUuid + { `Ptr ()' + , useDevice `Device' + } -> `()' checkStatus*- #} + + {-# INLINE unpack #-} + unpack :: Ptr () -> IO UUID + unpack !p = do + let !q = castPtr p + a <- word <$> peekElemOff q 0 <*> peekElemOff q 1 <*> peekElemOff q 2 <*> peekElemOff q 3 + b <- word <$> peekElemOff q 4 <*> peekElemOff q 5 <*> peekElemOff q 6 <*> peekElemOff q 7 + c <- word <$> peekElemOff q 8 <*> peekElemOff q 9 <*> peekElemOff q 10 <*> peekElemOff q 11 + d <- word <$> peekElemOff q 12 <*> peekElemOff q 13 <*> peekElemOff q 14 <*> peekElemOff q 15 + return $! fromWords a b c d + + {-# INLINE word #-} + word :: Word8 -> Word8 -> Word8 -> Word8 -> Word32 + word !a !b !c !d + = (fromIntegral a `shiftL` 24) + .|. (fromIntegral b `shiftL` 16) + .|. (fromIntegral c `shiftL` 8) + .|. (fromIntegral d ) +#endif + + +-- TODO: cuDeviceGetLuid, introduced CUDA-10.0 (windows only) + -- | -- Return the properties of the selected device -- @@ -257,127 +306,79 @@ -- 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 + let totalConstMem = cuTotalConstMem p + sharedMemPerBlock = cuSharedMemPerBlock p + regsPerBlock = cuRegsPerBlock p + warpSize = cuWarpSize p + maxThreadsPerBlock = cuMaxThreadsPerBlock p + maxBlockSize = cuMaxBlockSize p + maxGridSize = cuMaxGridSize p + clockRate = cuClockRate p + memPitch = cuMemPitch p + textureAlignment = cuTextureAlignment p #else - 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 + totalConstMem <- fromIntegral <$> attribute d TotalConstantMemory + sharedMemPerBlock <- fromIntegral <$> attribute d SharedMemoryPerBlock + memPitch <- fromIntegral <$> attribute d MaxPitch + textureAlignment <- fromIntegral <$> attribute d TextureAlignment + clockRate <- attribute d ClockRate + warpSize <- attribute d WarpSize + regsPerBlock <- attribute d RegistersPerBlock + maxThreadsPerBlock <- attribute d MaxThreadsPerBlock + maxBlockSize <- (,,) <$> attribute d MaxBlockDimX <*> attribute d MaxBlockDimY <*> attribute d MaxBlockDimZ + maxGridSize <- (,,) <$> attribute d MaxGridDimX <*> attribute d MaxGridDimY <*> attribute d MaxGridDimZ #endif -- The rest of the properties. -- - 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 + deviceName <- name d + computeCapability <- capability d + totalGlobalMem <- totalMem d + multiProcessorCount <- attribute d MultiprocessorCount + computeMode <- toEnum <$> attribute d ComputeMode + deviceOverlap <- toBool <$> attribute d GpuOverlap + kernelExecTimeoutEnabled <- toBool <$> attribute d KernelExecTimeout + integrated <- toBool <$> attribute d Integrated + canMapHostMemory <- toBool <$> attribute d CanMapHostMemory #if CUDA_VERSION >= 3000 - 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 + concurrentKernels <- toBool <$> attribute d ConcurrentKernels + eccEnabled <- toBool <$> attribute d EccEnabled + maxTextureDim1D <- attribute d MaximumTexture1dWidth + maxTextureDim2D <- (,) <$> attribute d MaximumTexture2dWidth <*> attribute d MaximumTexture2dHeight + maxTextureDim3D <- (,,) <$> attribute d MaximumTexture3dWidth <*> attribute d MaximumTexture3dHeight <*> attribute d MaximumTexture3dDepth #endif #if CUDA_VERSION >= 4000 - 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 + asyncEngineCount <- attribute d AsyncEngineCount + cacheMemL2 <- attribute d L2CacheSize + maxThreadsPerMultiProcessor <- attribute d MaxThreadsPerMultiprocessor + memBusWidth <- attribute d GlobalMemoryBusWidth + memClockRate <- attribute d MemoryClockRate + pciInfo <- PCI <$> attribute d PciBusId <*> attribute d PciDeviceId <*> attribute d PciDomainId + unifiedAddressing <- toBool <$> attribute d UnifiedAddressing + tccDriverEnabled <- toBool <$> attribute d TccDriver #endif #if CUDA_VERSION >= 5050 - sp <- toBool `fmap` attribute d StreamPrioritiesSupported + streamPriorities <- toBool <$> 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 + globalL1Cache <- toBool <$> attribute d GlobalL1CacheSupported + localL1Cache <- toBool <$> attribute d LocalL1CacheSupported + managedMemory <- toBool <$> attribute d ManagedMemory + multiGPUBoard <- toBool <$> attribute d MultiGpuBoard + multiGPUBoardGroupID <- attribute d MultiGpuBoardGroupId #endif -#if CUDA_VERSION >= 5050 - , streamPriorities = sp +#if CUDA_VERSION >= 8000 + preemption <- toBool <$> attribute d ComputePreemptionSupported + singleToDoublePerfRatio <- attribute d SingleToDoublePrecisionPerfRatio #endif -#if CUDA_VERSION >= 6000 - , globalL1Cache = gl1 - , localL1Cache = ll1 - , managedMemory = mm - , multiGPUBoard = mg - , multiGPUBoardGroupID = mid +#if CUDA_VERSION >= 9000 + cooperativeLaunch <- toBool <$> attribute d CooperativeLaunch + cooperativeLaunchMultiDevice <- toBool <$> attribute d CooperativeMultiDeviceLaunch #endif - } + return DeviceProperties{..} + + #if CUDA_VERSION < 5000 -- Deprecated as of CUDA-5.0 {-# INLINE cuDeviceGetProperties #-} @@ -393,11 +394,9 @@ -- -- {-# INLINEABLE totalMem #-} -totalMem :: Device -> IO Int64 -totalMem !d = resultIfOk =<< cuDeviceTotalMem d - -{-# INLINE cuDeviceTotalMem #-} -{# fun unsafe cuDeviceTotalMem +{# fun unsafe cuDeviceTotalMem as totalMem { alloca- `Int64' peekIntConv* - , useDevice `Device' } -> `Status' cToEnum #} + , useDevice `Device' + } + -> `()' checkStatus*- #} diff --git a/src/Foreign/CUDA/Driver/Error.chs b/src/Foreign/CUDA/Driver/Error.chs --- a/src/Foreign/CUDA/Driver/Error.chs +++ b/src/Foreign/CUDA/Driver/Error.chs @@ -4,7 +4,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Driver.Error --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2018] Trevor L. McDonell -- License : BSD -- -- Error handling @@ -17,7 +17,7 @@ Status(..), CUDAException(..), describe, cudaError, cudaErrorIO, requireSDK, - resultIfOk, nothingIfOk, + resultIfOk, nothingIfOk, checkStatus, ) where @@ -209,4 +209,8 @@ case status of Success -> return () _ -> throwIO (ExitCode status) + +{-# INLINE checkStatus #-} +checkStatus :: CInt -> IO () +checkStatus = nothingIfOk . cToEnum diff --git a/src/Foreign/CUDA/Driver/Event.chs b/src/Foreign/CUDA/Driver/Event.chs --- a/src/Foreign/CUDA/Driver/Event.chs +++ b/src/Foreign/CUDA/Driver/Event.chs @@ -3,10 +3,13 @@ {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE TemplateHaskell #-} +#ifdef USE_EMPTY_CASE +{-# LANGUAGE EmptyCase #-} +#endif -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Driver.Event --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2018] Trevor L. McDonell -- License : BSD -- -- Event management for low-level driver interface @@ -25,16 +28,46 @@ {# context lib="cuda" #} -- Friends -import Foreign.CUDA.Types import Foreign.CUDA.Internal.C2HS import Foreign.CUDA.Driver.Error +import Foreign.CUDA.Driver.Stream ( Stream(..), defaultStream ) -- System import Foreign import Foreign.C import Data.Maybe -import Control.Monad ( liftM ) -import Control.Exception ( throwIO ) +import Control.Monad ( liftM ) +import Control.Exception ( throwIO ) + + +-------------------------------------------------------------------------------- +-- Data Types +-------------------------------------------------------------------------------- + +-- | +-- Events are markers that can be inserted into the CUDA execution stream and +-- later queried. +-- +newtype Event = Event { useEvent :: {# type CUevent #}} + deriving (Eq, Show) + +-- | +-- Event creation flags +-- +{# enum CUevent_flags as EventFlag + { underscoreToCase + } + with prefix="CU_EVENT" deriving (Eq, Show, Bounded) #} + +-- | +-- Possible option flags for waiting for events +-- +data WaitFlag +instance Enum WaitFlag where +#ifdef USE_EMPTY_CASE + toEnum x = error ("WaitFlag.toEnum: Cannot match " ++ show x) + fromEnum x = case x of {} +#endif -------------------------------------------------------------------------------- diff --git a/src/Foreign/CUDA/Driver/Exec.chs b/src/Foreign/CUDA/Driver/Exec.chs --- a/src/Foreign/CUDA/Driver/Exec.chs +++ b/src/Foreign/CUDA/Driver/Exec.chs @@ -7,7 +7,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Driver.Exec --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2018] Trevor L. McDonell -- License : BSD -- -- Kernel execution control for low-level driver interface @@ -17,7 +17,7 @@ module Foreign.CUDA.Driver.Exec ( -- * Kernel Execution - Fun(Fun), FunParam(..), FunAttribute(..), SharedMem(..), + Fun(..), FunParam(..), FunAttribute(..), SharedMem(..), requires, setCacheConfigFun, setSharedMemConfigFun, @@ -353,6 +353,7 @@ #endif -- TODO: cuLaunchCooperativeKernelMultiDevice introduced CUDA-9.0 +-- TODO: cuLaunchHostFunc introduced CUDA-10.0 -------------------------------------------------------------------------------- -- Deprecated @@ -402,8 +403,8 @@ {-# INLINE cuFuncSetSharedSize #-} {# fun unsafe cuFuncSetSharedSize - { useFun `Fun' - , cIntConv `Integer' } -> `Status' cToEnum #} + { useFun `Fun' + , fromInteger `Integer' } -> `Status' cToEnum #} -- | @@ -441,7 +442,7 @@ {# fun unsafe cuParamSetf { useFun `Fun' , `Int' - , `Float' } -> `Status' cToEnum #} + , CFloat `Float' } -> `Status' cToEnum #} {-# INLINE cuParamSetv #-} {# fun unsafe cuParamSetv diff --git a/src/Foreign/CUDA/Driver/Graph/Base.chs b/src/Foreign/CUDA/Driver/Graph/Base.chs new file mode 100644 --- /dev/null +++ b/src/Foreign/CUDA/Driver/Graph/Base.chs @@ -0,0 +1,77 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +#ifdef USE_EMPTY_CASE +{-# LANGUAGE EmptyCase #-} +#endif +-------------------------------------------------------------------------------- +-- | +-- Module : Foreign.CUDA.Driver.Graph.Base +-- Copyright : [2018] Trevor L. McDonell +-- License : BSD +-- +-- Graph execution functions for the low-level driver interface +-- +-- Requires CUDA-10 +-- +-------------------------------------------------------------------------------- + +module Foreign.CUDA.Driver.Graph.Base + where + +#include "cbits/stubs.h" +{# context lib="cuda" #} + +import Foreign.Storable +import Foreign.Ptr + + +-------------------------------------------------------------------------------- +-- Data Types +-------------------------------------------------------------------------------- + +#if CUDA_VERSION < 10000 +data Graph +#else +newtype Graph = Graph { useGraph :: {# type CUgraph #}} + deriving (Eq, Show) +#endif + +data GraphFlag +instance Enum GraphFlag where +#ifdef USE_EMPTY_CASE + toEnum x = error ("GraphFlag.toEnum: Cannot match " ++ show x) + fromEnum x = case x of {} +#endif + +#if CUDA_VERSION < 10000 +data Node +data NodeType + +instance Enum NodeType where +#ifdef USE_EMPTY_CASE + toEnum x = error ("NodeType.toEnum: Cannot match " ++ show x) + fromEnum x = case x of {} +#endif +#else +newtype Node = Node { useNode :: {# type CUgraphNode #}} + deriving (Eq, Show, Storable) + +{# enum CUgraphNodeType as NodeType + { underscoreToCase + , CU_GRAPH_NODE_TYPE_GRAPH as Subgraph + } + with prefix="CU_GRAPH_NODE_TYPE" deriving (Eq, Show, Bounded) #} +#endif + + +#if CUDA_VERSION < 10000 +data Executable +#else +newtype Executable = Executable { useExecutable :: {# type CUgraphExec #}} + deriving (Eq, Show) +#endif + diff --git a/src/Foreign/CUDA/Driver/Graph/Build.chs b/src/Foreign/CUDA/Driver/Graph/Build.chs new file mode 100644 --- /dev/null +++ b/src/Foreign/CUDA/Driver/Graph/Build.chs @@ -0,0 +1,689 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Foreign.CUDA.Driver.Graph.Build +-- Copyright : [2018] Trevor L. McDonell +-- License : BSD +-- +-- Graph construction functions for the low-level driver interface +-- +-- Requires CUDA-10 +-- +-------------------------------------------------------------------------------- + +module Foreign.CUDA.Driver.Graph.Build ( + + Graph(..), Node(..), NodeType(..), HostCallback, + create, destroy, clone, remove, + + -- ** Construction + addChild, + addEmpty, + addHost, + addKernel, + addMemcpy, + addMemset, + addDependencies, + removeDependencies, + + -- ** Querying + getType, + getChildGraph, + getEdges, + getNodes, + getRootNodes, + getDependencies, + getDependents, + findInClone, + +) where + +#include "cbits/stubs.h" +{# context lib="cuda" #} + +import Foreign.CUDA.Driver.Context.Base ( Context(..) ) +import Foreign.CUDA.Driver.Error +import Foreign.CUDA.Driver.Exec ( Fun(..), FunParam(..) ) +import Foreign.CUDA.Driver.Graph.Base +import Foreign.CUDA.Driver.Marshal ( useDeviceHandle ) +import Foreign.CUDA.Driver.Stream ( Stream(..) ) +import Foreign.CUDA.Driver.Unified ( MemoryType(..) ) +import Foreign.CUDA.Internal.C2HS +import Foreign.CUDA.Ptr ( DevicePtr(..) ) + +import Control.Monad ( liftM ) +import Unsafe.Coerce + +import Data.Word +import Foreign +import Foreign.C +import Foreign.Storable + + +-- | Callback function executed on the host +-- +-- +-- +-- @since 0.10.0.0 +-- +#if CUDA_VERSION < 10000 +type HostCallback = FunPtr () +#else +type HostCallback = {# type CUhostFn #} +#endif + + +-------------------------------------------------------------------------------- +-- Graph creation +-------------------------------------------------------------------------------- + +-- | Create an empty task graph +-- +-- Requires CUDA-10.0 +-- +-- +-- +-- @since 0.10.0.0 +-- +{-# INLINEABLE create #-} +#if CUDA_VERSION < 10000 +create :: [GraphFlag] -> IO Graph +create = requireSDK 'create 10.0 +#else +{# fun unsafe cuGraphCreate as create + { alloca- `Graph' peekGraph* + , combineBitMasks `[GraphFlag]' + } + -> `()' checkStatus*- #} +#endif + + +-- | Destroy a graph, as well as all of its nodes +-- +-- Requires CUDA-10.0 +-- +-- +-- +-- @since 0.10.0.0 +{-# INLINEABLE destroy #-} +#if CUDA_VERSION < 10000 +destroy :: Graph -> IO () +destroy = requireSDK 'destroy 10.0 +#else +{# fun unsafe cuGraphDestroy as destroy + { useGraph `Graph' + } + -> `()' checkStatus*- #} +#endif + + +-- | Clone a graph +-- +-- Requires CUDA-10.0 +-- +-- +-- +-- @since 0.10.0.0 +-- +{-# INLINEABLE clone #-} +#if CUDA_VERSION < 10000 +clone :: Graph -> IO Graph +clone = requireSDK 'clone 10.0 +#else +{# fun unsafe cuGraphClone as clone + { alloca- `Graph' peekGraph* + , useGraph `Graph' + } + -> `()' checkStatus*- #} +#endif + + +-- | Remove a node from the graph +-- +-- Requires CUDA-10.0 +-- +-- +-- +-- @since 0.10.0.0 +-- +{-# INLINEABLE remove #-} +#if CUDA_VERSION < 10000 +remove :: Node -> IO () +remove = requireSDK 'remove 10.0 +#else +{# fun unsafe cuGraphDestroyNode as remove + { useNode `Node' + } + -> `()' checkStatus*- #} +#endif + + +-- | Create a child graph node and add it to the graph +-- +-- Requires CUDA-10.0 +-- +-- +-- +-- @since 0.10.0.0 +-- +{-# INLINEABLE addChild #-} +addChild :: Graph -> Graph -> [Node] -> IO Node +#if CUDA_VERSION < 10000 +addChild = requireSDK 'addChild 10.0 +#else +addChild parent child dependencies = cuGraphAddChildGraphNode parent dependencies child + where + {# fun unsafe cuGraphAddChildGraphNode + { alloca- `Node' peekNode* + , useGraph `Graph' + , withNodeArrayLen* `[Node]'& + , useGraph `Graph' + } + -> `()' checkStatus*- #} +#endif + + +-- | Add dependency edges to the graph +-- +-- Requires CUDA-10.0 +-- +-- +-- +-- @since 0.10.0.0 +-- +{-# INLINEABLE addDependencies #-} +addDependencies :: Graph -> [(Node,Node)] -> IO () +#if CUDA_VERSION < 10000 +addDependencies = requireSDK 'addDependencies 10.0 +#else +addDependencies !g !deps = cuGraphAddDependencies g from to + where + (from, to) = unzip deps + + {# fun unsafe cuGraphAddDependencies + { useGraph `Graph' + , withNodeArray* `[Node]' + , withNodeArrayLen* `[Node]'& + } + -> `()' checkStatus*- #} +#endif + + +-- | Remove dependency edges from the graph +-- +-- Requires CUDA-10.0 +-- +-- +-- +-- @since 0.10.0.0 +-- +{-# INLINE removeDependencies #-} +removeDependencies :: Graph -> [(Node,Node)] -> IO () +#if CUDA_VERSION < 10000 +removeDependencies = requireSDK 'removeDependencies 10.0 +#else +removeDependencies !g !deps = cuGraphRemoveDependencies g from to + where + (from, to) = unzip deps + + {# fun unsafe cuGraphRemoveDependencies + { useGraph `Graph' + , withNodeArray* `[Node]' + , withNodeArrayLen* `[Node]'& + } + -> `()' checkStatus*- #} +#endif + + +-- | Create an empty node and add it to the graph. +-- +-- Requires CUDA-10.0 +-- +-- +-- +-- @since 0.10.0.0 +-- +{-# INLINEABLE addEmpty #-} +#if CUDA_VERSION < 10000 +addEmpty :: Graph -> [Node] -> IO Node +addEmpty = requireSDK 'addEmpty 10.0 +#else +{# fun unsafe cuGraphAddEmptyNode as addEmpty + { alloca- `Node' peekNode* + , useGraph `Graph' + , withNodeArrayLen* `[Node]'& + } + -> `()' checkStatus*- #} +#endif + + +-- | Creates a host execution node and adds it to the graph +-- +-- Requires CUDA-10.0 +-- +-- +-- +-- @since 0.10.0.0 +-- +{-# INLINEABLE addHost #-} +#if CUDA_VERSION < 10000 +addHost :: Graph -> [Node] -> HostCallback -> Ptr () -> IO Node +addHost = requireSDK 'addHost 10.0 +#else +{# fun unsafe cuGraphAddHostNode_simple as addHost + { alloca- `Node' peekNode* + , useGraph `Graph' + , withNodeArrayLen* `[Node]'& + , id `HostCallback' + , `Ptr ()' + } + -> `()' checkStatus*- #} +#endif + + +-- | Create a kernel execution node and adds it to the graph +-- +-- Requires CUDA-10.0 +-- +-- +-- +-- @since 0.10.0.0 +-- +{-# INLINEABLE addKernel #-} +addKernel + :: Graph + -> [Node] + -> Fun + -> (Int, Int, Int) -- ^ grid dimension + -> (Int, Int, Int) -- ^ thread block dimensions + -> Int -- ^ shared memory (bytes) + -> [FunParam] + -> IO Node +#if CUDA_VERSION < 10000 +addKernel = requireSDK 'addKernel 10.0 +#else +addKernel !g !ns !fun (!gx,!gy,!gz) (!tx,!ty,!tz) !sm !args + = withMany withFP args + $ \pa -> withArray pa + $ \pp -> cuGraphAddKernelNode_simple g ns fun gx gy gz tx ty tz sm pp + where + withFP :: FunParam -> (Ptr () -> IO b) -> IO b + withFP !p !f = case p of + IArg v -> with' v (f . castPtr) + FArg v -> with' v (f . castPtr) + VArg v -> with' v (f . castPtr) + + -- can't use the standard 'with' because 'alloca' will pass an undefined + -- dummy argument when determining 'sizeOf' and 'alignment', but sometimes + -- instances in Accelerate need to evaluate this argument. + -- + with' :: Storable a => a -> (Ptr a -> IO b) -> IO b + with' !val !f = + allocaBytes (sizeOf val) $ \ptr -> do + poke ptr val + f ptr + + {# fun unsafe cuGraphAddKernelNode_simple + { alloca- `Node' peekNode* + , useGraph `Graph' + , withNodeArrayLen* `[Node]'& + , useFun `Fun' + , `Int' + , `Int' + , `Int' + , `Int' + , `Int' + , `Int' + , `Int' + , id `Ptr (Ptr ())' + } + -> `()' checkStatus*- #} +#endif + + +-- | Create a memcpy node and add it to the graph +-- +-- Requires CUDA-10.0 +-- +-- +-- +-- @since 0.10.0.0 +-- +#if CUDA_VERSION < 10000 +addMemcpy :: Graph -> [Node] -> Context -> Int -> Int -> Int -> Int -> MemoryType -> Ptr a -> Int -> Int -> Int -> Int -> Int -> Int -> MemoryType -> Ptr a -> Int -> Int -> Int -> Int -> Int -> IO Node +addMemcpy = requireSDK 'addMemcpy 10.0 +#else +{# fun unsafe cuGraphAddMemcpyNode_simple as addMemcpy + { alloca- `Node' peekNode* + , useGraph `Graph' + , withNodeArrayLen* `[Node]'& + , useContext `Context' + , `Int' -- ^ srcXInBytes + , `Int' -- ^ srcY + , `Int' -- ^ srcZ + , `Int' -- ^ srcLOD + , cFromEnum `MemoryType' -- ^ source memory type + , castPtr `Ptr a' -- ^ source ptr + , `Int' -- ^ srcPitch + , `Int' -- ^ srcHeight + , `Int' -- ^ dstXInBytes + , `Int' -- ^ dstY + , `Int' -- ^ dstZ + , `Int' -- ^ dstLOD + , cFromEnum `MemoryType' -- ^ destination memory type + , castPtr `Ptr a' -- ^ destination ptr + , `Int' -- ^ dstPitch + , `Int' -- ^ dstHeight + , `Int' -- ^ widthInBytes + , `Int' -- ^ height + , `Int' -- ^ depth + } + -> `()' checkStatus*- #} +#endif + + +-- | Create a memset node and add it to the graph +-- +-- Requires CUDA-10.0 +-- +-- +-- +-- @since 0.10.0.0 +-- +{-# INLINEABLE addMemset #-} +addMemset + :: Storable a + => Graph + -> [Node] + -> Context + -> DevicePtr a + -> a + -> Int -- ^ height + -> Int -- ^ pitch + -> Int -- ^ width + -> IO Node +#if CUDA_VERSION < 10000 +addMemset = requireSDK 'addMemset 10.0 +#else +addMemset !g !ns !ctx !dptr !val !h !p !w = + cuGraphAddMemsetNode_simple g ns ctx dptr bytes h p val' w + where + bytes = sizeOf val + + val' :: Word32 + val' = case bytes of + 1 -> fromIntegral (unsafeCoerce val :: Word8) + 2 -> fromIntegral (unsafeCoerce val :: Word16) + 4 -> fromIntegral (unsafeCoerce val :: Word32) + _ -> cudaError "can only memset 8-, 16-, and 32-bit values" + + {# fun unsafe cuGraphAddMemsetNode_simple + { alloca- `Node' peekNode* + , useGraph `Graph' + , withNodeArrayLen* `[Node]'& + , useContext `Context' + , useDeviceHandle `DevicePtr a' + , `Int' + , `Int' + , `Int' + , `Word32' + , `Int' + } + -> `()' checkStatus*- #} +#endif + + +-------------------------------------------------------------------------------- +-- Query +-------------------------------------------------------------------------------- + +-- | Return the type of a node +-- +-- Requires CUDA-10.0 +-- +-- +-- +-- @since 0.10.0.0 +-- +{-# INLINEABLE getType #-} +#if CUDA_VERSION < 10000 +getType :: Node -> IO NodeType +getType = requireSDK 'getType 10.0 +#else +{# fun unsafe cuGraphNodeGetType as getType + { useNode `Node' + , alloca- `NodeType' peekEnum* + } + -> `()' checkStatus*- #} +#endif + + +-- | Retrieve the embedded graph of a child sub-graph node +-- +-- Requires CUDA-10.0 +-- +-- +-- +-- @since 0.10.0.0 +-- +{-# INLINEABLE getChildGraph #-} +#if CUDA_VERSION < 10000 +getChildGraph :: Node -> IO Graph +getChildGraph = requireSDK 'getChildGraph 10.0 +#else +{# fun unsafe cuGraphChildGraphNodeGetGraph as getChildGraph + { useNode `Node' + , alloca- `Graph' peekGraph* + } + -> `()' checkStatus*- #} +#endif + + +-- | Return a graph's dependency edges +-- +-- Requires CUDA-10.0 +-- +-- +-- +-- @since 0.10.0.0 +-- +{-# INLINEABLE getEdges #-} +getEdges :: Graph -> IO [(Node, Node)] +#if CUDA_VERSION < 10000 +getEdges = requireSDK 'getEdges 10.0 +#else +getEdges !g = + alloca $ \p_count -> do + cuGraphGetEdges g nullPtr nullPtr p_count + count <- peekIntConv p_count + allocaArray count $ \p_from -> do + allocaArray count $ \p_to -> do + cuGraphGetEdges g p_from p_to p_count + from <- peekArray count p_from + to <- peekArray count p_to + return $ zip from to + where + {# fun unsafe cuGraphGetEdges + { useGraph `Graph' + , castPtr `Ptr Node' + , castPtr `Ptr Node' + , id `Ptr CULong' + } + -> `()' checkStatus*- #} +#endif + + +-- | Return a graph's nodes +-- +-- Requires CUDA-10.0 +-- +-- +-- +-- @since 0.10.0.0 +-- +{-# INLINEABLE getNodes #-} +getNodes :: Graph -> IO [Node] +#if CUDA_VERSION < 10000 +getNodes = requireSDK 'getNodes 10.0 +#else +getNodes !g = + alloca $ \p_count -> do + cuGraphGetNodes g nullPtr p_count + count <- peekIntConv p_count + allocaArray count $ \p_nodes -> do + cuGraphGetNodes g p_nodes p_count + peekArray count p_nodes + where + {# fun unsafe cuGraphGetNodes + { useGraph `Graph' + , castPtr `Ptr Node' + , id `Ptr CULong' + } + -> `()' checkStatus*- #} +#endif + + +-- | Returns the root nodes of a graph +-- +-- Requires CUDA-10.0 +-- +-- +-- +-- @since 0.10.0.0 +-- +{-# INLINEABLE getRootNodes #-} +getRootNodes :: Graph -> IO [Node] +#if CUDA_VERSION < 10000 +getRootNodes = requireSDK 'getRootNodes 10.0 +#else +getRootNodes g = + alloca $ \p_count -> do + cuGraphGetRootNodes g nullPtr p_count + count <- peekIntConv p_count + allocaArray count $ \p_nodes -> do + cuGraphGetRootNodes g p_nodes p_count + peekArray count p_nodes + where + {# fun unsafe cuGraphGetRootNodes + { useGraph `Graph' + , castPtr `Ptr Node' + , id `Ptr CULong' + } + -> `()' checkStatus*- #} +#endif + + +-- | Return the dependencies of a node +-- +-- Requires CUDA-10.0 +-- +-- +-- +-- @since 0.10.0.0 +-- +{-# INLINEABLE getDependencies #-} +getDependencies :: Node -> IO [Node] +#if CUDA_VERSION < 10000 +getDependencies = requireSDK 'getDependencies 10.0 +#else +getDependencies !n = + alloca $ \p_count -> do + cuGraphNodeGetDependencies n nullPtr p_count + count <- peekIntConv p_count + allocaArray count $ \p_deps -> do + cuGraphNodeGetDependencies n p_deps p_count + peekArray count p_deps + where + {# fun unsafe cuGraphNodeGetDependencies + { useNode `Node' + , castPtr `Ptr Node' + , id `Ptr CULong' + } + -> `()' checkStatus*- #} +#endif + + +-- | Return a node's dependent nodes +-- +-- Requires CUDA-10.0 +-- +-- +-- +-- @since 0.10.0.0 +-- +{-# INLINEABLE getDependents #-} +getDependents :: Node -> IO [Node] +#if CUDA_VERSION < 10000 +getDependents = requireSDK 'getDependents 10.0 +#else +getDependents n = + alloca $ \p_count -> do + cuGraphNodeGetDependentNodes n nullPtr p_count + count <- peekIntConv p_count + allocaArray count $ \p_deps -> do + cuGraphNodeGetDependentNodes n p_deps p_count + peekArray count p_deps + where + {# fun unsafe cuGraphNodeGetDependentNodes + { useNode `Node' + , castPtr `Ptr Node' + , id `Ptr CULong' + } + -> `()' checkStatus*- #} +#endif + + +-- | Find a cloned version of a node +-- +-- Requires CUDA-10.0 +-- +-- +-- +-- @since 0.10.0.0 +-- +{-# INLINEABLE findInClone #-} +#if CUDA_VERSION < 10000 +findInClone :: Node -> Graph -> IO Node +findInClone = requireSDK 'findInClone 10 +#else +{# fun unsafe cuGraphNodeFindInClone as findInClone + { alloca- `Node' peekNode* + , useNode `Node' + , useGraph `Graph' + } + -> `()' checkStatus*- #} +#endif + + +-- TODO: since CUDA-10.0 +-- * cuGraphHostNode[Get/Set]Params +-- * cuGraphKernelNode[Get/Set]Params +-- * cuGraphMemcpyNode[Get/Set]Params +-- * cuGraphMemsetNode[Get/Set]Params + +-------------------------------------------------------------------------------- +-- Internal +-------------------------------------------------------------------------------- + +#if CUDA_VERSION >= 10000 +{-# INLINE peekGraph #-} +peekGraph :: Ptr {# type CUgraph #} -> IO Graph +peekGraph = liftM Graph . peek + +{-# INLINE peekNode #-} +peekNode :: Ptr {# type CUgraphNode #} -> IO Node +peekNode = liftM Node . peek + +{-# INLINE withNodeArray #-} +withNodeArray :: [Node] -> (Ptr {# type CUgraphNode #} -> IO a) -> IO a +withNodeArray ns f = withArray ns (f . castPtr) + +{-# INLINE withNodeArrayLen #-} +withNodeArrayLen :: [Node] -> ((Ptr {# type CUgraphNode #}, CULong) -> IO a) -> IO a +withNodeArrayLen ns f = withArrayLen ns $ \i p -> f (castPtr p, cIntConv i) +#endif + diff --git a/src/Foreign/CUDA/Driver/Graph/Capture.chs b/src/Foreign/CUDA/Driver/Graph/Capture.chs new file mode 100644 --- /dev/null +++ b/src/Foreign/CUDA/Driver/Graph/Capture.chs @@ -0,0 +1,128 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE TemplateHaskell #-} +#ifdef USE_EMPTY_CASE +{-# LANGUAGE EmptyCase #-} +#endif +-------------------------------------------------------------------------------- +-- | +-- Module : Foreign.CUDA.Driver.Graph.Capture +-- Copyright : [2018] Trevor L. McDonell +-- License : BSD +-- +-- Requires CUDA-10 +-- +-------------------------------------------------------------------------------- + +module Foreign.CUDA.Driver.Graph.Capture ( + + Status(..), + start, stop, status, + +) where + +#include "cbits/stubs.h" +{# context lib="cuda" #} + +import Foreign.CUDA.Driver.Error hiding ( Status ) +import Foreign.CUDA.Driver.Graph.Base +import Foreign.CUDA.Driver.Stream +import Foreign.CUDA.Internal.C2HS + +import Control.Monad ( liftM ) + +import Foreign +import Foreign.C + + +#if CUDA_VERSION < 10000 +data Status + +instance Enum Status where +#ifdef USE_EMPTY_CASE + toEnum x = error ("Status.toEnum: Cannot match " ++ show x) + fromEnum x = case x of {} +#endif + +#else +{# enum CUstreamCaptureStatus as Status + { underscoreToCase } + with prefix="CU_STREAM_CAPTURE_STATUS" deriving (Eq, Show, Bounded) #} +#endif + + +-------------------------------------------------------------------------------- +-- Graph capture +-------------------------------------------------------------------------------- + +-- | Begin graph capture on a stream +-- +-- Requires CUDA-10.0 +-- +-- +-- +-- @since 0.10.0.0 +-- +#if CUDA_VERSION < 10000 +start :: Stream -> IO () +start = requireSDK 'start 10.0 +#else +{# fun unsafe cuStreamBeginCapture as start + { useStream `Stream' + } + -> `()' checkStatus*- #} +#endif + + +-- | End graph capture on a stream +-- +-- Requires CUDA-10.0 +-- +-- +-- +-- @since 0.10.0.0 +-- +#if CUDA_VERSION < 10000 +stop :: Stream -> IO Graph +stop = requireSDK 'stop 10.0 +#else +{# fun unsafe cuStreamEndCapture as stop + { useStream `Stream' + , alloca- `Graph' peekGraph* + } + -> `()' checkStatus*- #} +#endif + + +-- | Return a stream's capture status +-- +-- Requires CUDA-10.0 +-- +-- +-- +-- @since 0.10.0.0 +-- +#if CUDA_VERSION < 10000 +status :: Stream -> IO Status +status = requireSDK 'status 10.0 +#else +{# fun unsafe cuStreamIsCapturing as status + { useStream `Stream' + , alloca- `Status' peekEnum* + } + -> `()' checkStatus*- #} +#endif + + +-------------------------------------------------------------------------------- +-- Internal +-------------------------------------------------------------------------------- + +#if CUDA_VERSION >= 10000 +{-# INLINE peekGraph #-} +peekGraph :: Ptr {# type CUgraph #} -> IO Graph +peekGraph = liftM Graph . peek +#endif + diff --git a/src/Foreign/CUDA/Driver/Graph/Exec.chs b/src/Foreign/CUDA/Driver/Graph/Exec.chs new file mode 100644 --- /dev/null +++ b/src/Foreign/CUDA/Driver/Graph/Exec.chs @@ -0,0 +1,132 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Foreign.CUDA.Driver.Graph.Exec +-- Copyright : [2018] Trevor L. McDonell +-- License : BSD +-- +-- Graph execution functions for the low-level driver interface +-- +-- Requires CUDA-10 +-- +-------------------------------------------------------------------------------- + +module Foreign.CUDA.Driver.Graph.Exec ( + + Executable(..), + + -- ** Execution + launch, + instantiate, + destroy, + +) where + +#include "cbits/stubs.h" +{# context lib="cuda" #} + +import Foreign.CUDA.Driver.Error +import Foreign.CUDA.Driver.Graph.Base +import Foreign.CUDA.Driver.Stream ( Stream(..) ) +import Foreign.CUDA.Internal.C2HS + +import Foreign +import Foreign.C + +import Control.Monad ( liftM ) +import Data.ByteString.Char8 ( ByteString ) +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Internal as B + + +-------------------------------------------------------------------------------- +-- Graph execution +-------------------------------------------------------------------------------- + +-- | Execute a graph in the given stream. Only one instance may execute at +-- a time; to execute a graph concurrently, it must be 'instantiate'd into +-- multiple executables. +-- +-- Requires CUDA-10.0 +-- +-- +-- +-- @since 0.10.0.0 +-- +{-# INLINEABLE launch #-} +#if CUDA_VERSION < 10000 +launch :: Executable -> Stream -> IO () +launch _ _ = requireSDK 'launch 10.0 +#else +{# fun unsafe cuGraphLaunch as launch + { useExecutable `Executable' + , useStream `Stream' + } + -> `()' checkStatus*- #} +#endif + + +-- | Instantiate the task graph description of a program into an executable +-- graph. +-- +-- Requires CUDA-10.0 +-- +-- +-- +-- @since 0.10.0.0 +-- +{-# INLINEABLE instantiate #-} +instantiate :: Graph -> IO Executable +#if CUDA_VERSION < 10000 +instantiate _ = requireSDK 'instantiate 10.0 +#else +instantiate !g = do + let logSize = 2048 + allocaArray logSize $ \p_elog -> do + (s, e, n) <- cuGraphInstantiate g p_elog logSize + -- + case s of + Success -> return e + _ -> do + errLog <- peekCStringLen (p_elog, logSize) + cudaErrorIO (unlines [describe s, "phErrorNode = " ++ show n, errLog]) + +{-# INLINE cuGraphInstantiate #-} +{# fun unsafe cuGraphInstantiate + { alloca- `Executable' peekExecutable* + , useGraph `Graph' + , alloca- `Maybe Node' peekErrNode* + , castPtr `CString' + , `Int' + } + -> `Status' cToEnum #} + where + peekExecutable = liftM Executable . peek + peekErrNode p = if p == nullPtr + then return Nothing + else liftM (Just . Node) (peek p) +#endif + + +-- | Destroy an executable graph +-- +-- Requires CUDA-10.0 +-- +-- +-- +-- @since 0.10.0.0 +-- +{-# INLINEABLE destroy #-} +#if CUDA_VERSION < 10000 +destroy :: Executable -> IO () +destroy _ = requireSDK 'destroy 10.0 +#else +{# fun unsafe cuGraphExecDestroy as destroy + { useExecutable `Executable' + } + -> `()' checkStatus*- #} +#endif + diff --git a/src/Foreign/CUDA/Driver/IPC/Event.chs b/src/Foreign/CUDA/Driver/IPC/Event.chs --- a/src/Foreign/CUDA/Driver/IPC/Event.chs +++ b/src/Foreign/CUDA/Driver/IPC/Event.chs @@ -5,7 +5,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Driver.IPC.Event --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2018] Trevor L. McDonell -- License : BSD -- -- IPC event management for low-level driver interface. diff --git a/src/Foreign/CUDA/Driver/IPC/Marshal.chs b/src/Foreign/CUDA/Driver/IPC/Marshal.chs --- a/src/Foreign/CUDA/Driver/IPC/Marshal.chs +++ b/src/Foreign/CUDA/Driver/IPC/Marshal.chs @@ -6,7 +6,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Driver.IPC.Marshal --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2018] Trevor L. McDonell -- License : BSD -- -- IPC memory management for low-level driver interface. diff --git a/src/Foreign/CUDA/Driver/Marshal.chs b/src/Foreign/CUDA/Driver/Marshal.chs --- a/src/Foreign/CUDA/Driver/Marshal.chs +++ b/src/Foreign/CUDA/Driver/Marshal.chs @@ -2,12 +2,14 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_HADDOCK prune #-} -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Driver.Marshal --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2018] Trevor L. McDonell -- License : BSD -- -- Memory management for low-level driver interface @@ -28,6 +30,7 @@ AttachFlag(..), mallocManagedArray, prefetchArrayAsync, + attachArrayAsync, -- * Marshalling peekArray, peekArrayAsync, peekArray2D, peekArray2DAsync, peekListArray, @@ -74,6 +77,10 @@ import Foreign.Storable import qualified Foreign.Marshal as F +import GHC.Ptr +import GHC.Word +import GHC.Base + #c typedef enum CUmemhostalloc_option_enum { CU_MEMHOSTALLOC_OPTION_PORTABLE = CU_MEMHOSTALLOC_PORTABLE, @@ -354,13 +361,32 @@ {# fun unsafe cuMemPrefetchAsync { useDeviceHandle `DevicePtr a' , `Int' - , `CInt' + , id `CInt' , useStream `Stream' } -> `Status' cToEnum #} #endif +-- | Attach an array of the given number of elements to a stream asynchronously +-- +-- +-- +-- @since 0.10.0.0 +-- +{-# INLINEABLE attachArrayAsync #-} +attachArrayAsync :: forall a. Storable a => [AttachFlag] -> Stream -> DevicePtr a -> Int -> IO () +attachArrayAsync !flags !stream !ptr !n = cuStreamAttachMemAsync stream ptr (n * sizeOf (undefined::a)) flags + where + {# fun unsafe cuStreamAttachMemAsync + { useStream `Stream' + , useDeviceHandle `DevicePtr a' + , `Int' + , combineBitMasks `[AttachFlag]' + } + -> `()' checkStatus*- #} + + -------------------------------------------------------------------------------- -- Marshalling -------------------------------------------------------------------------------- @@ -990,7 +1016,7 @@ 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" + _ -> cudaErrorIO "can only memset 8-, 16-, and 32-bit values" -- -- We use unsafe coerce below to reinterpret the bits of the value to memset as, @@ -1037,7 +1063,7 @@ 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" + _ -> cudaErrorIO "can only memset 8-, 16-, and 32-bit values" where stream = fromMaybe defaultStream mst @@ -1138,11 +1164,14 @@ -- {-# INLINE peekDeviceHandle #-} peekDeviceHandle :: Ptr DeviceHandle -> IO (DevicePtr a) -peekDeviceHandle !p = DevicePtr . intPtrToPtr . fromIntegral <$> peek p +peekDeviceHandle !p = do + CULLong (W64# w#) <- peek p + return $! DevicePtr (Ptr (int2Addr# (word2Int# w#))) -- Use a device pointer as an opaque handle type -- {-# INLINE useDeviceHandle #-} useDeviceHandle :: DevicePtr a -> DeviceHandle -useDeviceHandle = fromIntegral . ptrToIntPtr . useDevicePtr +useDeviceHandle (DevicePtr (Ptr addr#)) = + CULLong (W64# (int2Word# (addr2Int# addr#))) diff --git a/src/Foreign/CUDA/Driver/Module.hs b/src/Foreign/CUDA/Driver/Module.hs --- a/src/Foreign/CUDA/Driver/Module.hs +++ b/src/Foreign/CUDA/Driver/Module.hs @@ -1,7 +1,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Driver.Module --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2018] Trevor L. McDonell -- License : BSD -- -- Module management for low-level driver interface diff --git a/src/Foreign/CUDA/Driver/Module/Base.chs b/src/Foreign/CUDA/Driver/Module/Base.chs --- a/src/Foreign/CUDA/Driver/Module/Base.chs +++ b/src/Foreign/CUDA/Driver/Module/Base.chs @@ -7,7 +7,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Driver.Module.Base --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2018] Trevor L. McDonell -- License : BSD -- -- Module loading for low-level driver interface @@ -39,6 +39,7 @@ import Foreign.CUDA.Analysis.Device import Foreign.CUDA.Driver.Error import Foreign.CUDA.Internal.C2HS +import Foreign.C.Extra -- System import Foreign @@ -223,7 +224,7 @@ _ -> do errLog <- peekCString p_elog - cudaError (unlines [describe s, errLog]) + cudaErrorIO (unlines [describe s, errLog]) {-# INLINE cuModuleLoadDataEx #-} @@ -278,47 +279,5 @@ {-# INLINE jitTargetOfCompute #-} jitTargetOfCompute :: Compute -> JITTarget -#if CUDA_VERSION < 9000 -jitTargetOfCompute (Compute 1 0) = Compute10 -jitTargetOfCompute (Compute 1 1) = Compute11 -jitTargetOfCompute (Compute 1 2) = Compute12 -jitTargetOfCompute (Compute 1 3) = Compute13 -#endif -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) +jitTargetOfCompute (Compute x y) = toEnum (10*x + y) diff --git a/src/Foreign/CUDA/Driver/Module/Link.chs b/src/Foreign/CUDA/Driver/Module/Link.chs --- a/src/Foreign/CUDA/Driver/Module/Link.chs +++ b/src/Foreign/CUDA/Driver/Module/Link.chs @@ -2,11 +2,12 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE MagicHash #-} {-# LANGUAGE TemplateHaskell #-} -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Driver.Module.Link --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2018] Trevor L. McDonell -- License : BSD -- -- Module linking for low-level driver interface @@ -40,6 +41,7 @@ import Foreign.C import Unsafe.Coerce +import GHC.Ptr import Data.ByteString.Char8 ( ByteString ) import qualified Data.ByteString.Char8 as B @@ -203,10 +205,11 @@ #else addDataFromPtr !ls !n !img !t !options = let (opt,val) = unzip $ map jitOptionUnpack options + name = Ptr ""# 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 + nothingIfOk =<< cuLinkAddData ls t img n name i p_opts p_vals {-# INLINE cuLinkAddData #-} {# fun unsafe cuLinkAddData @@ -214,7 +217,7 @@ , cFromEnum `JITInputType' , castPtr `Ptr Word8' , `Int' - , `String' + , id `Ptr CChar' , `Int' , id `Ptr CInt' , id `Ptr (Ptr ())' diff --git a/src/Foreign/CUDA/Driver/Module/Query.chs b/src/Foreign/CUDA/Driver/Module/Query.chs --- a/src/Foreign/CUDA/Driver/Module/Query.chs +++ b/src/Foreign/CUDA/Driver/Module/Query.chs @@ -1,9 +1,11 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Driver.Module.Query --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2018] Trevor L. McDonell -- License : BSD -- -- Querying module attributes for low-level driver interface @@ -34,8 +36,16 @@ import Foreign.C import Control.Exception ( throwIO ) import Control.Monad ( liftM ) +import Data.ByteString.Short ( ShortByteString ) +import qualified Data.ByteString.Short as BS +import qualified Data.ByteString.Short.Internal as BI +import qualified Data.ByteString.Internal as BI +import Prelude as P +import GHC.Exts +import GHC.Base ( IO(..) ) + -------------------------------------------------------------------------------- -- Querying module attributes -------------------------------------------------------------------------------- @@ -46,15 +56,18 @@ -- -- {-# INLINEABLE getFun #-} -getFun :: Module -> String -> IO Fun +getFun :: Module -> ShortByteString -> 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 + { alloca- `Fun' peekFun* + , useModule `Module' + , useAsCString* `ShortByteString' + } + -> `Status' cToEnum #} + where + peekFun = liftM Fun . peek -- | @@ -63,17 +76,19 @@ -- -- {-# INLINEABLE getPtr #-} -getPtr :: Module -> String -> IO (DevicePtr a, Int) +getPtr :: Module -> ShortByteString -> IO (DevicePtr a, Int) getPtr !mdl !name = do (!status,!dptr,!bytes) <- cuModuleGetGlobal mdl name resultIfFound "global" name (status,(dptr,bytes)) {-# INLINE cuModuleGetGlobal #-} {# fun unsafe cuModuleGetGlobal - { alloca- `DevicePtr a' peekDeviceHandle* - , alloca- `Int' peekIntConv* - , useModule `Module' - , withCString* `String' } -> `Status' cToEnum #} + { alloca- `DevicePtr a' peekDeviceHandle* + , alloca- `Int' peekIntConv* + , useModule `Module' + , useAsCString* `ShortByteString' + } + -> `Status' cToEnum #} -- | @@ -84,14 +99,16 @@ -- -- {-# INLINEABLE getTex #-} -getTex :: Module -> String -> IO Texture +getTex :: Module -> ShortByteString -> 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 #} + { alloca- `Texture' peekTex* + , useModule `Module' + , useAsCString* `ShortByteString' + } + -> `Status' cToEnum #} -------------------------------------------------------------------------------- @@ -99,10 +116,38 @@ -------------------------------------------------------------------------------- {-# INLINE resultIfFound #-} -resultIfFound :: String -> String -> (Status, a) -> IO a +resultIfFound :: String -> ShortByteString -> (Status, a) -> IO a resultIfFound kind name (!status,!result) = case status of Success -> return result - NotFound -> cudaError (kind ++ ' ' : describe status ++ ": " ++ name) + NotFound -> cudaErrorIO (kind ++ ' ' : describe status ++ ": " ++ unpack name) _ -> throwIO (ExitCode status) + + +-- Utilities +-- --------- + +-- [Short]ByteStrings are not null-terminated, so can't be passed directly to C. +-- +-- unsafeUseAsCString :: ShortByteString -> CString +-- unsafeUseAsCString (BI.SBS ba#) = Ptr (byteArrayContents# ba#) + +{-# INLINE useAsCString #-} +useAsCString :: ShortByteString -> (CString -> IO a) -> IO a +useAsCString (BI.SBS ba#) action = IO $ \s0 -> + case sizeofByteArray# ba# of { n# -> + case newPinnedByteArray# (n# +# 1#) s0 of { (# s1, mba# #) -> + case byteArrayContents# (unsafeCoerce# mba#) of { addr# -> + case copyByteArrayToAddr# ba# 0# addr# n# s1 of { s2 -> + case writeWord8OffAddr# addr# n# 0## s2 of { s3 -> + case action (Ptr addr#) of { IO action' -> + case action' s3 of { (# s4, r #) -> + case touch# mba# s4 of { s5 -> + (# s5, r #) + }}}}}}}} + + +{-# INLINE unpack #-} +unpack :: ShortByteString -> [Char] +unpack = P.map BI.w2c . BS.unpack diff --git a/src/Foreign/CUDA/Driver/Profiler.chs b/src/Foreign/CUDA/Driver/Profiler.chs --- a/src/Foreign/CUDA/Driver/Profiler.chs +++ b/src/Foreign/CUDA/Driver/Profiler.chs @@ -2,7 +2,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Driver.Profiler --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2018] Trevor L. McDonell -- License : BSD -- -- Profiler control for low-level driver interface diff --git a/src/Foreign/CUDA/Driver/Stream.chs b/src/Foreign/CUDA/Driver/Stream.chs --- a/src/Foreign/CUDA/Driver/Stream.chs +++ b/src/Foreign/CUDA/Driver/Stream.chs @@ -1,11 +1,15 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE MagicHash #-} {-# LANGUAGE TemplateHaskell #-} +#ifdef USE_EMPTY_CASE +{-# LANGUAGE EmptyCase #-} +#endif -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Driver.Stream --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2018] Trevor L. McDonell -- License : BSD -- -- Stream management for low-level driver interface @@ -15,11 +19,16 @@ module Foreign.CUDA.Driver.Stream ( -- * Stream Management - Stream(..), StreamFlag(..), StreamWriteFlag(..), StreamWaitFlag(..), - create, createWithPriority, destroy, finished, block, getPriority, + Stream(..), StreamPriority, StreamCallback, + StreamFlag(..), StreamWriteFlag(..), StreamWaitFlag(..), StreamCallbackFlag, + + create, createWithPriority, destroy, finished, block, callback, + getFlags, getPriority, getContext, write, wait, defaultStream, + defaultStreamLegacy, + defaultStreamPerThread, ) where @@ -28,19 +37,101 @@ -- Friends import Foreign.CUDA.Ptr -import Foreign.CUDA.Types import Foreign.CUDA.Driver.Error +import Foreign.CUDA.Driver.Context.Base ( Context(..) ) import Foreign.CUDA.Internal.C2HS -- System -import Control.Exception ( throwIO ) -import Control.Monad ( liftM ) +import Control.Exception ( throwIO ) +import Control.Monad ( liftM ) import Foreign import Foreign.C import Unsafe.Coerce +import GHC.Base +import GHC.Ptr +import GHC.Word + -------------------------------------------------------------------------------- +-- Data Types +-------------------------------------------------------------------------------- + +-- | +-- A processing stream. All operations in a stream are synchronous and executed +-- in sequence, but operations in different non-default streams may happen +-- out-of-order or concurrently with one another. +-- +-- Use 'Event's to synchronise operations between streams. +-- +newtype Stream = Stream { useStream :: {# type CUstream #}} + deriving (Eq, Show) + +-- | +-- Priority of an execution stream. Work submitted to a higher priority +-- stream may preempt execution of work already executing in a lower +-- priority stream. Lower numbers represent higher priorities. +-- +type StreamPriority = Int + +-- | +-- Execution stream creation flags +-- +#if CUDA_VERSION < 8000 +data StreamFlag +data StreamWriteFlag +data StreamWaitFlag + +instance Enum StreamFlag where +#ifdef USE_EMPTY_CASE + toEnum x = error ("StreamFlag.toEnum: Cannot match " ++ show x) + fromEnum x = case x of {} +#endif + +instance Enum StreamWriteFlag where +#ifdef USE_EMPTY_CASE + toEnum x = error ("StreamWriteFlag.toEnum: Cannot match " ++ show x) + fromEnum x = case x of {} +#endif + +instance Enum StreamWaitFlag where +#ifdef USE_EMPTY_CASE + toEnum x = error ("StreamWaitFlag.toEnum: Cannot match " ++ show x) + fromEnum x = case x of {} +#endif + +#else +{# enum CUstream_flags as StreamFlag + { underscoreToCase } + with prefix="CU_STREAM" deriving (Eq, Show, Bounded) #} + +{# enum CUstreamWriteValue_flags as StreamWriteFlag + { underscoreToCase } + with prefix="CU_STREAM" deriving (Eq, Show, Bounded) #} + +{# enum CUstreamWaitValue_flags as StreamWaitFlag + { underscoreToCase } + with prefix="CU_STREAM" deriving (Eq, Show, Bounded) #} +#endif + + +-- | A 'Stream' callback function +-- +-- +-- +-- @since 0.10.0.0 +-- +type StreamCallback = {# type CUstreamCallback #} + +data StreamCallbackFlag +instance Enum StreamCallbackFlag where +#ifdef USE_EMPTY_CASE + toEnum x = error ("StreamCallbackFlag.toEnum: Cannot match " ++ show x) + fromEnum x = case x of {} +#endif + + +-------------------------------------------------------------------------------- -- Stream management -------------------------------------------------------------------------------- @@ -88,7 +179,7 @@ {# fun unsafe cuStreamCreateWithPriority { alloca- `Stream' peekStream* , combineBitMasks `[StreamFlag]' - , cIntConv `StreamPriority' + , fromIntegral `StreamPriority' } -> `Status' cToEnum #} where @@ -169,17 +260,48 @@ #endif +-- | Query the flags of a given stream +-- +-- +-- +-- @since 0.10.0.0 +-- +{-# INLINEABLE getFlags #-} +{# fun unsafe cuStreamGetFlags as getFlags + { useStream `Stream' + , alloca- `[StreamFlag]' extract* + } + -> `()' checkStatus*- #} + where #if CUDA_VERSION < 8000 -data StreamWriteFlag -data StreamWaitFlag + extract _ = return [] #else -{# enum CUstreamWriteValue_flags as StreamWriteFlag - { underscoreToCase } - with prefix="CU_STREAM" deriving (Eq, Show, Bounded) #} + extract p = extractBitMasks `fmap` peek p +#endif -{# enum CUstreamWaitValue_flags as StreamWaitFlag - { underscoreToCase } - with prefix="CU_STREAM" deriving (Eq, Show, Bounded) #} + +-- | +-- Query the context associated with a stream +-- +-- Requires CUDA-9.2. +-- +-- +-- +-- @since 0.10.0.0 +-- +{-# INLINEABLE getContext #-} +getContext :: Stream -> IO Context +#if CUDA_VERSION < 9020 +getContext _ = requireSDK 'getContext 9.2 +#else +getContext !st = resultIfOk =<< cuStreamGetCtx st + +{-# INLINE cuStreamGetCtx #-} +{# fun unsafe cuStreamGetCtx + { useStream `Stream' + , alloca- `Context' peekCtx* } -> `Status' cToEnum #} + where + peekCtx = liftM Context . peek #endif @@ -201,7 +323,7 @@ case sizeOf val of 4 -> write32 (castDevPtr ptr) (unsafeCoerce val) stream flags 8 -> write64 (castDevPtr ptr) (unsafeCoerce val) stream flags - _ -> cudaError "Stream.write: can only write 32- and 64-bit values" + _ -> cudaErrorIO "Stream.write: can only write 32- and 64-bit values" {-# INLINE write32 #-} write32 :: DevicePtr Word32 -> Word32 -> Stream -> [StreamWriteFlag] -> IO () @@ -218,8 +340,6 @@ , combineBitMasks `[StreamWriteFlag]' } -> `Status' cToEnum #} - where - useDeviceHandle = fromIntegral . ptrToIntPtr . useDevicePtr #endif {-# INLINE write64 #-} @@ -237,8 +357,6 @@ , combineBitMasks `[StreamWriteFlag]' } -> `Status' cToEnum #} - where - useDeviceHandle = fromIntegral . ptrToIntPtr . useDevicePtr #endif @@ -259,7 +377,7 @@ case sizeOf val of 4 -> wait32 (castDevPtr ptr) (unsafeCoerce val) stream flags 8 -> wait64 (castDevPtr ptr) (unsafeCoerce val) stream flags - _ -> cudaError "Stream.wait: can only wait on 32- and 64-bit values" + _ -> cudaErrorIO "Stream.wait: can only wait on 32- and 64-bit values" {-# INLINE wait32 #-} wait32 :: DevicePtr Word32 -> Word32 -> Stream -> [StreamWaitFlag] -> IO () @@ -275,8 +393,6 @@ , `Word32' , combineBitMasks `[StreamWaitFlag]' } -> `Status' cToEnum #} - where - useDeviceHandle = fromIntegral . ptrToIntPtr . useDevicePtr #endif {-# INLINE wait64 #-} @@ -293,7 +409,70 @@ , `Word64' , combineBitMasks `[StreamWaitFlag]' } -> `Status' cToEnum #} - where - useDeviceHandle = fromIntegral . ptrToIntPtr . useDevicePtr #endif + + +-- | Add a callback to a compute stream. This function will be executed on the +-- host after all currently queued items in the stream have completed. +-- +-- +-- +-- @since 0.10.0.0 +-- +{-# INLINEABLE callback #-} +{# fun unsafe cuStreamAddCallback as callback + { useStream `Stream' + , id `StreamCallback' + , id `Ptr ()' + , combineBitMasks `[StreamCallbackFlag]' + } -> `()' checkStatus*- #} + + +-- | The default execution stream. This can be configured to have either +-- 'defaultStreamLegacy' or 'defaultStreamPerThread' synchronisation behaviour. +-- +-- +-- +{-# INLINE defaultStream #-} +defaultStream :: Stream +defaultStream = Stream (Ptr (int2Addr# 0#)) + + +-- | The legacy default stream is an implicit stream which synchronises with all +-- other streams in the same 'Context', except for non-blocking streams. +-- +-- +-- +-- @since 0.10.0.0 +-- +{-# INLINE defaultStreamLegacy #-} +defaultStreamLegacy :: Stream +defaultStreamLegacy = Stream (Ptr (int2Addr# 0x1#)) + + +-- | The per-thread default stream is an implicit stream local to both the +-- thread and the calling 'Context', and which does not synchronise with other +-- streams (just like explicitly created streams). The per-thread default stream +-- is not a non-blocking stream and will synchronise with the legacy default +-- stream if both are used in the same program. +-- +-- +-- +-- @since 0.10.0.0 +-- +{-# INLINE defaultStreamPerThread #-} +defaultStreamPerThread :: Stream +defaultStreamPerThread = Stream (Ptr (int2Addr# 0x2#)) + + +-------------------------------------------------------------------------------- +-- Internal +-------------------------------------------------------------------------------- + +-- Use a device pointer as an opaque handle type +-- +{-# INLINE useDeviceHandle #-} +useDeviceHandle :: DevicePtr a -> {# type CUdeviceptr #} +useDeviceHandle (DevicePtr (Ptr addr#)) = + CULLong (W64# (int2Word# (addr2Int# addr#))) diff --git a/src/Foreign/CUDA/Driver/Texture.chs b/src/Foreign/CUDA/Driver/Texture.chs --- a/src/Foreign/CUDA/Driver/Texture.chs +++ b/src/Foreign/CUDA/Driver/Texture.chs @@ -4,7 +4,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Driver.Texture --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2018] Trevor L. McDonell -- License : BSD -- -- Texture management for low-level driver interface diff --git a/src/Foreign/CUDA/Driver/Unified.chs b/src/Foreign/CUDA/Driver/Unified.chs --- a/src/Foreign/CUDA/Driver/Unified.chs +++ b/src/Foreign/CUDA/Driver/Unified.chs @@ -8,7 +8,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Driver.Unified --- Copyright : [2017] Trevor L. McDonell +-- Copyright : [2017..2018] Trevor L. McDonell -- License : BSD -- -- Unified addressing functions for the low-level driver interface @@ -101,7 +101,7 @@ import Foreign.CUDA.Driver.Error import Foreign.CUDA.Driver.Marshal import Foreign.CUDA.Internal.C2HS -import Foreign.CUDA.Types +import Foreign.CUDA.Ptr -- System import Control.Applicative diff --git a/src/Foreign/CUDA/Driver/Utils.chs b/src/Foreign/CUDA/Driver/Utils.chs --- a/src/Foreign/CUDA/Driver/Utils.chs +++ b/src/Foreign/CUDA/Driver/Utils.chs @@ -2,7 +2,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Driver.Utils --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2018] Trevor L. McDonell -- License : BSD -- -- Utility functions diff --git a/src/Foreign/CUDA/Internal/C2HS.hs b/src/Foreign/CUDA/Internal/C2HS.hs --- a/src/Foreign/CUDA/Internal/C2HS.hs +++ b/src/Foreign/CUDA/Internal/C2HS.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE MagicHash #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -- C->Haskell Compiler: Marshalling library -- -- Copyright (c) [1999...2005] Manuel M T Chakravarty @@ -56,7 +58,11 @@ import Foreign.C import Control.Monad ( liftM ) +import GHC.Int +import GHC.Word +import GHC.Base + -- Composite marshalling functions -- ------------------------------- @@ -189,19 +195,40 @@ cIntConv :: (Integral a, Integral b) => a -> b cIntConv = fromIntegral +-- This is enough to fix the missing specialisation for mallocArray, but perhaps +-- we should implement a more general solution which avoids the use of +-- fromIntegral entirely (in particular, without relying on orphan instances). +-- +{-# RULES + "fromIntegral/Int->CInt" fromIntegral = \(I# i#) -> CInt (I32# (narrow32Int# i#)) ; + "fromIntegral/Int->CLLong" fromIntegral = \(I# i#) -> CLLong (I64# i#) ; + #-} +{-# RULES + "fromIntegral/Int->CUInt" fromIntegral = \(I# i#) -> CUInt (W32# (narrow32Word# (int2Word# i#))) ; + "fromIntegral/Int->CULLong" fromIntegral = \(I# i#) -> CULLong (W64# (int2Word# i#)) ; + #-} + + -- The C 'long' type might be 32- or 64-bits wide + -- + -- "fromIntegral/Int->CLong" fromIntegral = \(I# i#) -> CLong (I64# i#) ; + -- "fromIntegral/Int->CULong" fromIntegral = \(I# i#) -> CULong (W64# (int2Word# i#)) ; + -- |Floating conversion -- {-# INLINE [1] cFloatConv #-} cFloatConv :: (RealFloat a, RealFloat b) => a -> b cFloatConv = realToFrac + -- As this conversion by default goes via `Rational', it can be very slow... {-# RULES - "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 + "realToFrac/Float->Float" realToFrac = \(x::Float) -> x ; + "realToFrac/Float->CFloat" realToFrac = \(x::Float) -> CFloat x ; + "realToFrac/CFloat->Float" realToFrac = \(CFloat x) -> x ; + #-} +{-# RULES + "realToFrac/Double->Double" realToFrac = \(x::Double) -> x; + "realToFrac/Double->CDouble" realToFrac = \(x::Double) -> CDouble x ; + "realToFrac/CDouble->Double" realToFrac = \(CDouble x) -> x ; #-} -- |Obtain C value from Haskell 'Bool'. diff --git a/src/Foreign/CUDA/Path.chs b/src/Foreign/CUDA/Path.chs --- a/src/Foreign/CUDA/Path.chs +++ b/src/Foreign/CUDA/Path.chs @@ -2,7 +2,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Path --- Copyright : [2017] Trevor L. McDonell +-- Copyright : [2017..2018] Trevor L. McDonell -- License : BSD -- -------------------------------------------------------------------------------- diff --git a/src/Foreign/CUDA/Ptr.hs b/src/Foreign/CUDA/Ptr.hs --- a/src/Foreign/CUDA/Ptr.hs +++ b/src/Foreign/CUDA/Ptr.hs @@ -2,7 +2,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Ptr --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2018] Trevor L. McDonell -- License : BSD -- -- Data pointers on the host and device. These can be shared freely between the @@ -36,10 +36,6 @@ ) where --- friends -import Foreign.CUDA.Types - --- system import Foreign.Ptr import Foreign.Storable @@ -49,6 +45,22 @@ -------------------------------------------------------------------------------- -- | +-- A reference to data stored on the device. +-- +newtype DevicePtr a = DevicePtr { useDevicePtr :: Ptr a } + deriving (Eq,Ord) + +instance Show (DevicePtr a) where + showsPrec n (DevicePtr p) = showsPrec n p + +instance Storable (DevicePtr a) where + sizeOf _ = sizeOf (undefined :: Ptr a) + alignment _ = alignment (undefined :: Ptr a) + peek p = DevicePtr `fmap` peek (castPtr p) + poke p v = poke (castPtr p) (useDevicePtr v) + + +-- | -- Look at the contents of device memory. This takes an IO action that will be -- applied to that pointer, the result of which is returned. It would be silly -- to return the pointer from the action. @@ -125,6 +137,32 @@ -------------------------------------------------------------------------------- -- Host Pointer -------------------------------------------------------------------------------- + +-- | +-- A reference to page-locked host memory. +-- +-- A 'HostPtr' is just a plain 'Ptr', but the memory has been allocated by CUDA +-- into page locked memory. This means that the data can be copied to the GPU +-- via DMA (direct memory access). Note that the use of the system function +-- `mlock` is not sufficient here --- the CUDA version ensures that the +-- /physical/ address stays this same, not just the virtual address. +-- +-- To copy data into a 'HostPtr' array, you may use for example 'withHostPtr' +-- together with 'Foreign.Marshal.Array.copyArray' or +-- 'Foreign.Marshal.Array.moveArray'. +-- +newtype HostPtr a = HostPtr { useHostPtr :: Ptr a } + deriving (Eq,Ord) + +instance Show (HostPtr a) where + showsPrec n (HostPtr p) = showsPrec n p + +instance Storable (HostPtr a) where + sizeOf _ = sizeOf (undefined :: Ptr a) + alignment _ = alignment (undefined :: Ptr a) + peek p = HostPtr `fmap` peek (castPtr p) + poke p v = poke (castPtr p) (useHostPtr v) + -- | -- Apply an IO action to the memory reference living inside the host pointer diff --git a/src/Foreign/CUDA/Runtime.hs b/src/Foreign/CUDA/Runtime.hs --- a/src/Foreign/CUDA/Runtime.hs +++ b/src/Foreign/CUDA/Runtime.hs @@ -1,7 +1,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Runtime --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2018] Trevor L. McDonell -- License : BSD -- -- Top level bindings to the C-for-CUDA runtime API diff --git a/src/Foreign/CUDA/Runtime/Device.chs b/src/Foreign/CUDA/Runtime/Device.chs --- a/src/Foreign/CUDA/Runtime/Device.chs +++ b/src/Foreign/CUDA/Runtime/Device.chs @@ -2,6 +2,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-orphans #-} #ifdef USE_EMPTY_CASE @@ -10,7 +11,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Runtime.Device --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2018] Trevor L. McDonell -- License : BSD -- -- Device management routines @@ -42,8 +43,10 @@ import Foreign.CUDA.Internal.C2HS -- System +import Control.Applicative import Foreign import Foreign.C +import Prelude #c typedef struct cudaDeviceProp cudaDeviceProp; @@ -86,117 +89,84 @@ 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 + deviceName <- peekCString =<< {#get cudaDeviceProp.name#} p + computeCapability <- Compute <$> (fromIntegral <$> {#get cudaDeviceProp.major#} p) + <*> (fromIntegral <$> {#get cudaDeviceProp.minor#} p) + totalGlobalMem <- cIntConv <$> {#get cudaDeviceProp.totalGlobalMem#} p + sharedMemPerBlock <- cIntConv <$> {#get cudaDeviceProp.sharedMemPerBlock#} p + regsPerBlock <- cIntConv <$> {#get cudaDeviceProp.regsPerBlock#} p + warpSize <- cIntConv <$> {#get cudaDeviceProp.warpSize#} p + memPitch <- cIntConv <$> {#get cudaDeviceProp.memPitch#} p + maxThreadsPerBlock <- cIntConv <$> {#get cudaDeviceProp.maxThreadsPerBlock#} p + clockRate <- cIntConv <$> {#get cudaDeviceProp.clockRate#} p + totalConstMem <- cIntConv <$> {#get cudaDeviceProp.totalConstMem#} p + textureAlignment <- cIntConv <$> {#get cudaDeviceProp.textureAlignment#} p + deviceOverlap <- cToBool <$> {#get cudaDeviceProp.deviceOverlap#} p + multiProcessorCount <- cIntConv <$> {#get cudaDeviceProp.multiProcessorCount#} p + kernelExecTimeoutEnabled <- cToBool <$> {#get cudaDeviceProp.kernelExecTimeoutEnabled#} p + integrated <- cToBool <$> {#get cudaDeviceProp.integrated#} p + canMapHostMemory <- cToBool <$> {#get cudaDeviceProp.canMapHostMemory#} p + computeMode <- cToEnum <$> {#get cudaDeviceProp.computeMode#} p #if CUDART_VERSION >= 3000 - ck <- cToBool `fmap` {#get cudaDeviceProp.concurrentKernels#} p - u1 <- cIntConv `fmap` {#get cudaDeviceProp.maxTexture1D#} p + concurrentKernels <- cToBool <$> {#get cudaDeviceProp.concurrentKernels#} p + maxTextureDim1D <- cIntConv <$> {#get cudaDeviceProp.maxTexture1D#} p #endif +#if CUDART_VERSION >= 3000 && CUDART_VERSION < 3010 + -- XXX: not visible from CUDA runtime API 3.0 (only accessible from the driver API) + let eccEnabled = False +#endif #if CUDART_VERSION >= 3010 - ee <- cToBool `fmap` {#get cudaDeviceProp.ECCEnabled#} p + eccEnabled <- cToBool <$> {#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 + asyncEngineCount <- cIntConv <$> {#get cudaDeviceProp.asyncEngineCount#} p + cacheMemL2 <- cIntConv <$> {#get cudaDeviceProp.l2CacheSize#} p + maxThreadsPerMultiProcessor <- cIntConv <$> {#get cudaDeviceProp.maxThreadsPerMultiProcessor#} p + memBusWidth <- cIntConv <$> {#get cudaDeviceProp.memoryBusWidth#} p + memClockRate <- cIntConv <$> {#get cudaDeviceProp.memoryClockRate#} p + pciInfo <- PCI <$> (cIntConv <$> {#get cudaDeviceProp.pciBusID#} p) + <*> (cIntConv <$> {#get cudaDeviceProp.pciDeviceID#} p) + <*> (cIntConv <$> {#get cudaDeviceProp.pciDomainID#} p) + tccDriverEnabled <- cToBool <$> {#get cudaDeviceProp.tccDriver#} p + unifiedAddressing <- cToBool <$> {#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 + [t1,t2,t3] <- peekArrayWith cIntConv 3 =<< {#get cudaDeviceProp.maxThreadsDim#} p + [g1,g2,g3] <- peekArrayWith cIntConv 3 =<< {#get cudaDeviceProp.maxGridSize#} p + let maxBlockSize = (t1,t2,t3) + maxGridSize = (g1,g2,g3) #if CUDART_VERSION >= 3000 - [u21,u22] <- peekArrayWith cIntConv 2 =<< {#get cudaDeviceProp.maxTexture2D#} p - [u31,u32,u33] <- peekArrayWith cIntConv 3 =<< {#get cudaDeviceProp.maxTexture3D#} p + [u21,u22] <- peekArrayWith cIntConv 2 =<< {#get cudaDeviceProp.maxTexture2D#} p + [u31,u32,u33] <- peekArrayWith cIntConv 3 =<< {#get cudaDeviceProp.maxTexture3D#} p + let maxTextureDim2D = (u21,u22) + maxTextureDim3D = (u31,u32,u33) #endif #if CUDART_VERSION >= 5050 - sp <- cToBool `fmap` {#get cudaDeviceProp.streamPrioritiesSupported#} p + streamPriorities <- cToBool <$> {#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 + globalL1Cache <- cToBool <$> {#get cudaDeviceProp.globalL1CacheSupported#} p + localL1Cache <- cToBool <$> {#get cudaDeviceProp.localL1CacheSupported#} p + managedMemory <- cToBool <$> {#get cudaDeviceProp.managedMemory#} p + multiGPUBoard <- cToBool <$> {#get cudaDeviceProp.isMultiGpuBoard#} p + multiGPUBoardGroupID <- cIntConv <$> {#get cudaDeviceProp.multiGpuBoardGroupID#} p #endif -#if CUDART_VERSION >= 4000 - , asyncEngineCount = ae - , cacheMemL2 = l2 - , maxThreadsPerMultiProcessor = tm - , memBusWidth = mw - , memClockRate = mc - , tccDriverEnabled = tc - , unifiedAddressing = ua - , pciInfo = PCI pb pd pm +#if CUDART_VERSION >= 8000 +#if CUDART_VERSION == 8000 + -- XXX: Not visible from the CUDA runtime API 8.0 (only accessible from the driver API) + let preemption = False +#else + preemption <- cToBool <$> {#get cudaDeviceProp.computePreemptionSupported#} p #endif -#if CUDA_VERSION >= 5050 - , streamPriorities = sp + singleToDoublePerfRatio <- cIntConv <$> {#get cudaDeviceProp.singleToDoublePrecisionPerfRatio#} p #endif -#if CUDA_VERSION >= 6000 - , globalL1Cache = gl1 - , localL1Cache = ll1 - , managedMemory = mm - , multiGPUBoard = mg - , multiGPUBoardGroupID = mid +#if CUDART_VERSION >= 9000 + cooperativeLaunch <- cToBool <$> {#get cudaDeviceProp.cooperativeLaunch#} p + cooperativeLaunchMultiDevice <- cToBool <$> {#get cudaDeviceProp.cooperativeMultiDeviceLaunch#} p #endif - } + return DeviceProperties{..} + -------------------------------------------------------------------------------- -- Device Management -------------------------------------------------------------------------------- @@ -340,7 +310,7 @@ data PeerFlag instance Enum PeerFlag where #ifdef USE_EMPTY_CASE - toEnum x = case x of {} + toEnum x = error ("PeerFlag.toEnum: Cannot match " ++ show x) fromEnum x = case x of {} #endif diff --git a/src/Foreign/CUDA/Runtime/Error.chs b/src/Foreign/CUDA/Runtime/Error.chs --- a/src/Foreign/CUDA/Runtime/Error.chs +++ b/src/Foreign/CUDA/Runtime/Error.chs @@ -4,7 +4,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Runtime.Error --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2018] Trevor L. McDonell -- License : BSD -- -- Error handling functions diff --git a/src/Foreign/CUDA/Runtime/Event.chs b/src/Foreign/CUDA/Runtime/Event.chs --- a/src/Foreign/CUDA/Runtime/Event.chs +++ b/src/Foreign/CUDA/Runtime/Event.chs @@ -6,7 +6,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Driver.Event --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2018] Trevor L. McDonell -- License : BSD -- -- Event management for C-for-CUDA runtime environment @@ -25,16 +25,17 @@ {# context lib="cudart" #} -- Friends -import Foreign.CUDA.Types -import Foreign.CUDA.Runtime.Error +import Foreign.CUDA.Driver.Event ( Event(..), EventFlag(..), WaitFlag ) +import Foreign.CUDA.Driver.Stream ( Stream(..), defaultStream ) import Foreign.CUDA.Internal.C2HS +import Foreign.CUDA.Runtime.Error -- System import Foreign import Foreign.C -import Control.Monad ( liftM ) -import Control.Exception ( throwIO ) -import Data.Maybe ( fromMaybe ) +import Control.Monad ( liftM ) +import Control.Exception ( throwIO ) +import Data.Maybe ( fromMaybe ) -------------------------------------------------------------------------------- diff --git a/src/Foreign/CUDA/Runtime/Exec.chs b/src/Foreign/CUDA/Runtime/Exec.chs --- a/src/Foreign/CUDA/Runtime/Exec.chs +++ b/src/Foreign/CUDA/Runtime/Exec.chs @@ -6,7 +6,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Runtime.Exec --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2018] Trevor L. McDonell -- License : BSD -- -- Kernel execution control for C-for-CUDA runtime interface diff --git a/src/Foreign/CUDA/Runtime/Marshal.chs b/src/Foreign/CUDA/Runtime/Marshal.chs --- a/src/Foreign/CUDA/Runtime/Marshal.chs +++ b/src/Foreign/CUDA/Runtime/Marshal.chs @@ -5,7 +5,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Runtime.Marshal --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2018] Trevor L. McDonell -- License : BSD -- -- Memory management for CUDA devices diff --git a/src/Foreign/CUDA/Runtime/Stream.chs b/src/Foreign/CUDA/Runtime/Stream.chs --- a/src/Foreign/CUDA/Runtime/Stream.chs +++ b/src/Foreign/CUDA/Runtime/Stream.chs @@ -3,7 +3,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Runtime.Stream --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2018] Trevor L. McDonell -- License : BSD -- -- Stream management routines @@ -14,23 +14,25 @@ -- * Stream Management Stream(..), - create, destroy, finished, block, defaultStream + create, destroy, finished, block, + defaultStream, defaultStreamLegacy, defaultStreamPerThread, + ) where #include "cbits/stubs.h" {# context lib="cudart" #} -- Friends -import Foreign.CUDA.Types -import Foreign.CUDA.Runtime.Error +import Foreign.CUDA.Driver.Stream ( Stream(..), defaultStream, defaultStreamLegacy, defaultStreamPerThread ) import Foreign.CUDA.Internal.C2HS +import Foreign.CUDA.Runtime.Error -- System import Foreign import Foreign.C -import Control.Monad ( liftM ) -import Control.Exception ( throwIO ) +import Control.Monad ( liftM ) +import Control.Exception ( throwIO ) -------------------------------------------------------------------------------- diff --git a/src/Foreign/CUDA/Runtime/Texture.chs b/src/Foreign/CUDA/Runtime/Texture.chs --- a/src/Foreign/CUDA/Runtime/Texture.chs +++ b/src/Foreign/CUDA/Runtime/Texture.chs @@ -3,7 +3,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Runtime.Texture --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2018] Trevor L. McDonell -- License : BSD -- -- Texture references diff --git a/src/Foreign/CUDA/Runtime/Utils.chs b/src/Foreign/CUDA/Runtime/Utils.chs --- a/src/Foreign/CUDA/Runtime/Utils.chs +++ b/src/Foreign/CUDA/Runtime/Utils.chs @@ -2,7 +2,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Runtime.Utils --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2018] Trevor L. McDonell -- License : BSD -- -- Utility functions diff --git a/src/Foreign/CUDA/Types.chs b/src/Foreign/CUDA/Types.chs deleted file mode 100644 --- a/src/Foreign/CUDA/Types.chs +++ /dev/null @@ -1,165 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE EmptyDataDecls #-} -#ifdef USE_EMPTY_CASE -{-# LANGUAGE EmptyCase #-} -#endif --------------------------------------------------------------------------------- --- | --- Module : Foreign.CUDA.Types --- Copyright : [2009..2017] Trevor L. McDonell --- License : BSD --- --- Data types that are equivalent and can be shared freely between the CUDA --- Runtime and Driver APIs. --- --------------------------------------------------------------------------------- - -module Foreign.CUDA.Types ( - - -- * Pointers - DevicePtr(..), HostPtr(..), - - -- * Events - Event(..), EventFlag(..), WaitFlag, - - -- * Streams - Stream(..), StreamFlag(..), StreamPriority, - 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 - , CU_EVENT_DEFAULT as EventDefault - } - 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 - --- | --- Execution stream creation flags --- -#if CUDA_VERSION < 7500 -data StreamFlag -instance Enum StreamFlag where -#ifdef USE_EMPTY_CASE - toEnum x = case x of {} - fromEnum x = case x of {} -#endif -#else -{# enum CUstream_flags as StreamFlag - { underscoreToCase - , CU_STREAM_DEFAULT as StreamDefault - } - with prefix="CU_STREAM" deriving (Eq, Show, Bounded) #} -#endif - - --- | --- The main execution stream. No operations overlap with operations in the --- default stream. --- -{-# INLINE defaultStream #-} -defaultStream :: Stream -defaultStream = Stream nullPtr -