diff --git a/Foreign/CUDA.hs b/Foreign/CUDA.hs --- a/Foreign/CUDA.hs +++ b/Foreign/CUDA.hs @@ -1,7 +1,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA --- Copyright : (c) [2009..2012] Trevor L. McDonell +-- Copyright : [2009..2014] Trevor L. McDonell -- License : BSD -- -- Top level bindings. By default, expose the C-for-CUDA runtime API bindings, @@ -9,11 +9,11 @@ -- -------------------------------------------------------------------------------- -module Foreign.CUDA - ( - module Foreign.CUDA.Runtime - ) - where +module Foreign.CUDA ( + + module Foreign.CUDA.Runtime + +) where import Foreign.CUDA.Runtime diff --git a/Foreign/CUDA/Analysis.hs b/Foreign/CUDA/Analysis.hs --- a/Foreign/CUDA/Analysis.hs +++ b/Foreign/CUDA/Analysis.hs @@ -1,7 +1,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Analysis --- Copyright : (c) [2009..2012] Trevor L. McDonell +-- Copyright : [2009..2014] Trevor L. McDonell -- License : BSD -- -- Meta-module exporting CUDA analysis routines diff --git a/Foreign/CUDA/Analysis/Device.chs b/Foreign/CUDA/Analysis/Device.chs --- a/Foreign/CUDA/Analysis/Device.chs +++ b/Foreign/CUDA/Analysis/Device.chs @@ -1,7 +1,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Analysis.Device --- Copyright : (c) [2009..2012] Trevor L. McDonell +-- Copyright : [2009..2014] Trevor L. McDonell -- License : BSD -- -- Common device functions @@ -143,16 +143,18 @@ -- This is mostly extracted from tables in the CUDA occupancy calculator. -- resources compute = case compute of - Compute 1 0 -> DeviceResources 32 768 8 24 8 16384 512 8192 256 2 124 Block -- Tesla G80 - Compute 1 1 -> DeviceResources 32 768 8 24 8 16384 512 8192 256 2 124 Block -- Tesla G8x - Compute 1 2 -> DeviceResources 32 1024 8 32 8 16384 512 16384 512 2 124 Block -- Tesla G9x - Compute 1 3 -> DeviceResources 32 1024 8 32 8 16384 512 16384 512 2 124 Block -- Tesla GT200 - Compute 2 0 -> DeviceResources 32 1536 8 48 32 49152 128 32768 64 2 63 Warp -- Fermi GF100 - Compute 2 1 -> DeviceResources 32 1536 8 48 48 49152 128 32768 64 2 63 Warp -- Fermi GF10x - Compute 3 0 -> DeviceResources 32 2048 16 64 192 49152 256 65536 256 4 63 Warp -- Kepler GK10x - Compute 3 2 -> DeviceResources 32 2048 16 64 192 49152 256 65536 256 4 255 Warp -- Jetson TK1 (speculative) - Compute 3 5 -> DeviceResources 32 2048 16 64 192 49152 256 65536 256 4 255 Warp -- Kepler GK11x - Compute 5 0 -> DeviceResources 32 2048 32 64 128 65536 256 65536 256 4 255 Warp -- Maxwell GM10x + Compute 1 0 -> DeviceResources 32 768 8 24 8 16384 512 8192 256 2 124 Block -- Tesla G80 + Compute 1 1 -> DeviceResources 32 768 8 24 8 16384 512 8192 256 2 124 Block -- Tesla G8x + Compute 1 2 -> DeviceResources 32 1024 8 32 8 16384 512 16384 512 2 124 Block -- Tesla G9x + Compute 1 3 -> DeviceResources 32 1024 8 32 8 16384 512 16384 512 2 124 Block -- Tesla GT200 + Compute 2 0 -> DeviceResources 32 1536 8 48 32 49152 128 32768 64 2 63 Warp -- Fermi GF100 + Compute 2 1 -> DeviceResources 32 1536 8 48 48 49152 128 32768 64 2 63 Warp -- Fermi GF10x + Compute 3 0 -> DeviceResources 32 2048 16 64 192 49152 256 65536 256 4 63 Warp -- Kepler GK10x + Compute 3 2 -> DeviceResources 32 2048 16 64 192 49152 256 65536 256 4 255 Warp -- Jetson TK1 (speculative) + Compute 3 5 -> DeviceResources 32 2048 16 64 192 49152 256 65536 256 4 255 Warp -- Kepler GK11x + Compute 3 7 -> DeviceResources 32 2048 16 64 192 114688 256 131072 256 4 266 Warp -- Kepler GK21x + Compute 5 0 -> DeviceResources 32 2048 32 64 128 65536 256 65536 256 4 255 Warp -- Maxwell GM10x + Compute 5 2 -> DeviceResources 32 2048 32 64 128 98304 256 65536 256 4 255 Warp -- Maxwell GM20x -- Something might have gone wrong, or the library just needs to be -- updated for the next generation of hardware, in which case we just want diff --git a/Foreign/CUDA/Analysis/Occupancy.hs b/Foreign/CUDA/Analysis/Occupancy.hs --- a/Foreign/CUDA/Analysis/Occupancy.hs +++ b/Foreign/CUDA/Analysis/Occupancy.hs @@ -2,7 +2,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Analysis.Occupancy --- Copyright : (c) [2009..2012] Trevor L. McDonell +-- Copyright : [2009..2014] Trevor L. McDonell -- License : BSD -- -- Occupancy calculations for CUDA kernels @@ -46,13 +46,13 @@ -------------------------------------------------------------------------------- -module Foreign.CUDA.Analysis.Occupancy - ( +module Foreign.CUDA.Analysis.Occupancy ( + Occupancy(..), occupancy, optimalBlockSize, optimalBlockSizeBy, maxResidentBlocks, incPow2, incWarp, decPow2, decWarp - ) - where + +) where import Data.Ord import Data.List diff --git a/Foreign/CUDA/Driver.hs b/Foreign/CUDA/Driver.hs --- a/Foreign/CUDA/Driver.hs +++ b/Foreign/CUDA/Driver.hs @@ -1,7 +1,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Driver --- Copyright : (c) [2009..2012] Trevor L. McDonell +-- Copyright : [2009..2014] Trevor L. McDonell -- License : BSD -- -- Top level bindings to CUDA driver API diff --git a/Foreign/CUDA/Driver/Context.chs b/Foreign/CUDA/Driver/Context.chs --- a/Foreign/CUDA/Driver/Context.chs +++ b/Foreign/CUDA/Driver/Context.chs @@ -1,11 +1,12 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE EmptyCase #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE ForeignFunctionInterface #-} -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Driver.Context --- Copyright : (c) [2009..2012] Trevor L. McDonell +-- Copyright : [2009..2014] Trevor L. McDonell -- License : BSD -- -- Context management for low-level driver interface @@ -32,14 +33,14 @@ {# context lib="cuda" #} -- Friends -import Foreign.CUDA.Driver.Device (Device(..)) +import Foreign.CUDA.Driver.Device ( Device(..) ) import Foreign.CUDA.Driver.Error import Foreign.CUDA.Internal.C2HS -- System import Foreign import Foreign.C -import Control.Monad (liftM) +import Control.Monad ( liftM ) -------------------------------------------------------------------------------- @@ -87,6 +88,8 @@ -- data PeerFlag instance Enum PeerFlag where + toEnum x = case x of {} + fromEnum x = case x of {} #if CUDA_VERSION >= 4000 @@ -235,7 +238,7 @@ sync = nothingIfOk =<< cuCtxSynchronize {-# INLINE cuCtxSynchronize #-} -{# fun unsafe cuCtxSynchronize +{# fun cuCtxSynchronize { } -> `Status' cToEnum #} diff --git a/Foreign/CUDA/Driver/Device.chs b/Foreign/CUDA/Driver/Device.chs --- a/Foreign/CUDA/Driver/Device.chs +++ b/Foreign/CUDA/Driver/Device.chs @@ -1,11 +1,12 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE EmptyCase #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE ForeignFunctionInterface #-} -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Driver.Device --- Copyright : (c) [2009..2012] Trevor L. McDonell +-- Copyright : [2009..2014] Trevor L. McDonell -- License : BSD -- -- Device management for low-level driver interface @@ -33,7 +34,7 @@ -- System import Foreign import Foreign.C -import Control.Monad (liftM) +import Control.Monad ( liftM ) -------------------------------------------------------------------------------- @@ -113,6 +114,8 @@ -- data InitFlag instance Enum InitFlag where + toEnum x = case x of {} + fromEnum x = case x of {} -------------------------------------------------------------------------------- diff --git a/Foreign/CUDA/Driver/Error.chs b/Foreign/CUDA/Driver/Error.chs --- a/Foreign/CUDA/Driver/Error.chs +++ b/Foreign/CUDA/Driver/Error.chs @@ -4,7 +4,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Driver.Error --- Copyright : (c) [2009..2012] Trevor L. McDonell +-- Copyright : [2009..2014] Trevor L. McDonell -- License : BSD -- -- Error handling diff --git a/Foreign/CUDA/Driver/Event.chs b/Foreign/CUDA/Driver/Event.chs --- a/Foreign/CUDA/Driver/Event.chs +++ b/Foreign/CUDA/Driver/Event.chs @@ -1,11 +1,12 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE EmptyCase #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE ForeignFunctionInterface #-} -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Driver.Event --- Copyright : (c) [2009..2012] Trevor L. McDonell +-- Copyright : [2009..2014] Trevor L. McDonell -- License : BSD -- -- Event management for low-level driver interface @@ -24,38 +25,16 @@ {# context lib="cuda" #} -- Friends +import Foreign.CUDA.Types import Foreign.CUDA.Internal.C2HS import Foreign.CUDA.Driver.Error -import Foreign.CUDA.Driver.Stream (Stream(..)) -- System import Foreign import Foreign.C -import Control.Monad (liftM) - - --------------------------------------------------------------------------------- --- Data Types --------------------------------------------------------------------------------- - --- | --- Events --- -newtype Event = Event { useEvent :: {# type CUevent #}} - deriving (Eq, Show) - --- | --- Event creation flags --- -{# enum CUevent_flags as EventFlag - { underscoreToCase } - with prefix="CU_EVENT" deriving (Eq, Show) #} - --- | --- Possible option flags for waiting for events --- -data WaitFlag -instance Enum WaitFlag where +import Data.Maybe +import Control.Monad ( liftM ) +import Control.Exception ( throwIO ) -------------------------------------------------------------------------------- @@ -112,7 +91,7 @@ case rv of Success -> return True NotReady -> return False - _ -> resultIfOk (rv,undefined) + _ -> throwIO (ExitCode rv) {-# INLINE cuEventQuery #-} {# fun unsafe cuEventQuery @@ -126,9 +105,7 @@ {-# INLINEABLE record #-} record :: Event -> Maybe Stream -> IO () record !ev !mst = - nothingIfOk =<< case mst of - Just st -> cuEventRecord ev st - Nothing -> cuEventRecord ev (Stream nullPtr) + nothingIfOk =<< cuEventRecord ev (fromMaybe defaultStream mst) {-# INLINE cuEventRecord #-} {# fun unsafe cuEventRecord @@ -138,7 +115,9 @@ -- | -- Makes all future work submitted to the (optional) stream wait until the given --- event reports completion before beginning execution. Requires cuda-3.2. +-- event reports completion before beginning execution. Synchronisation is +-- performed on the device, including when the event and stream are from +-- different device contexts. Requires cuda-3.2. -- {-# INLINEABLE wait #-} wait :: Event -> Maybe Stream -> [WaitFlag] -> IO () @@ -146,9 +125,7 @@ wait _ _ _ = requireSDK 3.2 "wait" #else wait !ev !mst !flags = - nothingIfOk =<< case mst of - Just st -> cuStreamWaitEvent st ev flags - Nothing -> cuStreamWaitEvent (Stream nullPtr) ev flags + nothingIfOk =<< cuStreamWaitEvent (fromMaybe defaultStream mst) ev flags {-# INLINE cuStreamWaitEvent #-} {# fun unsafe cuStreamWaitEvent @@ -165,6 +142,6 @@ block !ev = nothingIfOk =<< cuEventSynchronize ev {-# INLINE cuEventSynchronize #-} -{# fun unsafe cuEventSynchronize +{# fun cuEventSynchronize { useEvent `Event' } -> `Status' cToEnum #} diff --git a/Foreign/CUDA/Driver/Exec.chs b/Foreign/CUDA/Driver/Exec.chs --- a/Foreign/CUDA/Driver/Exec.chs +++ b/Foreign/CUDA/Driver/Exec.chs @@ -6,7 +6,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Driver.Exec --- Copyright : (c) [2009..2012] Trevor L. McDonell +-- Copyright : [2009..2014] Trevor L. McDonell -- License : BSD -- -- Kernel execution control for low-level driver interface @@ -28,14 +28,14 @@ -- 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.Context ( Cache(..) ) +import Foreign.CUDA.Driver.Stream ( Stream(..), defaultStream ) -- System import Foreign import Foreign.C import Data.Maybe -import Control.Monad (zipWithM_) +import Control.Monad ( zipWithM_ ) #if CUDA_VERSION >= 4000 @@ -84,7 +84,9 @@ poke p (FArg f) = poke (castPtr p) f poke p (VArg v) = poke (castPtr p) v + peek _ = error "Can not peek Foreign.CUDA.Driver.FunParam" + -------------------------------------------------------------------------------- -- Execution Control -------------------------------------------------------------------------------- @@ -163,9 +165,7 @@ {-# INLINEABLE launch #-} launch :: Fun -> (Int,Int) -> Maybe Stream -> IO () launch !fn (!w,!h) mst = - nothingIfOk =<< case mst of - Nothing -> cuLaunchGridAsync fn w h (Stream nullPtr) - Just st -> cuLaunchGridAsync fn w h st + nothingIfOk =<< cuLaunchGridAsync fn w h (fromMaybe defaultStream mst) {-# INLINE cuLaunchGridAsync #-} {# fun unsafe cuLaunchGridAsync @@ -206,7 +206,7 @@ $ \pa -> withArray pa $ \pp -> cuLaunchKernel fn gx gy gz tx ty tz sm st pp nullPtr where - !st = fromMaybe (Stream nullPtr) mst + !st = fromMaybe defaultStream mst withFP :: FunParam -> (Ptr FunParam -> IO b) -> IO b withFP !p !f = case p of @@ -235,7 +235,7 @@ buffer = wordPtrToPtr 0x01 -- CU_LAUNCH_PARAM_BUFFER_POINTER size = wordPtrToPtr 0x02 -- CU_LAUNCH_PARAM_BUFFER_SIZE bytes = foldl (\a x -> a + sizeOf x) 0 args - st = fromMaybe (Stream nullPtr) mst + st = fromMaybe defaultStream mst -- can't use the standard 'withArray' because 'mallocArray' will pass -- 'undefined' to 'sizeOf' when determining how many bytes to allocate, but diff --git a/Foreign/CUDA/Driver/Marshal.chs b/Foreign/CUDA/Driver/Marshal.chs --- a/Foreign/CUDA/Driver/Marshal.chs +++ b/Foreign/CUDA/Driver/Marshal.chs @@ -6,7 +6,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Driver.Marshal --- Copyright : (c) [2009..2012] Trevor L. McDonell +-- Copyright : [2009..2014] Trevor L. McDonell -- License : BSD -- -- Memory management for low-level driver interface @@ -51,8 +51,8 @@ -- Friends import Foreign.CUDA.Ptr import Foreign.CUDA.Driver.Error -import Foreign.CUDA.Driver.Stream (Stream(..)) -import Foreign.CUDA.Driver.Context (Context(..)) +import Foreign.CUDA.Driver.Stream ( Stream(..), defaultStream ) +import Foreign.CUDA.Driver.Context ( Context(..) ) import Foreign.CUDA.Internal.C2HS -- System @@ -65,7 +65,7 @@ import Foreign.C import Foreign.Ptr import Foreign.Storable -import qualified Foreign.Marshal as F +import qualified Foreign.Marshal as F #c typedef enum CUmemhostalloc_option_enum { @@ -75,17 +75,7 @@ } CUmemhostalloc_option; #endc -#if CUDA_VERSION >= 6000 -#c -typedef enum CUmemAttachFlags_option_enum { - CU_MEM_ATTACH_OPTION_GLOBAL = CU_MEM_ATTACH_GLOBAL, - CU_MEM_ATTACH_OPTION_HOST = CU_MEM_ATTACH_HOST, - CU_MEM_ATTACH_OPTION_SINGLE = CU_MEM_ATTACH_SINGLE -} CUmemAttachFlags_option; -#endc -#endif - -------------------------------------------------------------------------------- -- Host Allocation -------------------------------------------------------------------------------- @@ -248,12 +238,12 @@ -- | -- Options for unified memory allocations -- -#if CUDA_VERSION >= 6000 -{# enum CUmemAttachFlags_option as AttachFlag +#if CUDA_VERSION < 6000 +data AttachFlag +#else +{# enum CUmemAttach_flags as AttachFlag { underscoreToCase } with prefix="CU_MEM_ATTACH_OPTION" deriving (Eq, Show) #} -#else -data AttachFlag #endif -- | @@ -299,7 +289,7 @@ doPeek x _ = nothingIfOk =<< cuMemcpyDtoH hptr dptr (n * sizeOf x) {-# INLINE cuMemcpyDtoH #-} -{# fun unsafe cuMemcpyDtoH +{# fun cuMemcpyDtoH { castPtr `Ptr a' , useDeviceHandle `DevicePtr a' , `Int' } -> `Status' cToEnum #} @@ -314,10 +304,10 @@ 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) + doPeek x _ = nothingIfOk =<< cuMemcpyDtoHAsync hptr dptr (n * sizeOf x) (fromMaybe defaultStream mst) {-# INLINE cuMemcpyDtoHAsync #-} -{# fun unsafe cuMemcpyDtoHAsync +{# fun cuMemcpyDtoHAsync { useHP `HostPtr a' , useDeviceHandle `DevicePtr a' , `Int' @@ -357,7 +347,7 @@ nothingIfOk =<< cuMemcpy2DDtoH hptr hw' hx' hy dptr dw' dx' dy w' h {-# INLINE cuMemcpy2DDtoH #-} -{# fun unsafe cuMemcpy2DDtoH +{# fun cuMemcpy2DDtoH { castPtr `Ptr a' , `Int' , `Int' @@ -402,12 +392,12 @@ hx' = hx * bytes dw' = dw * bytes dx' = dx * bytes - st = fromMaybe (Stream nullPtr) mst + st = fromMaybe defaultStream mst in nothingIfOk =<< cuMemcpy2DDtoHAsync hptr hw' hx' hy dptr dw' dx' dy w' h st {-# INLINE cuMemcpy2DDtoHAsync #-} -{# fun unsafe cuMemcpy2DDtoHAsync +{# fun cuMemcpy2DDtoHAsync { useHP `HostPtr a' , `Int' , `Int' @@ -452,7 +442,7 @@ doPoke x _ = nothingIfOk =<< cuMemcpyHtoD dptr hptr (n * sizeOf x) {-# INLINE cuMemcpyHtoD #-} -{# fun unsafe cuMemcpyHtoD +{# fun cuMemcpyHtoD { useDeviceHandle `DevicePtr a' , castPtr `Ptr a' , `Int' } -> `Status' cToEnum #} @@ -467,10 +457,10 @@ 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) + dopoke x _ = nothingIfOk =<< cuMemcpyHtoDAsync dptr hptr (n * sizeOf x) (fromMaybe defaultStream mst) {-# INLINE cuMemcpyHtoDAsync #-} -{# fun unsafe cuMemcpyHtoDAsync +{# fun cuMemcpyHtoDAsync { useDeviceHandle `DevicePtr a' , useHP `HostPtr a' , `Int' @@ -510,7 +500,7 @@ nothingIfOk =<< cuMemcpy2DHtoD dptr dw' dx' dy hptr hw' hx' hy w' h {-# INLINE cuMemcpy2DHtoD #-} -{# fun unsafe cuMemcpy2DHtoD +{# fun cuMemcpy2DHtoD { useDeviceHandle `DevicePtr a' , `Int' , `Int' @@ -555,12 +545,12 @@ hx' = hx * bytes dw' = dw * bytes dx' = dx * bytes - st = fromMaybe (Stream nullPtr) mst + st = fromMaybe defaultStream mst in nothingIfOk =<< cuMemcpy2DHtoDAsync dptr dw' dx' dy hptr hw' hx' hy w' h st {-# INLINE cuMemcpy2DHtoDAsync #-} -{# fun unsafe cuMemcpy2DHtoDAsync +{# fun cuMemcpy2DHtoDAsync { useDeviceHandle `DevicePtr a' , `Int' , `Int' @@ -622,7 +612,7 @@ copyArrayAsync !n !src !dst !mst = docopy undefined src where docopy :: Storable a' => a' -> DevicePtr a' -> IO () - docopy x _ = nothingIfOk =<< cuMemcpyDtoDAsync dst src (n * sizeOf x) (fromMaybe (Stream nullPtr) mst) + docopy x _ = nothingIfOk =<< cuMemcpyDtoDAsync dst src (n * sizeOf x) (fromMaybe defaultStream mst) {-# INLINE cuMemcpyDtoDAsync #-} {# fun unsafe cuMemcpyDtoDAsync @@ -712,7 +702,7 @@ hx' = hx * bytes dw' = dw * bytes dx' = dx * bytes - st = fromMaybe (Stream nullPtr) mst + st = fromMaybe defaultStream mst in nothingIfOk =<< cuMemcpy2DDtoDAsync dst dw' dx' dy src hw' hx' hy w' h st @@ -787,7 +777,7 @@ 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 + stream = fromMaybe defaultStream st {-# INLINE cuMemcpyPeerAsync #-} {# fun unsafe cuMemcpyPeerAsync @@ -912,7 +902,7 @@ 4 -> nothingIfOk =<< cuMemsetD32Async dptr val n stream _ -> cudaError "can only memset 8-, 16-, and 32-bit values" where - stream = fromMaybe (Stream nullPtr) mst + stream = fromMaybe defaultStream mst {-# INLINE cuMemsetD8Async #-} {# fun unsafe cuMemsetD8Async diff --git a/Foreign/CUDA/Driver/Module.chs b/Foreign/CUDA/Driver/Module.chs --- a/Foreign/CUDA/Driver/Module.chs +++ b/Foreign/CUDA/Driver/Module.chs @@ -3,7 +3,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Driver.Module --- Copyright : (c) [2009..2012] Trevor L. McDonell +-- Copyright : [2009..2014] Trevor L. McDonell -- License : BSD -- -- Module management for low-level driver interface @@ -13,7 +13,7 @@ module Foreign.CUDA.Driver.Module ( -- * Module Management - Module, JITOption(..), JITTarget(..), JITResult(..), + Module, JITOption(..), JITTarget(..), JITResult(..), JITFallback(..), -- ** Querying module inhabitants getFun, getPtr, getTex, @@ -34,7 +34,7 @@ import Foreign.CUDA.Ptr import Foreign.CUDA.Driver.Error import Foreign.CUDA.Driver.Exec -import Foreign.CUDA.Driver.Marshal (peekDeviceHandle) +import Foreign.CUDA.Driver.Marshal ( peekDeviceHandle ) import Foreign.CUDA.Driver.Texture import Foreign.CUDA.Internal.C2HS @@ -43,15 +43,15 @@ import Foreign.C import Unsafe.Coerce -import Control.Monad (liftM) -import Control.Exception (throwIO) -import Data.Maybe (mapMaybe) -import Data.ByteString.Char8 (ByteString) -import qualified Data.ByteString.Char8 as B -import qualified Data.ByteString.Internal as B +import Control.Monad ( liftM ) +import Control.Exception ( throwIO ) +import Data.Maybe ( mapMaybe ) +import Data.ByteString.Char8 ( ByteString ) +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Internal as B #if CUDA_VERSION < 5050 -import Debug.Trace (trace) +import Debug.Trace ( trace ) #endif -------------------------------------------------------------------------------- @@ -100,7 +100,8 @@ with prefix="CU_TARGET" deriving (Eq, Show) #} {# enum CUjit_fallback as JITFallback - { underscoreToCase } + { underscoreToCase + , CU_PREFER_PTX as PTX } with prefix="CU_PREFER" deriving (Eq, Show) #} @@ -311,8 +312,18 @@ peekMod = liftM Module . peek {-# INLINE c_strnlen' #-} +#if defined(WIN32) +c_strnlen' :: CString -> CSize -> IO CSize +c_strnlen' str size = do + str' <- peekCStringLen (str, fromIntegral size) + return $ stringLen 0 str' + where stringLen acc [] = acc + stringLen acc ('\0':xs) = acc + stringLen acc (_:xs) = stringLen (acc+1) xs +#else foreign import ccall unsafe "string.h strnlen" c_strnlen' :: CString -> CSize -> IO CSize +#endif {-# INLINE c_strnlen #-} c_strnlen :: CString -> Int -> IO Int diff --git a/Foreign/CUDA/Driver/Stream.chs b/Foreign/CUDA/Driver/Stream.chs --- a/Foreign/CUDA/Driver/Stream.chs +++ b/Foreign/CUDA/Driver/Stream.chs @@ -1,10 +1,11 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE EmptyCase #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE ForeignFunctionInterface #-} -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Driver.Stream --- Copyright : (c) [2009..2012] Trevor L. McDonell +-- Copyright : [2009..2014] Trevor L. McDonell -- License : BSD -- -- Stream management for low-level driver interface @@ -15,7 +16,7 @@ -- * Stream Management Stream(..), StreamFlag, - create, destroy, finished, block + create, destroy, finished, block, defaultStream ) where @@ -23,34 +24,18 @@ {# context lib="cuda" #} -- Friends +import Foreign.CUDA.Types import Foreign.CUDA.Driver.Error import Foreign.CUDA.Internal.C2HS -- System import Foreign import Foreign.C -import Control.Monad (liftM) +import Control.Monad ( liftM ) +import Control.Exception ( throwIO ) -------------------------------------------------------------------------------- --- Data Types --------------------------------------------------------------------------------- - --- | --- A processing stream --- -newtype Stream = Stream { useStream :: {# type CUstream #}} - deriving (Eq, Show) - - --- | --- Possible option flags for stream initialisation. Dummy instance until the API --- exports actual option values. --- -data StreamFlag -instance Enum StreamFlag where - --------------------------------------------------------------------------------- -- Stream management -------------------------------------------------------------------------------- @@ -65,7 +50,8 @@ {# fun unsafe cuStreamCreate { alloca- `Stream' peekStream* , combineBitMasks `[StreamFlag]' } -> `Status' cToEnum #} - where peekStream = liftM Stream . peek + where + peekStream = liftM Stream . peek -- | -- Destroy a stream @@ -89,7 +75,7 @@ case rv of Success -> return True NotReady -> return False - _ -> resultIfOk (rv,undefined) + _ -> throwIO (ExitCode rv) {-# INLINE cuStreamQuery #-} {# fun unsafe cuStreamQuery @@ -104,6 +90,6 @@ block !st = nothingIfOk =<< cuStreamSynchronize st {-# INLINE cuStreamSynchronize #-} -{# fun unsafe cuStreamSynchronize +{# fun cuStreamSynchronize { useStream `Stream' } -> `Status' cToEnum #} diff --git a/Foreign/CUDA/Driver/Texture.chs b/Foreign/CUDA/Driver/Texture.chs --- a/Foreign/CUDA/Driver/Texture.chs +++ b/Foreign/CUDA/Driver/Texture.chs @@ -4,7 +4,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Driver.Texture --- Copyright : (c) [2009..2012] Trevor L. McDonell +-- Copyright : [2009..2014] Trevor L. McDonell -- License : BSD -- -- Texture management for low-level driver interface @@ -80,12 +80,14 @@ #c typedef enum CUtexture_flag_enum { CU_TEXTURE_FLAG_READ_AS_INTEGER = CU_TRSF_READ_AS_INTEGER, - CU_TEXTURE_FLAG_NORMALIZED_COORDINATES = CU_TRSF_NORMALIZED_COORDINATES + CU_TEXTURE_FLAG_NORMALIZED_COORDINATES = CU_TRSF_NORMALIZED_COORDINATES, + CU_TEXTURE_FLAG_SRGB = CU_TRSF_SRGB } CUtexture_flag; #endc {# enum CUtexture_flag as ReadMode - { underscoreToCase } + { underscoreToCase + , CU_TEXTURE_FLAG_SRGB as SRGB } with prefix="CU_TEXTURE_FLAG" deriving (Eq, Show) #} -- | diff --git a/Foreign/CUDA/Driver/Utils.chs b/Foreign/CUDA/Driver/Utils.chs --- a/Foreign/CUDA/Driver/Utils.chs +++ b/Foreign/CUDA/Driver/Utils.chs @@ -2,7 +2,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Driver.Utils --- Copyright : (c) [2009..2012] Trevor L. McDonell +-- Copyright : [2009..2014] Trevor L. McDonell -- License : BSD -- -- Utility functions diff --git a/Foreign/CUDA/Internal/C2HS.hs b/Foreign/CUDA/Internal/C2HS.hs --- a/Foreign/CUDA/Internal/C2HS.hs +++ b/Foreign/CUDA/Internal/C2HS.hs @@ -53,7 +53,7 @@ import Foreign import Foreign.C -import Control.Monad (liftM) +import Control.Monad ( liftM ) -- Composite marshalling functions @@ -177,42 +177,46 @@ -- |Integral conversion -- -{-# INLINE cIntConv #-} +{-# INLINE [1] cIntConv #-} cIntConv :: (Integral a, Integral b) => a -> b cIntConv = fromIntegral -- |Floating conversion -- -{-# INLINE cFloatConv #-} +{-# INLINE [1] cFloatConv #-} cFloatConv :: (RealFloat a, RealFloat b) => a -> b cFloatConv = realToFrac -- As this conversion by default goes via `Rational', it can be very slow... {-# RULES - "cFloatConv/Float->Float" forall (x::Float). cFloatConv x = x; - "cFloatConv/Double->Double" forall (x::Double). cFloatConv x = x + "cFloatConv/Float->Float" forall (x::Float). cFloatConv x = x; + "cFloatConv/Double->Double" forall (x::Double). cFloatConv x = x; + "cFloatConv/Float->CFloat" forall (x::Float). cFloatConv x = CFloat x; + "cFloatConv/CFloat->Float" forall (x::Float). cFloatConv CFloat x = x; + "cFloatConv/Double->CDouble" forall (x::Double). cFloatConv x = CDouble x; + "cFloatConv/CDouble->Double" forall (x::Double). cFloatConv CDouble x = x #-} -- |Obtain C value from Haskell 'Bool'. -- -{-# INLINE cFromBool #-} +{-# INLINE [1] cFromBool #-} cFromBool :: Num a => Bool -> a cFromBool = fromBool -- |Obtain Haskell 'Bool' from C value. -- -{-# INLINE cToBool #-} +{-# INLINE [1] cToBool #-} cToBool :: (Eq a, Num a) => a -> Bool cToBool = toBool -- |Convert a C enumeration to Haskell. -- -{-# INLINE cToEnum #-} +{-# INLINE [1] cToEnum #-} cToEnum :: (Integral i, Enum e) => i -> e cToEnum = toEnum . cIntConv -- |Convert a Haskell enumeration to C. -- -{-# INLINE cFromEnum #-} +{-# INLINE [1] cFromEnum #-} cFromEnum :: (Enum e, Integral i) => e -> i cFromEnum = cIntConv . fromEnum diff --git a/Foreign/CUDA/Internal/Offsets.hsc b/Foreign/CUDA/Internal/Offsets.hsc --- a/Foreign/CUDA/Internal/Offsets.hsc +++ b/Foreign/CUDA/Internal/Offsets.hsc @@ -1,10 +1,11 @@ {-# LANGUAGE ForeignFunctionInterface #-} -{- - - Structure field offset constants. - - Too difficult to extract using C->Haskell )= - -} +-- +-- Structure field offset constants. +-- Too difficult to extract using C->Haskell )= +-- -module Foreign.CUDA.Internal.Offsets where +module Foreign.CUDA.Internal.Offsets + where -------------------------------------------------------------------------------- diff --git a/Foreign/CUDA/Ptr.hs b/Foreign/CUDA/Ptr.hs --- a/Foreign/CUDA/Ptr.hs +++ b/Foreign/CUDA/Ptr.hs @@ -2,19 +2,44 @@ -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Ptr --- Copyright : (c) [2009..2012] Trevor L. McDonell +-- Copyright : [2009..2014] Trevor L. McDonell -- License : BSD -- --- A common interface for host and device pointers. While it is possible mix the --- Driver and Runtime environments with CUDA versions >= 3.0, it is still a good --- idea to pick one interface and stick to it. +-- Data pointers on the host and device. These can be shared freely between the +-- CUDA runtime and Driver APIs. -- -------------------------------------------------------------------------------- -module Foreign.CUDA.Ptr - where +module Foreign.CUDA.Ptr ( --- System + -- * Device pointers + DevicePtr(..), + withDevicePtr, + devPtrToWordPtr, + wordPtrToDevPtr, + nullDevPtr, + castDevPtr, + plusDevPtr, + alignDevPtr, + minusDevPtr, + advanceDevPtr, + + -- * Host pointers + HostPtr(..), + withHostPtr, + nullHostPtr, + castHostPtr, + plusHostPtr, + alignHostPtr, + minusHostPtr, + advanceHostPtr, + +) where + +-- friends +import Foreign.CUDA.Types + +-- system import Foreign.Ptr import Foreign.Storable @@ -24,22 +49,6 @@ -------------------------------------------------------------------------------- -- | --- A reference to data stored on the device. --- -newtype DevicePtr a = DevicePtr { useDevicePtr :: Ptr a } - deriving (Eq,Ord) - -instance Show (DevicePtr a) where - showsPrec n (DevicePtr p) = showsPrec n p - -instance Storable (DevicePtr a) where - sizeOf _ = sizeOf (undefined :: Ptr a) - alignment _ = alignment (undefined :: Ptr a) - peek p = DevicePtr `fmap` peek (castPtr p) - poke p v = poke (castPtr p) (useDevicePtr v) - - --- | -- Look at the contents of device memory. This takes an IO action that will be -- applied to that pointer, the result of which is returned. It would be silly -- to return the pointer from the action. @@ -116,32 +125,6 @@ -------------------------------------------------------------------------------- -- Host Pointer -------------------------------------------------------------------------------- - --- | --- A reference to page-locked host memory. --- --- A 'HostPtr' is just a plain 'Ptr', but the memory has been allocated by the --- CUDA runtime into page locked memory. This means that the data can be copied --- to the GPU via DMA (direct memory access). Note that the use of the system --- function `mlock` is not sufficient here --- the CUDA version ensures that --- the /physical/ addresses stay this same, not just the virtual address. --- --- To copy data into a 'HostPtr' array, you may use for example 'withHostPtr' --- together with 'Foreign.Marshal.Array.copyArray' or --- 'Foreign.Marshal.Array.moveArray'. --- -newtype HostPtr a = HostPtr { useHostPtr :: Ptr a } - deriving (Eq,Ord) - -instance Show (HostPtr a) where - showsPrec n (HostPtr p) = showsPrec n p - -instance Storable (HostPtr a) where - sizeOf _ = sizeOf (undefined :: Ptr a) - alignment _ = alignment (undefined :: Ptr a) - peek p = HostPtr `fmap` peek (castPtr p) - poke p v = poke (castPtr p) (useHostPtr v) - -- | -- Apply an IO action to the memory reference living inside the host pointer diff --git a/Foreign/CUDA/Runtime.hs b/Foreign/CUDA/Runtime.hs --- a/Foreign/CUDA/Runtime.hs +++ b/Foreign/CUDA/Runtime.hs @@ -1,7 +1,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Runtime --- Copyright : (c) [2009..2012] Trevor L. McDonell +-- Copyright : [2009..2014] Trevor L. McDonell -- License : BSD -- -- Top level bindings to the C-for-CUDA runtime API diff --git a/Foreign/CUDA/Runtime/Device.chs b/Foreign/CUDA/Runtime/Device.chs --- a/Foreign/CUDA/Runtime/Device.chs +++ b/Foreign/CUDA/Runtime/Device.chs @@ -1,11 +1,13 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE EmptyCase #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE ForeignFunctionInterface #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Runtime.Device --- Copyright : (c) [2009..2012] Trevor L. McDonell +-- Copyright : [2009..2014] Trevor L. McDonell -- License : BSD -- -- Device management routines @@ -283,11 +285,11 @@ #if CUDART_VERSION < 4000 {-# INLINE cudaThreadSynchronize #-} sync = nothingIfOk =<< cudaThreadSynchronize -{# fun unsafe cudaThreadSynchronize { } -> `Status' cToEnum #} +{# fun cudaThreadSynchronize { } -> `Status' cToEnum #} #else {-# INLINE cudaDeviceSynchronize #-} sync = nothingIfOk =<< cudaDeviceSynchronize -{# fun unsafe cudaDeviceSynchronize { } -> `Status' cToEnum #} +{# fun cudaDeviceSynchronize { } -> `Status' cToEnum #} #endif -- | @@ -321,6 +323,8 @@ -- data PeerFlag instance Enum PeerFlag where + toEnum x = case x of {} + fromEnum x = case x of {} -- | -- Queries if the first device can directly access the memory of the second. If diff --git a/Foreign/CUDA/Runtime/Error.chs b/Foreign/CUDA/Runtime/Error.chs --- a/Foreign/CUDA/Runtime/Error.chs +++ b/Foreign/CUDA/Runtime/Error.chs @@ -4,7 +4,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Runtime.Error --- Copyright : (c) [2009..2012] Trevor L. McDonell +-- Copyright : [2009..2014] Trevor L. McDonell -- License : BSD -- -- Error handling functions diff --git a/Foreign/CUDA/Runtime/Event.chs b/Foreign/CUDA/Runtime/Event.chs --- a/Foreign/CUDA/Runtime/Event.chs +++ b/Foreign/CUDA/Runtime/Event.chs @@ -1,11 +1,12 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE EmptyCase #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE ForeignFunctionInterface #-} -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Driver.Event --- Copyright : (c) [2009..2012] Trevor L. McDonell +-- Copyright : [2009..2014] Trevor L. McDonell -- License : BSD -- -- Event management for C-for-CUDA runtime environment @@ -24,49 +25,19 @@ {# context lib="cudart" #} -- Friends +import Foreign.CUDA.Types import Foreign.CUDA.Runtime.Error -import Foreign.CUDA.Runtime.Stream ( Stream(..), defaultStream ) import Foreign.CUDA.Internal.C2HS -- System import Foreign import Foreign.C import Control.Monad ( liftM ) +import Control.Exception ( throwIO ) import Data.Maybe ( fromMaybe ) -#c -typedef enum cudaEvent_option_enum { -// CUDA_EVENT_OPTION_DEFAULT = cuduEventDefault, - CUDA_EVENT_OPTION_BLOCKING_SYNC = cudaEventBlockingSync -} cudaEvent_option; -#endc - -------------------------------------------------------------------------------- --- Data Types --------------------------------------------------------------------------------- - --- | --- Events --- -newtype Event = Event { useEvent :: {# type cudaEvent_t #}} - deriving (Eq, Show) - --- | --- Event creation flags --- -{# enum cudaEvent_option_enum as EventFlag - { underscoreToCase } - with prefix="CUDA_EVENT_OPTION" deriving (Eq,Show) #} - --- | --- Possible option flags for waiting for events --- -data WaitFlag -instance Enum WaitFlag where - - --------------------------------------------------------------------------------- -- Event management -------------------------------------------------------------------------------- @@ -120,7 +91,7 @@ case rv of Success -> return True NotReady -> return False - _ -> resultIfOk (rv,undefined) + _ -> throwIO (ExitCode rv) {-# INLINE cudaEventQuery #-} {# fun unsafe cudaEventQuery @@ -144,7 +115,9 @@ -- | -- Makes all future work submitted to the (optional) stream wait until the given --- event reports completion before beginning execution. Requires cuda-3.2. +-- event reports completion before beginning execution. Synchronisation is +-- performed on the device, including when the event and stream are from +-- different device contexts. Requires cuda-3.2. -- {-# INLINEABLE wait #-} wait :: Event -> Maybe Stream -> [WaitFlag] -> IO () @@ -170,6 +143,6 @@ block !ev = nothingIfOk =<< cudaEventSynchronize ev {-# INLINE cudaEventSynchronize #-} -{# fun unsafe cudaEventSynchronize +{# fun cudaEventSynchronize { useEvent `Event' } -> `Status' cToEnum #} diff --git a/Foreign/CUDA/Runtime/Exec.chs b/Foreign/CUDA/Runtime/Exec.chs --- a/Foreign/CUDA/Runtime/Exec.chs +++ b/Foreign/CUDA/Runtime/Exec.chs @@ -5,7 +5,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Runtime.Exec --- Copyright : (c) [2009..2012] Trevor L. McDonell +-- Copyright : [2009..2014] Trevor L. McDonell -- License : BSD -- -- Kernel execution control for C-for-CUDA runtime interface @@ -24,7 +24,7 @@ {# context lib="cudart" #} -- Friends -import Foreign.CUDA.Runtime.Stream +import Foreign.CUDA.Runtime.Stream ( Stream(..), defaultStream ) import Foreign.CUDA.Runtime.Error import Foreign.CUDA.Internal.C2HS @@ -74,6 +74,7 @@ sizeOf _ = {# sizeof cudaFuncAttributes #} alignment _ = alignment (undefined :: Ptr ()) + poke _ _ = error "Can not poke Foreign.CUDA.Runtime.FunAttributes" peek p = do cs <- cIntConv `fmap` {#get cudaFuncAttributes.constSizeBytes#} p ls <- cIntConv `fmap` {#get cudaFuncAttributes.localSizeBytes#} p diff --git a/Foreign/CUDA/Runtime/Marshal.chs b/Foreign/CUDA/Runtime/Marshal.chs --- a/Foreign/CUDA/Runtime/Marshal.chs +++ b/Foreign/CUDA/Runtime/Marshal.chs @@ -4,7 +4,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Runtime.Marshal --- Copyright : (c) [2009..2012] Trevor L. McDonell +-- Copyright : [2009..2014] Trevor L. McDonell -- License : BSD -- -- Memory management for CUDA devices @@ -93,7 +93,8 @@ -- Allocate a section of linear memory on the host which is page-locked and -- directly accessible from the device. The storage is sufficient to hold the -- given number of elements of a storable type. The runtime system automatically --- accelerates calls to functions such as 'memcpy' to page-locked memory. +-- accelerates calls to functions such as 'peekArrayAsync' and 'pokeArrayAsync' +-- that refer to page-locked memory. -- -- Note that since the amount of pageable memory is thusly reduced, overall -- system performance may suffer. This is best used sparingly to allocate @@ -447,7 +448,7 @@ nothingIfOk =<< cudaMemcpy dst src (fromIntegral n * fromIntegral (sizeOf x)) dir {-# INLINE cudaMemcpy #-} -{# fun unsafe cudaMemcpy +{# fun cudaMemcpy { castPtr `Ptr a' , castPtr `Ptr a' , cIntConv `Int64' @@ -475,7 +476,7 @@ nothingIfOk =<< cudaMemcpyAsync dst src bytes kind (fromMaybe defaultStream mst) {-# INLINE cudaMemcpyAsync #-} -{# fun unsafe cudaMemcpyAsync +{# fun cudaMemcpyAsync { castPtr `Ptr a' , castPtr `Ptr a' , cIntConv `Int64' @@ -510,7 +511,7 @@ nothingIfOk =<< cudaMemcpy2D dst dw' src sw' w' h' kind {-# INLINE cudaMemcpy2D #-} -{# fun unsafe cudaMemcpy2D +{# fun cudaMemcpy2D { castPtr `Ptr a' , `Int64' , castPtr `Ptr a' @@ -552,7 +553,7 @@ nothingIfOk =<< cudaMemcpy2DAsync dst dw' src sw' w' h' kind st {-# INLINE cudaMemcpy2DAsync #-} -{# fun unsafe cudaMemcpy2DAsync +{# fun cudaMemcpy2DAsync { castPtr `Ptr a' , `Int64' , castPtr `Ptr a' diff --git a/Foreign/CUDA/Runtime/Stream.chs b/Foreign/CUDA/Runtime/Stream.chs --- a/Foreign/CUDA/Runtime/Stream.chs +++ b/Foreign/CUDA/Runtime/Stream.chs @@ -3,7 +3,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Runtime.Stream --- Copyright : (c) [2009..2012] Trevor L. McDonell +-- Copyright : [2009..2014] Trevor L. McDonell -- License : BSD -- -- Stream management routines @@ -22,24 +22,15 @@ {# context lib="cudart" #} -- Friends +import Foreign.CUDA.Types import Foreign.CUDA.Runtime.Error import Foreign.CUDA.Internal.C2HS -- System import Foreign import Foreign.C -import Control.Monad (liftM) - - --------------------------------------------------------------------------------- --- Data Types --------------------------------------------------------------------------------- - --- | --- A processing stream --- -newtype Stream = Stream { useStream :: {# type cudaStream_t #}} - deriving (Eq, Show) +import Control.Monad ( liftM ) +import Control.Exception ( throwIO ) -------------------------------------------------------------------------------- @@ -80,7 +71,7 @@ case rv of Success -> return True NotReady -> return False - _ -> resultIfOk (rv,undefined) + _ -> throwIO (ExitCode rv) {-# INLINE cudaStreamQuery #-} {# fun unsafe cudaStreamQuery @@ -95,20 +86,20 @@ block !s = nothingIfOk =<< cudaStreamSynchronize s {-# INLINE cudaStreamSynchronize #-} -{# fun unsafe cudaStreamSynchronize +{# fun cudaStreamSynchronize { useStream `Stream' } -> `Status' cToEnum #} -- | -- The main execution stream (0) -- -{-# INLINE defaultStream #-} -defaultStream :: Stream -#if CUDART_VERSION < 3010 -defaultStream = Stream 0 -#else -defaultStream = Stream nullPtr -#endif +-- {-# INLINE defaultStream #-} +-- defaultStream :: Stream +-- #if CUDART_VERSION < 3010 +-- defaultStream = Stream 0 +-- #else +-- defaultStream = Stream nullPtr +-- #endif -------------------------------------------------------------------------------- -- Internal @@ -121,5 +112,4 @@ #else peekStream = liftM Stream . peek #endif - diff --git a/Foreign/CUDA/Runtime/Texture.chs b/Foreign/CUDA/Runtime/Texture.chs --- a/Foreign/CUDA/Runtime/Texture.chs +++ b/Foreign/CUDA/Runtime/Texture.chs @@ -3,7 +3,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Runtime.Texture --- Copyright : (c) [2009..2012] Trevor L. McDonell +-- Copyright : [2009..2014] Trevor L. McDonell -- License : BSD -- -- Texture references diff --git a/Foreign/CUDA/Runtime/Utils.chs b/Foreign/CUDA/Runtime/Utils.chs --- a/Foreign/CUDA/Runtime/Utils.chs +++ b/Foreign/CUDA/Runtime/Utils.chs @@ -2,7 +2,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Foreign.CUDA.Runtime.Utils --- Copyright : (c) [2009..2012] Trevor L. McDonell +-- Copyright : [2009..2014] Trevor L. McDonell -- License : BSD -- -- Utility functions diff --git a/Foreign/CUDA/Types.chs b/Foreign/CUDA/Types.chs new file mode 100644 --- /dev/null +++ b/Foreign/CUDA/Types.chs @@ -0,0 +1,140 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE EmptyDataDecls #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Foreign.CUDA.Types +-- Copyright : [2009..2014] Trevor L. McDonell +-- License : BSD +-- +-- Data types that are equivalent and can be shared freely between the CUDA +-- Runtime and Driver APIs. +-- +-------------------------------------------------------------------------------- + +module Foreign.CUDA.Types ( + + -- * Pointers + DevicePtr(..), HostPtr(..), + + -- * Events + Event(..), EventFlag(..), WaitFlag, + + -- * Streams + Stream(..), StreamFlag, + defaultStream, + +) where + +-- system +import Foreign.Ptr +import Foreign.Storable + +#include "cbits/stubs.h" +{# context lib="cuda" #} + + +-------------------------------------------------------------------------------- +-- Data pointers +-------------------------------------------------------------------------------- + +-- | +-- A reference to data stored on the device. +-- +newtype DevicePtr a = DevicePtr { useDevicePtr :: Ptr a } + deriving (Eq,Ord) + +instance Show (DevicePtr a) where + showsPrec n (DevicePtr p) = showsPrec n p + +instance Storable (DevicePtr a) where + sizeOf _ = sizeOf (undefined :: Ptr a) + alignment _ = alignment (undefined :: Ptr a) + peek p = DevicePtr `fmap` peek (castPtr p) + poke p v = poke (castPtr p) (useDevicePtr v) + + +-- | +-- A reference to page-locked host memory. +-- +-- A 'HostPtr' is just a plain 'Ptr', but the memory has been allocated by CUDA +-- into page locked memory. This means that the data can be copied to the GPU +-- via DMA (direct memory access). Note that the use of the system function +-- `mlock` is not sufficient here --- the CUDA version ensures that the +-- /physical/ address stays this same, not just the virtual address. +-- +-- To copy data into a 'HostPtr' array, you may use for example 'withHostPtr' +-- together with 'Foreign.Marshal.Array.copyArray' or +-- 'Foreign.Marshal.Array.moveArray'. +-- +newtype HostPtr a = HostPtr { useHostPtr :: Ptr a } + deriving (Eq,Ord) + +instance Show (HostPtr a) where + showsPrec n (HostPtr p) = showsPrec n p + +instance Storable (HostPtr a) where + sizeOf _ = sizeOf (undefined :: Ptr a) + alignment _ = alignment (undefined :: Ptr a) + peek p = HostPtr `fmap` peek (castPtr p) + poke p v = poke (castPtr p) (useHostPtr v) + + +-------------------------------------------------------------------------------- +-- Events +-------------------------------------------------------------------------------- + +-- | +-- Events are markers that can be inserted into the CUDA execution stream and +-- later queried. +-- +newtype Event = Event { useEvent :: {# type CUevent #}} + deriving (Eq, Show) + +-- | +-- Event creation flags +-- +{# enum CUevent_flags as EventFlag + { underscoreToCase } + with prefix="CU_EVENT" deriving (Eq, Show) #} + +-- | +-- Possible option flags for waiting for events +-- +data WaitFlag +instance Enum WaitFlag where + toEnum x = case x of {} + fromEnum x = case x of {} + + +-------------------------------------------------------------------------------- +-- Stream management +-------------------------------------------------------------------------------- + +-- | +-- A processing stream. All operations in a stream are synchronous and executed +-- in sequence, but operations in different non-default streams may happen +-- out-of-order or concurrently with one another. +-- +-- Use 'Event's to synchronise operations between streams. +-- +newtype Stream = Stream { useStream :: {# type CUstream #}} + deriving (Eq, Show) + +-- | +-- Possible option flags for stream initialisation. Dummy instance until the API +-- exports actual option values. +-- +data StreamFlag +instance Enum StreamFlag where + toEnum x = case x of {} + fromEnum x = case x of {} + +-- | +-- The main execution stream. No operations overlap with operations in the +-- default stream. +-- +{-# INLINE defaultStream #-} +defaultStream :: Stream +defaultStream = Stream nullPtr + diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) [2009..2012] Trevor L. McDonell, University of New South Wales. +Copyright (c) [2009..2014] Trevor L. McDonell, University of New South Wales. All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/configure.ac b/configure.ac --- a/configure.ac +++ b/configure.ac @@ -1,4 +1,4 @@ -AC_INIT([Haskell CUDA bindings], [0.6.5.0], [tmcdonell@cse.unsw.edu.au], [cuda]) +AC_INIT([Haskell CUDA bindings], [0.6.6.0], [tmcdonell@cse.unsw.edu.au], [cuda]) AC_CONFIG_SRCDIR([Foreign/CUDA.hs]) AC_CONFIG_FILES([cuda.buildinfo]) AC_PROG_CC @@ -34,7 +34,7 @@ case $target in *mingw* ) - cuda_c2hsflags="--cppopts=-E --cppopts=-arch=sm_20 --cppopts="-D${target_os}_TARGET_OS=1" " + cuda_c2hsflags="--cpp="$NVCC" --cppopts=-E --cppopts=-arch=sm_20 --cppopts="-D${target_os}_TARGET_OS=1" " CPPFLAGS+=" "-D${target_os}_TARGET_OS=1" " ;; * ) @@ -185,4 +185,3 @@ AC_SUBST([cuda_frameworks]) AC_SUBST([cuda_ghci_libs]) AC_OUTPUT - diff --git a/cuda.cabal b/cuda.cabal --- a/cuda.cabal +++ b/cuda.cabal @@ -1,5 +1,5 @@ Name: cuda -Version: 0.6.5.1 +Version: 0.6.6.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 @@ -17,7 +17,9 @@ . [/NOTE:/] . - Due to a bug in nvcc, you must use c2hs-0.17.2. See tmcdonell/cuda#18. + Due to a bug in nvcc, this package is not compatible with c2hs-0.18.* or + c2hs-0.19.*. See tmcdonell/cuda#18. + . License: BSD3 License-file: LICENSE @@ -48,6 +50,7 @@ Library Exposed-Modules: Foreign.CUDA Foreign.CUDA.Ptr + Foreign.CUDA.Types Foreign.CUDA.Analysis Foreign.CUDA.Analysis.Device Foreign.CUDA.Analysis.Occupancy