diff --git a/Foreign/CUDA/Analysis/Device.chs b/Foreign/CUDA/Analysis/Device.chs --- a/Foreign/CUDA/Analysis/Device.chs +++ b/Foreign/CUDA/Analysis/Device.chs @@ -97,11 +97,9 @@ #endif kernelExecTimeoutEnabled :: !Bool, -- ^ Whether there is a runtime limit on kernels integrated :: !Bool, -- ^ As opposed to discrete -#if CUDA_VERSION >= 4000 canMapHostMemory :: !Bool, -- ^ Device can use pinned memory +#if CUDA_VERSION >= 4000 unifiedAddressing :: !Bool -- ^ Device shares a unified address space with the host -#else - canMapHostMemory :: !Bool -- ^ Device can use pinned memory #endif } deriving (Show) @@ -153,6 +151,7 @@ Compute 2 1 -> DeviceResources 32 1536 8 48 48 49152 128 32768 64 2 63 Warp -- Fermi GF10x Compute 3 0 -> DeviceResources 32 2048 16 64 192 49152 256 65536 256 4 63 Warp -- Kepler GK10x Compute 3 5 -> DeviceResources 32 2048 16 64 192 49152 256 65536 256 4 255 Warp -- Kepler GK11x + Compute 5 0 -> DeviceResources 32 2048 32 64 128 65536 256 65536 256 4 255 Warp -- Maxwell GM10x -- Something might have gone wrong, or the library just needs to be -- updated for the next generation of hardware, in which case we just want diff --git a/Foreign/CUDA/Driver/Error.chs b/Foreign/CUDA/Driver/Error.chs --- a/Foreign/CUDA/Driver/Error.chs +++ b/Foreign/CUDA/Driver/Error.chs @@ -1,5 +1,6 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ForeignFunctionInterface #-} -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Driver.Error @@ -13,10 +14,18 @@ module Foreign.CUDA.Driver.Error where +-- Friends +import Foreign.CUDA.Internal.C2HS -- System import Data.Typeable import Control.Exception +import Control.Monad +import Foreign.C +import Foreign.Ptr +import Foreign.Marshal +import Foreign.Storable +import System.IO.Unsafe #include "cbits/stubs.h" {# context lib="cuda" #} @@ -31,8 +40,11 @@ -- {# enum CUresult as Status { underscoreToCase - , CUDA_SUCCESS as Success - , CUDA_ERROR_NO_BINARY_FOR_GPU as NoBinaryForGPU } + , CUDA_SUCCESS as Success + , CUDA_ERROR_NO_BINARY_FOR_GPU as NoBinaryForGPU + , CUDA_ERROR_INVALID_PTX as InvalidPTX + , CUDA_ERROR_INVALID_PC as InvalidPC + } with prefix="CUDA_ERROR" deriving (Eq, Show) #} @@ -40,6 +52,17 @@ -- Return a descriptive error string associated with a particular error code -- describe :: Status -> String +#if CUDA_VERSION >= 6000 +describe status + = unsafePerformIO $ resultIfOk =<< cuGetErrorString status + +{# fun unsafe cuGetErrorString + { cFromEnum `Status' + , alloca- `String' ppeek* } -> `Status' cToEnum #} + where + ppeek = peek >=> peekCString + +#else describe Success = "no error" describe InvalidValue = "invalid argument" describe OutOfMemory = "out of memory" @@ -106,6 +129,7 @@ describe NotSupported = "not supported" #endif describe Unknown = "unknown error" +#endif -------------------------------------------------------------------------------- @@ -140,6 +164,7 @@ -------------------------------------------------------------------------------- -- Helper Functions -------------------------------------------------------------------------------- + -- | -- Return the results of a function on successful execution, otherwise throw an diff --git a/Foreign/CUDA/Driver/Exec.chs b/Foreign/CUDA/Driver/Exec.chs --- a/Foreign/CUDA/Driver/Exec.chs +++ b/Foreign/CUDA/Driver/Exec.chs @@ -67,7 +67,7 @@ -- Kernel function parameters -- data FunParam where - IArg :: !Int -> FunParam + IArg :: !Int32 -> FunParam FArg :: !Float -> FunParam VArg :: Storable a => !a -> FunParam @@ -302,7 +302,7 @@ {# fun unsafe cuParamSeti { useFun `Fun' , `Int' - , `Int' } -> `Status' cToEnum #} + , `Int32' } -> `Status' cToEnum #} {-# INLINE cuParamSetf #-} {# fun unsafe cuParamSetf diff --git a/Foreign/CUDA/Driver/Marshal.chs b/Foreign/CUDA/Driver/Marshal.chs --- a/Foreign/CUDA/Driver/Marshal.chs +++ b/Foreign/CUDA/Driver/Marshal.chs @@ -1,5 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# OPTIONS_HADDOCK prune #-} -------------------------------------------------------------------------------- @@ -21,6 +22,10 @@ -- * Device Allocation mallocArray, allocaArray, free, + -- * Unified Memory Allocation + AttachFlag(..), + mallocManagedArray, + -- * Marshalling peekArray, peekArrayAsync, peekListArray, pokeArray, pokeArrayAsync, pokeListArray, @@ -70,7 +75,17 @@ } CUmemhostalloc_option; #endc +#if CUDA_VERSION >= 6000 +#c +typedef enum CUmemAttachFlags_option_enum { + CU_MEM_ATTACH_OPTION_GLOBAL = CU_MEM_ATTACH_GLOBAL, + CU_MEM_ATTACH_OPTION_HOST = CU_MEM_ATTACH_HOST, + CU_MEM_ATTACH_OPTION_SINGLE = CU_MEM_ATTACH_SINGLE +} CUmemAttachFlags_option; +#endc +#endif + -------------------------------------------------------------------------------- -- Host Allocation -------------------------------------------------------------------------------- @@ -224,6 +239,45 @@ {-# INLINE cuMemFree #-} {# fun unsafe cuMemFree { useDeviceHandle `DevicePtr a' } -> `Status' cToEnum #} + + +-------------------------------------------------------------------------------- +-- Unified memory allocations +-------------------------------------------------------------------------------- + +-- | +-- Options for unified memory allocations +-- +#if CUDA_VERSION >= 6000 +{# enum CUmemAttachFlags_option as AttachFlag + { underscoreToCase } + with prefix="CU_MEM_ATTACH_OPTION" deriving (Eq, Show) #} +#else +data AttachFlag +#endif + +-- | +-- Allocates memory that will be automatically managed by the Unified Memory +-- system +-- +{-# INLINEABLE mallocManagedArray #-} +mallocManagedArray :: Storable a => [AttachFlag] -> Int -> IO (DevicePtr a) +#if CUDA_VERSION < 6000 +mallocManagedArray _ _ = requireSDK 6.0 "mallocManagedArray" +#else +mallocManagedArray !flags = doMalloc undefined + where + doMalloc :: Storable a' => a' -> Int -> IO (DevicePtr a') + doMalloc x !n = resultIfOk =<< cuMemAllocManaged (n * sizeOf x) flags + +{-# INLINE cuMemAllocManaged #-} +{# fun unsafe cuMemAllocManaged + { alloca'- `DevicePtr a' peekDeviceHandle* + , `Int' + , combineBitMasks `[AttachFlag]' } -> `Status' cToEnum #} + where + alloca' !f = F.alloca $ \ !p -> poke p nullPtr >> f (castPtr p) +#endif -------------------------------------------------------------------------------- diff --git a/Foreign/CUDA/Driver/Module.chs b/Foreign/CUDA/Driver/Module.chs --- a/Foreign/CUDA/Driver/Module.chs +++ b/Foreign/CUDA/Driver/Module.chs @@ -14,14 +14,23 @@ -- * Module Management Module, JITOption(..), JITTarget(..), JITResult(..), - getFun, getPtr, getTex, loadFile, loadData, loadDataEx, unload + -- ** Querying module inhabitants + getFun, getPtr, getTex, + + -- ** Loading and unloading modules + loadFile, + loadData, loadDataFromPtr, + loadDataEx, loadDataFromPtrEx, + unload + ) where #include "cbits/stubs.h" {# context lib="cuda" #} -- Friends +import Foreign.CUDA.Analysis.Device import Foreign.CUDA.Ptr import Foreign.CUDA.Driver.Error import Foreign.CUDA.Driver.Exec @@ -36,9 +45,14 @@ import Control.Monad (liftM) import Control.Exception (throwIO) +import Data.Maybe (mapMaybe) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Internal as B +#if CUDA_VERSION < 5050 +import Debug.Trace (trace) +#endif -------------------------------------------------------------------------------- -- Data Types @@ -48,6 +62,7 @@ -- A reference to a Module object, containing collections of device functions -- newtype Module = Module { useModule :: {# type CUmodule #}} + deriving (Eq, Show) -- | @@ -57,8 +72,11 @@ = MaxRegisters !Int -- ^ maximum number of registers per thread | ThreadsPerBlock !Int -- ^ number of threads per block to target for | OptimisationLevel !Int -- ^ level of optimisation to apply (1-4, default 4) - | Target !JITTarget -- ^ compilation target, otherwise determined from context --- | FallbackStrategy JITFallback + | Target !Compute -- ^ compilation target, otherwise determined from context + | FallbackStrategy !JITFallback -- ^ fallback strategy if matching cubin not found + | GenerateDebugInfo -- ^ generate debug info (-g) (requires cuda >= 5.5) + | GenerateLineInfo -- ^ generate line number information (-lineinfo) (requires cuda >= 5.5) + | Verbose -- ^ verbose log messages (requires cuda >= 5.5) deriving (Show) -- | @@ -67,8 +85,8 @@ data JITResult = JITResult { jitTime :: !Float, -- ^ milliseconds spent compiling PTX - jitInfoLog :: !ByteString, -- ^ information about PTX asembly - jitErrorLog :: !ByteString -- ^ compilation errors + jitInfoLog :: !ByteString, -- ^ information about PTX assembly + jitModule :: !Module -- ^ compilation error log or compiled module } deriving (Show) @@ -138,7 +156,7 @@ -- | -- Load the contents of the specified file (either a ptx or cubin file) to --- create a new module, and load that module into the current context +-- create a new module, and load that module into the current context. -- {-# INLINEABLE loadFile #-} loadFile :: FilePath -> IO Module @@ -152,60 +170,116 @@ -- | -- Load the contents of the given image into a new module, and load that module --- into the current context. The image (typically) is the contents of a cubin or --- ptx file as a NULL-terminated string. +-- into the current context. The image is (typically) the contents of a cubin or +-- PTX file. -- +-- Note that the 'ByteString' will be copied into a temporary staging area so +-- that it can be passed to C. +-- {-# INLINEABLE loadData #-} loadData :: ByteString -> IO Module -loadData !img = resultIfOk =<< cuModuleLoadData img +loadData !img = + B.useAsCString img (\p -> loadDataFromPtr (castPtr p)) +-- | +-- As 'loadData', but read the image data from the given pointer. The image is a +-- NULL-terminated sequence of bytes. +-- +{-# INLINEABLE loadDataFromPtr #-} +loadDataFromPtr :: Ptr Word8 -> IO Module +loadDataFromPtr !img = resultIfOk =<< cuModuleLoadData img + {-# INLINE cuModuleLoadData #-} {# fun unsafe cuModuleLoadData - { alloca- `Module' peekMod* - , useByteString* `ByteString' } -> ` Status' cToEnum #} + { alloca- `Module' peekMod* + , castPtr `Ptr Word8' } -> ` Status' cToEnum #} -- | --- Load a module with online compiler options. The actual attributes of the +-- Load the contents of the given image into a module with online compiler +-- options, and load the module into the current context. The image is +-- (typically) the contents of a cubin or PTX file. The actual attributes of the -- compiled kernel can be probed using 'requires'. -- +-- Note that the 'ByteString' will be copied into a temporary staging area so +-- that it can be passed to C. +-- {-# INLINEABLE loadDataEx #-} -loadDataEx :: ByteString -> [JITOption] -> IO (Module, JITResult) +loadDataEx :: ByteString -> [JITOption] -> IO JITResult loadDataEx !img !options = - allocaArray logSize $ \p_ilog -> - allocaArray logSize $ \p_elog -> + B.useAsCString img (\p -> loadDataFromPtrEx (castPtr p) options) + +-- | +-- As 'loadDataEx', but read the image data from the given pointer. The image is +-- a NULL-terminated sequence of bytes. +-- +{-# INLINEABLE loadDataFromPtrEx #-} +loadDataFromPtrEx :: Ptr Word8 -> [JITOption] -> IO JITResult +loadDataFromPtrEx !img !options = do + fp_ilog <- B.mallocByteString logSize + + allocaArray logSize $ \p_elog -> do + withForeignPtr fp_ilog $ \p_ilog -> do + let (opt,val) = unzip $ - [ (JIT_WALL_TIME, 0) -- must be first + [ (JIT_WALL_TIME, 0) -- must be first, this is extracted below , (JIT_INFO_LOG_BUFFER_SIZE_BYTES, logSize) , (JIT_ERROR_LOG_BUFFER_SIZE_BYTES, logSize) , (JIT_INFO_LOG_BUFFER, unsafeCoerce (p_ilog :: CString)) - , (JIT_ERROR_LOG_BUFFER, unsafeCoerce (p_elog :: CString)) ] ++ map unpack options in + , (JIT_ERROR_LOG_BUFFER, unsafeCoerce (p_elog :: CString)) ] ++ mapMaybe unpack options - withArray (map cFromEnum opt) $ \p_opts -> + withArray (map cFromEnum opt) $ \p_opts -> do withArray (map unsafeCoerce val) $ \p_vals -> do (s,mdl) <- cuModuleLoadDataEx img (length opt) p_opts p_vals - infoLog <- B.packCString p_ilog - errLog <- B.packCString p_elog - time <- peek (castPtr p_vals) - resultIfOk (s, (mdl, JITResult time infoLog errLog)) + case s of + Success -> do + time <- peek (castPtr p_vals) + infoLog <- B.fromForeignPtr (castForeignPtr fp_ilog) 0 `fmap` c_strnlen p_ilog logSize + return $! JITResult time infoLog mdl + + _ -> do + errLog <- peekCString p_elog + cudaError (unlines [describe s, errLog]) + where logSize = 2048 - unpack (MaxRegisters x) = (JIT_MAX_REGISTERS, x) - unpack (ThreadsPerBlock x) = (JIT_THREADS_PER_BLOCK, x) - unpack (OptimisationLevel x) = (JIT_OPTIMIZATION_LEVEL, x) - unpack (Target x) = (JIT_TARGET, fromEnum x) + unpack (MaxRegisters x) = Just (JIT_MAX_REGISTERS, x) + unpack (ThreadsPerBlock x) = Just (JIT_THREADS_PER_BLOCK, x) + unpack (OptimisationLevel x) = Just (JIT_OPTIMIZATION_LEVEL, x) + unpack (Target x) = Just (JIT_TARGET, jitTargetOfCompute x) + unpack (FallbackStrategy x) = Just (JIT_FALLBACK_STRATEGY, fromEnum x) +#if CUDA_VERSION >= 5050 + unpack GenerateDebugInfo = Just (JIT_GENERATE_DEBUG_INFO, fromEnum True) + unpack GenerateLineInfo = Just (JIT_GENERATE_LINE_INFO, fromEnum True) + unpack Verbose = Just (JIT_LOG_VERBOSE, fromEnum True) +#else + unpack x = trace ("Warning: JITOption '" ++ show x ++ "' requires at least cuda-5.5") Nothing +#endif + jitTargetOfCompute (Compute x y) + = fromEnum + $ case (x,y) of + (1,0) -> Compute10 + (1,1) -> Compute11 + (1,2) -> Compute12 + (1,3) -> Compute13 + (2,0) -> Compute20 + (2,1) -> Compute21 + (3,0) -> Compute30 + (3,5) -> Compute35 + _ -> error ("Unknown JIT Target for Compute " ++ show (Compute x y)) + {-# INLINE cuModuleLoadDataEx #-} {# fun unsafe cuModuleLoadDataEx - { alloca- `Module' peekMod* - , useByteString* `ByteString' - , `Int' - , id `Ptr CInt' - , id `Ptr (Ptr ())' } -> `Status' cToEnum #} + { alloca- `Module' peekMod* + , castPtr `Ptr Word8' + , `Int' + , id `Ptr CInt' + , id `Ptr (Ptr ())' } -> `Status' cToEnum #} -- | @@ -236,7 +310,11 @@ peekMod :: Ptr {# type CUmodule #} -> IO Module peekMod = liftM Module . peek -{-# INLINE useByteString #-} -useByteString :: ByteString -> (Ptr a -> IO b) -> IO b -useByteString !bs !act = B.useAsCString bs $ \ !p -> act (castPtr p) +{-# INLINE c_strnlen' #-} +foreign import ccall unsafe "string.h strnlen" c_strnlen' + :: CString -> CSize -> IO CSize + +{-# INLINE c_strnlen #-} +c_strnlen :: CString -> Int -> IO Int +c_strnlen str maxlen = cIntConv `fmap` c_strnlen' str (cIntConv maxlen) diff --git a/Foreign/CUDA/Runtime/Error.chs b/Foreign/CUDA/Runtime/Error.chs --- a/Foreign/CUDA/Runtime/Error.chs +++ b/Foreign/CUDA/Runtime/Error.chs @@ -20,13 +20,12 @@ ) where - -- Friends import Foreign.CUDA.Internal.C2HS -- System -import Foreign hiding ( unsafePerformIO ) import Foreign.C +import Foreign.Ptr import Data.Typeable import Control.Exception import System.IO.Unsafe diff --git a/Foreign/CUDA/Runtime/Exec.chs b/Foreign/CUDA/Runtime/Exec.chs --- a/Foreign/CUDA/Runtime/Exec.chs +++ b/Foreign/CUDA/Runtime/Exec.chs @@ -15,8 +15,8 @@ module Foreign.CUDA.Runtime.Exec ( -- * Kernel Execution - FunAttributes(..), FunParam(..), CacheConfig(..), - attributes, setConfig, setParams, setCacheConfig, launch + Fun, FunAttributes(..), FunParam(..), CacheConfig(..), + attributes, setConfig, setParams, setCacheConfig, launch, launchKernel, ) where @@ -43,7 +43,20 @@ -- Data Types -------------------------------------------------------------------------------- +-- | +-- A @__global__@ device function. -- +-- Note that the use of a string naming a function was deprecated in CUDA 4.1 +-- and removed in CUDA 5.0. +-- +#if CUDART_VERSION >= 5000 +type Fun = FunPtr () +#else +type Fun = String +#endif + + +-- -- Function Attributes -- {# pointer *cudaFuncAttributes as ^ foreign -> FunAttributes nocode #} @@ -109,13 +122,13 @@ -- itemises the requirements to successfully launch the given kernel. -- {-# INLINEABLE attributes #-} -attributes :: String -> IO FunAttributes +attributes :: Fun -> IO FunAttributes attributes !fn = resultIfOk =<< cudaFuncGetAttributes fn {-# INLINE cudaFuncGetAttributes #-} {# fun unsafe cudaFuncGetAttributes - { alloca- `FunAttributes' peek* - , withCString_* `String' } -> `Status' cToEnum #} + { alloca- `FunAttributes' peek* + , withFun* `Fun' } -> `Status' cToEnum #} -- | @@ -151,6 +164,7 @@ -- Set the argument parameters that will be passed to the next kernel -- invocation. This is used in conjunction with 'setConfig' to control kernel -- execution. +-- {-# INLINEABLE setParams #-} setParams :: [FunParam] -> IO () setParams = foldM_ k 0 @@ -200,7 +214,7 @@ -- synchronisation point for streamed kernel launches -- {-# INLINEABLE setCacheConfig #-} -setCacheConfig :: String -> CacheConfig -> IO () +setCacheConfig :: Fun -> CacheConfig -> IO () #if CUDART_VERSION < 3000 setCacheConfig _ _ = requireSDK 3.0 "setCacheConfig" #else @@ -208,32 +222,53 @@ {-# INLINE cudaFuncSetCacheConfig #-} {# fun unsafe cudaFuncSetCacheConfig - { withCString_* `String' - , cFromEnum `CacheConfig' } -> `Status' cToEnum #} + { withFun* `Fun' + , cFromEnum `CacheConfig' } -> `Status' cToEnum #} #endif -- | --- Invoke the named kernel on the device, which must have been declared --- @__global__@. This must be preceded by a call to 'setConfig' and (if --- appropriate) 'setParams'. +-- Invoke the @__global__@ kernel function on the device. This must be preceded +-- by a call to 'setConfig' and (if appropriate) 'setParams'. -- {-# INLINEABLE launch #-} -launch :: String -> IO () +launch :: Fun -> IO () launch !fn = nothingIfOk =<< cudaLaunch fn {-# INLINE cudaLaunch #-} {# fun unsafe cudaLaunch - { withCString_* `String' } -> `Status' cToEnum #} + { withFun* `Fun' } -> `Status' cToEnum #} +-- | +-- Invoke a kernel on a @(gx * gy)@ grid of blocks, where each block contains +-- @(tx * ty * tz)@ threads and has access to a given number of bytes of shared +-- memory. The launch may also be associated with a specific 'Stream'. +-- +{-# INLINEABLE launchKernel #-} +launchKernel + :: Fun -- ^ Device function symbol + -> (Int,Int) -- ^ grid dimensions + -> (Int,Int,Int) -- ^ thread block shape + -> Int64 -- ^ shared memory per block (bytes) + -> Maybe Stream -- ^ (optional) execution stream + -> [FunParam] + -> IO () +launchKernel !fn !grid !block !sm !mst !args = do + setConfig grid block sm mst + setParams args + launch fn + -------------------------------------------------------------------------------- -- Internals -------------------------------------------------------------------------------- --- CUDA 5.0 changed the types of some attributes from char* to void* +-- CUDA 5.0 changed the type of a kernel function from char* to void* -- -{-# INLINE withCString_ #-} -withCString_ :: String -> (Ptr a -> IO b) -> IO b -withCString_ !str !fn = withCString str (fn . castPtr) +withFun :: Fun -> (Ptr a -> IO b) -> IO b +#if CUDART_VERSION >= 5000 +withFun fn action = action (castFunPtrToPtr fn) +#else +withFun = withCString +#endif diff --git a/Foreign/CUDA/Runtime/Marshal.chs b/Foreign/CUDA/Runtime/Marshal.chs --- a/Foreign/CUDA/Runtime/Marshal.chs +++ b/Foreign/CUDA/Runtime/Marshal.chs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE ForeignFunctionInterface #-} -------------------------------------------------------------------------------- -- | @@ -19,6 +20,10 @@ -- * Device Allocation mallocArray, allocaArray, free, + -- * Unified Memory Allocation + AttachFlag(..), + mallocManagedArray, + -- * Marshalling peekArray, peekArrayAsync, peekListArray, pokeArray, pokeArrayAsync, pokeListArray, @@ -60,7 +65,17 @@ } cudaMemHostAlloc_option; #endc +#if CUDART_VERSION >= 6000 +#c +typedef enum cudaMemAttachFlags_option_enum { + CUDA_MEM_ATTACH_OPTION_GLOBAL = cudaMemAttachGlobal, + CUDA_MEM_ATTACH_OPTION_HOST = cudaMemAttachHost, + CUDA_MEM_ATTACH_OPTION_SINGLE = cudaMemAttachSingle +} cudaMemAttachFlags_option; +#endc +#endif + -------------------------------------------------------------------------------- -- Host Allocation -------------------------------------------------------------------------------- @@ -165,6 +180,46 @@ { dptr `DevicePtr a' } -> `Status' cToEnum #} where dptr = useDevicePtr . castDevPtr + + +-------------------------------------------------------------------------------- +-- Unified memory allocation +-------------------------------------------------------------------------------- + +-- | +-- Options for unified memory allocations +-- +#if CUDART_VERSION >= 6000 +{# enum cudaMemAttachFlags_option as AttachFlag + { underscoreToCase } + with prefix="CUDA_MEM_ATTACH_OPTION" deriving (Eq, Show) #} +#else +data AttachFlag +#endif + +-- | +-- Allocates memory that will be automatically managed by the Unified Memory +-- system +-- +{-# INLINEABLE mallocManagedArray #-} +mallocManagedArray :: Storable a => [AttachFlag] -> Int -> IO (DevicePtr a) +#if CUDART_VERSION < 6000 +mallocManagedArray _ _ = requireSDK 6.0 "mallocManagedArray" +#else +mallocManagedArray !flags = doMalloc undefined + where + doMalloc :: Storable a' => a' -> Int -> IO (DevicePtr a') + doMalloc x !n = resultIfOk =<< cudaMallocManaged (fromIntegral n * fromIntegral (sizeOf x)) flags + +{-# INLINE cudaMallocManaged #-} +{# fun unsafe cudaMallocManaged + { alloca'- `DevicePtr a' dptr* + , cIntConv `Int64' + , combineBitMasks `[AttachFlag]' } -> `Status' cToEnum #} + where + alloca' !f = F.alloca $ \ !p -> poke p nullPtr >> f (castPtr p) + dptr !p = (castDevPtr . DevicePtr) `fmap` peek p +#endif -------------------------------------------------------------------------------- diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -11,6 +11,8 @@ import Distribution.Simple.PreProcess hiding (ppC2hs) import Control.Exception +import Control.Monad +import System.Exit import System.FilePath import System.Directory import System.Environment @@ -27,12 +29,26 @@ where preprocessors = hookedPreProcessors autoconfUserHooks customHooks = autoconfUserHooks { - postConf = defaultPostConf, + preConf = preConfHook, + postConf = postConfHook, hookedPreProcessors = ("chs",ppC2hs) : filter (\x -> fst x /= "chs") preprocessors } - defaultPostConf :: Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO () - defaultPostConf args flags pkg_descr lbi + preConfHook :: Args -> ConfigFlags -> IO HookedBuildInfo + preConfHook args flags = do + let verbosity = fromFlag (configVerbosity flags) + + confExists <- doesFileExist "configure" + unless confExists $ do + code <- rawSystemExitCode verbosity "autoconf" [] + case code of + ExitSuccess -> return () + ExitFailure c -> die $ "autoconf exited with code " ++ show c + + preConf autoconfUserHooks args flags + + postConfHook :: Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO () + postConfHook args flags pkg_descr lbi = let verbosity = fromFlag (configVerbosity flags) in do noExtraFlags args diff --git a/configure b/configure --- a/configure +++ b/configure @@ -3097,7 +3097,7 @@ # if test "$NVCC" != ""; then cuda_prefix="$(dirname "$(dirname "$NVCC")")" - cuda_c2hsflags="--cpp="$NVCC" --cppopts=-E " + cuda_c2hsflags="--cpp="$NVCC" --cppopts=-E --cppopts=-arch=sm_20 " else echo "WARNING: Cannot find the CUDA compiler 'nvcc'. This is likely to cause problems." cuda_prefix="/usr/local/cuda" @@ -3105,15 +3105,16 @@ # Location of the toolkit binaries and libraries # +cuda_frameworks="" cuda_inc_path="${cuda_prefix}/include" CPPFLAGS+=" -I${cuda_inc_path} " -cuda_frameworks="" case $target_os in darwin*) cuda_lib_path="${cuda_prefix}/lib" cuda_frameworks="CUDA" - LDFLAGS+=" -Xlinker -rpath ${cuda_lib_path} -F/Library/Frameworks -framework ${cuda_frameworks}" + LDFLAGS+=" -F/Library/Frameworks -framework ${cuda_frameworks}" + #LDFLAGS+=" -Xlinker -rpath ${cuda_lib_path} " #CPPFLAGS+=" -arch ${target_cpu} " ;; *) diff --git a/configure.ac b/configure.ac --- a/configure.ac +++ b/configure.ac @@ -1,4 +1,4 @@ -AC_INIT([Haskell CUDA bindings], [0.5.1.0], [tmcdonell@cse.unsw.edu.au], [cuda]) +AC_INIT([Haskell CUDA bindings], [0.6.0.0], [tmcdonell@cse.unsw.edu.au], [cuda]) AC_CONFIG_SRCDIR([Foreign/CUDA.hs]) AC_CONFIG_FILES([cuda.buildinfo]) AC_PROG_CC @@ -11,11 +11,11 @@ # prefix to the include and library search directories. Additionally, set nvcc # as the C preprocessor for c2hs (only, or it won't try to link cudart) # -AC_ARG_WITH([compiler], [ --with-compiler=HC use HC as the Haskell compiler], +AC_ARG_WITH([compiler], [ --with-compiler=HC use HC as the Haskell compiler], [GHC=$withval], [AC_PATH_PROG(GHC, ghc)]) -AC_ARG_WITH([nvcc], [ --with-nvcc=NVCC use NVCC as the CUDA compiler], +AC_ARG_WITH([nvcc], [ --with-nvcc=NVCC use NVCC as the CUDA compiler], [NVCC=$withval], [AC_PATH_PROG(NVCC, nvcc, [], [$PATH:/usr/local/cuda/bin])]) -AC_ARG_WITH([gcc], [ --with-gcc=CC use CC as the C compiler], +AC_ARG_WITH([gcc], [ --with-gcc=CC use CC as the C compiler], [CC=$withval]) # If NVCC is detected in the path, set the location of the toolkit relative to @@ -23,7 +23,7 @@ # if test "$NVCC" != ""; then cuda_prefix="$(dirname "$(dirname "$NVCC")")" - cuda_c2hsflags="--cpp="$NVCC" --cppopts=-E " + cuda_c2hsflags="--cpp="$NVCC" --cppopts=-E --cppopts=-arch=sm_20 " else echo "WARNING: Cannot find the CUDA compiler 'nvcc'. This is likely to cause problems." cuda_prefix="/usr/local/cuda" @@ -31,15 +31,16 @@ # Location of the toolkit binaries and libraries # +cuda_frameworks="" cuda_inc_path="${cuda_prefix}/include" CPPFLAGS+=" -I${cuda_inc_path} " -cuda_frameworks="" case $target_os in darwin*) cuda_lib_path="${cuda_prefix}/lib" cuda_frameworks="CUDA" - LDFLAGS+=" -Xlinker -rpath ${cuda_lib_path} -F/Library/Frameworks -framework ${cuda_frameworks}" + LDFLAGS+=" -F/Library/Frameworks -framework ${cuda_frameworks}" + #LDFLAGS+=" -Xlinker -rpath ${cuda_lib_path} " #CPPFLAGS+=" -arch ${target_cpu} " ;; *) diff --git a/cuda.cabal b/cuda.cabal --- a/cuda.cabal +++ b/cuda.cabal @@ -1,5 +1,5 @@ Name: cuda -Version: 0.5.1.1 +Version: 0.6.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 @@ -13,23 +13,26 @@ The configure script will look for your CUDA installation in the standard places, and if the nvcc compiler is found in your PATH, relative to that. . - /NOTE:/ Mavericks users (OS X 10.9) should use CUDA 5.5.28 and upwards. - . - This release is for version 5.0 of the CUDA toolkit. + This release is for version 6.0 of the CUDA toolkit. License: BSD3 License-file: LICENSE -Copyright: Copyright (c) [2009..2013]. Trevor L. McDonell +Copyright: Copyright (c) [2009..2014]. 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.6 +Cabal-version: >= 1.8 Tested-with: GHC >= 7.6 Build-type: Custom -Extra-tmp-files: cuda.buildinfo config.status config.log + +Extra-tmp-files: cuda.buildinfo + config.status + config.log + autom4te.cache + Extra-source-files: configure configure.ac config.guess @@ -76,6 +79,16 @@ Extensions: ghc-options: -Wall -O2 -funbox-strict-fields -fwarn-tabs ghc-prof-options: -fprof-auto -fprof-cafs + + +Test-suite deviceQuery + Type: exitcode-stdio-1.0 + Main-is: DeviceQuery.hs + hs-source-dirs: examples/src/deviceQueryDrv + + Build-depends: base >= 4 && < 5, + cuda, + pretty source-repository head diff --git a/examples/src/deviceQueryDrv/DeviceQuery.hs b/examples/src/deviceQueryDrv/DeviceQuery.hs new file mode 100644 --- /dev/null +++ b/examples/src/deviceQueryDrv/DeviceQuery.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE RecordWildCards #-} + +import Numeric +import Control.Monad +import Text.Printf +import Text.PrettyPrint + +import Foreign.CUDA.Analysis as CUDA +import qualified Foreign.CUDA.Driver as CUDA + + +main :: IO () +main = do + version <- CUDA.driverVersion + printf "CUDA device query (Driver API, statically linked)\n" + printf "CUDA driver version %d.%d\n" (version`div`1000) ((version`mod`100)`div`10) + + CUDA.initialise [] + numDevices <- CUDA.count + + if numDevices == 0 + 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 + + +statDevice :: DeviceProperties -> IO () +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" + + 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) + ,("Memory clock rate:", text $ showFreq memClockRate) + ,("Memory bus width:", text $ showFreq memBusWidth) + ,("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)) + ] + in + putStrLn . render + $ hang table 4 + $ case computeMode of + Default -> text "Multiple host threads can use the device simultaneously" + Exclusive -> text "Only one host thread in a process is able to use this device" + Prohibited -> text "No host thread can use this device" + ExclusiveProcess -> text "Multiple threads in one process can use the device simultaneously" + + +showFreq :: Integral i => i -> String +showFreq x = showFFloatSIBase Nothing 1000 (fromIntegral x :: Double) "Hz" + +showBytes :: Integral i => i -> String +showBytes x = showFFloatSIBase (Just 0) 1024 (fromIntegral x :: Double) "B" + +showFFloatSIBase :: RealFloat a => Maybe Int -> a -> a -> ShowS +showFFloatSIBase p b n + = showString + $ showFFloat p n' (' ':si_unit) + where + n' = n / (b ^^ pow) + pow = (-4) `max` floor (logBase b n) `min` 4 :: Int + si_unit = case pow of + -4 -> "p" + -3 -> "n" + -2 -> "ยต" + -1 -> "m" + 0 -> "" + 1 -> "k" + 2 -> "M" + 3 -> "G" + 4 -> "T" + _ -> error "out of range!" +