add compute resources for maxwell architecture

--------------------------------------------------------------------------------
-- |
-- Module    : Foreign.CUDA.Analysis.Device
-- Copyright : (c) [2009..2012] Trevor L. McDonell
-- License   : BSD
--
-- Common device functions
--
--------------------------------------------------------------------------------

module Foreign.CUDA.Analysis.Device
  (
    Compute(..), ComputeMode(..),
    DeviceProperties(..), DeviceResources(..), Allocation(..), PCI(..),
    deviceResources
  )
  where

#include "cbits/stubs.h"

import Data.Int
import Debug.Trace

-- |
-- The compute mode the device is currently in
--
{# enum CUcomputemode as ComputeMode
    { underscoreToCase }
    with prefix="CU_COMPUTEMODE" deriving (Eq, Show) #}

-- |
-- GPU compute capability, major and minor revision number respectively.
--
data Compute = Compute !Int !Int
  deriving Eq

instance Show Compute where
  show (Compute major minor) = show major ++ "." ++ show minor

instance Ord Compute where
  compare (Compute m1 n1) (Compute m2 n2) =
    case compare m1 m2 of
      EQ -> compare n1 n2
      x  -> x

{--
cap :: Int -> Int -> Double
cap a 0 = fromIntegral a
cap a b = let a' = fromIntegral a in
            let b' = fromIntegral b in
            a' + b' / max 10 (10^ ((ceiling . logBase 10) b' :: Int))
--}

-- |
-- The properties of a compute device
--
data DeviceProperties = DeviceProperties
  {
    deviceName                  :: !String,             -- ^ Identifier
    computeCapability           :: !Compute,            -- ^ Supported compute capability
    totalGlobalMem              :: !Int64,              -- ^ Available global memory on the device in bytes
    totalConstMem               :: !Int64,              -- ^ Available constant memory on the device in bytes
    sharedMemPerBlock           :: !Int64,              -- ^ Available shared memory per block in bytes
    regsPerBlock                :: !Int,                -- ^ 32-bit registers per block
    warpSize                    :: !Int,                -- ^ Warp size in threads (SIMD width)
    maxThreadsPerBlock          :: !Int,                -- ^ Max number of threads per block
#if CUDA_VERSION >= 4000
    maxThreadsPerMultiProcessor :: !Int,                -- ^ Max number of threads per multiprocessor
#endif
    maxBlockSize                :: !(Int,Int,Int),      -- ^ Max size of each dimension of a block
    maxGridSize                 :: !(Int,Int,Int),      -- ^ Max size of each dimension of a grid
#if CUDA_VERSION >= 3000
    maxTextureDim1D             :: !Int,                -- ^ Maximum texture dimensions
    maxTextureDim2D             :: !(Int,Int),
    maxTextureDim3D             :: !(Int,Int,Int),
#endif
    clockRate                   :: !Int,                -- ^ Clock frequency in kilohertz
    multiProcessorCount         :: !Int,                -- ^ Number of multiprocessors on the device
    memPitch                    :: !Int64,              -- ^ Max pitch in bytes allowed by memory copies
#if CUDA_VERSION >= 4000
    memBusWidth                 :: !Int,                -- ^ Global memory bus width in bits
    memClockRate                :: !Int,                -- ^ Peak memory clock frequency in kilohertz
#endif
    textureAlignment            :: !Int64,              -- ^ Alignment requirement for textures
    computeMode                 :: !ComputeMode,
    deviceOverlap               :: !Bool,               -- ^ Device can concurrently copy memory and execute a kernel
#if CUDA_VERSION >= 3000
    concurrentKernels           :: !Bool,               -- ^ Device can possibly execute multiple kernels concurrently
    eccEnabled                  :: !Bool,               -- ^ Device supports and has enabled error correction
#endif
#if CUDA_VERSION >= 4000
    asyncEngineCount            :: !Int,                -- ^ Number of asynchronous engines
    cacheMemL2                  :: !Int,                -- ^ Size of the L2 cache in bytes
    tccDriverEnabled            :: !Bool,               -- ^ Whether this is a Tesla device using the TCC driver
    pciInfo                     :: !PCI,                -- ^ PCI device information for the device
#endif
    kernelExecTimeoutEnabled    :: !Bool,               -- ^ Whether there is a runtime limit on kernels
    integrated                  :: !Bool,               -- ^ As opposed to discrete
#if CUDA_VERSION >= 4000
    canMapHostMemory            :: !Bool,               -- ^ Device can use pinned memory
    unifiedAddressing           :: !Bool                -- ^ Device shares a unified address space with the host
#else
    canMapHostMemory            :: !Bool                -- ^ Device can use pinned memory
#endif
  }
  deriving (Show)

data PCI = PCI
  {
    busID       :: !Int,                -- ^ PCI bus ID of the device
    deviceID    :: !Int,                -- ^ PCI device ID
    domainID    :: !Int                 -- ^ PCI domain ID
  }
  deriving (Show)

-- GPU Hardware Resources
--
data Allocation      = Warp | Block
data DeviceResources = DeviceResources
  {
    threadsPerWarp      :: !Int,        -- ^ Warp size
    threadsPerMP        :: !Int,        -- ^ Maximum number of in-flight threads on a multiprocessor
    threadBlocksPerMP   :: !Int,        -- ^ Maximum number of thread blocks resident on a multiprocessor
    warpsPerMP          :: !Int,        -- ^ Maximum number of in-flight warps per multiprocessor
    coresPerMP          :: !Int,        -- ^ Number of SIMD arithmetic units per multiprocessor
    sharedMemPerMP      :: !Int,        -- ^ Total amount of shared memory per multiprocessor (bytes)
    sharedMemAllocUnit  :: !Int,        -- ^ Shared memory allocation unit size (bytes)
    regFileSize         :: !Int,        -- ^ Total number of registers in a multiprocessor
    regAllocUnit        :: !Int,        -- ^ Register allocation unit size
    regAllocWarp        :: !Int,        -- ^ Register allocation granularity for warps
    regPerThread        :: !Int,        -- ^ Maximum number of registers per thread
    allocation          :: !Allocation  -- ^ How multiprocessor resources are divided
  }

-- |
-- Extract some additional hardware resource limitations for a given device.
--
deviceResources :: DeviceProperties -> DeviceResources
deviceResources = resources . computeCapability
  where
    -- This is mostly extracted from tables in the CUDA occupancy calculator.
    --
    resources compute = case compute of
      Compute 1 0 -> DeviceResources 32  768  8 24   8 16384 512  8192 256 2 124 Block  -- Tesla G80
      Compute 1 1 -> DeviceResources 32  768  8 24   8 16384 512  8192 256 2 124 Block  -- Tesla G8x
      Compute 1 2 -> DeviceResources 32 1024  8 32   8 16384 512 16384 512 2 124 Block  -- Tesla G9x
      Compute 1 3 -> DeviceResources 32 1024  8 32   8 16384 512 16384 512 2 124 Block  -- Tesla GT200
      Compute 2 0 -> DeviceResources 32 1536  8 48  32 49152 128 32768  64 2  63 Warp   -- Fermi GF100
      Compute 2 1 -> DeviceResources 32 1536  8 48  48 49152 128 32768  64 2  63 Warp   -- Fermi GF10x
      Compute 3 0 -> DeviceResources 32 2048 16 64 192 49152 256 65536 256 4  63 Warp   -- Kepler GK10x
      Compute 3 5 -> DeviceResources 32 2048 16 64 192 49152 256 65536 256 4 255 Warp   -- Kepler GK11x
      Compute 5 0 -> DeviceResources 32 2048 32 64 128 65536 256 65536 256 4 255 Warp   -- Maxwell GM10x

      -- Something might have gone wrong, or the library just needs to be
      -- updated for the next generation of hardware, in which case we just want
      -- 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" ]

--------------------------------------------------------------------------------
-- |
-- Module    : Foreign.CUDA.Analysis.Device
-- Copyright : (c) [2009..2012] Trevor L. McDonell
-- License   : BSD
--
-- Common device functions
--
--------------------------------------------------------------------------------

module Foreign.CUDA.Analysis.Device
  (
    Compute(..), ComputeMode(..),
    DeviceProperties(..), DeviceResources(..), Allocation(..), PCI(..),
    deviceResources
  )
  where

#include "cbits/stubs.h"

import Data.Int
import Debug.Trace

-- |
-- The compute mode the device is currently in
--
{# enum CUcomputemode as ComputeMode
    { underscoreToCase }
    with prefix="CU_COMPUTEMODE" deriving (Eq, Show) #}

-- |
-- GPU compute capability, major and minor revision number respectively.
--
data Compute = Compute !Int !Int
  deriving Eq

instance Show Compute where
  show (Compute major minor) = show major ++ "." ++ show minor

instance Ord Compute where
  compare (Compute m1 n1) (Compute m2 n2) =
    case compare m1 m2 of
      EQ -> compare n1 n2
      x  -> x

{--
cap :: Int -> Int -> Double
cap a 0 = fromIntegral a
cap a b = let a' = fromIntegral a in
            let b' = fromIntegral b in
            a' + b' / max 10 (10^ ((ceiling . logBase 10) b' :: Int))
--}

-- |
-- The properties of a compute device
--
data DeviceProperties = DeviceProperties
  {
    deviceName                  :: !String,             -- ^ Identifier
    computeCapability           :: !Compute,            -- ^ Supported compute capability
    totalGlobalMem              :: !Int64,              -- ^ Available global memory on the device in bytes
    totalConstMem               :: !Int64,              -- ^ Available constant memory on the device in bytes
    sharedMemPerBlock           :: !Int64,              -- ^ Available shared memory per block in bytes
    regsPerBlock                :: !Int,                -- ^ 32-bit registers per block
    warpSize                    :: !Int,                -- ^ Warp size in threads (SIMD width)
    maxThreadsPerBlock          :: !Int,                -- ^ Max number of threads per block
#if CUDA_VERSION >= 4000
    maxThreadsPerMultiProcessor :: !Int,                -- ^ Max number of threads per multiprocessor
#endif
    maxBlockSize                :: !(Int,Int,Int),      -- ^ Max size of each dimension of a block
    maxGridSize                 :: !(Int,Int,Int),      -- ^ Max size of each dimension of a grid
#if CUDA_VERSION >= 3000
    maxTextureDim1D             :: !Int,                -- ^ Maximum texture dimensions
    maxTextureDim2D             :: !(Int,Int),
    maxTextureDim3D             :: !(Int,Int,Int),
#endif
    clockRate                   :: !Int,                -- ^ Clock frequency in kilohertz
    multiProcessorCount         :: !Int,                -- ^ Number of multiprocessors on the device
    memPitch                    :: !Int64,              -- ^ Max pitch in bytes allowed by memory copies
#if CUDA_VERSION >= 4000
    memBusWidth                 :: !Int,                -- ^ Global memory bus width in bits
    memClockRate                :: !Int,                -- ^ Peak memory clock frequency in kilohertz
#endif
    textureAlignment            :: !Int64,              -- ^ Alignment requirement for textures
    computeMode                 :: !ComputeMode,
    deviceOverlap               :: !Bool,               -- ^ Device can concurrently copy memory and execute a kernel
#if CUDA_VERSION >= 3000
    concurrentKernels           :: !Bool,               -- ^ Device can possibly execute multiple kernels concurrently
    eccEnabled                  :: !Bool,               -- ^ Device supports and has enabled error correction
#endif
#if CUDA_VERSION >= 4000
    asyncEngineCount            :: !Int,                -- ^ Number of asynchronous engines
    cacheMemL2                  :: !Int,                -- ^ Size of the L2 cache in bytes
    tccDriverEnabled            :: !Bool,               -- ^ Whether this is a Tesla device using the TCC driver
    pciInfo                     :: !PCI,                -- ^ PCI device information for the device
#endif
    kernelExecTimeoutEnabled    :: !Bool,               -- ^ Whether there is a runtime limit on kernels
    integrated                  :: !Bool,               -- ^ As opposed to discrete
#if CUDA_VERSION >= 4000
    canMapHostMemory            :: !Bool,               -- ^ Device can use pinned memory
    unifiedAddressing           :: !Bool                -- ^ Device shares a unified address space with the host
#else
    canMapHostMemory            :: !Bool                -- ^ Device can use pinned memory
#endif
  }
  deriving (Show)

data PCI = PCI
  {
    busID       :: !Int,                -- ^ PCI bus ID of the device
    deviceID    :: !Int,                -- ^ PCI device ID
    domainID    :: !Int                 -- ^ PCI domain ID
  }
  deriving (Show)

-- GPU Hardware Resources
--
data Allocation      = Warp | Block
data DeviceResources = DeviceResources
  {
    threadsPerWarp      :: !Int,        -- ^ Warp size
    threadsPerMP        :: !Int,        -- ^ Maximum number of in-flight threads on a multiprocessor
    threadBlocksPerMP   :: !Int,        -- ^ Maximum number of thread blocks resident on a multiprocessor
    warpsPerMP          :: !Int,        -- ^ Maximum number of in-flight warps per multiprocessor
    coresPerMP          :: !Int,        -- ^ Number of SIMD arithmetic units per multiprocessor
    sharedMemPerMP      :: !Int,        -- ^ Total amount of shared memory per multiprocessor (bytes)
    sharedMemAllocUnit  :: !Int,        -- ^ Shared memory allocation unit size (bytes)
    regFileSize         :: !Int,        -- ^ Total number of registers in a multiprocessor
    regAllocUnit        :: !Int,        -- ^ Register allocation unit size
    regAllocWarp        :: !Int,        -- ^ Register allocation granularity for warps
    regPerThread        :: !Int,        -- ^ Maximum number of registers per thread
    allocation          :: !Allocation  -- ^ How multiprocessor resources are divided
  }

-- |
-- Extract some additional hardware resource limitations for a given device.
--
deviceResources :: DeviceProperties -> DeviceResources
deviceResources = resources . computeCapability
  where
    -- This is mostly extracted from tables in the CUDA occupancy calculator.
    --
    resources compute = case compute of
      Compute 1 0 -> DeviceResources 32  768  8 24   8 16384 512  8192 256 2 124 Block  -- Tesla G80
      Compute 1 1 -> DeviceResources 32  768  8 24   8 16384 512  8192 256 2 124 Block  -- Tesla G8x
      Compute 1 2 -> DeviceResources 32 1024  8 32   8 16384 512 16384 512 2 124 Block  -- Tesla G9x
      Compute 1 3 -> DeviceResources 32 1024  8 32   8 16384 512 16384 512 2 124 Block  -- Tesla GT200
      Compute 2 0 -> DeviceResources 32 1536  8 48  32 49152 128 32768  64 2  63 Warp   -- Fermi GF100
      Compute 2 1 -> DeviceResources 32 1536  8 48  48 49152 128 32768  64 2  63 Warp   -- Fermi GF10x
      Compute 3 0 -> DeviceResources 32 2048 16 64 192 49152 256 65536 256 4  63 Warp   -- Kepler GK10x
      Compute 3 5 -> DeviceResources 32 2048 16 64 192 49152 256 65536 256 4 255 Warp   -- Kepler GK11x

      -- 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" ]


make it explicit that the runtime version of memset only supports 8-bit values

Ignore-this: 5594b41b17af4e230368e91118d8ee3b

darcs-hash:20091221104523-dcabc-d149f9b2ed4610863ffc8ee325102872ff1c79bf.gz

{-# LANGUAGE ForeignFunctionInterface #-}
--------------------------------------------------------------------------------
-- |
-- Module    : Foreign.CUDA.Runtime.Marshal
-- Copyright : (c) 2009 Trevor L. McDonell
-- License   : BSD
--
-- Memory management for CUDA devices
--
--------------------------------------------------------------------------------

module Foreign.CUDA.Runtime.Marshal
  (
    -- * Host Allocation
    AllocFlag(..),
    mallocHostArray, freeHost,

    -- * Device Allocation
    mallocArray, allocaArray, free,

    -- * Marshalling
    peekArray, peekArrayAsync, peekListArray,
    pokeArray, pokeArrayAsync, pokeListArray,

    -- * Combined Allocation and Marshalling
    newListArray, withListArray,

    -- * Utility
    memset
  )
  where

#include <cuda_runtime_api.h>
{# context lib="cudart" #}

-- Friends
import Foreign.CUDA.Runtime.Ptr
import Foreign.CUDA.Runtime.Error
import Foreign.CUDA.Runtime.Stream
import Foreign.CUDA.Internal.C2HS

-- System
import Data.Int
import Control.Exception.Extensible

import Foreign.C
import Foreign.Ptr
import Foreign.Storable
import qualified Foreign.Marshal as F

#c
typedef enum cudaMemHostAlloc_option_enum {
//  CUDA_MEMHOSTALLOC_OPTION_DEFAULT        = cudaHostAllocDefault,
    CUDA_MEMHOSTALLOC_OPTION_DEVICE_MAPPED  = cudaHostAllocMapped,
    CUDA_MEMHOSTALLOC_OPTION_PORTABLE       = cudaHostAllocPortable,
    CUDA_MEMHOSTALLOC_OPTION_WRITE_COMBINED = cudaHostAllocWriteCombined
} cudaMemHostAlloc_option;
#endc

--------------------------------------------------------------------------------
-- Host Allocation
--------------------------------------------------------------------------------

-- |
-- Options for host allocation
--
{# enum cudaMemHostAlloc_option as AllocFlag
    { underscoreToCase }
    with prefix="CUDA_MEMHOSTALLOC_OPTION" deriving (Eq, Show) #}

-- |
-- 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.
--
-- Note that since the amount of pageable memory is thusly reduced, overall
-- system performance may suffer. This is best used sparingly to allocate
-- staging areas for data exchange
--
mallocHostArray :: Storable a => [AllocFlag] -> Int -> IO (HostPtr a)
mallocHostArray flags = doMalloc undefined
  where
    doMalloc :: Storable a' => a' -> Int -> IO (HostPtr a')
    doMalloc x n = resultIfOk =<< cudaHostAlloc (fromIntegral n * fromIntegral (sizeOf x)) flags

{# fun unsafe cudaHostAlloc
  { alloca'-        `HostPtr a' hptr*
  , cIntConv        `Int64'
  , combineBitMasks `[AllocFlag]'     } -> `Status' cToEnum #}
  where
    alloca' = F.alloca
    hptr p  = (HostPtr . castPtr) `fmap` peek p

-- |
-- Free page-locked host memory previously allocated with 'mallecHost'
--
freeHost :: HostPtr a -> IO ()
freeHost p = nothingIfOk =<< cudaFreeHost p

{# fun unsafe cudaFreeHost
  { hptr `HostPtr a' } -> `Status' cToEnum #}
  where hptr = castPtr . useHostPtr

--------------------------------------------------------------------------------
-- Device Allocation
--------------------------------------------------------------------------------

-- |
-- Allocate a section of linear memory on the device, and return a reference to
-- it. The memory is sufficient to hold the given number of elements of storable
-- type. It is suitable aligned, and not cleared.
--
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))

{# fun unsafe cudaMalloc
  { alloca'- `DevicePtr a' dptr*
  , cIntConv `Int64'             } -> `Status' cToEnum #}
  where
    -- C-> Haskell doesn't like qualified imports in marshaller specifications
    alloca' = F.alloca
    dptr p  = (castDevPtr . DevicePtr) `fmap` peek p

-- |
-- Execute a computation, passing a pointer to a temporarily allocated block of
-- memory sufficient to hold the given number of elements of storable type. The
-- memory is freed when the computation terminates (normally or via an
-- exception), so the pointer must not be used after this.
--
-- Note that kernel launches can be asynchronous, so you may need to add a
-- synchronisation point at the end of the computation.
--
allocaArray :: Storable a => Int -> (DevicePtr a -> IO b) -> IO b
allocaArray n = bracket (mallocArray n) free

-- |
-- Free previously allocated memory on the device
--
free :: DevicePtr a -> IO ()
free p = nothingIfOk =<< cudaFree p

{# fun unsafe cudaFree
  { dptr `DevicePtr a' } -> `Status' cToEnum #}
  where
    dptr = useDevicePtr . castDevPtr

--------------------------------------------------------------------------------
-- Marshalling
--------------------------------------------------------------------------------

-- |
-- Copy a number of elements from the device to host memory. This is a
-- synchronous operation.
--
peekArray :: Storable a => Int -> DevicePtr a -> Ptr a -> IO ()
peekArray n dptr hptr = memcpy hptr (useDevicePtr dptr) n DeviceToHost

-- |
-- Copy memory from the device asynchronously, possibly associated with a
-- particular stream. The destination memory must be page locked.
--
peekArrayAsync :: Storable a => Int -> DevicePtr a -> HostPtr a -> Maybe Stream -> IO ()
peekArrayAsync n dptr hptr mst =
  memcpyAsync (useHostPtr hptr) (useDevicePtr dptr) n DeviceToHost mst

-- |
-- Copy a number of elements from the device into a new Haskell list. Note that
-- this requires two memory copies: firstly from the device into a heap
-- allocated array, and from there marshalled into a list
--
peekListArray :: Storable a => Int -> DevicePtr a -> IO [a]
peekListArray n dptr =
  F.allocaArray n $ \p -> do
    peekArray   n dptr p
    F.peekArray n p

-- |
-- Copy a number of elements onto the device. This is a synchronous operation.
--
pokeArray :: Storable a => Int -> Ptr a -> DevicePtr a -> IO ()
pokeArray n hptr dptr = memcpy (useDevicePtr dptr) hptr n HostToDevice

-- |
-- Copy memory onto the device asynchronously, possibly associated with a
-- particular stream. The source memory must be page-locked.
--
pokeArrayAsync :: Storable a => Int -> HostPtr a -> DevicePtr a -> Maybe Stream -> IO ()
pokeArrayAsync n hptr dptr mst =
  memcpyAsync (useDevicePtr dptr) (useHostPtr hptr) n HostToDevice mst

-- |
-- Write a list of storable elements into a device array. The array must be
-- sufficiently large to hold the entire list. This requires two marshalling
-- operations
--
pokeListArray :: Storable a => [a] -> DevicePtr a -> IO ()
pokeListArray xs dptr = F.withArrayLen xs $ \len p -> pokeArray len p dptr

--
-- Memory copy kind
--
{# enum cudaMemcpyKind as CopyDirection {}
    with prefix="cudaMemcpy" deriving (Eq, Show) #}

-- |
-- Copy data between host and device. This is a synchronous operation.
--
memcpy :: Storable a
       => Ptr a                 -- ^ destination
       -> Ptr a                 -- ^ source
       -> Int                   -- ^ number of elements
       -> CopyDirection
       -> IO ()
memcpy dst src n dir = doMemcpy undefined dst
  where
    doMemcpy :: Storable a' => a' -> Ptr a' -> IO ()
    doMemcpy x _ =
      nothingIfOk =<< cudaMemcpy dst src (fromIntegral n * fromIntegral (sizeOf x)) dir

{# fun unsafe cudaMemcpy
  { castPtr   `Ptr a'
  , castPtr   `Ptr a'
  , cIntConv  `Int64'
  , cFromEnum `CopyDirection' } -> `Status' cToEnum #}

-- |
-- Copy data between the host and device asynchronously, possibly associated
-- with a particular stream. The host-side memory must be page-locked (allocated
-- with 'mallocHostArray').
--
memcpyAsync :: Storable a
            => Ptr a            -- ^ destination
            -> Ptr a            -- ^ source
            -> Int              -- ^ number of elements
            -> CopyDirection
            -> Maybe Stream
            -> IO ()
memcpyAsync dst src n kind mst = doMemcpy undefined dst
  where
    doMemcpy :: Storable a' => a' -> Ptr a' -> IO ()
    doMemcpy x _ =
      let bytes = fromIntegral n * fromIntegral (sizeOf x) in
      nothingIfOk =<< case mst of
        Nothing -> cudaMemcpyAsync dst src bytes kind (Stream 0)
        Just st -> cudaMemcpyAsync dst src bytes kind st

{# fun unsafe cudaMemcpyAsync
  { castPtr   `Ptr a'
  , castPtr   `Ptr a'
  , cIntConv  `Int64'
  , cFromEnum `CopyDirection'
  , useStream `Stream'        } -> `Status' cToEnum #}

--------------------------------------------------------------------------------
-- Combined Allocation and Marshalling
--------------------------------------------------------------------------------

-- |
-- Write a list of storable elements into a newly allocated device array. Note
-- that this requires two copy operations: firstly from a Haskell list into a
-- heap-allocated array, and from there into device memory. The array should be
-- 'free'd when no longer required.
--
newListArray :: Storable a => [a] -> IO (DevicePtr a)
newListArray xs =
  F.withArrayLen xs                     $ \len p ->
  bracketOnError (mallocArray len) free $ \d_xs -> do
    pokeArray len p d_xs
    return d_xs

-- |
-- Temporarily store a list of elements into a newly allocated device array. An
-- IO action is applied to the array, the result of which is returned. Similar
-- to 'newListArray', this requires two marshalling operations of the data.
--
-- As with 'allocaArray', the memory is freed once the action completes, so you
-- should not return the pointer from the action, and be sure that any
-- asynchronous operations (such as kernel execution) have completed.
--
withListArray :: Storable a => [a] -> (DevicePtr a -> IO b) -> IO b
withListArray xs = bracket (newListArray xs) free

--------------------------------------------------------------------------------
-- Utility
--------------------------------------------------------------------------------

-- |
-- Initialise device memory to a given 8-bit value
--
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

{# fun unsafe cudaMemset
  { dptr     `DevicePtr a'
  , cIntConv `Int8'
  , cIntConv `Int64'       } -> `Status' cToEnum #}
  where
    dptr = useDevicePtr . castDevPtr

{-# LANGUAGE ForeignFunctionInterface #-}
--------------------------------------------------------------------------------
-- |
-- Module    : Foreign.CUDA.Runtime.Marshal
-- Copyright : (c) 2009 Trevor L. McDonell
-- License   : BSD
--
-- Memory management for CUDA devices
--
--------------------------------------------------------------------------------

module Foreign.CUDA.Runtime.Marshal
  (
    -- * Host Allocation
    AllocFlag(..),
    mallocHostArray, freeHost,

    -- * Device Allocation
    mallocArray, allocaArray, free,

    -- * Marshalling
    peekArray, peekArrayAsync, peekListArray,
    pokeArray, pokeArrayAsync, pokeListArray,

    -- * Combined Allocation and Marshalling
    newListArray, withListArray,

    -- * Utility
    memset
  )
  where

#include <cuda_runtime_api.h>
{# context lib="cudart" #}

-- Friends
import Foreign.CUDA.Runtime.Ptr
import Foreign.CUDA.Runtime.Error
import Foreign.CUDA.Runtime.Stream
import Foreign.CUDA.Internal.C2HS

-- System
import Data.Int
import Control.Exception.Extensible

import Foreign.C
import Foreign.Ptr
import Foreign.Storable
import qualified Foreign.Marshal as F

#c
typedef enum cudaMemHostAlloc_option_enum {
//  CUDA_MEMHOSTALLOC_OPTION_DEFAULT        = cudaHostAllocDefault,
    CUDA_MEMHOSTALLOC_OPTION_DEVICE_MAPPED  = cudaHostAllocMapped,
    CUDA_MEMHOSTALLOC_OPTION_PORTABLE       = cudaHostAllocPortable,
    CUDA_MEMHOSTALLOC_OPTION_WRITE_COMBINED = cudaHostAllocWriteCombined
} cudaMemHostAlloc_option;
#endc

--------------------------------------------------------------------------------
-- Host Allocation
--------------------------------------------------------------------------------

-- |
-- Options for host allocation
--
{# enum cudaMemHostAlloc_option as AllocFlag
    { underscoreToCase }
    with prefix="CUDA_MEMHOSTALLOC_OPTION" deriving (Eq, Show) #}

-- |
-- 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.
--
-- Note that since the amount of pageable memory is thusly reduced, overall
-- system performance may suffer. This is best used sparingly to allocate
-- staging areas for data exchange
--
mallocHostArray :: Storable a => [AllocFlag] -> Int -> IO (HostPtr a)
mallocHostArray flags = doMalloc undefined
  where
    doMalloc :: Storable a' => a' -> Int -> IO (HostPtr a')
    doMalloc x n = resultIfOk =<< cudaHostAlloc (fromIntegral n * fromIntegral (sizeOf x)) flags

{# fun unsafe cudaHostAlloc
  { alloca'-        `HostPtr a' hptr*
  , cIntConv        `Int64'
  , combineBitMasks `[AllocFlag]'     } -> `Status' cToEnum #}
  where
    alloca' = F.alloca
    hptr p  = (HostPtr . castPtr) `fmap` peek p

-- |
-- Free page-locked host memory previously allocated with 'mallecHost'
--
freeHost :: HostPtr a -> IO ()
freeHost p = nothingIfOk =<< cudaFreeHost p

{# fun unsafe cudaFreeHost
  { hptr `HostPtr a' } -> `Status' cToEnum #}
  where hptr = castPtr . useHostPtr

--------------------------------------------------------------------------------
-- Device Allocation
--------------------------------------------------------------------------------

-- |
-- Allocate a section of linear memory on the device, and return a reference to
-- it. The memory is sufficient to hold the given number of elements of storable
-- type. It is suitable aligned, and not cleared.
--
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))

{# fun unsafe cudaMalloc
  { alloca'- `DevicePtr a' dptr*
  , cIntConv `Int64'             } -> `Status' cToEnum #}
  where
    -- C-> Haskell doesn't like qualified imports in marshaller specifications
    alloca' = F.alloca
    dptr p  = (castDevPtr . DevicePtr) `fmap` peek p

-- |
-- Execute a computation, passing a pointer to a temporarily allocated block of
-- memory sufficient to hold the given number of elements of storable type. The
-- memory is freed when the computation terminates (normally or via an
-- exception), so the pointer must not be used after this.
--
-- Note that kernel launches can be asynchronous, so you may need to add a
-- synchronisation point at the end of the computation.
--
allocaArray :: Storable a => Int -> (DevicePtr a -> IO b) -> IO b
allocaArray n = bracket (mallocArray n) free

-- |
-- Free previously allocated memory on the device
--
free :: DevicePtr a -> IO ()
free p = nothingIfOk =<< cudaFree p

{# fun unsafe cudaFree
  { dptr `DevicePtr a' } -> `Status' cToEnum #}
  where
    dptr = useDevicePtr . castDevPtr

--------------------------------------------------------------------------------
-- Marshalling
--------------------------------------------------------------------------------

-- |
-- Copy a number of elements from the device to host memory. This is a
-- synchronous operation.
--
peekArray :: Storable a => Int -> DevicePtr a -> Ptr a -> IO ()
peekArray n dptr hptr = memcpy hptr (useDevicePtr dptr) n DeviceToHost

-- |
-- Copy memory from the device asynchronously, possibly associated with a
-- particular stream. The destination memory must be page locked.
--
peekArrayAsync :: Storable a => Int -> DevicePtr a -> HostPtr a -> Maybe Stream -> IO ()
peekArrayAsync n dptr hptr mst =
  memcpyAsync (useHostPtr hptr) (useDevicePtr dptr) n DeviceToHost mst

-- |
-- Copy a number of elements from the device into a new Haskell list. Note that
-- this requires two memory copies: firstly from the device into a heap
-- allocated array, and from there marshalled into a list
--
peekListArray :: Storable a => Int -> DevicePtr a -> IO [a]
peekListArray n dptr =
  F.allocaArray n $ \p -> do
    peekArray   n dptr p
    F.peekArray n p

-- |
-- Copy a number of elements onto the device. This is a synchronous operation.
--
pokeArray :: Storable a => Int -> Ptr a -> DevicePtr a -> IO ()
pokeArray n hptr dptr = memcpy (useDevicePtr dptr) hptr n HostToDevice

-- |
-- Copy memory onto the device asynchronously, possibly associated with a
-- particular stream. The source memory must be page-locked.
--
pokeArrayAsync :: Storable a => Int -> HostPtr a -> DevicePtr a -> Maybe Stream -> IO ()
pokeArrayAsync n hptr dptr mst =
  memcpyAsync (useDevicePtr dptr) (useHostPtr hptr) n HostToDevice mst

-- |
-- Write a list of storable elements into a device array. The array must be
-- sufficiently large to hold the entire list. This requires two marshalling
-- operations
--
pokeListArray :: Storable a => [a] -> DevicePtr a -> IO ()
pokeListArray xs dptr = F.withArrayLen xs $ \len p -> pokeArray len p dptr

--
-- Memory copy kind
--
{# enum cudaMemcpyKind as CopyDirection {}
    with prefix="cudaMemcpy" deriving (Eq, Show) #}

-- |
-- Copy data between host and device. This is a synchronous operation.
--
memcpy :: Storable a
       => Ptr a                 -- ^ destination
       -> Ptr a                 -- ^ source
       -> Int                   -- ^ number of elements
       -> CopyDirection
       -> IO ()
memcpy dst src n dir = doMemcpy undefined dst
  where
    doMemcpy :: Storable a' => a' -> Ptr a' -> IO ()
    doMemcpy x _ =
      nothingIfOk =<< cudaMemcpy dst src (fromIntegral n * fromIntegral (sizeOf x)) dir

{# fun unsafe cudaMemcpy
  { castPtr   `Ptr a'
  , castPtr   `Ptr a'
  , cIntConv  `Int64'
  , cFromEnum `CopyDirection' } -> `Status' cToEnum #}

-- |
-- Copy data between the host and device asynchronously, possibly associated
-- with a particular stream. The host-side memory must be page-locked (allocated
-- with 'mallocHostArray').
--
memcpyAsync :: Storable a
            => Ptr a            -- ^ destination
            -> Ptr a            -- ^ source
            -> Int              -- ^ number of elements
            -> CopyDirection
            -> Maybe Stream
            -> IO ()
memcpyAsync dst src n kind mst = doMemcpy undefined dst
  where
    doMemcpy :: Storable a' => a' -> Ptr a' -> IO ()
    doMemcpy x _ =
      let bytes = fromIntegral n * fromIntegral (sizeOf x) in
      nothingIfOk =<< case mst of
        Nothing -> cudaMemcpyAsync dst src bytes kind (Stream 0)
        Just st -> cudaMemcpyAsync dst src bytes kind st

{# fun unsafe cudaMemcpyAsync
  { castPtr   `Ptr a'
  , castPtr   `Ptr a'
  , cIntConv  `Int64'
  , cFromEnum `CopyDirection'
  , useStream `Stream'        } -> `Status' cToEnum #}

--------------------------------------------------------------------------------
-- Combined Allocation and Marshalling
--------------------------------------------------------------------------------

-- |
-- Write a list of storable elements into a newly allocated device array. Note
-- that this requires two copy operations: firstly from a Haskell list into a
-- heap-allocated array, and from there into device memory. The array should be
-- 'free'd when no longer required.
--
newListArray :: Storable a => [a] -> IO (DevicePtr a)
newListArray xs =
  F.withArrayLen xs                     $ \len p ->
  bracketOnError (mallocArray len) free $ \d_xs -> do
    pokeArray len p d_xs
    return d_xs

-- |
-- Temporarily store a list of elements into a newly allocated device array. An
-- IO action is applied to the array, the result of which is returned. Similar
-- to 'newListArray', this requires two marshalling operations of the data.
--
-- As with 'allocaArray', the memory is freed once the action completes, so you
-- should not return the pointer from the action, and be sure that any
-- asynchronous operations (such as kernel execution) have completed.
--
withListArray :: Storable a => [a] -> (DevicePtr a -> IO b) -> IO b
withListArray xs = bracket (newListArray xs) free

--------------------------------------------------------------------------------
-- Utility
--------------------------------------------------------------------------------

-- |
-- Initialise device memory to a given 8-bit value
--
memset :: DevicePtr a                   -- ^ The device memory
       -> Int64                         -- ^ Number of bytes
       -> Int                           -- ^ Value to set for each byte
       -> IO ()
memset dptr bytes symbol = nothingIfOk =<< cudaMemset dptr symbol bytes

{# fun unsafe cudaMemset
  { dptr     `DevicePtr a'
  ,          `Int'
  , cIntConv `Int64'       } -> `Status' cToEnum #}
  where
    dptr = useDevicePtr . castDevPtr