cuda 0.4.1.1 → 0.5.0.0
raw patch · 31 files changed
+799/−371 lines, 31 filesdep −extensible-exceptionsdep ~basesetup-changed
Dependencies removed: extensible-exceptions
Dependency ranges changed: base
Files
- Foreign/CUDA.hs +1/−1
- Foreign/CUDA/Analysis.hs +1/−1
- Foreign/CUDA/Analysis/Device.chs +51/−21
- Foreign/CUDA/Analysis/Occupancy.hs +18/−10
- Foreign/CUDA/Driver.hs +1/−1
- Foreign/CUDA/Driver/Context.chs +58/−23
- Foreign/CUDA/Driver/Device.chs +33/−18
- Foreign/CUDA/Driver/Error.chs +10/−2
- Foreign/CUDA/Driver/Event.chs +27/−10
- Foreign/CUDA/Driver/Exec.chs +44/−47
- Foreign/CUDA/Driver/Marshal.chs +85/−38
- Foreign/CUDA/Driver/Module.chs +30/−12
- Foreign/CUDA/Driver/Stream.chs +16/−7
- Foreign/CUDA/Driver/Texture.chs +36/−12
- Foreign/CUDA/Driver/Utils.chs +3/−1
- Foreign/CUDA/Internal/C2HS.hs +34/−40
- Foreign/CUDA/Ptr.hs +32/−15
- Foreign/CUDA/Runtime.hs +1/−1
- Foreign/CUDA/Runtime/Device.chs +56/−24
- Foreign/CUDA/Runtime/Error.chs +6/−3
- Foreign/CUDA/Runtime/Event.chs +27/−10
- Foreign/CUDA/Runtime/Exec.chs +37/−12
- Foreign/CUDA/Runtime/Marshal.chs +54/−30
- Foreign/CUDA/Runtime/Stream.chs +16/−5
- Foreign/CUDA/Runtime/Texture.chs +21/−6
- Foreign/CUDA/Runtime/Utils.chs +5/−1
- LICENSE +1/−1
- Setup.hs +1/−1
- configure +82/−10
- configure.ac +5/−2
- cuda.cabal +7/−6
Foreign/CUDA.hs view
@@ -1,7 +1,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA--- Copyright : (c) [2009..2011] Trevor L. McDonell+-- Copyright : (c) [2009..2012] Trevor L. McDonell -- License : BSD -- -- Top level bindings. By default, expose the C-for-CUDA runtime API bindings,
Foreign/CUDA/Analysis.hs view
@@ -1,7 +1,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Analysis--- Copyright : (c) [2009..2011] Trevor L. McDonell+-- Copyright : (c) [2009..2012] Trevor L. McDonell -- License : BSD -- -- Meta-module exporting CUDA analysis routines
Foreign/CUDA/Analysis/Device.chs view
@@ -1,7 +1,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Analysis.Device--- Copyright : (c) [2009..2011] Trevor L. McDonell+-- Copyright : (c) [2009..2012] Trevor L. McDonell -- License : BSD -- -- Common device functions@@ -10,16 +10,16 @@ module Foreign.CUDA.Analysis.Device (- Compute, ComputeMode(..),+ Compute(..), ComputeMode(..), DeviceProperties(..), DeviceResources(..), Allocation(..), PCI(..),- resources+ deviceResources ) where #include <cuda.h> import Data.Int-import Data.Maybe+import Debug.Trace -- |@@ -30,16 +30,34 @@ with prefix="CU_COMPUTEMODE" deriving (Eq, Show) #} -- |--- GPU compute capability+-- GPU compute capability, major and minor revision number respectively. ---type Compute = Double+data Compute = Compute !Int !Int+ deriving Eq +instance Show Compute where+ show (Compute major minor) = show major ++ "." ++ show minor++instance Ord Compute where+ compare (Compute m1 n1) (Compute m2 n2) =+ case compare m1 m2 of+ EQ -> compare n1 n2+ x -> x++{--+cap :: Int -> Int -> Double+cap a 0 = fromIntegral a+cap a b = let a' = fromIntegral a in+ let b' = fromIntegral b in+ a' + b' / max 10 (10^ ((ceiling . logBase 10) b' :: Int))+--}+ -- | -- The properties of a compute device -- data DeviceProperties = DeviceProperties {- deviceName :: String, -- ^ Identifier+ 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@@ -107,6 +125,7 @@ threadsPerMP :: !Int, -- ^ Maximum number of in-flight threads on a multiprocessor threadBlocksPerMP :: !Int, -- ^ Maximum number of thread blocks resident on a multiprocessor warpsPerMP :: !Int, -- ^ Maximum number of in-flight warps per multiprocessor+ coresPerMP :: !Int, -- ^ Number of SIMD arithmetic units per multiprocessor sharedMemPerMP :: !Int, -- ^ Total amount of shared memory per multiprocessor (bytes) sharedMemAllocUnit :: !Int, -- ^ Shared memory allocation unit size (bytes) regFileSize :: !Int, -- ^ Total number of registers in a multiprocessor@@ -117,21 +136,32 @@ -- |--- Extract some additional hardware resource limitations for a given device. If--- an exact match is not found, choose a sensible default.+-- Extract some additional hardware resource limitations for a given device. ---resources :: DeviceProperties -> DeviceResources-resources dev = fromMaybe def (lookup compute gpuData)+deviceResources :: DeviceProperties -> DeviceResources+deviceResources = resources . computeCapability where- compute = computeCapability dev- def | compute < 1.0 = snd $ head gpuData- | otherwise = snd $ last gpuData+ -- This is mostly extracted from tables in the CUDA occupancy calculator.+ --+ resources compute = case compute of+ Compute 1 0 -> DeviceResources 32 768 8 24 8 16384 512 8192 256 2 Block -- Tesla G80+ Compute 1 1 -> DeviceResources 32 768 8 24 8 16384 512 8192 256 2 Block -- Tesla G8x+ Compute 1 2 -> DeviceResources 32 1024 8 32 8 16384 512 16384 512 2 Block -- Tesla G9x+ Compute 1 3 -> DeviceResources 32 1024 8 32 8 16384 512 16384 512 2 Block -- Tesla GT200+ Compute 2 0 -> DeviceResources 32 1536 8 48 32 49152 128 32768 64 2 Warp -- Fermi GF100+ Compute 2 1 -> DeviceResources 32 1536 8 48 48 49152 128 32768 64 2 Warp -- Fermi GF10x+ Compute 3 0 -> DeviceResources 32 2048 16 64 192 49152 256 65536 256 4 Warp -- Kepler GK10x+ Compute 3 5 -> DeviceResources 32 2048 16 64 192 49152 256 65536 256 4 Warp -- Kepler GK11x - gpuData =- [(1.0, DeviceResources 32 768 8 24 16384 512 8192 256 2 Block)- ,(1.1, DeviceResources 32 768 8 24 16384 512 8192 256 2 Block)- ,(1.2, DeviceResources 32 1024 8 32 16384 512 16384 512 2 Block)- ,(1.3, DeviceResources 32 1024 8 32 16384 512 16384 512 2 Block)- ,(2.0, DeviceResources 32 1536 8 48 49152 128 32768 64 1 Warp)- ]+ -- Something might have gone wrong, or the library just needs to be+ -- updated for the next generation of hardware, in which case we just want+ -- to pick a sensible default and carry on.+ --+ -- This is slightly dodgy as the warning message is coming from pure code.+ -- However, it should be OK because all library functions run in IO, so it+ -- is likely the user code is as well.+ --+ _ -> trace warning $ resources (Compute 3 0)+ where warning = unlines [ "*** Warning: unknown CUDA device compute capability: " ++ show compute+ , "*** Please submit a bug report at https://github.com/tmcdonell/cuda/issues" ]
Foreign/CUDA/Analysis/Occupancy.hs view
@@ -2,7 +2,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Analysis.Occupancy--- Copyright : (c) [2009..2011] Trevor L. McDonell+-- Copyright : (c) [2009..2012] Trevor L. McDonell -- License : BSD -- -- Occupancy calculations for CUDA kernels@@ -75,6 +75,7 @@ -- | -- Calculate occupancy data for a given GPU and kernel resource usage --+{-# INLINEABLE occupancy #-} occupancy :: DeviceProperties -- ^ Properties of the card in question -> Int -- ^ Threads per block@@ -98,7 +99,7 @@ -- Physical resources --- gpu = resources dev+ gpu = deviceResources dev -- Allocation per thread block --@@ -120,6 +121,7 @@ -- resource usage. This returns the smallest satisfying block size in increments -- of a single warp. --+{-# INLINEABLE optimalBlockSize #-} optimalBlockSize :: DeviceProperties -- ^ Architecture to optimise for -> (Int -> Int) -- ^ Register count as a function of thread block size@@ -135,13 +137,14 @@ -- should be monotonically decreasing to return the smallest block size yielding -- maximum occupancy, and vice-versa. --+{-# INLINEABLE optimalBlockSizeBy #-} optimalBlockSizeBy :: DeviceProperties -> (DeviceProperties -> [Int]) -> (Int -> Int) -> (Int -> Int) -> (Int, Occupancy)-optimalBlockSizeBy dev fblk freg fsmem+optimalBlockSizeBy !dev !fblk !freg !fsmem = maximumBy (comparing (occupancy100 . snd)) $ zip threads residency where residency = map (\t -> occupancy dev t (freg t) (fsmem t)) threads@@ -151,8 +154,9 @@ -- | Increments in powers-of-two, over the range of supported thread block sizes -- for the given device. --+{-# INLINEABLE incPow2 #-} incPow2 :: DeviceProperties -> [Int]-incPow2 dev = map ((2::Int)^) [lb, lb+1 .. ub]+incPow2 !dev = map ((2::Int)^) [lb, lb+1 .. ub] where round' = round :: Double -> Int lb = round' . logBase 2 . fromIntegral $ warpSize dev@@ -161,8 +165,9 @@ -- | Decrements in powers-of-two, over the range of supported thread block sizes -- for the given device. --+{-# INLINEABLE decPow2 #-} decPow2 :: DeviceProperties -> [Int]-decPow2 dev = map ((2::Int)^) [ub, ub-1 .. lb]+decPow2 !dev = map ((2::Int)^) [ub, ub-1 .. lb] where round' = round :: Double -> Int lb = round' . logBase 2 . fromIntegral $ warpSize dev@@ -171,17 +176,19 @@ -- | Decrements in the warp size of the device, over the range of supported -- thread block sizes. --+{-# INLINEABLE decWarp #-} decWarp :: DeviceProperties -> [Int]-decWarp dev = [block, block-warp .. warp]+decWarp !dev = [block, block-warp .. warp] where- warp = warpSize dev- block = maxThreadsPerBlock dev+ !warp = warpSize dev+ !block = maxThreadsPerBlock dev -- | Increments in the warp size of the device, over the range of supported -- thread block sizes. --+{-# INLINEABLE incWarp #-} incWarp :: DeviceProperties -> [Int]-incWarp dev = [warp, 2*warp .. block]+incWarp !dev = [warp, 2*warp .. block] where warp = warpSize dev block = maxThreadsPerBlock dev@@ -191,12 +198,13 @@ -- Determine the maximum number of CTAs that can be run simultaneously for a -- given kernel / device combination. --+{-# INLINEABLE maxResidentBlocks #-} maxResidentBlocks :: DeviceProperties -- ^ Properties of the card in question -> Int -- ^ Threads per block -> Int -- ^ Registers per thread -> Int -- ^ Shared memory per block (bytes) -> Int -- ^ Maximum number of resident blocks-maxResidentBlocks dev thds regs smem =+maxResidentBlocks !dev !thds !regs !smem = multiProcessorCount dev * activeThreadBlocks (occupancy dev thds regs smem)
Foreign/CUDA/Driver.hs view
@@ -1,7 +1,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Driver--- Copyright : (c) [2009..2011] Trevor L. McDonell+-- Copyright : (c) [2009..2012] Trevor L. McDonell -- License : BSD -- -- Top level bindings to CUDA driver API
Foreign/CUDA/Driver/Context.chs view
@@ -1,8 +1,11 @@-{-# LANGUAGE CPP, ForeignFunctionInterface, EmptyDataDecls #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ForeignFunctionInterface #-} -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Driver.Context--- Copyright : (c) [2009..2011] Trevor L. McDonell+-- Copyright : (c) [2009..2012] Trevor L. McDonell -- License : BSD -- -- Context management for low-level driver interface@@ -69,9 +72,9 @@ #endif -- |--- Device cache configuration flags+-- Device cache configuration preference ---#if CUDA_VERSION < 3020+#if CUDA_VERSION < 3000 data Cache #else {# enum CUfunc_cache_enum as Cache@@ -99,9 +102,11 @@ -- | -- Create a new CUDA context and associate it with the calling thread --+{-# INLINEABLE create #-} create :: Device -> [ContextFlag] -> IO Context-create dev flags = resultIfOk =<< cuCtxCreate flags dev+create !dev !flags = resultIfOk =<< cuCtxCreate flags dev +{-# INLINE cuCtxCreate #-} {# fun unsafe cuCtxCreate { alloca- `Context' peekCtx* , combineBitMasks `[ContextFlag]'@@ -113,9 +118,11 @@ -- Increments the usage count of the context. API: no context flags are -- currently supported, so this parameter must be empty. --+{-# INLINEABLE attach #-} attach :: Context -> [ContextFlag] -> IO ()-attach ctx flags = nothingIfOk =<< cuCtxAttach ctx flags+attach !ctx !flags = nothingIfOk =<< cuCtxAttach ctx flags +{-# INLINE cuCtxAttach #-} {# fun unsafe cuCtxAttach { withCtx* `Context' , combineBitMasks `[ContextFlag]' } -> `Status' cToEnum #}@@ -125,9 +132,11 @@ -- | -- Detach the context, and destroy if no longer used --+{-# INLINEABLE detach #-} detach :: Context -> IO ()-detach ctx = nothingIfOk =<< cuCtxDetach ctx+detach !ctx = nothingIfOk =<< cuCtxDetach ctx +{-# INLINE cuCtxDetach #-} {# fun unsafe cuCtxDetach { useContext `Context' } -> `Status' cToEnum #} @@ -136,9 +145,11 @@ -- Destroy the specified context. This fails if the context is more than a -- single attachment (including that from initial creation). --+{-# INLINEABLE destroy #-} destroy :: Context -> IO ()-destroy ctx = nothingIfOk =<< cuCtxDestroy ctx+destroy !ctx = nothingIfOk =<< cuCtxDestroy ctx +{-# INLINE cuCtxDestroy #-} {# fun unsafe cuCtxDestroy { useContext `Context' } -> `Status' cToEnum #} @@ -146,12 +157,14 @@ -- | -- Return the context bound to the calling CPU thread. Requires cuda-4.0. --+{-# INLINEABLE get #-} get :: IO Context #if CUDA_VERSION < 4000 get = requireSDK 4.0 "get" #else get = resultIfOk =<< cuCtxGetCurrent +{-# INLINE cuCtxGetCurrent #-} {# fun unsafe cuCtxGetCurrent { alloca- `Context' peekCtx* } -> `Status' cToEnum #} where peekCtx = liftM Context . peek@@ -161,12 +174,14 @@ -- | -- Bind the specified context to the calling thread. Requires cuda-4.0. --+{-# INLINEABLE set #-} set :: Context -> IO () #if CUDA_VERSION < 4000-set _ = requireSDK 4.0 "set"+set _ = requireSDK 4.0 "set" #else-set ctx = nothingIfOk =<< cuCtxSetCurrent ctx+set !ctx = nothingIfOk =<< cuCtxSetCurrent ctx +{-# INLINE cuCtxSetCurrent #-} {# fun unsafe cuCtxSetCurrent { useContext `Context' } -> `Status' cToEnum #} #endif@@ -174,9 +189,11 @@ -- | -- Return the device of the currently active context --+{-# INLINEABLE device #-} device :: IO Device device = resultIfOk =<< cuCtxGetDevice +{-# INLINE cuCtxGetDevice #-} {# fun unsafe cuCtxGetDevice { alloca- `Device' dev* } -> `Status' cToEnum #} where dev = liftM Device . peekIntConv@@ -187,9 +204,11 @@ -- single usage count (matching calls to 'attach' and 'detach'). If successful, -- the new context is returned, and the old may be attached to a different CPU. --+{-# INLINEABLE pop #-} pop :: IO Context pop = resultIfOk =<< cuCtxPopCurrent +{-# INLINE cuCtxPopCurrent #-} {# fun unsafe cuCtxPopCurrent { alloca- `Context' peekCtx* } -> `Status' cToEnum #} where peekCtx = liftM Context . peek@@ -199,9 +218,11 @@ -- Push the given context onto the CPU's thread stack of current contexts. The -- context must be floating (via 'pop'), i.e. not attached to any thread. --+{-# INLINEABLE push #-} push :: Context -> IO ()-push ctx = nothingIfOk =<< cuCtxPushCurrent ctx+push !ctx = nothingIfOk =<< cuCtxPushCurrent ctx +{-# INLINE cuCtxPushCurrent #-} {# fun unsafe cuCtxPushCurrent { useContext `Context' } -> `Status' cToEnum #} @@ -209,9 +230,11 @@ -- | -- Block until the device has completed all preceding requests --+{-# INLINEABLE sync #-} sync :: IO () sync = nothingIfOk =<< cuCtxSynchronize +{-# INLINE cuCtxSynchronize #-} {# fun unsafe cuCtxSynchronize { } -> `Status' cToEnum #} @@ -225,12 +248,14 @@ -- direct access is possible, it can then be enabled with 'add'. Requires -- cuda-4.0. --+{-# INLINEABLE accessible #-} accessible :: Device -> Device -> IO Bool #if CUDA_VERSION < 4000-accessible _ _ = requireSDK 4.0 "accessible"+accessible _ _ = requireSDK 4.0 "accessible" #else-accessible dev peer = resultIfOk =<< cuDeviceCanAccessPeer dev peer+accessible !dev !peer = resultIfOk =<< cuDeviceCanAccessPeer dev peer +{-# INLINE cuDeviceCanAccessPeer #-} {# fun unsafe cuDeviceCanAccessPeer { alloca- `Bool' peekBool* , useDevice `Device'@@ -243,12 +268,14 @@ -- addressing, then enable allocations in the supplied context to be accessible -- by the current context. Requires cuda-4.0. --+{-# INLINEABLE add #-} add :: Context -> [PeerFlag] -> IO () #if CUDA_VERSION < 4000-add _ _ = requireSDK 4.0 "add"+add _ _ = requireSDK 4.0 "add" #else-add ctx flags = nothingIfOk =<< cuCtxEnablePeerAccess ctx flags+add !ctx !flags = nothingIfOk =<< cuCtxEnablePeerAccess ctx flags +{-# INLINE cuCtxEnablePeerAccess #-} {# fun unsafe cuCtxEnablePeerAccess { useContext `Context' , combineBitMasks `[PeerFlag]' } -> `Status' cToEnum #}@@ -259,12 +286,14 @@ -- Disable direct memory access from the current context to the supplied -- context. Requires cuda-4.0. --+{-# INLINEABLE remove #-} remove :: Context -> IO () #if CUDA_VERSION < 4000-remove _ = requireSDK 4.0 "remove"+remove _ = requireSDK 4.0 "remove" #else-remove ctx = nothingIfOk =<< cuCtxDisablePeerAccess ctx+remove !ctx = nothingIfOk =<< cuCtxDisablePeerAccess ctx +{-# INLINE cuCtxDisablePeerAccess #-} {# fun unsafe cuCtxDisablePeerAccess { useContext `Context' } -> `Status' cToEnum #} #endif@@ -277,12 +306,14 @@ -- | -- Query compute 2.0 call stack limits. Requires cuda-3.1. --+{-# INLINEABLE getLimit #-} getLimit :: Limit -> IO Int #if CUDA_VERSION < 3010-getLimit _ = requireSDK 3.1 "getLimit"+getLimit _ = requireSDK 3.1 "getLimit" #else-getLimit l = resultIfOk =<< cuCtxGetLimit l+getLimit !l = resultIfOk =<< cuCtxGetLimit l +{-# INLINE cuCtxGetLimit #-} {# fun unsafe cuCtxGetLimit { alloca- `Int' peekIntConv* , cFromEnum `Limit' } -> `Status' cToEnum #}@@ -292,12 +323,14 @@ -- Specify the size of the call stack, for compute 2.0 devices. Requires -- cuda-3.1. --+{-# INLINEABLE setLimit #-} setLimit :: Limit -> Int -> IO () #if CUDA_VERSION < 3010-setLimit _ _ = requireSDK 3.1 "setLimit"+setLimit _ _ = requireSDK 3.1 "setLimit" #else-setLimit l n = nothingIfOk =<< cuCtxSetLimit l n+setLimit !l !n = nothingIfOk =<< cuCtxSetLimit l n +{-# INLINE cuCtxSetLimit #-} {# fun unsafe cuCtxSetLimit { cFromEnum `Limit' , cIntConv `Int' } -> `Status' cToEnum #}@@ -308,12 +341,14 @@ -- resources, this sets the preferred cache configuration for the current -- context. This is only a preference. Requires cuda-3.2. --+{-# INLINEABLE setCacheConfig #-} setCacheConfig :: Cache -> IO () #if CUDA_VERSION < 3020-setCacheConfig _ = requireSDK 3.2 "setCacheConfig"+setCacheConfig _ = requireSDK 3.2 "setCacheConfig" #else-setCacheConfig c = nothingIfOk =<< cuCtxSetCacheConfig c+setCacheConfig !c = nothingIfOk =<< cuCtxSetCacheConfig c +{-# INLINE cuCtxSetCacheConfig #-} {# fun unsafe cuCtxSetCacheConfig { cFromEnum `Cache' } -> `Status' cToEnum #} #endif
Foreign/CUDA/Driver/Device.chs view
@@ -1,8 +1,11 @@-{-# LANGUAGE CPP, ForeignFunctionInterface, EmptyDataDecls #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ForeignFunctionInterface #-} -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Driver.Device--- Copyright : (c) [2009..2011] Trevor L. McDonell+-- Copyright : (c) [2009..2012] Trevor L. McDonell -- License : BSD -- -- Device management for low-level driver interface@@ -13,7 +16,7 @@ -- * Device Management Device(..), -- should be exported abstractly- DeviceProperties(..), DeviceAttribute(..), ComputeMode(..), InitFlag,+ DeviceProperties(..), DeviceAttribute(..), Compute(..), ComputeMode(..), InitFlag, initialise, capability, device, attribute, count, name, props, totalMem ) where@@ -45,7 +48,8 @@ -- Device attributes -- {# enum CUdevice_attribute as DeviceAttribute- { underscoreToCase }+ { underscoreToCase+ , MAX as CU_DEVICE_ATTRIBUTE_MAX } -- ignore with prefix="CU_DEVICE_ATTRIBUTE" deriving (Eq, Show) #} {# pointer *CUdevprop as ^ foreign -> CUDevProp nocode #}@@ -119,9 +123,11 @@ -- Initialise the CUDA driver API. Must be called before any other driver -- function. --+{-# INLINEABLE initialise #-} initialise :: [InitFlag] -> IO ()-initialise flags = nothingIfOk =<< cuInit flags+initialise !flags = nothingIfOk =<< cuInit flags +{-# INLINE cuInit #-} {# fun unsafe cuInit { combineBitMasks `[InitFlag]' } -> `Status' cToEnum #} @@ -133,15 +139,12 @@ -- | -- Return the compute compatibility revision supported by the device ---capability :: Device -> IO Double-capability dev =- (\(s,a,b) -> resultIfOk (s,cap a b)) =<< cuDeviceComputeCapability dev- where- cap a 0 = fromIntegral a- cap a b = let a' = fromIntegral a in- let b' = fromIntegral b in- a' + b' / max 10 (10^ ((ceiling . logBase 10) b' :: Int))+{-# INLINEABLE capability #-}+capability :: Device -> IO Compute+capability !dev =+ (\(!s,!a,!b) -> resultIfOk (s,Compute a b)) =<< cuDeviceComputeCapability dev +{-# INLINE cuDeviceComputeCapability #-} {# fun unsafe cuDeviceComputeCapability { alloca- `Int' peekIntConv* , alloca- `Int' peekIntConv*@@ -151,9 +154,11 @@ -- | -- Return a device handle --+{-# INLINEABLE device #-} device :: Int -> IO Device-device d = resultIfOk =<< cuDeviceGet d+device !d = resultIfOk =<< cuDeviceGet d +{-# INLINE cuDeviceGet #-} {# fun unsafe cuDeviceGet { alloca- `Device' dev* , cIntConv `Int' } -> `Status' cToEnum #}@@ -163,9 +168,11 @@ -- | -- Return the selected attribute for the given device --+{-# INLINEABLE attribute #-} attribute :: Device -> DeviceAttribute -> IO Int-attribute d a = resultIfOk =<< cuDeviceGetAttribute a d+attribute !d !a = resultIfOk =<< cuDeviceGetAttribute a d +{-# INLINE cuDeviceGetAttribute #-} {# fun unsafe cuDeviceGetAttribute { alloca- `Int' peekIntConv* , cFromEnum `DeviceAttribute'@@ -175,9 +182,11 @@ -- | -- Return the number of device with compute capability > 1.0 --+{-# INLINEABLE count #-} count :: IO Int count = resultIfOk =<< cuDeviceGetCount +{-# INLINE cuDeviceGetCount #-} {# fun unsafe cuDeviceGetCount { alloca- `Int' peekIntConv* } -> `Status' cToEnum #} @@ -185,9 +194,11 @@ -- | -- Name of the device --+{-# INLINEABLE name #-} name :: Device -> IO String-name d = resultIfOk =<< cuDeviceGetName d+name !d = resultIfOk =<< cuDeviceGetName d +{-# INLINE cuDeviceGetName #-} {# fun unsafe cuDeviceGetName { allocaS- `String'& peekS* , useDevice `Device' } -> `Status' cToEnum #}@@ -204,8 +215,9 @@ -- Annoyingly, the driver API requires several different functions to extract -- all device properties that are part of a single structure in the runtime API --+{-# INLINEABLE props #-} props :: Device -> IO DeviceProperties-props d = do+props !d = do p <- resultIfOk =<< cuDeviceGetProperties d -- And the remaining properties@@ -283,6 +295,7 @@ } +{-# INLINE cuDeviceGetProperties #-} {# fun unsafe cuDeviceGetProperties { alloca- `CUDevProp' peek* , useDevice `Device' } -> `Status' cToEnum #}@@ -291,9 +304,11 @@ -- | -- Total memory available on the device (bytes) --+{-# INLINEABLE totalMem #-} totalMem :: Device -> IO Int64-totalMem d = resultIfOk =<< cuDeviceTotalMem d+totalMem !d = resultIfOk =<< cuDeviceTotalMem d +{-# INLINE cuDeviceTotalMem #-} {# fun unsafe cuDeviceTotalMem { alloca- `Int64' peekIntConv* , useDevice `Device' } -> `Status' cToEnum #}
Foreign/CUDA/Driver/Error.chs view
@@ -1,8 +1,9 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveDataTypeable #-} -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Driver.Error--- Copyright : (c) [2009..2011] Trevor L. McDonell+-- Copyright : (c) [2009..2012] Trevor L. McDonell -- License : BSD -- -- Error handling@@ -15,7 +16,7 @@ -- System import Data.Typeable-import Control.Exception.Extensible+import Control.Exception #include <cuda.h> {# context lib="cuda" #}@@ -99,6 +100,11 @@ describe HostMemoryAlreadyRegistered = "part or all of the requested memory range is already mapped" describe HostMemoryNotRegistered = "pointer does not correspond to a registered memory region" #endif+#if CUDA_VERSION >= 5000+describe PeerAccessUnsupported = "peer access is not supported across the given devices"+describe NotPermitted = "not permitted"+describe NotSupported = "not supported"+#endif describe Unknown = "unknown error" @@ -139,6 +145,7 @@ -- Return the results of a function on successful execution, otherwise throw an -- exception with an error string associated with the return code --+{-# INLINE resultIfOk #-} resultIfOk :: (Status, a) -> IO a resultIfOk (status,result) = case status of@@ -150,6 +157,7 @@ -- Throw an exception with an error string associated with an unsuccessful -- return code, otherwise return unit. --+{-# INLINE nothingIfOk #-} nothingIfOk :: Status -> IO () nothingIfOk status = case status of
Foreign/CUDA/Driver/Event.chs view
@@ -1,8 +1,11 @@-{-# LANGUAGE CPP, ForeignFunctionInterface, EmptyDataDecls #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ForeignFunctionInterface #-} -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Driver.Event--- Copyright : (c) [2009..2011] Trevor L. McDonell+-- Copyright : (c) [2009..2012] Trevor L. McDonell -- License : BSD -- -- Event management for low-level driver interface@@ -62,9 +65,11 @@ -- | -- Create a new event --+{-# INLINEABLE create #-} create :: [EventFlag] -> IO Event-create flags = resultIfOk =<< cuEventCreate flags+create !flags = resultIfOk =<< cuEventCreate flags +{-# INLINE cuEventCreate #-} {# fun unsafe cuEventCreate { alloca- `Event' peekEvt* , combineBitMasks `[EventFlag]' } -> `Status' cToEnum #}@@ -74,9 +79,11 @@ -- | -- Destroy an event --+{-# INLINEABLE destroy #-} destroy :: Event -> IO ()-destroy ev = nothingIfOk =<< cuEventDestroy ev+destroy !ev = nothingIfOk =<< cuEventDestroy ev +{-# INLINE cuEventDestroy #-} {# fun unsafe cuEventDestroy { useEvent `Event' } -> `Status' cToEnum #} @@ -84,9 +91,11 @@ -- | -- Determine the elapsed time (in milliseconds) between two events --+{-# INLINEABLE elapsedTime #-} elapsedTime :: Event -> Event -> IO Float-elapsedTime ev1 ev2 = resultIfOk =<< cuEventElapsedTime ev1 ev2+elapsedTime !ev1 !ev2 = resultIfOk =<< cuEventElapsedTime ev1 ev2 +{-# INLINE cuEventElapsedTime #-} {# fun unsafe cuEventElapsedTime { alloca- `Float' peekFloatConv* , useEvent `Event'@@ -96,14 +105,16 @@ -- | -- Determines if a event has actually been recorded --+{-# INLINEABLE query #-} query :: Event -> IO Bool-query ev =+query !ev = cuEventQuery ev >>= \rv -> case rv of Success -> return True NotReady -> return False _ -> resultIfOk (rv,undefined) +{-# INLINE cuEventQuery #-} {# fun unsafe cuEventQuery { useEvent `Event' } -> `Status' cToEnum #} @@ -112,12 +123,14 @@ -- Record an event once all operations in the current context (or optionally -- specified stream) have completed. This operation is asynchronous. --+{-# INLINEABLE record #-} record :: Event -> Maybe Stream -> IO ()-record ev mst =+record !ev !mst = nothingIfOk =<< case mst of Just st -> cuEventRecord ev st Nothing -> cuEventRecord ev (Stream nullPtr) +{-# INLINE cuEventRecord #-} {# fun unsafe cuEventRecord { useEvent `Event' , useStream `Stream' } -> `Status' cToEnum #}@@ -127,15 +140,17 @@ -- Makes all future work submitted to the (optional) stream wait until the given -- event reports completion before beginning execution. Requires cuda-3.2. --+{-# INLINEABLE wait #-} wait :: Event -> Maybe Stream -> [WaitFlag] -> IO () #if CUDA_VERSION < 3020-wait _ _ _ = requireSDK 3.2 "wait"+wait _ _ _ = requireSDK 3.2 "wait" #else-wait ev mst flags =+wait !ev !mst !flags = nothingIfOk =<< case mst of Just st -> cuStreamWaitEvent st ev flags Nothing -> cuStreamWaitEvent (Stream nullPtr) ev flags +{-# INLINE cuStreamWaitEvent #-} {# fun unsafe cuStreamWaitEvent { useStream `Stream' , useEvent `Event'@@ -145,9 +160,11 @@ -- | -- Wait until the event has been recorded --+{-# INLINEABLE block #-} block :: Event -> IO ()-block ev = nothingIfOk =<< cuEventSynchronize ev+block !ev = nothingIfOk =<< cuEventSynchronize ev +{-# INLINE cuEventSynchronize #-} {# fun unsafe cuEventSynchronize { useEvent `Event' } -> `Status' cToEnum #}
Foreign/CUDA/Driver/Exec.chs view
@@ -1,8 +1,12 @@-{-# LANGUAGE GADTs, CPP, ForeignFunctionInterface, EmptyDataDecls #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE GADTs #-} -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Driver.Exec--- Copyright : (c) [2009..2011] Trevor L. McDonell+-- Copyright : (c) [2009..2012] Trevor L. McDonell -- License : BSD -- -- Kernel execution control for low-level driver interface@@ -12,7 +16,7 @@ module Foreign.CUDA.Driver.Exec ( -- * Kernel Execution- Fun(Fun), FunParam(..), FunAttribute(..), CacheConfig(..),+ Fun(Fun), FunParam(..), FunAttribute(..), requires, setBlockShape, setSharedSize, setParams, setCacheConfigFun, launch, launchKernel, launchKernel' @@ -24,8 +28,8 @@ -- Friends import Foreign.CUDA.Internal.C2HS import Foreign.CUDA.Driver.Error+import Foreign.CUDA.Driver.Context (Cache(..)) import Foreign.CUDA.Driver.Stream (Stream(..))-import Foreign.CUDA.Driver.Texture (Texture(..)) -- System import Foreign@@ -34,9 +38,6 @@ import Control.Monad (zipWithM_) -#if CUDA_VERSION >= 3020-{-# DEPRECATED TArg "as of CUDA version 3.2" #-}-#endif #if CUDA_VERSION >= 4000 {-# DEPRECATED setBlockShape, setSharedSize, setParams, launch "use launchKernel instead" #-}@@ -58,44 +59,30 @@ -- {# enum CUfunction_attribute as FunAttribute { underscoreToCase- , MAX_THREADS_PER_BLOCK as MaxKernelThreadsPerBlock }+ , MAX_THREADS_PER_BLOCK as MaxKernelThreadsPerBlock+ , MAX as CU_FUNC_ATTRIBUTE_MAX } -- ignore with prefix="CU_FUNC_ATTRIBUTE" deriving (Eq, Show) #} -- |--- Cache configuration preference----#if CUDA_VERSION < 3000-data CacheConfig-#else-{# enum CUfunc_cache_enum as CacheConfig- { underscoreToCase }- with prefix="CU_FUNC_CACHE_PREFER" deriving (Eq, Show) #}-#endif---- | -- Kernel function parameters -- data FunParam where IArg :: !Int -> FunParam FArg :: !Float -> FunParam- TArg :: !Texture -> FunParam VArg :: Storable a => !a -> FunParam instance Storable FunParam where sizeOf (IArg _) = sizeOf (undefined :: CUInt) sizeOf (FArg _) = sizeOf (undefined :: CFloat) sizeOf (VArg v) = sizeOf v- sizeOf (TArg _) = 0 alignment (IArg _) = alignment (undefined :: CUInt) alignment (FArg _) = alignment (undefined :: CFloat) alignment (VArg v) = alignment v- alignment (TArg _) = 0 poke p (IArg i) = poke (castPtr p) i poke p (FArg f) = poke (castPtr p) f poke p (VArg v) = poke (castPtr p) v- poke _ (TArg _) = return () --------------------------------------------------------------------------------@@ -105,9 +92,11 @@ -- | -- Returns the value of the selected attribute requirement for the given kernel --+{-# INLINEABLE requires #-} requires :: Fun -> FunAttribute -> IO Int-requires fn att = resultIfOk =<< cuFuncGetAttribute att fn+requires !fn !att = resultIfOk =<< cuFuncGetAttribute att fn +{-# INLINE cuFuncGetAttribute #-} {# fun unsafe cuFuncGetAttribute { alloca- `Int' peekIntConv* , cFromEnum `FunAttribute'@@ -118,9 +107,11 @@ -- Specify the @(x,y,z)@ dimensions of the thread blocks that are created when -- the given kernel function is launched. --+{-# INLINEABLE setBlockShape #-} setBlockShape :: Fun -> (Int,Int,Int) -> IO ()-setBlockShape fn (x,y,z) = nothingIfOk =<< cuFuncSetBlockShape fn x y z+setBlockShape !fn (!x,!y,!z) = nothingIfOk =<< cuFuncSetBlockShape fn x y z +{-# INLINE cuFuncSetBlockShape #-} {# fun unsafe cuFuncSetBlockShape { useFun `Fun' , `Int'@@ -132,9 +123,11 @@ -- Set the number of bytes of dynamic shared memory to be available to each -- thread block when the function is launched --+{-# INLINEABLE setSharedSize #-} setSharedSize :: Fun -> Integer -> IO ()-setSharedSize fn bytes = nothingIfOk =<< cuFuncSetSharedSize fn bytes+setSharedSize !fn !bytes = nothingIfOk =<< cuFuncSetSharedSize fn bytes +{-# INLINE cuFuncSetSharedSize #-} {# fun unsafe cuFuncSetSharedSize { useFun `Fun' , cIntConv `Integer' } -> `Status' cToEnum #}@@ -149,15 +142,17 @@ -- Switching between configuration modes may insert a device-side -- synchronisation point for streamed kernel launches. ---setCacheConfigFun :: Fun -> CacheConfig -> IO ()+{-# INLINEABLE setCacheConfigFun #-}+setCacheConfigFun :: Fun -> Cache -> IO () #if CUDA_VERSION < 3000-setCacheConfigFun _ _ = requireSDK 3.0 "setCacheConfigFun"+setCacheConfigFun _ _ = requireSDK 3.0 "setCacheConfigFun" #else-setCacheConfigFun fn pref = nothingIfOk =<< cuFuncSetCacheConfig fn pref+setCacheConfigFun !fn !pref = nothingIfOk =<< cuFuncSetCacheConfig fn pref +{-# INLINE cuFuncSetCacheConfig #-} {# fun unsafe cuFuncSetCacheConfig { useFun `Fun'- , cFromEnum `CacheConfig' } -> `Status' cToEnum #}+ , cFromEnum `Cache' } -> `Status' cToEnum #} #endif -- |@@ -165,12 +160,14 @@ -- number of threads specified by a previous call to 'setBlockShape'. The launch -- may also be associated with a specific 'Stream'. --+{-# INLINEABLE launch #-} launch :: Fun -> (Int,Int) -> Maybe Stream -> IO ()-launch fn (w,h) mst =+launch !fn (!w,!h) mst = nothingIfOk =<< case mst of Nothing -> cuLaunchGridAsync fn w h (Stream nullPtr) Just st -> cuLaunchGridAsync fn w h st +{-# INLINE cuLaunchGridAsync #-} {# fun unsafe cuLaunchGridAsync { useFun `Fun' , `Int'@@ -192,6 +189,8 @@ -- requiring the application to know the size and alignment/padding of each -- kernel parameter. --+{-# INLINEABLE launchKernel #-}+{-# INLINEABLE launchKernel' #-} launchKernel, launchKernel' :: Fun -- ^ function to execute -> (Int,Int,Int) -- ^ block grid dimension@@ -201,33 +200,32 @@ -> [FunParam] -- ^ list of function parameters -> IO () #if CUDA_VERSION >= 4000-launchKernel fn (gx,gy,gz) (tx,ty,tz) sm mst args+launchKernel !fn (!gx,!gy,!gz) (!tx,!ty,!tz) !sm !mst !args = (=<<) nothingIfOk $ withMany withFP args $ \pa -> withArray pa $ \pp -> cuLaunchKernel fn gx gy gz tx ty tz sm st pp nullPtr where- st = fromMaybe (Stream nullPtr) mst+ !st = fromMaybe (Stream nullPtr) mst withFP :: FunParam -> (Ptr FunParam -> IO b) -> IO b- withFP p f = case p of+ withFP !p !f = case p of IArg v -> with' v (f . castPtr) FArg v -> with' v (f . castPtr) VArg v -> with' v (f . castPtr)- TArg _ -> error "launchKernel: TArg is deprecated" -- 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 =+ with' !val !f = allocaBytes (sizeOf val) $ \ptr -> do poke ptr val f ptr -launchKernel' fn (gx,gy,gz) (tx,ty,tz) sm mst args+launchKernel' !fn (!gx,!gy,!gz) (!tx,!ty,!tz) !sm !mst !args = (=<<) nothingIfOk $ with bytes $ \pb -> withArray' args@@ -244,12 +242,13 @@ -- our Storable instance for FunParam needs to dispatch on each constructor, -- hence evaluating the undefined. --- withArray' vals f =+ withArray' !vals !f = allocaBytes bytes $ \ptr -> do pokeArray ptr vals f ptr +{-# INLINE cuLaunchKernel #-} {# fun unsafe cuLaunchKernel { useFun `Fun' , `Int', `Int', `Int'@@ -260,7 +259,7 @@ , castPtr `Ptr (Ptr ())' } -> `Status' cToEnum #} #else-launchKernel fn (gx,gy,_) (tx,ty,tz) sm mst args = do+launchKernel !fn (!gx,!gy,_) (!tx,!ty,!tz) !sm !mst !args = do setParams fn args setSharedSize fn (toInteger sm) setBlockShape fn (tx,ty,tz)@@ -277,8 +276,9 @@ -- | -- Set the parameters that will specified next time the kernel is invoked --+{-# INLINEABLE setParams #-} setParams :: Fun -> [FunParam] -> IO ()-setParams fn prs = do+setParams !fn !prs = do zipWithM_ (set fn) offsets prs nothingIfOk =<< cuParamSetSize fn (last offsets) where@@ -286,38 +286,35 @@ size (IArg _) = sizeOf (undefined :: CUInt) size (FArg _) = sizeOf (undefined :: CFloat)- size (TArg _) = 0 size (VArg v) = sizeOf v set f o (IArg v) = nothingIfOk =<< cuParamSeti f o v set f o (FArg v) = nothingIfOk =<< cuParamSetf f o v- set f _ (TArg v) = nothingIfOk =<< cuParamSetTexRef f (-1) v set f o (VArg v) = with v $ \p -> (nothingIfOk =<< cuParamSetv f o p (sizeOf v)) +{-# INLINE cuParamSetSize #-} {# fun unsafe cuParamSetSize { useFun `Fun' , `Int' } -> `Status' cToEnum #} +{-# INLINE cuParamSeti #-} {# fun unsafe cuParamSeti { useFun `Fun' , `Int' , `Int' } -> `Status' cToEnum #} +{-# INLINE cuParamSetf #-} {# fun unsafe cuParamSetf { useFun `Fun' , `Int' , `Float' } -> `Status' cToEnum #} +{-# INLINE cuParamSetv #-} {# fun unsafe cuParamSetv `Storable a' => { useFun `Fun' , `Int' , castPtr `Ptr a' , `Int' } -> `Status' cToEnum #}--{# fun unsafe cuParamSetTexRef- { useFun `Fun'- , `Int' -- must be CU_PARAM_TR_DEFAULT (-1)- , useTexture `Texture' } -> `Status' cToEnum #}
Foreign/CUDA/Driver/Marshal.chs view
@@ -1,17 +1,17 @@-{-# LANGUAGE CPP, ForeignFunctionInterface #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ForeignFunctionInterface #-} {-# OPTIONS_HADDOCK prune #-} -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Driver.Marshal--- Copyright : (c) [2009..2011] Trevor L. McDonell+-- Copyright : (c) [2009..2012] Trevor L. McDonell -- License : BSD -- -- Memory management for low-level driver interface -- -------------------------------------------------------------------------------- -{-# LANGUAGE ScopedTypeVariables #-}- module Foreign.CUDA.Driver.Marshal ( -- * Host Allocation@@ -56,7 +56,7 @@ import Data.Maybe import Unsafe.Coerce import Control.Applicative-import Control.Exception.Extensible+import Control.Exception import Foreign.C import Foreign.Ptr@@ -92,28 +92,31 @@ -- system performance may suffer. This is best used sparingly to allocate -- staging areas for data exchange. --+{-# INLINEABLE mallocHostArray #-} mallocHostArray :: Storable a => [AllocFlag] -> Int -> IO (HostPtr a)-mallocHostArray flags = doMalloc undefined+mallocHostArray !flags = doMalloc undefined where doMalloc :: Storable a' => a' -> Int -> IO (HostPtr a')- doMalloc x n = resultIfOk =<< cuMemHostAlloc (n * sizeOf x) flags+ doMalloc x !n = resultIfOk =<< cuMemHostAlloc (n * sizeOf x) flags +{-# INLINE cuMemHostAlloc #-} {# fun unsafe cuMemHostAlloc { alloca'- `HostPtr a' peekHP* , `Int' , combineBitMasks `[AllocFlag]' } -> `Status' cToEnum #} where- alloca' f = F.alloca $ \(ptr :: Ptr (Ptr ())) ->- poke ptr nullPtr >> f (castPtr ptr)- peekHP p = (HostPtr . castPtr) `fmap` peek p+ alloca' !f = F.alloca $ \ !p -> poke p nullPtr >> f (castPtr p)+ peekHP !p = HostPtr . castPtr <$> peek p -- | -- Free a section of page-locked host memory --+{-# INLINEABLE freeHost #-} freeHost :: HostPtr a -> IO ()-freeHost p = nothingIfOk =<< cuMemFreeHost p+freeHost !p = nothingIfOk =<< cuMemFreeHost p +{-# INLINE cuMemFreeHost #-} {# fun unsafe cuMemFreeHost { useHP `HostPtr a' } -> `Status' cToEnum #} where@@ -134,17 +137,19 @@ -- -- This function is not yet implemented on Mac OS X. Requires cuda-4.0. --+{-# INLINEABLE registerArray #-} registerArray :: Storable a => [AllocFlag] -> Int -> Ptr a -> IO (HostPtr a) #if CUDA_VERSION < 4000-registerArray _ _ _ = requireSDK 4.0 "registerArray"+registerArray _ _ _ = requireSDK 4.0 "registerArray" #else-registerArray flags n = go undefined+registerArray !flags !n = go undefined where go :: Storable b => b -> Ptr b -> IO (HostPtr b)- go x p = do+ go x !p = do status <- cuMemHostRegister p (n * sizeOf x) flags resultIfOk (status,HostPtr p) +{-# INLINE cuMemHostRegister #-} {# fun unsafe cuMemHostRegister { castPtr `Ptr a' , `Int'@@ -157,14 +162,16 @@ -- -- This function is not yet implemented on Mac OS X. Requires cuda-4.0. --+{-# INLINEABLE unregisterArray #-} unregisterArray :: HostPtr a -> IO (Ptr a) #if CUDA_VERSION < 4000 unregisterArray _ = requireSDK 4.0 "unregisterArray" #else-unregisterArray (HostPtr p) = do+unregisterArray (HostPtr !p) = do status <- cuMemHostUnregister p resultIfOk (status,p) +{-# INLINE cuMemHostUnregister #-} {# fun unsafe cuMemHostUnregister { castPtr `Ptr a' } -> `Status' cToEnum #} #endif@@ -179,18 +186,19 @@ -- it. The memory is sufficient to hold the given number of elements of storable -- type. It is suitably aligned for any type, and is not cleared. --+{-# INLINEABLE mallocArray #-} mallocArray :: Storable a => Int -> IO (DevicePtr a) mallocArray = doMalloc undefined where doMalloc :: Storable a' => a' -> Int -> IO (DevicePtr a')- doMalloc x n = resultIfOk =<< cuMemAlloc (n * sizeOf x)+ doMalloc x !n = resultIfOk =<< cuMemAlloc (n * sizeOf x) +{-# INLINE cuMemAlloc #-} {# fun unsafe cuMemAlloc { alloca'- `DevicePtr a' peekDeviceHandle* , `Int' } -> `Status' cToEnum #} where- alloca' f = F.alloca $ \(ptr :: Ptr (Ptr ())) ->- poke ptr nullPtr >> f (castPtr ptr)+ alloca' !f = F.alloca $ \ !p -> poke p nullPtr >> f (castPtr p) -- |@@ -202,16 +210,19 @@ -- Note that kernel launches can be asynchronous, so you may want to add a -- synchronisation point using 'sync' as part of the computation. --+{-# INLINEABLE allocaArray #-} allocaArray :: Storable a => Int -> (DevicePtr a -> IO b) -> IO b-allocaArray n = bracket (mallocArray n) free+allocaArray !n = bracket (mallocArray n) free -- | -- Release a section of device memory --+{-# INLINEABLE free #-} free :: DevicePtr a -> IO ()-free dp = nothingIfOk =<< cuMemFree dp+free !dp = nothingIfOk =<< cuMemFree dp +{-# INLINE cuMemFree #-} {# fun unsafe cuMemFree { useDeviceHandle `DevicePtr a' } -> `Status' cToEnum #} @@ -224,12 +235,14 @@ -- Copy a number of elements from the device to host memory. This is a -- synchronous operation --+{-# INLINEABLE peekArray #-} peekArray :: Storable a => Int -> DevicePtr a -> Ptr a -> IO ()-peekArray n dptr hptr = doPeek undefined dptr+peekArray !n !dptr !hptr = doPeek undefined dptr where doPeek :: Storable a' => a' -> DevicePtr a' -> IO () doPeek x _ = nothingIfOk =<< cuMemcpyDtoH hptr dptr (n * sizeOf x) +{-# INLINE cuMemcpyDtoH #-} {# fun unsafe cuMemcpyDtoH { castPtr `Ptr a' , useDeviceHandle `DevicePtr a'@@ -240,12 +253,14 @@ -- Copy memory from the device asynchronously, possibly associated with a -- particular stream. The destination host memory must be page-locked. --+{-# INLINEABLE peekArrayAsync #-} peekArrayAsync :: Storable a => Int -> DevicePtr a -> HostPtr a -> Maybe Stream -> IO ()-peekArrayAsync n dptr hptr mst = doPeek undefined dptr+peekArrayAsync !n !dptr !hptr !mst = doPeek undefined dptr where doPeek :: Storable a' => a' -> DevicePtr a' -> IO () doPeek x _ = nothingIfOk =<< cuMemcpyDtoHAsync hptr dptr (n * sizeOf x) (fromMaybe (Stream nullPtr) mst) +{-# INLINE cuMemcpyDtoHAsync #-} {# fun unsafe cuMemcpyDtoHAsync { useHP `HostPtr a' , useDeviceHandle `DevicePtr a'@@ -260,8 +275,9 @@ -- this requires two memory copies: firstly from the device into a heap -- allocated array, and from there marshalled into a list. --+{-# INLINEABLE peekListArray #-} peekListArray :: Storable a => Int -> DevicePtr a -> IO [a]-peekListArray n dptr =+peekListArray !n !dptr = F.allocaArray n $ \p -> do peekArray n dptr p F.peekArray n p@@ -270,12 +286,14 @@ -- | -- Copy a number of elements onto the device. This is a synchronous operation --+{-# INLINEABLE pokeArray #-} pokeArray :: Storable a => Int -> Ptr a -> DevicePtr a -> IO ()-pokeArray n hptr dptr = doPoke undefined dptr+pokeArray !n !hptr !dptr = doPoke undefined dptr where doPoke :: Storable a' => a' -> DevicePtr a' -> IO () doPoke x _ = nothingIfOk =<< cuMemcpyHtoD dptr hptr (n * sizeOf x) +{-# INLINE cuMemcpyHtoD #-} {# fun unsafe cuMemcpyHtoD { useDeviceHandle `DevicePtr a' , castPtr `Ptr a'@@ -286,12 +304,14 @@ -- Copy memory onto the device asynchronously, possibly associated with a -- particular stream. The source host memory must be page-locked. --+{-# INLINEABLE pokeArrayAsync #-} pokeArrayAsync :: Storable a => Int -> HostPtr a -> DevicePtr a -> Maybe Stream -> IO ()-pokeArrayAsync n hptr dptr mst = dopoke undefined dptr+pokeArrayAsync !n !hptr !dptr !mst = dopoke undefined dptr where dopoke :: Storable a' => a' -> DevicePtr a' -> IO () dopoke x _ = nothingIfOk =<< cuMemcpyHtoDAsync dptr hptr (n * sizeOf x) (fromMaybe (Stream nullPtr) mst) +{-# INLINE cuMemcpyHtoDAsync #-} {# fun unsafe cuMemcpyHtoDAsync { useDeviceHandle `DevicePtr a' , useHP `HostPtr a'@@ -306,8 +326,9 @@ -- be sufficiently large to hold the entire list. This requires two marshalling -- operations. --+{-# INLINEABLE pokeListArray #-} pokeListArray :: Storable a => [a] -> DevicePtr a -> IO ()-pokeListArray xs dptr = F.withArrayLen xs $ \len p -> pokeArray len p dptr+pokeListArray !xs !dptr = F.withArrayLen xs $ \ !len !p -> pokeArray len p dptr -- |@@ -316,12 +337,14 @@ -- asynchronous with respect to the host, but will never overlap with kernel -- execution. --+{-# INLINEABLE copyArrayAsync #-} copyArrayAsync :: Storable a => Int -> DevicePtr a -> DevicePtr a -> IO ()-copyArrayAsync n = docopy undefined+copyArrayAsync !n = docopy undefined where docopy :: Storable a' => a' -> DevicePtr a' -> DevicePtr a' -> IO () docopy x src dst = nothingIfOk =<< cuMemcpyDtoD dst src (n * sizeOf x) +{-# INLINE cuMemcpyDtoD #-} {# fun unsafe cuMemcpyDtoD { useDeviceHandle `DevicePtr a' , useDeviceHandle `DevicePtr a'@@ -335,19 +358,21 @@ -- the source and destination contexts. To avoid this synchronisation, use -- 'copyArrayPeerAsync' instead. --+{-# INLINEABLE copyArrayPeer #-} copyArrayPeer :: Storable a => Int -- ^ number of array elements -> DevicePtr a -> Context -- ^ source array and context -> DevicePtr a -> Context -- ^ destination array and context -> IO () #if CUDA_VERSION < 4000-copyArrayPeer _ _ _ _ _ = requireSDK 4.0 "copyArrayPeer"+copyArrayPeer _ _ _ _ _ = requireSDK 4.0 "copyArrayPeer" #else-copyArrayPeer n src srcCtx dst dstCtx = go undefined src dst+copyArrayPeer !n !src !srcCtx !dst !dstCtx = go undefined src dst where go :: Storable b => b -> DevicePtr b -> DevicePtr b -> IO () go x _ _ = nothingIfOk =<< cuMemcpyPeer dst dstCtx src srcCtx (n * sizeOf x) +{-# INLINE cuMemcpyPeer #-} {# fun unsafe cuMemcpyPeer { useDeviceHandle `DevicePtr a' , useContext `Context'@@ -362,6 +387,7 @@ -- Note that this function is asynchronous with respect to the host and all work -- in other streams and devices. --+{-# INLINEABLE copyArrayPeerAsync #-} copyArrayPeerAsync :: Storable a => Int -- ^ number of array elements -> DevicePtr a -> Context -- ^ source array and context@@ -369,14 +395,15 @@ -> Maybe Stream -- ^ stream to associate with -> IO () #if CUDA_VERSION < 4000-copyArrayPeerAsync _ _ _ _ _ _ = requireSDK 4.0 "copyArrayPeerAsync"+copyArrayPeerAsync _ _ _ _ _ _ = requireSDK 4.0 "copyArrayPeerAsync" #else-copyArrayPeerAsync n src srcCtx dst dstCtx st = go undefined src dst+copyArrayPeerAsync !n !src !srcCtx !dst !dstCtx !st = go undefined src dst where go :: Storable b => b -> DevicePtr b -> DevicePtr b -> IO () go x _ _ = nothingIfOk =<< cuMemcpyPeerAsync dst dstCtx src srcCtx (n * sizeOf x) stream stream = fromMaybe (Stream nullPtr) st +{-# INLINE cuMemcpyPeerAsync #-} {# fun unsafe cuMemcpyPeerAsync { useDeviceHandle `DevicePtr a' , useContext `Context'@@ -398,6 +425,7 @@ -- list to a heap allocated array, and from there onto the graphics device. The -- memory should be 'free'd when no longer required. --+{-# INLINEABLE newListArrayLen #-} newListArrayLen :: Storable a => [a] -> IO (DevicePtr a, Int) newListArrayLen xs = F.withArrayLen xs $ \len p ->@@ -410,6 +438,7 @@ -- Write a list of storable elements into a newly allocated device array. This -- is 'newListArrayLen' composed with 'fst'. --+{-# INLINEABLE newListArray #-} newListArray :: Storable a => [a] -> IO (DevicePtr a) newListArray xs = fst `fmap` newListArrayLen xs @@ -423,6 +452,7 @@ -- should not return the pointer from the action, and be wary of asynchronous -- kernel execution. --+{-# INLINEABLE withListArray #-} withListArray :: Storable a => [a] -> (DevicePtr a -> IO b) -> IO b withListArray xs = withListArrayLen xs . const @@ -431,6 +461,7 @@ -- A variant of 'withListArray' which also supplies the number of elements in -- the array to the applied function --+{-# INLINEABLE withListArrayLen #-} withListArrayLen :: Storable a => [a] -> (Int -> DevicePtr a -> IO b) -> IO b withListArrayLen xs f = bracket (newListArrayLen xs) (free . fst) (uncurry . flip $ f)@@ -448,8 +479,9 @@ -- Set a number of data elements to the specified value, which may be either 8-, -- 16-, or 32-bits wide. --+{-# INLINEABLE memset #-} memset :: Storable a => DevicePtr a -> Int -> a -> IO ()-memset dptr n val = case sizeOf val of+memset !dptr !n !val = case sizeOf val of 1 -> nothingIfOk =<< cuMemsetD8 dptr val n 2 -> nothingIfOk =<< cuMemsetD16 dptr val n 4 -> nothingIfOk =<< cuMemsetD32 dptr val n@@ -459,16 +491,19 @@ -- We use unsafe coerce below to reinterpret the bits of the value to memset as, -- into the integer type required by the setting functions. --+{-# INLINE cuMemsetD8 #-} {# fun unsafe cuMemsetD8 { useDeviceHandle `DevicePtr a' , unsafeCoerce `a' , `Int' } -> `Status' cToEnum #} +{-# INLINE cuMemsetD16 #-} {# fun unsafe cuMemsetD16 { useDeviceHandle `DevicePtr a' , unsafeCoerce `a' , `Int' } -> `Status' cToEnum #} +{-# INLINE cuMemsetD32 #-} {# fun unsafe cuMemsetD32 { useDeviceHandle `DevicePtr a' , unsafeCoerce `a'@@ -480,11 +515,12 @@ -- 8-, 16-, or 32-bits wide. The operation is asynchronous and may optionally be -- associated with a stream. Requires cuda-3.2. --+{-# INLINEABLE memsetAsync #-} memsetAsync :: Storable a => DevicePtr a -> Int -> a -> Maybe Stream -> IO () #if CUDA_VERSION < 3020-memsetAsync _ _ _ _ = requireSDK 3.2 "memsetAsync"+memsetAsync _ _ _ _ = requireSDK 3.2 "memsetAsync" #else-memsetAsync dptr n val mst = case sizeOf val of+memsetAsync !dptr !n !val !mst = case sizeOf val of 1 -> nothingIfOk =<< cuMemsetD8Async dptr val n stream 2 -> nothingIfOk =<< cuMemsetD16Async dptr val n stream 4 -> nothingIfOk =<< cuMemsetD32Async dptr val n stream@@ -492,18 +528,21 @@ where stream = fromMaybe (Stream nullPtr) mst +{-# INLINE cuMemsetD8Async #-} {# fun unsafe cuMemsetD8Async { useDeviceHandle `DevicePtr a' , unsafeCoerce `a' , `Int' , useStream `Stream' } -> `Status' cToEnum #} +{-# INLINE cuMemsetD16Async #-} {# fun unsafe cuMemsetD16Async { useDeviceHandle `DevicePtr a' , unsafeCoerce `a' , `Int' , useStream `Stream' } -> `Status' cToEnum #} +{-# INLINE cuMemsetD32Async #-} {# fun unsafe cuMemsetD32Async { useDeviceHandle `DevicePtr a' , unsafeCoerce `a'@@ -518,9 +557,11 @@ -- -- Currently, no options are supported and this must be empty. --+{-# INLINEABLE getDevicePtr #-} getDevicePtr :: [AllocFlag] -> HostPtr a -> IO (DevicePtr a)-getDevicePtr flags hp = resultIfOk =<< cuMemHostGetDevicePointer hp flags+getDevicePtr !flags !hp = resultIfOk =<< cuMemHostGetDevicePointer hp flags +{-# INLINE cuMemHostGetDevicePointer #-} {# fun unsafe cuMemHostGetDevicePointer { alloca'- `DevicePtr a' peekDeviceHandle* , useHP `HostPtr a'@@ -532,11 +573,13 @@ -- | -- Return the base address and allocation size of the given device pointer --+{-# INLINEABLE getBasePtr #-} getBasePtr :: DevicePtr a -> IO (DevicePtr a, Int64)-getBasePtr dptr = do+getBasePtr !dptr = do (status,base,size) <- cuMemGetAddressRange dptr resultIfOk (status, (base,size)) +{-# INLINE cuMemGetAddressRange #-} {# fun unsafe cuMemGetAddressRange { alloca'- `DevicePtr a' peekDeviceHandle* , alloca'- `Int64' peekIntConv*@@ -549,11 +592,13 @@ -- Return the amount of free and total memory respectively available to the -- current context (bytes) --+{-# INLINEABLE getMemInfo #-} getMemInfo :: IO (Int64, Int64) getMemInfo = do- (status,f,t) <- cuMemGetInfo+ (!status,!f,!t) <- cuMemGetInfo resultIfOk (status,(f,t)) +{-# INLINE cuMemGetInfo #-} {# fun unsafe cuMemGetInfo { alloca'- `Int64' peekIntConv* , alloca'- `Int64' peekIntConv* } -> `Status' cToEnum #}@@ -571,11 +616,13 @@ -- arcane distinctions for the different driver versions and Tesla (compute 1.x) -- and Fermi (compute 2.x) class architectures on 32- and 64-bit hosts. --+{-# INLINE peekDeviceHandle #-} peekDeviceHandle :: Ptr DeviceHandle -> IO (DevicePtr a)-peekDeviceHandle p = DevicePtr . intPtrToPtr . fromIntegral <$> peek p+peekDeviceHandle !p = DevicePtr . intPtrToPtr . fromIntegral <$> peek p -- Use a device pointer as an opaque handle type --+{-# INLINE useDeviceHandle #-} useDeviceHandle :: DevicePtr a -> DeviceHandle useDeviceHandle = fromIntegral . ptrToIntPtr . useDevicePtr
Foreign/CUDA/Driver/Module.chs view
@@ -1,8 +1,9 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ForeignFunctionInterface #-} -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Driver.Module--- Copyright : (c) [2009..2011] Trevor L. McDonell+-- Copyright : (c) [2009..2012] Trevor L. McDonell -- License : BSD -- -- Module management for low-level driver interface@@ -35,7 +36,7 @@ import Unsafe.Coerce import Control.Monad (liftM)-import Control.Exception.Extensible (throwIO)+import Control.Exception (throwIO) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B @@ -93,9 +94,11 @@ -- | -- Returns a function handle --+{-# INLINEABLE getFun #-} getFun :: Module -> String -> IO Fun-getFun mdl fn = resultIfFound "function" fn =<< cuModuleGetFunction mdl fn+getFun !mdl !fn = resultIfFound "function" fn =<< cuModuleGetFunction mdl fn +{-# INLINE cuModuleGetFunction #-} {# fun unsafe cuModuleGetFunction { alloca- `Fun' peekFun* , useModule `Module'@@ -106,11 +109,13 @@ -- | -- Return a global pointer, and size of the global (in bytes) --+{-# INLINEABLE getPtr #-} getPtr :: Module -> String -> IO (DevicePtr a, Int)-getPtr mdl name = do- (status,dptr,bytes) <- cuModuleGetGlobal mdl name+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*@@ -121,9 +126,11 @@ -- | -- Return a handle to a texture reference --+{-# INLINEABLE getTex #-} getTex :: Module -> String -> IO Texture-getTex mdl name = resultIfFound "texture" name =<< cuModuleGetTexRef mdl name+getTex !mdl !name = resultIfFound "texture" name =<< cuModuleGetTexRef mdl name +{-# INLINE cuModuleGetTexRef #-} {# fun unsafe cuModuleGetTexRef { alloca- `Texture' peekTex* , useModule `Module'@@ -134,9 +141,11 @@ -- Load the contents of the specified file (either a ptx or cubin file) to -- create a new module, and load that module into the current context --+{-# INLINEABLE loadFile #-} loadFile :: FilePath -> IO Module-loadFile ptx = resultIfOk =<< cuModuleLoad ptx+loadFile !ptx = resultIfOk =<< cuModuleLoad ptx +{-# INLINE cuModuleLoad #-} {# fun unsafe cuModuleLoad { alloca- `Module' peekMod* , withCString* `FilePath' } -> `Status' cToEnum #}@@ -147,9 +156,11 @@ -- into the current context. The image (typically) is the contents of a cubin or -- ptx file as a NULL-terminated string. --+{-# INLINEABLE loadData #-} loadData :: ByteString -> IO Module-loadData img = resultIfOk =<< cuModuleLoadData img+loadData !img = resultIfOk =<< cuModuleLoadData img +{-# INLINE cuModuleLoadData #-} {# fun unsafe cuModuleLoadData { alloca- `Module' peekMod* , useByteString* `ByteString' } -> ` Status' cToEnum #}@@ -159,8 +170,9 @@ -- Load a module with online compiler options. The actual attributes of the -- compiled kernel can be probed using 'requires'. --+{-# INLINEABLE loadDataEx #-} loadDataEx :: ByteString -> [JITOption] -> IO (Module, JITResult)-loadDataEx img options =+loadDataEx !img !options = allocaArray logSize $ \p_ilog -> allocaArray logSize $ \p_elog -> let (opt,val) = unzip $@@ -188,6 +200,7 @@ unpack (Target x) = (JIT_TARGET, fromEnum x) +{-# INLINE cuModuleLoadDataEx #-} {# fun unsafe cuModuleLoadDataEx { alloca- `Module' peekMod* , useByteString* `ByteString'@@ -199,9 +212,11 @@ -- | -- Unload a module from the current context --+{-# INLINEABLE unload #-} unload :: Module -> IO ()-unload m = nothingIfOk =<< cuModuleUnload m+unload !m = nothingIfOk =<< cuModuleUnload m +{-# INLINE cuModuleUnload #-} {# fun unsafe cuModuleUnload { useModule `Module' } -> `Status' cToEnum #} @@ -210,16 +225,19 @@ -- Internal -------------------------------------------------------------------------------- +{-# INLINE resultIfFound #-} resultIfFound :: String -> String -> (Status, a) -> IO a-resultIfFound kind name (status,result) =+resultIfFound kind name (!status,!result) = case status of Success -> return result NotFound -> cudaError (kind ++ ' ' : describe status ++ ": " ++ name) _ -> throwIO (ExitCode status) +{-# INLINE peekMod #-} peekMod :: Ptr {# type CUmodule #} -> IO Module peekMod = liftM Module . peek +{-# INLINE useByteString #-} useByteString :: ByteString -> (Ptr a -> IO b) -> IO b-useByteString bs act = B.useAsCString bs $ \p -> act (castPtr p)+useByteString !bs !act = B.useAsCString bs $ \ !p -> act (castPtr p)
Foreign/CUDA/Driver/Stream.chs view
@@ -1,8 +1,10 @@-{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ForeignFunctionInterface #-} -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Driver.Stream--- Copyright : (c) [2009..2011] Trevor L. McDonell+-- Copyright : (c) [2009..2012] Trevor L. McDonell -- License : BSD -- -- Stream management for low-level driver interface@@ -46,7 +48,6 @@ -- exports actual option values. -- data StreamFlag- instance Enum StreamFlag where --------------------------------------------------------------------------------@@ -56,9 +57,11 @@ -- | -- Create a new stream --+{-# INLINEABLE create #-} create :: [StreamFlag] -> IO Stream-create flags = resultIfOk =<< cuStreamCreate flags+create !flags = resultIfOk =<< cuStreamCreate flags +{-# INLINE cuStreamCreate #-} {# fun unsafe cuStreamCreate { alloca- `Stream' peekStream* , combineBitMasks `[StreamFlag]' } -> `Status' cToEnum #}@@ -67,9 +70,11 @@ -- | -- Destroy a stream --+{-# INLINEABLE destroy #-} destroy :: Stream -> IO ()-destroy st = nothingIfOk =<< cuStreamDestroy st+destroy !st = nothingIfOk =<< cuStreamDestroy st +{-# INLINE cuStreamDestroy #-} {# fun unsafe cuStreamDestroy { useStream `Stream' } -> `Status' cToEnum #} @@ -77,14 +82,16 @@ -- | -- Check if all operations in the stream have completed --+{-# INLINEABLE finished #-} finished :: Stream -> IO Bool-finished st =+finished !st = cuStreamQuery st >>= \rv -> case rv of Success -> return True NotReady -> return False _ -> resultIfOk (rv,undefined) +{-# INLINE cuStreamQuery #-} {# fun unsafe cuStreamQuery { useStream `Stream' } -> `Status' cToEnum #} @@ -92,9 +99,11 @@ -- | -- Wait until the device has completed all operations in the Stream --+{-# INLINEABLE block #-} block :: Stream -> IO ()-block st = nothingIfOk =<< cuStreamSynchronize st+block !st = nothingIfOk =<< cuStreamSynchronize st +{-# INLINE cuStreamSynchronize #-} {# fun unsafe cuStreamSynchronize { useStream `Stream' } -> `Status' cToEnum #}
Foreign/CUDA/Driver/Texture.chs view
@@ -1,9 +1,10 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# OPTIONS_HADDOCK prune #-} -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Driver.Texture--- Copyright : (c) [2009..2011] Trevor L. McDonell+-- Copyright : (c) [2009..2012] Trevor L. McDonell -- License : BSD -- -- Texture management for low-level driver interface@@ -111,9 +112,11 @@ -- reference functions are used to specify the format and interpretation to be -- used when the memory is read through this reference. --+{-# INLINEABLE create #-} create :: IO Texture create = resultIfOk =<< cuTexRefCreate +{-# INLINE cuTexRefCreate #-} {# fun unsafe cuTexRefCreate { alloca- `Texture' peekTex* } -> `Status' cToEnum #} @@ -121,9 +124,11 @@ -- | -- Destroy a texture reference --+{-# INLINEABLE destroy #-} destroy :: Texture -> IO ()-destroy tex = nothingIfOk =<< cuTexRefDestroy tex+destroy !tex = nothingIfOk =<< cuTexRefDestroy tex +{-# INLINE cuTexRefDestroy #-} {# fun unsafe cuTexRefDestroy { useTexture `Texture' } -> `Status' cToEnum #} @@ -132,9 +137,11 @@ -- Bind a linear array address of the given size (bytes) as a texture -- reference. Any previously bound references are unbound. --+{-# INLINEABLE bind #-} bind :: Texture -> DevicePtr a -> Int64 -> IO ()-bind tex dptr bytes = nothingIfOk =<< cuTexRefSetAddress tex dptr bytes+bind !tex !dptr !bytes = nothingIfOk =<< cuTexRefSetAddress tex dptr bytes +{-# INLINE cuTexRefSetAddress #-} {# fun unsafe cuTexRefSetAddress { alloca- `Int' , useTexture `Texture'@@ -148,10 +155,12 @@ -- calls to 'setFormat' can not follow a call to 'bind2D' for the same texture -- reference. --+{-# INLINEABLE bind2D #-} bind2D :: Texture -> Format -> Int -> DevicePtr a -> (Int,Int) -> Int64 -> IO ()-bind2D tex fmt chn dptr (width,height) pitch =+bind2D !tex !fmt !chn !dptr (!width,!height) !pitch = nothingIfOk =<< cuTexRefSetAddress2DSimple tex fmt chn dptr width height pitch +{-# INLINE cuTexRefSetAddress2DSimple #-} {# fun unsafe cuTexRefSetAddress2DSimple { useTexture `Texture' , cFromEnum `Format'@@ -166,9 +175,11 @@ -- Get the addressing mode used by a texture reference, corresponding to the -- given dimension (currently the only supported dimension values are 0 or 1). --+{-# INLINEABLE getAddressMode #-} getAddressMode :: Texture -> Int -> IO AddressMode-getAddressMode tex dim = resultIfOk =<< cuTexRefGetAddressMode tex dim+getAddressMode !tex !dim = resultIfOk =<< cuTexRefGetAddressMode tex dim +{-# INLINE cuTexRefGetAddressMode #-} {# fun unsafe cuTexRefGetAddressMode { alloca- `AddressMode' peekEnum* , useTexture `Texture'@@ -178,9 +189,11 @@ -- | -- Get the filtering mode used by a texture reference --+{-# INLINEABLE getFilterMode #-} getFilterMode :: Texture -> IO FilterMode-getFilterMode tex = resultIfOk =<< cuTexRefGetFilterMode tex+getFilterMode !tex = resultIfOk =<< cuTexRefGetFilterMode tex +{-# INLINE cuTexRefGetFilterMode #-} {# fun unsafe cuTexRefGetFilterMode { alloca- `FilterMode' peekEnum* , useTexture `Texture' } -> `Status' cToEnum #}@@ -189,11 +202,13 @@ -- | -- Get the data format and number of channel components of the bound texture --+{-# INLINEABLE getFormat #-} getFormat :: Texture -> IO (Format, Int)-getFormat tex = do- (status,fmt,dim) <- cuTexRefGetFormat tex+getFormat !tex = do+ (!status,!fmt,!dim) <- cuTexRefGetFormat tex resultIfOk (status,(fmt,dim)) +{-# INLINE cuTexRefGetFormat #-} {# fun unsafe cuTexRefGetFormat { alloca- `Format' peekEnum* , alloca- `Int' peekIntConv*@@ -203,9 +218,11 @@ -- | -- Specify the addressing mode for the given dimension of a texture reference --+{-# INLINEABLE setAddressMode #-} setAddressMode :: Texture -> Int -> AddressMode -> IO ()-setAddressMode tex dim mode = nothingIfOk =<< cuTexRefSetAddressMode tex dim mode+setAddressMode !tex !dim !mode = nothingIfOk =<< cuTexRefSetAddressMode tex dim mode +{-# INLINE cuTexRefSetAddressMode #-} {# fun unsafe cuTexRefSetAddressMode { useTexture `Texture' , `Int'@@ -216,9 +233,11 @@ -- Specify the filtering mode to be used when reading memory through a texture -- reference --+{-# INLINEABLE setFilterMode #-} setFilterMode :: Texture -> FilterMode -> IO ()-setFilterMode tex mode = nothingIfOk =<< cuTexRefSetFilterMode tex mode+setFilterMode !tex !mode = nothingIfOk =<< cuTexRefSetFilterMode tex mode +{-# INLINE cuTexRefSetFilterMode #-} {# fun unsafe cuTexRefSetFilterMode { useTexture `Texture' , cFromEnum `FilterMode' } -> `Status' cToEnum #}@@ -228,9 +247,11 @@ -- Specify additional characteristics for reading and indexing the texture -- reference --+{-# INLINEABLE setReadMode #-} setReadMode :: Texture -> ReadMode -> IO ()-setReadMode tex mode = nothingIfOk =<< cuTexRefSetFlags tex mode+setReadMode !tex !mode = nothingIfOk =<< cuTexRefSetFlags tex mode +{-# INLINE cuTexRefSetFlags #-} {# fun unsafe cuTexRefSetFlags { useTexture `Texture' , cFromEnum `ReadMode' } -> `Status' cToEnum #}@@ -240,9 +261,11 @@ -- Specify the format of the data and number of packed components per element to -- be read by the texture reference --+{-# INLINEABLE setFormat #-} setFormat :: Texture -> Format -> Int -> IO ()-setFormat tex fmt chn = nothingIfOk =<< cuTexRefSetFormat tex fmt chn+setFormat !tex !fmt !chn = nothingIfOk =<< cuTexRefSetFormat tex fmt chn +{-# INLINE cuTexRefSetFormat #-} {# fun unsafe cuTexRefSetFormat { useTexture `Texture' , cFromEnum `Format'@@ -253,6 +276,7 @@ -- Internal -------------------------------------------------------------------------------- +{-# INLINE peekTex #-} peekTex :: Ptr {# type CUtexref #} -> IO Texture peekTex = liftM Texture . peek
Foreign/CUDA/Driver/Utils.chs view
@@ -2,7 +2,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Driver.Utils--- Copyright : (c) [2009..2011] Trevor L. McDonell+-- Copyright : (c) [2009..2012] Trevor L. McDonell -- License : BSD -- -- Utility functions@@ -27,9 +27,11 @@ -- | -- Return the version number of the installed CUDA driver --+{-# INLINEABLE driverVersion #-} driverVersion :: IO Int driverVersion = resultIfOk =<< cuDriverGetVersion +{-# INLINE cuDriverGetVersion #-} {# fun unsafe cuDriverGetVersion { alloca- `Int' peekIntConv* } -> `Status' cToEnum #}
Foreign/CUDA/Internal/C2HS.hs view
@@ -4,19 +4,19 @@ -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are met:--- +-- -- 1. Redistributions of source code must retain the above copyright notice,--- this list of conditions and the following disclaimer. +-- this list of conditions and the following disclaimer. -- 2. Redistributions in binary form must reproduce the above copyright -- notice, this list of conditions and the following disclaimer in the--- documentation and/or other materials provided with the distribution. +-- documentation and/or other materials provided with the distribution. -- 3. The name of the author may not be used to endorse or promote products--- derived from this software without specific prior written permission. +-- derived from this software without specific prior written permission. -- -- THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR -- IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES -- OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN--- NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +-- NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED -- TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR -- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF@@ -28,7 +28,7 @@ -- -- Language: Haskell 98 ----- This module provides the marshaling routines for Haskell files produced by +-- This module provides the marshaling routines for Haskell files produced by -- C->Haskell for binding to C library interfaces. It exports all of the -- low-level FFI (language-independent plus the C-specific parts) together -- with the C->HS-specific higher-level marshalling routines.@@ -36,12 +36,6 @@ module Foreign.CUDA.Internal.C2HS ( --- -- * Re-export the language-independent component of the FFI --- module Foreign,------ -- * Re-export the C language component of the FFI--- module CForeign,- -- * Composite marshalling functions withCStringLenIntConv, peekCStringLenIntConv, withIntConv, withFloatConv, peekIntConv, peekFloatConv, withBool, peekBool, withEnum, peekEnum,@@ -54,13 +48,10 @@ -- * Conversion between C and Haskell types cIntConv, cFloatConv, cToBool, cFromBool, cToEnum, cFromEnum-) where +) where import Foreign- hiding (Word)- -- Should also hide the Foreign.Marshal.Pool exports in- -- compilers that export them import Foreign.C import Control.Monad (liftM) @@ -70,49 +61,45 @@ -- Strings with explicit length ---withCStringLenIntConv :: String -> (CStringLen -> IO a) -> IO a-withCStringLenIntConv s f = withCStringLen s $ \(p, n) -> f (p, cIntConv n)+withCStringLenIntConv :: String -> (CStringLen -> IO a) -> IO a+withCStringLenIntConv s f = withCStringLen s $ \(p, n) -> f (p, cIntConv n) -peekCStringLenIntConv :: CStringLen -> IO String-peekCStringLenIntConv (s, n) = peekCStringLen (s, cIntConv n)+peekCStringLenIntConv :: CStringLen -> IO String+peekCStringLenIntConv (s, n) = peekCStringLen (s, cIntConv n) -- Marshalling of numerals -- -withIntConv :: (Storable b, Integral a, Integral b) - => a -> (Ptr b -> IO c) -> IO c-withIntConv = with . cIntConv+withIntConv :: (Storable b, Integral a, Integral b) => a -> (Ptr b -> IO c) -> IO c+withIntConv = with . cIntConv -withFloatConv :: (Storable b, RealFloat a, RealFloat b) - => a -> (Ptr b -> IO c) -> IO c-withFloatConv = with . cFloatConv+withFloatConv :: (Storable b, RealFloat a, RealFloat b) => a -> (Ptr b -> IO c) -> IO c+withFloatConv = with . cFloatConv -peekIntConv :: (Storable a, Integral a, Integral b) - => Ptr a -> IO b-peekIntConv = liftM cIntConv . peek+peekIntConv :: (Storable a, Integral a, Integral b) => Ptr a -> IO b+peekIntConv = liftM cIntConv . peek -peekFloatConv :: (Storable a, RealFloat a, RealFloat b) - => Ptr a -> IO b-peekFloatConv = liftM cFloatConv . peek+peekFloatConv :: (Storable a, RealFloat a, RealFloat b) => Ptr a -> IO b+peekFloatConv = liftM cFloatConv . peek -- Passing Booleans by reference -- withBool :: (Integral a, Storable a) => Bool -> (Ptr a -> IO b) -> IO b-withBool = with . fromBool+withBool = with . fromBool peekBool :: (Integral a, Storable a) => Ptr a -> IO Bool-peekBool = liftM toBool . peek+peekBool = liftM toBool . peek -- Passing enums by reference -- withEnum :: (Enum a, Integral b, Storable b) => a -> (Ptr b -> IO c) -> IO c-withEnum = with . cFromEnum+withEnum = with . cFromEnum peekEnum :: (Enum a, Integral b, Storable b) => Ptr b -> IO a-peekEnum = liftM cToEnum . peek+peekEnum = liftM cToEnum . peek {-@@ -148,13 +135,13 @@ -- * the second argument allows to map a result wrapped into `Just' to some -- other domain ---nothingIf :: (a -> Bool) -> (a -> b) -> a -> Maybe b-nothingIf p f x = if p x then Nothing else Just $ f x+nothingIf :: (a -> Bool) -> (a -> b) -> a -> Maybe b+nothingIf p f x = if p x then Nothing else Just $ f x -- |Instance for special casing null pointers. -- nothingIfNull :: (Ptr a -> b) -> Ptr a -> Maybe b-nothingIfNull = nothingIf (== nullPtr)+nothingIfNull = nothingIf (== nullPtr) -- Support for bit masks@@ -190,35 +177,42 @@ -- |Integral conversion --+{-# INLINE cIntConv #-} cIntConv :: (Integral a, Integral b) => a -> b cIntConv = fromIntegral -- |Floating conversion --+{-# INLINE cFloatConv #-} cFloatConv :: (RealFloat a, RealFloat b) => a -> b cFloatConv = realToFrac -- As this conversion by default goes via `Rational', it can be very slow...-{-# RULES +{-# RULES "cFloatConv/Float->Float" forall (x::Float). cFloatConv x = x; "cFloatConv/Double->Double" forall (x::Double). cFloatConv x = x #-} -- |Obtain C value from Haskell 'Bool'. --+{-# INLINE cFromBool #-} cFromBool :: Num a => Bool -> a cFromBool = fromBool -- |Obtain Haskell 'Bool' from C value. --+{-# INLINE cToBool #-} cToBool :: (Eq a, Num a) => a -> Bool cToBool = toBool -- |Convert a C enumeration to Haskell. --+{-# INLINE cToEnum #-} cToEnum :: (Integral i, Enum e) => i -> e cToEnum = toEnum . cIntConv -- |Convert a Haskell enumeration to C. --+{-# INLINE cFromEnum #-} cFromEnum :: (Enum e, Integral i) => e -> i cFromEnum = cIntConv . fromEnum+
Foreign/CUDA/Ptr.hs view
@@ -1,7 +1,8 @@+{-# LANGUAGE BangPatterns #-} -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Ptr--- Copyright : (c) [2009..2011] Trevor L. McDonell+-- Copyright : (c) [2009..2012] Trevor L. McDonell -- License : BSD -- -- A common interface for host and device pointers. While it is possible mix the@@ -43,18 +44,21 @@ -- applied to that pointer, the result of which is returned. It would be silly -- to return the pointer from the action. --+{-# INLINEABLE withDevicePtr #-} withDevicePtr :: DevicePtr a -> (Ptr a -> IO b) -> IO b-withDevicePtr p f = f (useDevicePtr p)+withDevicePtr !p !f = f (useDevicePtr p) -- | -- Return a unique handle associated with the given device pointer --+{-# INLINEABLE devPtrToWordPtr #-} devPtrToWordPtr :: DevicePtr a -> WordPtr devPtrToWordPtr = ptrToWordPtr . useDevicePtr -- | -- Return a device pointer from the given handle --+{-# INLINEABLE wordPtrToDevPtr #-} wordPtrToDevPtr :: WordPtr -> DevicePtr a wordPtrToDevPtr = DevicePtr . wordPtrToPtr @@ -62,27 +66,31 @@ -- The constant 'nullDevPtr' contains the distinguished memory location that is -- not associated with a valid memory location --+{-# INLINEABLE nullDevPtr #-} nullDevPtr :: DevicePtr a nullDevPtr = DevicePtr nullPtr -- | -- Cast a device pointer from one type to another --+{-# INLINEABLE castDevPtr #-} castDevPtr :: DevicePtr a -> DevicePtr b-castDevPtr (DevicePtr p) = DevicePtr (castPtr p)+castDevPtr (DevicePtr !p) = DevicePtr (castPtr p) -- | -- Advance the pointer address by the given offset in bytes. --+{-# INLINEABLE plusDevPtr #-} plusDevPtr :: DevicePtr a -> Int -> DevicePtr a-plusDevPtr (DevicePtr p) d = DevicePtr (p `plusPtr` d)+plusDevPtr (DevicePtr !p) !d = DevicePtr (p `plusPtr` d) -- | -- Given an alignment constraint, align the device pointer to the next highest -- address satisfying the constraint --+{-# INLINEABLE alignDevPtr #-} alignDevPtr :: DevicePtr a -> Int -> DevicePtr a-alignDevPtr (DevicePtr p) i = DevicePtr (p `alignPtr` i)+alignDevPtr (DevicePtr !p) !i = DevicePtr (p `alignPtr` i) -- | -- Compute the difference between the second and first argument. This fulfils@@ -90,17 +98,19 @@ -- -- > p2 == p1 `plusDevPtr` (p2 `minusDevPtr` p1) --+{-# INLINEABLE minusDevPtr #-} minusDevPtr :: DevicePtr a -> DevicePtr a -> Int-minusDevPtr (DevicePtr a) (DevicePtr b) = a `minusPtr` b+minusDevPtr (DevicePtr !a) (DevicePtr !b) = a `minusPtr` b -- | -- Advance a pointer into a device array by the given number of elements --+{-# INLINEABLE advanceDevPtr #-} advanceDevPtr :: Storable a => DevicePtr a -> Int -> DevicePtr a-advanceDevPtr = doAdvance undefined+advanceDevPtr = doAdvance undefined where doAdvance :: Storable a' => a' -> DevicePtr a' -> Int -> DevicePtr a'- doAdvance x p i = p `plusDevPtr` (i * sizeOf x)+ doAdvance x !p !i = p `plusDevPtr` (i * sizeOf x) --------------------------------------------------------------------------------@@ -127,48 +137,55 @@ -- Apply an IO action to the memory reference living inside the host pointer -- object. All uses of the pointer should be inside the 'withHostPtr' bracket. --+{-# INLINEABLE withHostPtr #-} withHostPtr :: HostPtr a -> (Ptr a -> IO b) -> IO b-withHostPtr p f = f (useHostPtr p)+withHostPtr !p !f = f (useHostPtr p) -- | -- The constant 'nullHostPtr' contains the distinguished memory location that is -- not associated with a valid memory location --+{-# INLINEABLE nullHostPtr #-} nullHostPtr :: HostPtr a nullHostPtr = HostPtr nullPtr -- | -- Cast a host pointer from one type to another --+{-# INLINEABLE castHostPtr #-} castHostPtr :: HostPtr a -> HostPtr b-castHostPtr (HostPtr p) = HostPtr (castPtr p)+castHostPtr (HostPtr !p) = HostPtr (castPtr p) -- | -- Advance the pointer address by the given offset in bytes --+{-# INLINEABLE plusHostPtr #-} plusHostPtr :: HostPtr a -> Int -> HostPtr a-plusHostPtr (HostPtr p) d = HostPtr (p `plusPtr` d)+plusHostPtr (HostPtr !p) !d = HostPtr (p `plusPtr` d) -- | -- Given an alignment constraint, align the host pointer to the next highest -- address satisfying the constraint --+{-# INLINEABLE alignHostPtr #-} alignHostPtr :: HostPtr a -> Int -> HostPtr a-alignHostPtr (HostPtr p) i = HostPtr (p `alignPtr` i)+alignHostPtr (HostPtr !p) !i = HostPtr (p `alignPtr` i) -- | -- Compute the difference between the second and first argument --+{-# INLINEABLE minusHostPtr #-} minusHostPtr :: HostPtr a -> HostPtr a -> Int-minusHostPtr (HostPtr a) (HostPtr b) = a `minusPtr` b+minusHostPtr (HostPtr !a) (HostPtr !b) = a `minusPtr` b -- | -- Advance a pointer into a host array by a given number of elements --+{-# INLINEABLE advanceHostPtr #-} advanceHostPtr :: Storable a => HostPtr a -> Int -> HostPtr a-advanceHostPtr = doAdvance undefined+advanceHostPtr = doAdvance undefined where doAdvance :: Storable a' => a' -> HostPtr a' -> Int -> HostPtr a'- doAdvance x p i = p `plusHostPtr` (i * sizeOf x)+ doAdvance x !p !i = p `plusHostPtr` (i * sizeOf x)
Foreign/CUDA/Runtime.hs view
@@ -1,7 +1,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Runtime--- Copyright : (c) [2009..2011] Trevor L. McDonell+-- Copyright : (c) [2009..2012] Trevor L. McDonell -- License : BSD -- -- Top level bindings to the C-for-CUDA runtime API
Foreign/CUDA/Runtime/Device.chs view
@@ -1,8 +1,11 @@-{-# LANGUAGE CPP, ForeignFunctionInterface, EmptyDataDecls #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ForeignFunctionInterface #-} -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Runtime.Device--- Copyright : (c) [2009..2011] Trevor L. McDonell+-- Copyright : (c) [2009..2012] Trevor L. McDonell -- License : BSD -- -- Device management routines@@ -12,7 +15,7 @@ module Foreign.CUDA.Runtime.Device ( -- * Device Management- ComputeMode(..), Device, DeviceFlag(..), DeviceProperties(..),+ Device, DeviceFlag(..), DeviceProperties(..), Compute(..), ComputeMode(..), choose, get, count, props, set, setFlags, setOrder, reset, sync, -- * Peer Access@@ -129,13 +132,10 @@ (u31:u32:u33:_) <- map cIntConv `fmap` peekArray 3 (p `plusPtr` devMaxTexture3DOffset :: Ptr CInt) #endif - let cap a 0 = a- cap a b = a + b / max 10 (10^ ((ceiling . logBase 10) b :: Int))- return DeviceProperties { deviceName = n,- computeCapability = cap v1 v2,+ computeCapability = Compute v1 v2, totalGlobalMem = gm, totalConstMem = cm, sharedMemPerBlock = sm,@@ -186,9 +186,11 @@ -- | -- Select the compute device which best matches the given criteria --+{-# INLINEABLE choose #-} choose :: DeviceProperties -> IO Device-choose dev = resultIfOk =<< cudaChooseDevice dev+choose !dev = resultIfOk =<< cudaChooseDevice dev +{-# INLINE cudaChooseDevice #-} {# fun unsafe cudaChooseDevice { alloca- `Int' peekIntConv* , withDevProp* `DeviceProperties' } -> `Status' cToEnum #}@@ -199,9 +201,11 @@ -- | -- Returns which device is currently being used --+{-# INLINEABLE get #-} get :: IO Device get = resultIfOk =<< cudaGetDevice +{-# INLINE cudaGetDevice #-} {# fun unsafe cudaGetDevice { alloca- `Int' peekIntConv* } -> `Status' cToEnum #} @@ -210,9 +214,11 @@ -- Returns the number of devices available for execution, with compute -- capability >= 1.0 --+{-# INLINEABLE count #-} count :: IO Int count = resultIfOk =<< cudaGetDeviceCount +{-# INLINE cudaGetDeviceCount #-} {# fun unsafe cudaGetDeviceCount { alloca- `Int' peekIntConv* } -> `Status' cToEnum #} @@ -220,9 +226,11 @@ -- | -- Return information about the selected compute device --+{-# INLINEABLE props #-} props :: Device -> IO DeviceProperties-props n = resultIfOk =<< cudaGetDeviceProperties n+props !n = resultIfOk =<< cudaGetDeviceProperties n +{-# INLINE cudaGetDeviceProperties #-} {# fun unsafe cudaGetDeviceProperties { alloca- `DeviceProperties' peek* , `Int' } -> `Status' cToEnum #}@@ -231,9 +239,11 @@ -- | -- Set device to be used for GPU execution --+{-# INLINEABLE set #-} set :: Device -> IO ()-set n = nothingIfOk =<< cudaSetDevice n+set !n = nothingIfOk =<< cudaSetDevice n +{-# INLINE cudaSetDevice #-} {# fun unsafe cudaSetDevice { `Int' } -> `Status' cToEnum #} @@ -241,9 +251,11 @@ -- | -- Set flags to be used for device executions --+{-# INLINEABLE setFlags #-} setFlags :: [DeviceFlag] -> IO ()-setFlags f = nothingIfOk =<< cudaSetDeviceFlags (combineBitMasks f)+setFlags !f = nothingIfOk =<< cudaSetDeviceFlags (combineBitMasks f) +{-# INLINE cudaSetDeviceFlags #-} {# fun unsafe cudaSetDeviceFlags { `Int' } -> `Status' cToEnum #} @@ -251,9 +263,11 @@ -- | -- Set list of devices for CUDA execution in priority order --+{-# INLINEABLE setOrder #-} setOrder :: [Device] -> IO ()-setOrder l = nothingIfOk =<< cudaSetValidDevices l (length l)+setOrder !l = nothingIfOk =<< cudaSetValidDevices l (length l) +{-# INLINE cudaSetValidDevices #-} {# fun unsafe cudaSetValidDevices { withArrayIntConv* `[Int]' , `Int' } -> `Status' cToEnum #}@@ -264,11 +278,14 @@ -- Block until the device has completed all preceding requested tasks. Returns -- an error if one of the tasks fails. --+{-# INLINEABLE sync #-} sync :: IO () #if CUDART_VERSION < 4000+{-# INLINE cudaThreadSynchronize #-} sync = nothingIfOk =<< cudaThreadSynchronize {# fun unsafe cudaThreadSynchronize { } -> `Status' cToEnum #} #else+{-# INLINE cudaDeviceSynchronize #-} sync = nothingIfOk =<< cudaDeviceSynchronize {# fun unsafe cudaDeviceSynchronize { } -> `Status' cToEnum #} #endif@@ -282,11 +299,14 @@ -- responsibility to ensure that the device is not being accessed by any other -- host threads from the process when this function is called. --+{-# INLINEABLE reset #-} reset :: IO () #if CUDART_VERSION >= 4000+{-# INLINE cudaDeviceReset #-} reset = nothingIfOk =<< cudaDeviceReset {# fun unsafe cudaDeviceReset { } -> `Status' cToEnum #} #else+{-# INLINE cudaThreadExit #-} reset = nothingIfOk =<< cudaThreadExit {# fun unsafe cudaThreadExit { } -> `Status' cToEnum #} #endif@@ -307,12 +327,14 @@ -- direct access is possible, it can then be enabled with 'add'. Requires -- cuda-4.0. --+{-# INLINEABLE accessible #-} accessible :: Device -> Device -> IO Bool #if CUDART_VERSION < 4000-accessible _ _ = requireSDK 4.0 "accessible"+accessible _ _ = requireSDK 4.0 "accessible" #else-accessible dev peer = resultIfOk =<< cudaDeviceCanAccessPeer dev peer+accessible !dev !peer = resultIfOk =<< cudaDeviceCanAccessPeer dev peer +{-# INLINE cudaDeviceCanAccessPeer #-} {# fun unsafe cudaDeviceCanAccessPeer { alloca- `Bool' peekBool* , cIntConv `Device'@@ -324,12 +346,14 @@ -- addressing, then enable allocations in the supplied context to be accessible -- by the current context. Requires cuda-4.0. --+{-# INLINEABLE add #-} add :: Device -> [PeerFlag] -> IO () #if CUDART_VERSION < 4000-add _ _ = requireSDK 4.0 "add"+add _ _ = requireSDK 4.0 "add" #else-add dev flags = nothingIfOk =<< cudaDeviceEnablePeerAccess dev flags+add !dev !flags = nothingIfOk =<< cudaDeviceEnablePeerAccess dev flags +{-# INLINE cudaDeviceEnablePeerAccess #-} {# fun unsafe cudaDeviceEnablePeerAccess { cIntConv `Device' , combineBitMasks `[PeerFlag]' } -> `Status' cToEnum #}@@ -340,12 +364,14 @@ -- Disable direct memory access from the current context to the supplied -- context. Requires cuda-4.0. --+{-# INLINEABLE remove #-} remove :: Device -> IO () #if CUDART_VERSION < 4000-remove _ = requireSDK 4.0 "remove"+remove _ = requireSDK 4.0 "remove" #else-remove dev = nothingIfOk =<< cudaDeviceDisablePeerAccess dev+remove !dev = nothingIfOk =<< cudaDeviceDisablePeerAccess dev +{-# INLINE cudaDeviceDisablePeerAccess #-} {# fun unsafe cudaDeviceDisablePeerAccess { cIntConv `Device' } -> `Status' cToEnum #} #endif@@ -370,18 +396,21 @@ -- | -- Query compute 2.0 call stack limits. Requires cuda-3.1. --+{-# INLINEABLE getLimit #-} getLimit :: Limit -> IO Int #if CUDART_VERSION < 3010-getLimit _ = requireSDK 3.1 "getLimit"+getLimit _ = requireSDK 3.1 "getLimit" #elif CUDART_VERSION < 4000-getLimit l = resultIfOk =<< cudaThreadGetLimit l+getLimit !l = resultIfOk =<< cudaThreadGetLimit l +{-# INLINE cudaThreadGetLimit #-} {# fun unsafe cudaThreadGetLimit { alloca- `Int' peekIntConv* , cFromEnum `Limit' } -> `Status' cToEnum #} #else-getLimit l = resultIfOk =<< cudaDeviceGetLimit l+getLimit !l = resultIfOk =<< cudaDeviceGetLimit l +{-# INLINE cudaDeviceGetLimit #-} {# fun unsafe cudaDeviceGetLimit { alloca- `Int' peekIntConv* , cFromEnum `Limit' } -> `Status' cToEnum #}@@ -391,18 +420,21 @@ -- | -- Set compute 2.0 call stack limits. Requires cuda-3.1. --+{-# INLINEABLE setLimit #-} setLimit :: Limit -> Int -> IO () #if CUDART_VERSION < 3010-setLimit _ _ = requireSDK 3.1 "setLimit"+setLimit _ _ = requireSDK 3.1 "setLimit" #elif CUDART_VERSION < 4000-setLimit l n = nothingIfOk =<< cudaThreadSetLimit l n+setLimit !l !n = nothingIfOk =<< cudaThreadSetLimit l n +{-# INLINE cudaThreadSetLimit #-} {# fun unsafe cudaThreadSetLimit { cFromEnum `Limit' , cIntConv `Int' } -> `Status' cToEnum #} #else-setLimit l n = nothingIfOk =<< cudaDeviceSetLimit l n+setLimit !l !n = nothingIfOk =<< cudaDeviceSetLimit l n +{-# INLINE cudaDeviceSetLimit #-} {# fun unsafe cudaDeviceSetLimit { cFromEnum `Limit' , cIntConv `Int' } -> `Status' cToEnum #}
Foreign/CUDA/Runtime/Error.chs view
@@ -1,8 +1,9 @@-{-# LANGUAGE ForeignFunctionInterface, DeriveDataTypeable #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ForeignFunctionInterface #-} -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Runtime.Error--- Copyright : (c) [2009..2011] Trevor L. McDonell+-- Copyright : (c) [2009..2012] Trevor L. McDonell -- License : BSD -- -- Error handling functions@@ -26,7 +27,7 @@ import Foreign hiding ( unsafePerformIO ) import Foreign.C import Data.Typeable-import Control.Exception.Extensible+import Control.Exception import System.IO.Unsafe #include "cbits/stubs.h"@@ -93,6 +94,7 @@ -- Return the results of a function on successful execution, otherwise return -- the error string associated with the return code --+{-# INLINE resultIfOk #-} resultIfOk :: (Status, a) -> IO a resultIfOk (status,result) = case status of@@ -104,6 +106,7 @@ -- Return the error string associated with an unsuccessful return code, -- otherwise Nothing --+{-# INLINE nothingIfOk #-} nothingIfOk :: Status -> IO () nothingIfOk status = case status of
Foreign/CUDA/Runtime/Event.chs view
@@ -1,8 +1,11 @@-{-# LANGUAGE CPP, ForeignFunctionInterface, EmptyDataDecls #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ForeignFunctionInterface #-} -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Driver.Event--- Copyright : (c) [2009..2011] Trevor L. McDonell+-- Copyright : (c) [2009..2012] Trevor L. McDonell -- License : BSD -- -- Event management for C-for-CUDA runtime environment@@ -69,9 +72,11 @@ -- | -- Create a new event --+{-# INLINEABLE create #-} create :: [EventFlag] -> IO Event-create flags = resultIfOk =<< cudaEventCreateWithFlags flags+create !flags = resultIfOk =<< cudaEventCreateWithFlags flags +{-# INLINE cudaEventCreateWithFlags #-} {# fun unsafe cudaEventCreateWithFlags { alloca- `Event' peekEvt* , combineBitMasks `[EventFlag]' } -> `Status' cToEnum #}@@ -81,9 +86,11 @@ -- | -- Destroy an event --+{-# INLINEABLE destroy #-} destroy :: Event -> IO ()-destroy ev = nothingIfOk =<< cudaEventDestroy ev+destroy !ev = nothingIfOk =<< cudaEventDestroy ev +{-# INLINE cudaEventDestroy #-} {# fun unsafe cudaEventDestroy { useEvent `Event' } -> `Status' cToEnum #} @@ -91,9 +98,11 @@ -- | -- Determine the elapsed time (in milliseconds) between two events --+{-# INLINEABLE elapsedTime #-} elapsedTime :: Event -> Event -> IO Float-elapsedTime ev1 ev2 = resultIfOk =<< cudaEventElapsedTime ev1 ev2+elapsedTime !ev1 !ev2 = resultIfOk =<< cudaEventElapsedTime ev1 ev2 +{-# INLINE cudaEventElapsedTime #-} {# fun unsafe cudaEventElapsedTime { alloca- `Float' peekFloatConv* , useEvent `Event'@@ -103,14 +112,16 @@ -- | -- Determines if a event has actually been recorded --+{-# INLINEABLE query #-} query :: Event -> IO Bool-query ev =+query !ev = cudaEventQuery ev >>= \rv -> case rv of Success -> return True NotReady -> return False _ -> resultIfOk (rv,undefined) +{-# INLINE cudaEventQuery #-} {# fun unsafe cudaEventQuery { useEvent `Event' } -> `Status' cToEnum #} @@ -119,10 +130,12 @@ -- Record an event once all operations in the current context (or optionally -- specified stream) have completed. This operation is asynchronous. --+{-# INLINEABLE record #-} record :: Event -> Maybe Stream -> IO ()-record ev mst =+record !ev !mst = nothingIfOk =<< cudaEventRecord ev (maybe defaultStream id mst) +{-# INLINE cudaEventRecord #-} {# fun unsafe cudaEventRecord { useEvent `Event' , useStream `Stream' } -> `Status' cToEnum #}@@ -132,14 +145,16 @@ -- Makes all future work submitted to the (optional) stream wait until the given -- event reports completion before beginning execution. Requires cuda-3.2. --+{-# INLINEABLE wait #-} wait :: Event -> Maybe Stream -> [WaitFlag] -> IO () #if CUDART_VERSION < 3020-wait _ _ _ = requireSDK 3.2 "wait"+wait _ _ _ = requireSDK 3.2 "wait" #else-wait ev mst flags =+wait !ev !mst !flags = let st = fromMaybe defaultStream mst in nothingIfOk =<< cudaStreamWaitEvent st ev flags +{-# INLINE cudaStreamWaitEvent #-} {# fun unsafe cudaStreamWaitEvent { useStream `Stream' , useEvent `Event'@@ -149,9 +164,11 @@ -- | -- Wait until the event has been recorded --+{-# INLINEABLE block #-} block :: Event -> IO ()-block ev = nothingIfOk =<< cudaEventSynchronize ev+block !ev = nothingIfOk =<< cudaEventSynchronize ev +{-# INLINE cudaEventSynchronize #-} {# fun unsafe cudaEventSynchronize { useEvent `Event' } -> `Status' cToEnum #}
Foreign/CUDA/Runtime/Exec.chs view
@@ -1,8 +1,11 @@-{-# LANGUAGE GADTs, CPP, ForeignFunctionInterface #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE GADTs #-} -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Runtime.Exec--- Copyright : (c) [2009..2011] Trevor L. McDonell+-- Copyright : (c) [2009..2012] Trevor L. McDonell -- License : BSD -- -- Kernel execution control for C-for-CUDA runtime interface@@ -105,12 +108,14 @@ -- Obtain the attributes of the named @__global__@ device function. This -- itemises the requirements to successfully launch the given kernel. --+{-# INLINEABLE attributes #-} attributes :: String -> IO FunAttributes-attributes fn = resultIfOk =<< cudaFuncGetAttributes fn+attributes !fn = resultIfOk =<< cudaFuncGetAttributes fn +{-# INLINE cudaFuncGetAttributes #-} {# fun unsafe cudaFuncGetAttributes- { alloca- `FunAttributes' peek*- , withCString* `String' } -> `Status' cToEnum #}+ { alloca- `FunAttributes' peek*+ , withCString_* `String' } -> `Status' cToEnum #} -- |@@ -118,12 +123,13 @@ -- with 'setParams', this pushes data onto the execution stack that will be -- popped when a function is 'launch'ed. --+{-# INLINEABLE setConfig #-} setConfig :: (Int,Int) -- ^ grid dimensions -> (Int,Int,Int) -- ^ block dimensions -> Int64 -- ^ shared memory per block (bytes) -> Maybe Stream -- ^ associated processing stream -> IO ()-setConfig (gx,gy) (bx,by,bz) sharedMem mst =+setConfig (!gx,!gy) (!bx,!by,!bz) !sharedMem !mst = nothingIfOk =<< cudaConfigureCallSimple gx gy bx by bz sharedMem (maybe defaultStream id mst) @@ -133,6 +139,7 @@ -- this is highly platform/compiler dependent. Wrap our own function stub -- accepting plain integers. --+{-# INLINE cudaConfigureCallSimple #-} {# fun unsafe cudaConfigureCallSimple { `Int', `Int' , `Int', `Int', `Int'@@ -144,10 +151,11 @@ -- Set the argument parameters that will be passed to the next kernel -- invocation. This is used in conjunction with 'setConfig' to control kernel -- execution.+{-# INLINEABLE setParams #-} setParams :: [FunParam] -> IO () setParams = foldM_ k 0 where- k offset arg = do+ k !offset !arg = do let s = size arg set arg s offset >>= nothingIfOk return (offset + s)@@ -165,6 +173,7 @@ cudaSetupArgument d s o +{-# INLINE cudaSetupArgument #-} {# fun unsafe cudaSetupArgument `Storable a' => { with'* `a'@@ -173,6 +182,7 @@ where with' v a = with v $ \p -> a (castPtr p) +{-# INLINE cudaSetDoubleForDevice #-} {# fun unsafe cudaSetDoubleForDevice { with'* `Double' peek'* } -> `Status' cToEnum #} where@@ -189,14 +199,16 @@ -- Switching between configuration modes may insert a device-side -- synchronisation point for streamed kernel launches --+{-# INLINEABLE setCacheConfig #-} setCacheConfig :: String -> CacheConfig -> IO () #if CUDART_VERSION < 3000-setCacheConfig _ _ = requireSDK 3.0 "setCacheConfig"+setCacheConfig _ _ = requireSDK 3.0 "setCacheConfig" #else-setCacheConfig fn pref = nothingIfOk =<< cudaFuncSetCacheConfig fn pref+setCacheConfig !fn !pref = nothingIfOk =<< cudaFuncSetCacheConfig fn pref +{-# INLINE cudaFuncSetCacheConfig #-} {# fun unsafe cudaFuncSetCacheConfig- { withCString* `String'+ { withCString_* `String' , cFromEnum `CacheConfig' } -> `Status' cToEnum #} #endif @@ -206,9 +218,22 @@ -- @__global__@. This must be preceded by a call to 'setConfig' and (if -- appropriate) 'setParams'. --+{-# INLINEABLE launch #-} launch :: String -> IO ()-launch fn = nothingIfOk =<< cudaLaunch fn+launch !fn = nothingIfOk =<< cudaLaunch fn +{-# INLINE cudaLaunch #-} {# fun unsafe cudaLaunch- { withCString* `String' } -> `Status' cToEnum #}+ { withCString_* `String' } -> `Status' cToEnum #}+++--------------------------------------------------------------------------------+-- Internals+--------------------------------------------------------------------------------++-- CUDA 5.0 changed the types of some attributes from char* to void*+--+{-# INLINE withCString_ #-}+withCString_ :: String -> (Ptr a -> IO b) -> IO b+withCString_ !str !fn = withCString str (fn . castPtr)
Foreign/CUDA/Runtime/Marshal.chs view
@@ -1,16 +1,15 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ForeignFunctionInterface #-} -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Runtime.Marshal--- Copyright : (c) [2009..2011] Trevor L. McDonell+-- Copyright : (c) [2009..2012] Trevor L. McDonell -- License : BSD -- -- Memory management for CUDA devices -- -------------------------------------------------------------------------------- -{-# LANGUAGE ScopedTypeVariables #-}- module Foreign.CUDA.Runtime.Marshal ( -- * Host Allocation@@ -45,7 +44,7 @@ -- System import Data.Int-import Control.Exception.Extensible+import Control.Exception import Foreign.C import Foreign.Ptr@@ -84,28 +83,31 @@ -- system performance may suffer. This is best used sparingly to allocate -- staging areas for data exchange --+{-# INLINEABLE mallocHostArray #-} mallocHostArray :: Storable a => [AllocFlag] -> Int -> IO (HostPtr a)-mallocHostArray flags = doMalloc undefined+mallocHostArray !flags = doMalloc undefined where doMalloc :: Storable a' => a' -> Int -> IO (HostPtr a')- doMalloc x n = resultIfOk =<< cudaHostAlloc (fromIntegral n * fromIntegral (sizeOf x)) flags+ doMalloc x !n = resultIfOk =<< cudaHostAlloc (fromIntegral n * fromIntegral (sizeOf x)) flags +{-# INLINE cudaHostAlloc #-} {# fun unsafe cudaHostAlloc { alloca'- `HostPtr a' hptr* , cIntConv `Int64' , combineBitMasks `[AllocFlag]' } -> `Status' cToEnum #} where- alloca' f = F.alloca $ \(ptr :: Ptr (Ptr ())) ->- poke ptr nullPtr >> f (castPtr ptr)- hptr p = (HostPtr . castPtr) `fmap` peek p+ alloca' !f = F.alloca $ \ !p -> poke p nullPtr >> f (castPtr p)+ hptr !p = (HostPtr . castPtr) `fmap` peek p -- | -- Free page-locked host memory previously allocated with 'mallecHost' --+{-# INLINEABLE freeHost #-} freeHost :: HostPtr a -> IO ()-freeHost p = nothingIfOk =<< cudaFreeHost p+freeHost !p = nothingIfOk =<< cudaFreeHost p +{-# INLINE cudaFreeHost #-} {# fun unsafe cudaFreeHost { hptr `HostPtr a' } -> `Status' cToEnum #} where hptr = castPtr . useHostPtr@@ -120,20 +122,21 @@ -- it. The memory is sufficient to hold the given number of elements of storable -- type. It is suitable aligned, and not cleared. --+{-# INLINEABLE mallocArray #-} mallocArray :: Storable a => Int -> IO (DevicePtr a) mallocArray = doMalloc undefined where doMalloc :: Storable a' => a' -> Int -> IO (DevicePtr a')- doMalloc x n = resultIfOk =<< cudaMalloc (fromIntegral n * fromIntegral (sizeOf x))+ doMalloc x !n = resultIfOk =<< cudaMalloc (fromIntegral n * fromIntegral (sizeOf x)) +{-# INLINE cudaMalloc #-} {# fun unsafe cudaMalloc { alloca'- `DevicePtr a' dptr* , cIntConv `Int64' } -> `Status' cToEnum #} where -- C-> Haskell doesn't like qualified imports in marshaller specifications- alloca' f = F.alloca $ \(ptr :: Ptr (Ptr ())) ->- poke ptr nullPtr >> f (castPtr ptr)- dptr p = (castDevPtr . DevicePtr) `fmap` peek p+ alloca' !f = F.alloca $ \ !p -> poke p nullPtr >> f (castPtr p)+ dptr !p = (castDevPtr . DevicePtr) `fmap` peek p -- |@@ -145,6 +148,7 @@ -- Note that kernel launches can be asynchronous, so you may need to add a -- synchronisation point at the end of the computation. --+{-# INLINEABLE allocaArray #-} allocaArray :: Storable a => Int -> (DevicePtr a -> IO b) -> IO b allocaArray n = bracket (mallocArray n) free @@ -152,9 +156,11 @@ -- | -- Free previously allocated memory on the device --+{-# INLINEABLE free #-} free :: DevicePtr a -> IO ()-free p = nothingIfOk =<< cudaFree p+free !p = nothingIfOk =<< cudaFree p +{-# INLINE cudaFree #-} {# fun unsafe cudaFree { dptr `DevicePtr a' } -> `Status' cToEnum #} where@@ -169,16 +175,18 @@ -- Copy a number of elements from the device to host memory. This is a -- synchronous operation. --+{-# INLINEABLE peekArray #-} peekArray :: Storable a => Int -> DevicePtr a -> Ptr a -> IO ()-peekArray n dptr hptr = memcpy hptr (useDevicePtr dptr) n DeviceToHost+peekArray !n !dptr !hptr = memcpy hptr (useDevicePtr dptr) n DeviceToHost -- | -- Copy memory from the device asynchronously, possibly associated with a -- particular stream. The destination memory must be page locked. --+{-# INLINEABLE peekArrayAsync #-} peekArrayAsync :: Storable a => Int -> DevicePtr a -> HostPtr a -> Maybe Stream -> IO ()-peekArrayAsync n dptr hptr mst =+peekArrayAsync !n !dptr !hptr !mst = memcpyAsync (useHostPtr hptr) (useDevicePtr dptr) n DeviceToHost mst @@ -187,8 +195,9 @@ -- this requires two memory copies: firstly from the device into a heap -- allocated array, and from there marshalled into a list --+{-# INLINEABLE peekListArray #-} peekListArray :: Storable a => Int -> DevicePtr a -> IO [a]-peekListArray n dptr =+peekListArray !n !dptr = F.allocaArray n $ \p -> do peekArray n dptr p F.peekArray n p@@ -197,16 +206,18 @@ -- | -- Copy a number of elements onto the device. This is a synchronous operation. --+{-# INLINEABLE pokeArray #-} pokeArray :: Storable a => Int -> Ptr a -> DevicePtr a -> IO ()-pokeArray n hptr dptr = memcpy (useDevicePtr dptr) hptr n HostToDevice+pokeArray !n !hptr !dptr = memcpy (useDevicePtr dptr) hptr n HostToDevice -- | -- Copy memory onto the device asynchronously, possibly associated with a -- particular stream. The source memory must be page-locked. --+{-# INLINEABLE pokeArrayAsync #-} pokeArrayAsync :: Storable a => Int -> HostPtr a -> DevicePtr a -> Maybe Stream -> IO ()-pokeArrayAsync n hptr dptr mst =+pokeArrayAsync !n !hptr !dptr !mst = memcpyAsync (useDevicePtr dptr) (useHostPtr hptr) n HostToDevice mst @@ -215,8 +226,9 @@ -- sufficiently large to hold the entire list. This requires two marshalling -- operations --+{-# INLINEABLE pokeListArray #-} pokeListArray :: Storable a => [a] -> DevicePtr a -> IO ()-pokeListArray xs dptr = F.withArrayLen xs $ \len p -> pokeArray len p dptr+pokeListArray !xs !dptr = F.withArrayLen xs $ \len p -> pokeArray len p dptr -- |@@ -224,8 +236,9 @@ -- second (destination). The copied areas may not overlap. This is a synchronous -- operation. --+{-# INLINEABLE copyArray #-} copyArray :: Storable a => Int -> DevicePtr a -> DevicePtr a -> IO ()-copyArray n src dst = memcpy (useDevicePtr dst) (useDevicePtr src) n DeviceToDevice+copyArray !n !src !dst = memcpy (useDevicePtr dst) (useDevicePtr src) n DeviceToDevice -- |@@ -234,8 +247,9 @@ -- asynchronous with respect to host, but will never overlap with kernel -- execution. --+{-# INLINEABLE copyArrayAsync #-} copyArrayAsync :: Storable a => Int -> DevicePtr a -> DevicePtr a -> Maybe Stream -> IO ()-copyArrayAsync n src dst mst =+copyArrayAsync !n !src !dst !mst = memcpyAsync (useDevicePtr dst) (useDevicePtr src) n DeviceToDevice mst @@ -248,18 +262,20 @@ -- | -- Copy data between host and device. This is a synchronous operation. --+{-# INLINEABLE memcpy #-} memcpy :: Storable a => Ptr a -- ^ destination -> Ptr a -- ^ source -> Int -- ^ number of elements -> CopyDirection -> IO ()-memcpy dst src n dir = doMemcpy undefined dst+memcpy !dst !src !n !dir = doMemcpy undefined dst where doMemcpy :: Storable a' => a' -> Ptr a' -> IO () doMemcpy x _ = nothingIfOk =<< cudaMemcpy dst src (fromIntegral n * fromIntegral (sizeOf x)) dir +{-# INLINE cudaMemcpy #-} {# fun unsafe cudaMemcpy { castPtr `Ptr a' , castPtr `Ptr a'@@ -272,6 +288,7 @@ -- with a particular stream. The host-side memory must be page-locked (allocated -- with 'mallocHostArray'). --+{-# INLINEABLE memcpyAsync #-} memcpyAsync :: Storable a => Ptr a -- ^ destination -> Ptr a -- ^ source@@ -279,13 +296,14 @@ -> CopyDirection -> Maybe Stream -> IO ()-memcpyAsync dst src n kind mst = doMemcpy undefined dst+memcpyAsync !dst !src !n !kind !mst = doMemcpy undefined dst where doMemcpy :: Storable a' => a' -> Ptr a' -> IO () doMemcpy x _ = let bytes = fromIntegral n * fromIntegral (sizeOf x) in nothingIfOk =<< cudaMemcpyAsync dst src bytes kind (maybe defaultStream id mst) +{-# INLINE cudaMemcpyAsync #-} {# fun unsafe cudaMemcpyAsync { castPtr `Ptr a' , castPtr `Ptr a'@@ -305,8 +323,9 @@ -- list into a heap-allocated array, and from there into device memory. The -- array should be 'free'd when no longer required. --+{-# INLINEABLE newListArrayLen #-} newListArrayLen :: Storable a => [a] -> IO (DevicePtr a, Int)-newListArrayLen xs =+newListArrayLen !xs = F.withArrayLen xs $ \len p -> bracketOnError (mallocArray len) free $ \d_xs -> do pokeArray len p d_xs@@ -317,8 +336,9 @@ -- Write a list of storable elements into a newly allocated device array. This -- is 'newListArrayLen' composed with 'fst'. --+{-# INLINEABLE newListArray #-} newListArray :: Storable a => [a] -> IO (DevicePtr a)-newListArray xs = fst `fmap` newListArrayLen xs+newListArray !xs = fst `fmap` newListArrayLen xs -- |@@ -330,16 +350,18 @@ -- should not return the pointer from the action, and be sure that any -- asynchronous operations (such as kernel execution) have completed. --+{-# INLINEABLE withListArray #-} withListArray :: Storable a => [a] -> (DevicePtr a -> IO b) -> IO b-withListArray xs = withListArrayLen xs . const+withListArray !xs = withListArrayLen xs . const -- | -- A variant of 'withListArray' which also supplies the number of elements in -- the array to the applied function --+{-# INLINEABLE withListArrayLen #-} withListArrayLen :: Storable a => [a] -> (Int -> DevicePtr a -> IO b) -> IO b-withListArrayLen xs f =+withListArrayLen !xs !f = bracket (newListArrayLen xs) (free . fst) (uncurry . flip $ f) -- -- XXX: Will this attempt to double-free the device array on error (together@@ -354,12 +376,14 @@ -- | -- Initialise device memory to a given 8-bit value --+{-# INLINEABLE memset #-} memset :: DevicePtr a -- ^ The device memory -> Int64 -- ^ Number of bytes -> Int8 -- ^ Value to set for each byte -> IO ()-memset dptr bytes symbol = nothingIfOk =<< cudaMemset dptr symbol bytes+memset !dptr !bytes !symbol = nothingIfOk =<< cudaMemset dptr symbol bytes +{-# INLINE cudaMemset #-} {# fun unsafe cudaMemset { dptr `DevicePtr a' , cIntConv `Int8'
Foreign/CUDA/Runtime/Stream.chs view
@@ -1,8 +1,9 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ForeignFunctionInterface #-} -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Runtime.Stream--- Copyright : (c) [2009..2011] Trevor L. McDonell+-- Copyright : (c) [2009..2012] Trevor L. McDonell -- License : BSD -- -- Stream management routines@@ -48,9 +49,11 @@ -- | -- Create a new asynchronous stream --+{-# INLINEABLE create #-} create :: IO Stream create = resultIfOk =<< cudaStreamCreate +{-# INLINE cudaStreamCreate #-} {# fun unsafe cudaStreamCreate { alloca- `Stream' peekStream* } -> `Status' cToEnum #} @@ -58,9 +61,11 @@ -- | -- Destroy and clean up an asynchronous stream --+{-# INLINEABLE destroy #-} destroy :: Stream -> IO ()-destroy s = nothingIfOk =<< cudaStreamDestroy s+destroy !s = nothingIfOk =<< cudaStreamDestroy s +{-# INLINE cudaStreamDestroy #-} {# fun unsafe cudaStreamDestroy { useStream `Stream' } -> `Status' cToEnum #} @@ -68,14 +73,16 @@ -- | -- Determine if all operations in a stream have completed ---finished :: Stream -> IO Bool-finished s =+{-# INLINEABLE finished #-}+finished :: Stream -> IO Bool+finished !s = cudaStreamQuery s >>= \rv -> do case rv of Success -> return True NotReady -> return False _ -> resultIfOk (rv,undefined) +{-# INLINE cudaStreamQuery #-} {# fun unsafe cudaStreamQuery { useStream `Stream' } -> `Status' cToEnum #} @@ -83,9 +90,11 @@ -- | -- Block until all operations in a Stream have been completed --+{-# INLINEABLE block #-} block :: Stream -> IO ()-block s = nothingIfOk =<< cudaStreamSynchronize s+block !s = nothingIfOk =<< cudaStreamSynchronize s +{-# INLINE cudaStreamSynchronize #-} {# fun unsafe cudaStreamSynchronize { useStream `Stream' } -> `Status' cToEnum #} @@ -93,6 +102,7 @@ -- | -- The main execution stream (0) --+{-# INLINE defaultStream #-} defaultStream :: Stream #if CUDART_VERSION < 3010 defaultStream = Stream 0@@ -104,6 +114,7 @@ -- Internal -------------------------------------------------------------------------------- +{-# INLINE peekStream #-} peekStream :: Ptr {#type cudaStream_t#} -> IO Stream #if CUDART_VERSION < 3010 peekStream = liftM Stream . peekIntConv
Foreign/CUDA/Runtime/Texture.chs view
@@ -1,8 +1,9 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ForeignFunctionInterface #-} -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Runtime.Texture--- Copyright : (c) [2009..2011] Trevor L. McDonell+-- Copyright : (c) [2009..2012] Trevor L. McDonell -- License : BSD -- -- Texture references@@ -131,12 +132,14 @@ -- reference given by the named symbol. Any previously bound references are -- unbound. --+{-# INLINEABLE bind #-} bind :: String -> Texture -> DevicePtr a -> Int64 -> IO ()-bind name tex dptr bytes = do+bind !name !tex !dptr !bytes = do ref <- getTex name poke ref tex nothingIfOk =<< cudaBindTexture ref dptr (format tex) bytes +{-# INLINE cudaBindTexture #-} {# fun unsafe cudaBindTexture { alloca- `Int' , id `TextureReference'@@ -150,12 +153,14 @@ -- in texel units, and the row pitch in bytes. Any previously bound references -- are unbound. --+{-# INLINEABLE bind2D #-} bind2D :: String -> Texture -> DevicePtr a -> (Int,Int) -> Int64 -> IO ()-bind2D name tex dptr (width,height) bytes = do+bind2D !name !tex !dptr (!width,!height) !bytes = do ref <- getTex name poke ref tex nothingIfOk =<< cudaBindTexture2D ref dptr (format tex) width height bytes +{-# INLINE cudaBindTexture2D #-} {# fun unsafe cudaBindTexture2D { alloca- `Int' , id `TextureReference'@@ -169,18 +174,28 @@ -- |Returns the texture reference associated with the given symbol --+{-# INLINEABLE getTex #-} getTex :: String -> IO TextureReference-getTex name = resultIfOk =<< cudaGetTextureReference name+getTex !name = resultIfOk =<< cudaGetTextureReference name +{-# INLINE cudaGetTextureReference #-} {# fun unsafe cudaGetTextureReference- { alloca- `Ptr Texture' peek*- , withCString* `String' } -> `Status' cToEnum #}+ { alloca- `Ptr Texture' peek*+ , withCString_* `String' } -> `Status' cToEnum #} -------------------------------------------------------------------------------- -- Internal -------------------------------------------------------------------------------- +{-# INLINE with_ #-} with_ :: Storable a => a -> (Ptr a -> IO b) -> IO b with_ = with+++-- CUDA 5.0 changed the types of some attributes from char* to void*+--+{-# INLINE withCString_ #-}+withCString_ :: String -> (Ptr a -> IO b) -> IO b+withCString_ !str !fn = withCString str (fn . castPtr)
Foreign/CUDA/Runtime/Utils.chs view
@@ -2,7 +2,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Runtime.Utils--- Copyright : (c) [2009..2011] Trevor L. McDonell+-- Copyright : (c) [2009..2012] Trevor L. McDonell -- License : BSD -- -- Utility functions@@ -27,9 +27,11 @@ -- | -- Return the version number of the installed CUDA driver --+{-# INLINEABLE runtimeVersion #-} runtimeVersion :: IO Int runtimeVersion = resultIfOk =<< cudaRuntimeGetVersion +{-# INLINE cudaRuntimeGetVersion #-} {# fun unsafe cudaRuntimeGetVersion { alloca- `Int' peekIntConv* } -> `Status' cToEnum #} @@ -37,9 +39,11 @@ -- | -- Return the version number of the installed CUDA runtime --+{-# INLINEABLE driverVersion #-} driverVersion :: IO Int driverVersion = resultIfOk =<< cudaDriverGetVersion +{-# INLINE cudaDriverGetVersion #-} {# fun unsafe cudaDriverGetVersion { alloca- `Int' peekIntConv* } -> `Status' cToEnum #}
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) [2009..2010] Trevor L. McDonell, University of New South Wales.+Copyright (c) [2009..2012] Trevor L. McDonell, University of New South Wales. All rights reserved. Redistribution and use in source and binary forms, with or without
Setup.hs view
@@ -10,7 +10,7 @@ import Distribution.Simple.LocalBuildInfo import Distribution.Simple.PreProcess hiding (ppC2hs) -import Control.Exception.Extensible+import Control.Exception import System.FilePath import System.Directory import System.Environment
configure view
@@ -1,6 +1,6 @@ #! /bin/sh # Guess values for system-dependent variables and create Makefiles.-# Generated by GNU Autoconf 2.69 for Haskell CUDA bindings 0.4.1.0.+# Generated by GNU Autoconf 2.69 for Haskell CUDA bindings 0.5.0.0. # # Report bugs to <tmcdonell@cse.unsw.edu.au>. #@@ -580,8 +580,8 @@ # Identity of this package. PACKAGE_NAME='Haskell CUDA bindings' PACKAGE_TARNAME='cuda'-PACKAGE_VERSION='0.4.1.0'-PACKAGE_STRING='Haskell CUDA bindings 0.4.1.0'+PACKAGE_VERSION='0.5.0.0'+PACKAGE_STRING='Haskell CUDA bindings 0.5.0.0' PACKAGE_BUGREPORT='tmcdonell@cse.unsw.edu.au' PACKAGE_URL='' @@ -631,6 +631,7 @@ GREP CPP NVCC+GHC target_os target_vendor target_cpu@@ -691,6 +692,9 @@ ac_subst_files='' ac_user_opts=' enable_option_checking+with_compiler+with_nvcc+with_gcc ' ac_precious_vars='build_alias host_alias@@ -1241,7 +1245,7 @@ # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat <<_ACEOF-\`configure' configures Haskell CUDA bindings 0.4.1.0 to adapt to many kinds of systems.+\`configure' configures Haskell CUDA bindings 0.5.0.0 to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... @@ -1307,10 +1311,17 @@ if test -n "$ac_init_help"; then case $ac_init_help in- short | recursive ) echo "Configuration of Haskell CUDA bindings 0.4.1.0:";;+ short | recursive ) echo "Configuration of Haskell CUDA bindings 0.5.0.0:";; esac cat <<\_ACEOF +Optional Packages:+ --with-PACKAGE[=ARG] use PACKAGE [ARG=yes]+ --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no)+Haskell compiler+CUDA compiler+C compiler+ Some influential environment variables: CC C compiler command CFLAGS C compiler flags@@ -1387,7 +1398,7 @@ test -n "$ac_init_help" && exit $ac_status if $ac_init_version; then cat <<\_ACEOF-Haskell CUDA bindings configure 0.4.1.0+Haskell CUDA bindings configure 0.5.0.0 generated by GNU Autoconf 2.69 Copyright (C) 2012 Free Software Foundation, Inc.@@ -1689,7 +1700,7 @@ This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. -It was created by Haskell CUDA bindings $as_me 0.4.1.0, which was+It was created by Haskell CUDA bindings $as_me 0.5.0.0, which was generated by GNU Autoconf 2.69. Invocation command line was $ $0 $@@@ -2976,7 +2987,59 @@ # 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) #-# Extract the first word of "nvcc", so it can be a program name with args.++# Check whether --with-compiler was given.+if test "${with_compiler+set}" = set; then :+ withval=$with_compiler; GHC=$withval+else+ # Extract the first word of "ghc", so it can be a program name with args.+set dummy ghc; ac_word=$2+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5+$as_echo_n "checking for $ac_word... " >&6; }+if ${ac_cv_path_GHC+:} false; then :+ $as_echo_n "(cached) " >&6+else+ case $GHC in+ [\\/]* | ?:[\\/]*)+ ac_cv_path_GHC="$GHC" # Let the user override the test with a path.+ ;;+ *)+ as_save_IFS=$IFS; IFS=$PATH_SEPARATOR+for as_dir in $PATH+do+ IFS=$as_save_IFS+ test -z "$as_dir" && as_dir=.+ for ac_exec_ext in '' $ac_executable_extensions; do+ if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then+ ac_cv_path_GHC="$as_dir/$ac_word$ac_exec_ext"+ $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5+ break 2+ fi+done+ done+IFS=$as_save_IFS++ ;;+esac+fi+GHC=$ac_cv_path_GHC+if test -n "$GHC"; then+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $GHC" >&5+$as_echo "$GHC" >&6; }+else+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5+$as_echo "no" >&6; }+fi+++fi+++# Check whether --with-nvcc was given.+if test "${with_nvcc+set}" = set; then :+ withval=$with_nvcc; NVCC=$withval+else+ # Extract the first word of "nvcc", so it can be a program name with args. set dummy nvcc; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; }@@ -3016,6 +3079,15 @@ fi +fi+++# Check whether --with-gcc was given.+if test "${with_gcc+set}" = set; then :+ withval=$with_gcc; CC=$withval+fi++ if test "$NVCC" != ""; then cuda_prefix="$(dirname "$(dirname "$NVCC")")" cuda_c2hsflags="--cpp="$NVCC" --cppopts=-E "@@ -4154,7 +4226,7 @@ # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. ac_log="-This file was extended by Haskell CUDA bindings $as_me 0.4.1.0, which was+This file was extended by Haskell CUDA bindings $as_me 0.5.0.0, which was generated by GNU Autoconf 2.69. Invocation command line was CONFIG_FILES = $CONFIG_FILES@@ -4207,7 +4279,7 @@ cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`" ac_cs_version="\\-Haskell CUDA bindings config.status 0.4.1.0+Haskell CUDA bindings config.status 0.5.0.0 configured by $0, generated by GNU Autoconf 2.69, with options \\"\$ac_cs_config\\"
configure.ac view
@@ -1,4 +1,4 @@-AC_INIT([Haskell CUDA bindings], [0.4.1.0], [tmcdonell@cse.unsw.edu.au], [cuda])+AC_INIT([Haskell CUDA bindings], [0.5.0.0], [tmcdonell@cse.unsw.edu.au], [cuda]) AC_CONFIG_SRCDIR([Foreign/CUDA.hs]) AC_CONFIG_FILES([cuda.buildinfo]) AC_PROG_CC@@ -11,7 +11,10 @@ # 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_PATH_PROG(NVCC, nvcc)+AC_ARG_WITH([compiler], [Haskell compiler], [GHC=$withval], [AC_PATH_PROG(GHC, ghc)])+AC_ARG_WITH([nvcc], [CUDA compiler], [NVCC=$withval], [AC_PATH_PROG(NVCC, nvcc)])+AC_ARG_WITH([gcc], [C compiler], [CC=$withval])+ if test "$NVCC" != ""; then cuda_prefix="$(dirname "$(dirname "$NVCC")")" cuda_c2hsflags="--cpp="$NVCC" --cppopts=-E "
cuda.cabal view
@@ -1,5 +1,5 @@ Name: cuda-Version: 0.4.1.1+Version: 0.5.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,16 +13,16 @@ 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. .- This release is for version 4.1 of the CUDA toolkit.+ This release is for version 5.0 of the CUDA toolkit. License: BSD3 License-file: LICENSE-Copyright: Copyright (c) [2009..2011]. Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+Copyright: Copyright (c) [2009..2012]. Trevor L. McDonell <tmcdonell@cse.unsw.edu.au> Author: Trevor L. McDonell <tmcdonell@cse.unsw.edu.au> Maintainer: Trevor L. McDonell <tmcdonell@cse.unsw.edu.au> Category: Foreign-Cabal-version: >=1.6-Tested-with: GHC >= 6.12+Cabal-version: >= 1.6+Tested-with: GHC >= 7.6 Build-type: Custom Extra-tmp-files: cuda.buildinfo config.status config.log@@ -68,9 +68,10 @@ C-sources: cbits/stubs.c Build-tools: c2hs >= 0.16, hsc2hs- Build-depends: base >= 3 && < 5, bytestring, extensible-exceptions+ Build-depends: base >= 4 && < 5, bytestring Extensions: ghc-options: -Wall -O2 -funbox-strict-fields -fwarn-tabs+ ghc-prof-options: -fprof-auto -fprof-cafs source-repository head