Define strnlen function on Windows

Define strnlen function on Windows

The MinGW distribution bundled with GHC does not provide the strnlen function.

{-# LANGUAGE BangPatterns             #-}
{-# LANGUAGE ForeignFunctionInterface #-}
--------------------------------------------------------------------------------
-- |
-- Module    : Foreign.CUDA.Driver.Module
-- Copyright : [2009..2014] Trevor L. McDonell
-- License   : BSD
--
-- Module management for low-level driver interface
--
--------------------------------------------------------------------------------

module Foreign.CUDA.Driver.Module (

  -- * Module Management
  Module, JITOption(..), JITTarget(..), JITResult(..), JITFallback(..),

  -- ** Querying module inhabitants
  getFun, getPtr, getTex,

  -- ** Loading and unloading modules
  loadFile,
  loadData,   loadDataFromPtr,
  loadDataEx, loadDataFromPtrEx,
  unload

) where

#include "cbits/stubs.h"
{# context lib="cuda" #}

-- Friends
import Foreign.CUDA.Analysis.Device
import Foreign.CUDA.Ptr
import Foreign.CUDA.Driver.Error
import Foreign.CUDA.Driver.Exec
import Foreign.CUDA.Driver.Marshal                      ( peekDeviceHandle )
import Foreign.CUDA.Driver.Texture
import Foreign.CUDA.Internal.C2HS

-- System
import Foreign
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

#if CUDA_VERSION < 5050
import Debug.Trace                                      ( trace )
#endif

--------------------------------------------------------------------------------
-- Data Types
--------------------------------------------------------------------------------

-- |
-- A reference to a Module object, containing collections of device functions
--
newtype Module = Module { useModule :: {# type CUmodule #}}
  deriving (Eq, Show)

-- |
-- Just-in-time compilation options
--
data JITOption
  = MaxRegisters       !Int             -- ^ maximum number of registers per thread
  | ThreadsPerBlock    !Int             -- ^ number of threads per block to target for
  | OptimisationLevel  !Int             -- ^ level of optimisation to apply (1-4, default 4)
  | Target             !Compute         -- ^ compilation target, otherwise determined from context
  | FallbackStrategy   !JITFallback     -- ^ fallback strategy if matching cubin not found
  | GenerateDebugInfo                   -- ^ generate debug info (-g) (requires cuda >= 5.5)
  | GenerateLineInfo                    -- ^ generate line number information (-lineinfo) (requires cuda >= 5.5)
  | Verbose                             -- ^ verbose log messages (requires cuda >= 5.5)
  deriving (Show)

-- |
-- Results of online compilation
--
data JITResult = JITResult
  {
    jitTime     :: !Float,              -- ^ milliseconds spent compiling PTX
    jitInfoLog  :: !ByteString,         -- ^ information about PTX assembly
    jitModule   :: !Module              -- ^ compilation error log or compiled module
  }
  deriving (Show)

{# enum CUjit_option as JITOptionInternal
    { }
    with prefix="CU" deriving (Eq, Show) #}

{# enum CUjit_target as JITTarget
    { underscoreToCase }
    with prefix="CU_TARGET" deriving (Eq, Show) #}

{# enum CUjit_fallback as JITFallback
    { underscoreToCase
    , CU_PREFER_PTX as PTX }
    with prefix="CU_PREFER" deriving (Eq, Show) #}

--------------------------------------------------------------------------------
-- Module management
--------------------------------------------------------------------------------

-- |
-- Returns a function handle
--
{-# INLINEABLE getFun #-}
getFun :: Module -> String -> IO Fun
getFun !mdl !fn = resultIfFound "function" fn =<< cuModuleGetFunction mdl fn

{-# INLINE cuModuleGetFunction #-}
{# fun unsafe cuModuleGetFunction
  { alloca-      `Fun'    peekFun*
  , useModule    `Module'
  , withCString* `String'          } -> `Status' cToEnum #}
  where peekFun = liftM Fun . peek

-- |
-- 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
  resultIfFound "global" name (status,(dptr,bytes))

{-# INLINE cuModuleGetGlobal #-}
{# fun unsafe cuModuleGetGlobal
  { alloca-      `DevicePtr a' peekDeviceHandle*
  , alloca-      `Int'         peekIntConv*
  , useModule    `Module'
  , withCString* `String'                        } -> `Status' cToEnum #}

-- |
-- Return a handle to a texture reference
--
{-# INLINEABLE getTex #-}
getTex :: Module -> String -> IO Texture
getTex !mdl !name = resultIfFound "texture" name =<< cuModuleGetTexRef mdl name

{-# INLINE cuModuleGetTexRef #-}
{# fun unsafe cuModuleGetTexRef
  { alloca-      `Texture' peekTex*
  , useModule    `Module'
  , withCString* `String'           } -> `Status' cToEnum #}

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

{-# INLINE cuModuleLoad #-}
{# fun unsafe cuModuleLoad
  { alloca-      `Module'   peekMod*
  , withCString* `FilePath'          } -> `Status' cToEnum #}

-- |
-- Load the contents of the given image into a new module, and load that module
-- into the current context. The image is (typically) the contents of a cubin or
-- PTX file.
--
-- Note that the 'ByteString' will be copied into a temporary staging area so
-- that it can be passed to C.
--
{-# INLINEABLE loadData #-}
loadData :: ByteString -> IO Module
loadData !img =
  B.useAsCString img (\p -> loadDataFromPtr (castPtr p))

-- |
-- As 'loadData', but read the image data from the given pointer. The image is a
-- NULL-terminated sequence of bytes.
--
{-# INLINEABLE loadDataFromPtr #-}
loadDataFromPtr :: Ptr Word8 -> IO Module
loadDataFromPtr !img = resultIfOk =<< cuModuleLoadData img

{-# INLINE cuModuleLoadData #-}
{# fun unsafe cuModuleLoadData
  { alloca- `Module'    peekMod*
  , castPtr `Ptr Word8'          } -> ` Status' cToEnum #}

-- |
-- Load the contents of the given image into a module with online compiler
-- options, and load the module into the current context. The image is
-- (typically) the contents of a cubin or PTX file. The actual attributes of the
-- compiled kernel can be probed using 'requires'.
--
-- Note that the 'ByteString' will be copied into a temporary staging area so
-- that it can be passed to C.
--
{-# INLINEABLE loadDataEx #-}
loadDataEx :: ByteString -> [JITOption] -> IO JITResult
loadDataEx !img !options =
  B.useAsCString img (\p -> loadDataFromPtrEx (castPtr p) options)

-- |
-- As 'loadDataEx', but read the image data from the given pointer. The image is
-- a NULL-terminated sequence of bytes.
--
{-# INLINEABLE loadDataFromPtrEx #-}
loadDataFromPtrEx :: Ptr Word8 -> [JITOption] -> IO JITResult
loadDataFromPtrEx !img !options = do
  fp_ilog <- B.mallocByteString logSize

  allocaArray logSize    $ \p_elog -> do
  withForeignPtr fp_ilog $ \p_ilog -> do

  let (opt,val) = unzip $
        [ (JIT_WALL_TIME, 0) -- must be first, this is extracted below
        , (JIT_INFO_LOG_BUFFER_SIZE_BYTES,  logSize)
        , (JIT_ERROR_LOG_BUFFER_SIZE_BYTES, logSize)
        , (JIT_INFO_LOG_BUFFER,  unsafeCoerce (p_ilog :: CString))
        , (JIT_ERROR_LOG_BUFFER, unsafeCoerce (p_elog :: CString)) ] ++ mapMaybe unpack options

  withArray (map cFromEnum opt)    $ \p_opts -> do
  withArray (map unsafeCoerce val) $ \p_vals -> do

  (s,mdl) <- cuModuleLoadDataEx img (length opt) p_opts p_vals

  case s of
    Success     -> do
      time    <- peek (castPtr p_vals)
      infoLog <- B.fromForeignPtr (castForeignPtr fp_ilog) 0 `fmap` c_strnlen p_ilog logSize
      return  $! JITResult time infoLog mdl

    _           -> do
      errLog  <- peekCString p_elog
      cudaError (unlines [describe s, errLog])

  where
    logSize = 2048

    unpack (MaxRegisters x)      = Just (JIT_MAX_REGISTERS,       x)
    unpack (ThreadsPerBlock x)   = Just (JIT_THREADS_PER_BLOCK,   x)
    unpack (OptimisationLevel x) = Just (JIT_OPTIMIZATION_LEVEL,  x)
    unpack (Target x)            = Just (JIT_TARGET,              jitTargetOfCompute x)
    unpack (FallbackStrategy x)  = Just (JIT_FALLBACK_STRATEGY,   fromEnum x)
#if CUDA_VERSION >= 5050
    unpack GenerateDebugInfo     = Just (JIT_GENERATE_DEBUG_INFO, fromEnum True)
    unpack GenerateLineInfo      = Just (JIT_GENERATE_LINE_INFO,  fromEnum True)
    unpack Verbose               = Just (JIT_LOG_VERBOSE,         fromEnum True)
#else
    unpack x                     = trace ("Warning: JITOption '" ++ show x ++ "' requires at least cuda-5.5") Nothing
#endif

    jitTargetOfCompute (Compute x y)
      = fromEnum
      $ case (x,y) of
          (1,0) -> Compute10
          (1,1) -> Compute11
          (1,2) -> Compute12
          (1,3) -> Compute13
          (2,0) -> Compute20
          (2,1) -> Compute21
          (3,0) -> Compute30
          (3,5) -> Compute35
          _     -> error ("Unknown JIT Target for Compute " ++ show (Compute x y))

{-# INLINE cuModuleLoadDataEx #-}
{# fun unsafe cuModuleLoadDataEx
  { alloca- `Module'       peekMod*
  , castPtr `Ptr Word8'
  ,         `Int'
  , id      `Ptr CInt'
  , id      `Ptr (Ptr ())'          } -> `Status' cToEnum #}

-- |
-- Unload a module from the current context
--
{-# INLINEABLE unload #-}
unload :: Module -> IO ()
unload !m = nothingIfOk =<< cuModuleUnload m

{-# INLINE cuModuleUnload #-}
{# fun unsafe cuModuleUnload
  { useModule `Module' } -> `Status' cToEnum #}

--------------------------------------------------------------------------------
-- Internal
--------------------------------------------------------------------------------

{-# INLINE resultIfFound #-}
resultIfFound :: String -> String -> (Status, a) -> IO a
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 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
c_strnlen str maxlen = cIntConv `fmap` c_strnlen' str (cIntConv maxlen)

{-# LANGUAGE BangPatterns             #-}
{-# LANGUAGE ForeignFunctionInterface #-}
--------------------------------------------------------------------------------
-- |
-- Module    : Foreign.CUDA.Driver.Module
-- Copyright : [2009..2014] Trevor L. McDonell
-- License   : BSD
--
-- Module management for low-level driver interface
--
--------------------------------------------------------------------------------

module Foreign.CUDA.Driver.Module (

  -- * Module Management
  Module, JITOption(..), JITTarget(..), JITResult(..), JITFallback(..),

  -- ** Querying module inhabitants
  getFun, getPtr, getTex,

  -- ** Loading and unloading modules
  loadFile,
  loadData,   loadDataFromPtr,
  loadDataEx, loadDataFromPtrEx,
  unload

) where

#include "cbits/stubs.h"
{# context lib="cuda" #}

-- Friends
import Foreign.CUDA.Analysis.Device
import Foreign.CUDA.Ptr
import Foreign.CUDA.Driver.Error
import Foreign.CUDA.Driver.Exec
import Foreign.CUDA.Driver.Marshal                      ( peekDeviceHandle )
import Foreign.CUDA.Driver.Texture
import Foreign.CUDA.Internal.C2HS

-- System
import Foreign
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

#if CUDA_VERSION < 5050
import Debug.Trace                                      ( trace )
#endif

--------------------------------------------------------------------------------
-- Data Types
--------------------------------------------------------------------------------

-- |
-- A reference to a Module object, containing collections of device functions
--
newtype Module = Module { useModule :: {# type CUmodule #}}
  deriving (Eq, Show)

-- |
-- Just-in-time compilation options
--
data JITOption
  = MaxRegisters       !Int             -- ^ maximum number of registers per thread
  | ThreadsPerBlock    !Int             -- ^ number of threads per block to target for
  | OptimisationLevel  !Int             -- ^ level of optimisation to apply (1-4, default 4)
  | Target             !Compute         -- ^ compilation target, otherwise determined from context
  | FallbackStrategy   !JITFallback     -- ^ fallback strategy if matching cubin not found
  | GenerateDebugInfo                   -- ^ generate debug info (-g) (requires cuda >= 5.5)
  | GenerateLineInfo                    -- ^ generate line number information (-lineinfo) (requires cuda >= 5.5)
  | Verbose                             -- ^ verbose log messages (requires cuda >= 5.5)
  deriving (Show)

-- |
-- Results of online compilation
--
data JITResult = JITResult
  {
    jitTime     :: !Float,              -- ^ milliseconds spent compiling PTX
    jitInfoLog  :: !ByteString,         -- ^ information about PTX assembly
    jitModule   :: !Module              -- ^ compilation error log or compiled module
  }
  deriving (Show)

{# enum CUjit_option as JITOptionInternal
    { }
    with prefix="CU" deriving (Eq, Show) #}

{# enum CUjit_target as JITTarget
    { underscoreToCase }
    with prefix="CU_TARGET" deriving (Eq, Show) #}

{# enum CUjit_fallback as JITFallback
    { underscoreToCase
    , CU_PREFER_PTX as PTX }
    with prefix="CU_PREFER" deriving (Eq, Show) #}

--------------------------------------------------------------------------------
-- Module management
--------------------------------------------------------------------------------

-- |
-- Returns a function handle
--
{-# INLINEABLE getFun #-}
getFun :: Module -> String -> IO Fun
getFun !mdl !fn = resultIfFound "function" fn =<< cuModuleGetFunction mdl fn

{-# INLINE cuModuleGetFunction #-}
{# fun unsafe cuModuleGetFunction
  { alloca-      `Fun'    peekFun*
  , useModule    `Module'
  , withCString* `String'          } -> `Status' cToEnum #}
  where peekFun = liftM Fun . peek

-- |
-- 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
  resultIfFound "global" name (status,(dptr,bytes))

{-# INLINE cuModuleGetGlobal #-}
{# fun unsafe cuModuleGetGlobal
  { alloca-      `DevicePtr a' peekDeviceHandle*
  , alloca-      `Int'         peekIntConv*
  , useModule    `Module'
  , withCString* `String'                        } -> `Status' cToEnum #}

-- |
-- Return a handle to a texture reference
--
{-# INLINEABLE getTex #-}
getTex :: Module -> String -> IO Texture
getTex !mdl !name = resultIfFound "texture" name =<< cuModuleGetTexRef mdl name

{-# INLINE cuModuleGetTexRef #-}
{# fun unsafe cuModuleGetTexRef
  { alloca-      `Texture' peekTex*
  , useModule    `Module'
  , withCString* `String'           } -> `Status' cToEnum #}

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

{-# INLINE cuModuleLoad #-}
{# fun unsafe cuModuleLoad
  { alloca-      `Module'   peekMod*
  , withCString* `FilePath'          } -> `Status' cToEnum #}

-- |
-- Load the contents of the given image into a new module, and load that module
-- into the current context. The image is (typically) the contents of a cubin or
-- PTX file.
--
-- Note that the 'ByteString' will be copied into a temporary staging area so
-- that it can be passed to C.
--
{-# INLINEABLE loadData #-}
loadData :: ByteString -> IO Module
loadData !img =
  B.useAsCString img (\p -> loadDataFromPtr (castPtr p))

-- |
-- As 'loadData', but read the image data from the given pointer. The image is a
-- NULL-terminated sequence of bytes.
--
{-# INLINEABLE loadDataFromPtr #-}
loadDataFromPtr :: Ptr Word8 -> IO Module
loadDataFromPtr !img = resultIfOk =<< cuModuleLoadData img

{-# INLINE cuModuleLoadData #-}
{# fun unsafe cuModuleLoadData
  { alloca- `Module'    peekMod*
  , castPtr `Ptr Word8'          } -> ` Status' cToEnum #}

-- |
-- Load the contents of the given image into a module with online compiler
-- options, and load the module into the current context. The image is
-- (typically) the contents of a cubin or PTX file. The actual attributes of the
-- compiled kernel can be probed using 'requires'.
--
-- Note that the 'ByteString' will be copied into a temporary staging area so
-- that it can be passed to C.
--
{-# INLINEABLE loadDataEx #-}
loadDataEx :: ByteString -> [JITOption] -> IO JITResult
loadDataEx !img !options =
  B.useAsCString img (\p -> loadDataFromPtrEx (castPtr p) options)

-- |
-- As 'loadDataEx', but read the image data from the given pointer. The image is
-- a NULL-terminated sequence of bytes.
--
{-# INLINEABLE loadDataFromPtrEx #-}
loadDataFromPtrEx :: Ptr Word8 -> [JITOption] -> IO JITResult
loadDataFromPtrEx !img !options = do
  fp_ilog <- B.mallocByteString logSize

  allocaArray logSize    $ \p_elog -> do
  withForeignPtr fp_ilog $ \p_ilog -> do

  let (opt,val) = unzip $
        [ (JIT_WALL_TIME, 0) -- must be first, this is extracted below
        , (JIT_INFO_LOG_BUFFER_SIZE_BYTES,  logSize)
        , (JIT_ERROR_LOG_BUFFER_SIZE_BYTES, logSize)
        , (JIT_INFO_LOG_BUFFER,  unsafeCoerce (p_ilog :: CString))
        , (JIT_ERROR_LOG_BUFFER, unsafeCoerce (p_elog :: CString)) ] ++ mapMaybe unpack options

  withArray (map cFromEnum opt)    $ \p_opts -> do
  withArray (map unsafeCoerce val) $ \p_vals -> do

  (s,mdl) <- cuModuleLoadDataEx img (length opt) p_opts p_vals

  case s of
    Success     -> do
      time    <- peek (castPtr p_vals)
      infoLog <- B.fromForeignPtr (castForeignPtr fp_ilog) 0 `fmap` c_strnlen p_ilog logSize
      return  $! JITResult time infoLog mdl

    _           -> do
      errLog  <- peekCString p_elog
      cudaError (unlines [describe s, errLog])

  where
    logSize = 2048

    unpack (MaxRegisters x)      = Just (JIT_MAX_REGISTERS,       x)
    unpack (ThreadsPerBlock x)   = Just (JIT_THREADS_PER_BLOCK,   x)
    unpack (OptimisationLevel x) = Just (JIT_OPTIMIZATION_LEVEL,  x)
    unpack (Target x)            = Just (JIT_TARGET,              jitTargetOfCompute x)
    unpack (FallbackStrategy x)  = Just (JIT_FALLBACK_STRATEGY,   fromEnum x)
#if CUDA_VERSION >= 5050
    unpack GenerateDebugInfo     = Just (JIT_GENERATE_DEBUG_INFO, fromEnum True)
    unpack GenerateLineInfo      = Just (JIT_GENERATE_LINE_INFO,  fromEnum True)
    unpack Verbose               = Just (JIT_LOG_VERBOSE,         fromEnum True)
#else
    unpack x                     = trace ("Warning: JITOption '" ++ show x ++ "' requires at least cuda-5.5") Nothing
#endif

    jitTargetOfCompute (Compute x y)
      = fromEnum
      $ case (x,y) of
          (1,0) -> Compute10
          (1,1) -> Compute11
          (1,2) -> Compute12
          (1,3) -> Compute13
          (2,0) -> Compute20
          (2,1) -> Compute21
          (3,0) -> Compute30
          (3,5) -> Compute35
          _     -> error ("Unknown JIT Target for Compute " ++ show (Compute x y))

{-# INLINE cuModuleLoadDataEx #-}
{# fun unsafe cuModuleLoadDataEx
  { alloca- `Module'       peekMod*
  , castPtr `Ptr Word8'
  ,         `Int'
  , id      `Ptr CInt'
  , id      `Ptr (Ptr ())'          } -> `Status' cToEnum #}

-- |
-- Unload a module from the current context
--
{-# INLINEABLE unload #-}
unload :: Module -> IO ()
unload !m = nothingIfOk =<< cuModuleUnload m

{-# INLINE cuModuleUnload #-}
{# fun unsafe cuModuleUnload
  { useModule `Module' } -> `Status' cToEnum #}

--------------------------------------------------------------------------------
-- Internal
--------------------------------------------------------------------------------

{-# INLINE resultIfFound #-}
resultIfFound :: String -> String -> (Status, a) -> IO a
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 c_strnlen' #-}
foreign import ccall unsafe "string.h strnlen" c_strnlen'
  :: CString -> CSize -> IO CSize

{-# INLINE c_strnlen #-}
c_strnlen :: CString -> Int -> IO Int
c_strnlen str maxlen = cIntConv `fmap` c_strnlen' str (cIntConv maxlen)


don't change the external JITOption interface for cuda-5.0

You'll get a runtime warning if you use an option that isn't supported in 5.0. Maybe that should be lifted to an error, but that is a bit annoying for clients to have to deal with.

{-# LANGUAGE BangPatterns             #-}
{-# LANGUAGE ForeignFunctionInterface #-}
--------------------------------------------------------------------------------
-- |
-- Module    : Foreign.CUDA.Driver.Module
-- Copyright : (c) [2009..2012] Trevor L. McDonell
-- License   : BSD
--
-- Module management for low-level driver interface
--
--------------------------------------------------------------------------------

module Foreign.CUDA.Driver.Module (

  -- * Module Management
  Module, JITOption(..), JITTarget(..), JITResult(..),

  -- ** Querying module inhabitants
  getFun, getPtr, getTex,

  -- ** Loading and unloading modules
  loadFile,
  loadData,   loadDataFromPtr,
  loadDataEx, loadDataFromPtrEx,
  unload

) where

#include "cbits/stubs.h"
{# context lib="cuda" #}

-- Friends
import Foreign.CUDA.Analysis.Device
import Foreign.CUDA.Ptr
import Foreign.CUDA.Driver.Error
import Foreign.CUDA.Driver.Exec
import Foreign.CUDA.Driver.Marshal              (peekDeviceHandle)
import Foreign.CUDA.Driver.Texture
import Foreign.CUDA.Internal.C2HS

-- System
import Foreign
import Foreign.C
import Unsafe.Coerce

import Control.Monad                            (liftM)
import Control.Exception                        (throwIO)
import Debug.Trace                              (trace)
import Data.Maybe                               (mapMaybe)
import Data.ByteString.Char8                    (ByteString)
import qualified Data.ByteString.Char8          as B
import qualified Data.ByteString.Internal       as B

--------------------------------------------------------------------------------
-- Data Types
--------------------------------------------------------------------------------

-- |
-- A reference to a Module object, containing collections of device functions
--
newtype Module = Module { useModule :: {# type CUmodule #}}
  deriving (Eq, Show)

-- |
-- Just-in-time compilation options
--
data JITOption
  = MaxRegisters       !Int             -- ^ maximum number of registers per thread
  | ThreadsPerBlock    !Int             -- ^ number of threads per block to target for
  | OptimisationLevel  !Int             -- ^ level of optimisation to apply (1-4, default 4)
  | Target             !Compute         -- ^ compilation target, otherwise determined from context
  | FallbackStrategy   !JITFallback     -- ^ fallback strategy if matching cubin not found
  | GenerateDebugInfo                   -- ^ generate debug info (-g) (requires cuda >= 5.5)
  | GenerateLineInfo                    -- ^ generate line number information (-lineinfo) (requires cuda >= 5.5)
  | Verbose                             -- ^ verbose log messages (requires cuda >= 5.5)
  deriving (Show)

-- |
-- Results of online compilation
--
data JITResult = JITResult
  {
    jitTime     :: !Float,              -- ^ milliseconds spent compiling PTX
    jitInfoLog  :: !ByteString,         -- ^ information about PTX assembly
    jitModule   :: !Module              -- ^ compilation error log or compiled module
  }
  deriving (Show)

{# enum CUjit_option as JITOptionInternal
    { }
    with prefix="CU" deriving (Eq, Show) #}

{# enum CUjit_target as JITTarget
    { underscoreToCase }
    with prefix="CU_TARGET" deriving (Eq, Show) #}

{# enum CUjit_fallback as JITFallback
    { underscoreToCase }
    with prefix="CU_PREFER" deriving (Eq, Show) #}

--------------------------------------------------------------------------------
-- Module management
--------------------------------------------------------------------------------

-- |
-- Returns a function handle
--
{-# INLINEABLE getFun #-}
getFun :: Module -> String -> IO Fun
getFun !mdl !fn = resultIfFound "function" fn =<< cuModuleGetFunction mdl fn

{-# INLINE cuModuleGetFunction #-}
{# fun unsafe cuModuleGetFunction
  { alloca-      `Fun'    peekFun*
  , useModule    `Module'
  , withCString* `String'          } -> `Status' cToEnum #}
  where peekFun = liftM Fun . peek

-- |
-- 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
  resultIfFound "global" name (status,(dptr,bytes))

{-# INLINE cuModuleGetGlobal #-}
{# fun unsafe cuModuleGetGlobal
  { alloca-      `DevicePtr a' peekDeviceHandle*
  , alloca-      `Int'         peekIntConv*
  , useModule    `Module'
  , withCString* `String'                        } -> `Status' cToEnum #}

-- |
-- Return a handle to a texture reference
--
{-# INLINEABLE getTex #-}
getTex :: Module -> String -> IO Texture
getTex !mdl !name = resultIfFound "texture" name =<< cuModuleGetTexRef mdl name

{-# INLINE cuModuleGetTexRef #-}
{# fun unsafe cuModuleGetTexRef
  { alloca-      `Texture' peekTex*
  , useModule    `Module'
  , withCString* `String'           } -> `Status' cToEnum #}

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

{-# INLINE cuModuleLoad #-}
{# fun unsafe cuModuleLoad
  { alloca-      `Module'   peekMod*
  , withCString* `FilePath'          } -> `Status' cToEnum #}

-- |
-- Load the contents of the given image into a new module, and load that module
-- into the current context. The image is (typically) the contents of a cubin or
-- PTX file.
--
-- Note that the 'ByteString' will be copied into a temporary staging area so
-- that it can be passed to C.
--
{-# INLINEABLE loadData #-}
loadData :: ByteString -> IO Module
loadData !img =
  B.useAsCString img (\p -> loadDataFromPtr (castPtr p))

-- |
-- As 'loadData', but read the image data from the given pointer. The image is a
-- NULL-terminated sequence of bytes.
--
{-# INLINEABLE loadDataFromPtr #-}
loadDataFromPtr :: Ptr Word8 -> IO Module
loadDataFromPtr !img = resultIfOk =<< cuModuleLoadData img

{-# INLINE cuModuleLoadData #-}
{# fun unsafe cuModuleLoadData
  { alloca- `Module'    peekMod*
  , castPtr `Ptr Word8'          } -> ` Status' cToEnum #}

-- |
-- Load the contents of the given image into a module with online compiler
-- options, and load the module into the current context. The image is
-- (typically) the contents of a cubin or PTX file. The actual attributes of the
-- compiled kernel can be probed using 'requires'.
--
-- Note that the 'ByteString' will be copied into a temporary staging area so
-- that it can be passed to C.
--
{-# INLINEABLE loadDataEx #-}
loadDataEx :: ByteString -> [JITOption] -> IO JITResult
loadDataEx !img !options =
  B.useAsCString img (\p -> loadDataFromPtrEx (castPtr p) options)

-- |
-- As 'loadDataEx', but read the image data from the given pointer. The image is
-- a NULL-terminated sequence of bytes.
--
{-# INLINEABLE loadDataFromPtrEx #-}
loadDataFromPtrEx :: Ptr Word8 -> [JITOption] -> IO JITResult
loadDataFromPtrEx !img !options = do
  fp_ilog <- B.mallocByteString logSize

  allocaArray logSize    $ \p_elog -> do
  withForeignPtr fp_ilog $ \p_ilog -> do

  let (opt,val) = unzip $
        [ (JIT_WALL_TIME, 0) -- must be first, this is extracted below
        , (JIT_INFO_LOG_BUFFER_SIZE_BYTES,  logSize)
        , (JIT_ERROR_LOG_BUFFER_SIZE_BYTES, logSize)
        , (JIT_INFO_LOG_BUFFER,  unsafeCoerce (p_ilog :: CString))
        , (JIT_ERROR_LOG_BUFFER, unsafeCoerce (p_elog :: CString)) ] ++ mapMaybe unpack options

  withArray (map cFromEnum opt)    $ \p_opts -> do
  withArray (map unsafeCoerce val) $ \p_vals -> do

  (s,mdl) <- cuModuleLoadDataEx img (length opt) p_opts p_vals

  case s of
    Success     -> do
      time    <- peek (castPtr p_vals)
      infoLog <- B.fromForeignPtr (castForeignPtr fp_ilog) 0 `fmap` c_strnlen p_ilog logSize
      return  $! JITResult time infoLog mdl

    _           -> do
      errLog  <- peekCString p_elog
      cudaError (unlines [describe s, errLog])

  where
    logSize = 2048

    unpack (MaxRegisters x)      = Just (JIT_MAX_REGISTERS,       x)
    unpack (ThreadsPerBlock x)   = Just (JIT_THREADS_PER_BLOCK,   x)
    unpack (OptimisationLevel x) = Just (JIT_OPTIMIZATION_LEVEL,  x)
    unpack (Target x)            = Just (JIT_TARGET,              jitTargetOfCompute x)
    unpack (FallbackStrategy x)  = Just (JIT_FALLBACK_STRATEGY,   fromEnum x)
#if CUDA_VERSION >= 5050
    unpack GenerateDebugInfo     = Just (JIT_GENERATE_DEBUG_INFO, fromEnum True)
    unpack GenerateLineInfo      = Just (JIT_GENERATE_LINE_INFO,  fromEnum True)
    unpack Verbose               = Just (JIT_LOG_VERBOSE,         fromEnum True)
#else
    unpack x                     = trace ("Warning: JITOption '" ++ show x ++ "' requires at least cuda-5.5") Nothing
#endif

    jitTargetOfCompute (Compute x y)
      = fromEnum
      $ case (x,y) of
          (1,0) -> Compute10
          (1,1) -> Compute11
          (1,2) -> Compute12
          (1,3) -> Compute13
          (2,0) -> Compute20
          (2,1) -> Compute21
          (3,0) -> Compute30
          (3,5) -> Compute35
          _     -> error ("Unknown JIT Target for Compute " ++ show (Compute x y))

{-# INLINE cuModuleLoadDataEx #-}
{# fun unsafe cuModuleLoadDataEx
  { alloca- `Module'       peekMod*
  , castPtr `Ptr Word8'
  ,         `Int'
  , id      `Ptr CInt'
  , id      `Ptr (Ptr ())'          } -> `Status' cToEnum #}

-- |
-- Unload a module from the current context
--
{-# INLINEABLE unload #-}
unload :: Module -> IO ()
unload !m = nothingIfOk =<< cuModuleUnload m

{-# INLINE cuModuleUnload #-}
{# fun unsafe cuModuleUnload
  { useModule `Module' } -> `Status' cToEnum #}

--------------------------------------------------------------------------------
-- Internal
--------------------------------------------------------------------------------

{-# INLINE resultIfFound #-}
resultIfFound :: String -> String -> (Status, a) -> IO a
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 c_strnlen' #-}
foreign import ccall unsafe "string.h strnlen" c_strnlen'
  :: CString -> CSize -> IO CSize

{-# INLINE c_strnlen #-}
c_strnlen :: CString -> Int -> IO Int
c_strnlen str maxlen = cIntConv `fmap` c_strnlen' str (cIntConv maxlen)

{-# LANGUAGE BangPatterns             #-}
{-# LANGUAGE ForeignFunctionInterface #-}
--------------------------------------------------------------------------------
-- |
-- Module    : Foreign.CUDA.Driver.Module
-- Copyright : (c) [2009..2012] Trevor L. McDonell
-- License   : BSD
--
-- Module management for low-level driver interface
--
--------------------------------------------------------------------------------

module Foreign.CUDA.Driver.Module (

  -- * Module Management
  Module, JITOption(..), JITTarget(..), JITResult(..),

  -- ** Querying module inhabitants
  getFun, getPtr, getTex,

  -- ** Loading and unloading modules
  loadFile,
  loadData,   loadDataFromPtr,
  loadDataEx, loadDataFromPtrEx,
  unload

) where

#include "cbits/stubs.h"
{# context lib="cuda" #}

-- Friends
import Foreign.CUDA.Analysis.Device
import Foreign.CUDA.Ptr
import Foreign.CUDA.Driver.Error
import Foreign.CUDA.Driver.Exec
import Foreign.CUDA.Driver.Marshal              (peekDeviceHandle)
import Foreign.CUDA.Driver.Texture
import Foreign.CUDA.Internal.C2HS

-- System
import Foreign
import Foreign.C
import Unsafe.Coerce

import Control.Monad                            (liftM)
import Control.Exception                        (throwIO)
import Data.ByteString.Char8                    (ByteString)
import qualified Data.ByteString.Char8          as B
import qualified Data.ByteString.Internal       as B

--------------------------------------------------------------------------------
-- Data Types
--------------------------------------------------------------------------------

-- |
-- A reference to a Module object, containing collections of device functions
--
newtype Module = Module { useModule :: {# type CUmodule #}}
  deriving (Eq, Show)

-- |
-- Just-in-time compilation options
--
data JITOption
  = MaxRegisters       !Int             -- ^ maximum number of registers per thread
  | ThreadsPerBlock    !Int             -- ^ number of threads per block to target for
  | OptimisationLevel  !Int             -- ^ level of optimisation to apply (1-4, default 4)
  | Target             !Compute         -- ^ compilation target, otherwise determined from context
  | FallbackStrategy   !JITFallback     -- ^ fallback strategy if matching cubin not found
#if CUDA_VERSION >= 5050
  | GenerateDebugInfo                   -- ^ generate debug info (-g)
  | GenerateLineInfo                    -- ^ generate line number information (-lineinfo)
  | Verbose                             -- ^ verbose log messages
#endif
  deriving (Show)

-- |
-- Results of online compilation
--
data JITResult = JITResult
  {
    jitTime     :: !Float,              -- ^ milliseconds spent compiling PTX
    jitInfoLog  :: !ByteString,         -- ^ information about PTX assembly
    jitModule   :: !Module              -- ^ compilation error log or compiled module
  }
  deriving (Show)

{# enum CUjit_option as JITOptionInternal
    { }
    with prefix="CU" deriving (Eq, Show) #}

{# enum CUjit_target as JITTarget
    { underscoreToCase }
    with prefix="CU_TARGET" deriving (Eq, Show) #}

{# enum CUjit_fallback as JITFallback
    { underscoreToCase }
    with prefix="CU_PREFER" deriving (Eq, Show) #}

--------------------------------------------------------------------------------
-- Module management
--------------------------------------------------------------------------------

-- |
-- Returns a function handle
--
{-# INLINEABLE getFun #-}
getFun :: Module -> String -> IO Fun
getFun !mdl !fn = resultIfFound "function" fn =<< cuModuleGetFunction mdl fn

{-# INLINE cuModuleGetFunction #-}
{# fun unsafe cuModuleGetFunction
  { alloca-      `Fun'    peekFun*
  , useModule    `Module'
  , withCString* `String'          } -> `Status' cToEnum #}
  where peekFun = liftM Fun . peek

-- |
-- 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
  resultIfFound "global" name (status,(dptr,bytes))

{-# INLINE cuModuleGetGlobal #-}
{# fun unsafe cuModuleGetGlobal
  { alloca-      `DevicePtr a' peekDeviceHandle*
  , alloca-      `Int'         peekIntConv*
  , useModule    `Module'
  , withCString* `String'                        } -> `Status' cToEnum #}

-- |
-- Return a handle to a texture reference
--
{-# INLINEABLE getTex #-}
getTex :: Module -> String -> IO Texture
getTex !mdl !name = resultIfFound "texture" name =<< cuModuleGetTexRef mdl name

{-# INLINE cuModuleGetTexRef #-}
{# fun unsafe cuModuleGetTexRef
  { alloca-      `Texture' peekTex*
  , useModule    `Module'
  , withCString* `String'           } -> `Status' cToEnum #}

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

{-# INLINE cuModuleLoad #-}
{# fun unsafe cuModuleLoad
  { alloca-      `Module'   peekMod*
  , withCString* `FilePath'          } -> `Status' cToEnum #}

-- |
-- Load the contents of the given image into a new module, and load that module
-- into the current context. The image is (typically) the contents of a cubin or
-- PTX file.
--
-- Note that the 'ByteString' will be copied into a temporary staging area so
-- that it can be passed to C.
--
{-# INLINEABLE loadData #-}
loadData :: ByteString -> IO Module
loadData !img =
  B.useAsCString img (\p -> loadDataFromPtr (castPtr p))

-- |
-- As 'loadData', but read the image data from the given pointer. The image is a
-- NULL-terminated sequence of bytes.
--
{-# INLINEABLE loadDataFromPtr #-}
loadDataFromPtr :: Ptr Word8 -> IO Module
loadDataFromPtr !img = resultIfOk =<< cuModuleLoadData img

{-# INLINE cuModuleLoadData #-}
{# fun unsafe cuModuleLoadData
  { alloca- `Module'    peekMod*
  , castPtr `Ptr Word8'          } -> ` Status' cToEnum #}

-- |
-- Load the contents of the given image into a module with online compiler
-- options, and load the module into the current context. The image is
-- (typically) the contents of a cubin or PTX file. The actual attributes of the
-- compiled kernel can be probed using 'requires'.
--
-- Note that the 'ByteString' will be copied into a temporary staging area so
-- that it can be passed to C.
--
{-# INLINEABLE loadDataEx #-}
loadDataEx :: ByteString -> [JITOption] -> IO JITResult
loadDataEx !img !options =
  B.useAsCString img (\p -> loadDataFromPtrEx (castPtr p) options)

-- |
-- As 'loadDataEx', but read the image data from the given pointer. The image is
-- a NULL-terminated sequence of bytes.
--
{-# INLINEABLE loadDataFromPtrEx #-}
loadDataFromPtrEx :: Ptr Word8 -> [JITOption] -> IO JITResult
loadDataFromPtrEx !img !options = do
  fp_ilog <- B.mallocByteString logSize

  allocaArray logSize    $ \p_elog -> do
  withForeignPtr fp_ilog $ \p_ilog -> do

  let (opt,val) = unzip $
        [ (JIT_WALL_TIME, 0) -- must be first, this is extracted below
        , (JIT_INFO_LOG_BUFFER_SIZE_BYTES,  logSize)
        , (JIT_ERROR_LOG_BUFFER_SIZE_BYTES, logSize)
        , (JIT_INFO_LOG_BUFFER,  unsafeCoerce (p_ilog :: CString))
        , (JIT_ERROR_LOG_BUFFER, unsafeCoerce (p_elog :: CString)) ] ++ map unpack options

  withArray (map cFromEnum opt)    $ \p_opts -> do
  withArray (map unsafeCoerce val) $ \p_vals -> do

  (s,mdl) <- cuModuleLoadDataEx img (length opt) p_opts p_vals

  case s of
    Success     -> do
      time    <- peek (castPtr p_vals)
      infoLog <- B.fromForeignPtr (castForeignPtr fp_ilog) 0 `fmap` c_strnlen p_ilog logSize
      return  $! JITResult time infoLog mdl

    _           -> do
      errLog  <- peekCString p_elog
      cudaError (unlines [describe s, errLog])

  where
    logSize = 2048

    unpack (MaxRegisters x)      = (JIT_MAX_REGISTERS,       x)
    unpack (ThreadsPerBlock x)   = (JIT_THREADS_PER_BLOCK,   x)
    unpack (OptimisationLevel x) = (JIT_OPTIMIZATION_LEVEL,  x)
    unpack (Target x)            = (JIT_TARGET,              jitTargetOfCompute x)
    unpack (FallbackStrategy x)  = (JIT_FALLBACK_STRATEGY,   fromEnum x)
#if CUDA_VERSION >= 5050
    unpack GenerateDebugInfo     = (JIT_GENERATE_DEBUG_INFO, fromEnum True)
    unpack GenerateLineInfo      = (JIT_GENERATE_LINE_INFO,  fromEnum True)
    unpack Verbose               = (JIT_LOG_VERBOSE,         fromEnum True)
#endif

    jitTargetOfCompute (Compute x y)
      = fromEnum
      $ case (x,y) of
          (1,0) -> Compute10
          (1,1) -> Compute11
          (1,2) -> Compute12
          (1,3) -> Compute13
          (2,0) -> Compute20
          (2,1) -> Compute21
          (3,0) -> Compute30
          (3,5) -> Compute35
          _     -> error ("Unknown JIT Target for Compute " ++ show (Compute x y))

{-# INLINE cuModuleLoadDataEx #-}
{# fun unsafe cuModuleLoadDataEx
  { alloca- `Module'       peekMod*
  , castPtr `Ptr Word8'
  ,         `Int'
  , id      `Ptr CInt'
  , id      `Ptr (Ptr ())'          } -> `Status' cToEnum #}

-- |
-- Unload a module from the current context
--
{-# INLINEABLE unload #-}
unload :: Module -> IO ()
unload !m = nothingIfOk =<< cuModuleUnload m

{-# INLINE cuModuleUnload #-}
{# fun unsafe cuModuleUnload
  { useModule `Module' } -> `Status' cToEnum #}

--------------------------------------------------------------------------------
-- Internal
--------------------------------------------------------------------------------

{-# INLINE resultIfFound #-}
resultIfFound :: String -> String -> (Status, a) -> IO a
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 c_strnlen' #-}
foreign import ccall unsafe "string.h strnlen" c_strnlen'
  :: CString -> CSize -> IO CSize

{-# INLINE c_strnlen #-}
c_strnlen :: CString -> Int -> IO Int
c_strnlen str maxlen = cIntConv `fmap` c_strnlen' str (cIntConv maxlen)


Have the runtime API throw exceptions

Have the runtime API throw exceptions

Ignore-this: 32bea19c60395283549a5a37c1f839f7
- In the same manner as the driver bindings, throw exceptions rather than
  returning error codes that must be explicitly checked.
- This is part one, updates to the individual modules to follow.

darcs-hash:20091219113837-dcabc-4df41191e97c3c7e35a8a98f21f5657167c69b6b.gz

{-# LANGUAGE ForeignFunctionInterface, DeriveDataTypeable #-}
--------------------------------------------------------------------------------
-- |
-- Module    : Foreign.CUDA.Runtime.Error
-- Copyright : (c) 2009 Trevor L. McDonell
-- License   : BSD
--
-- Error handling functions
--
--------------------------------------------------------------------------------

module Foreign.CUDA.Runtime.Error
  where

-- Friends
import Foreign.CUDA.Internal.C2HS

-- System
import Foreign
import Foreign.C
import Data.Typeable
import Control.Exception

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

--------------------------------------------------------------------------------
-- Return Status
--------------------------------------------------------------------------------

--
-- Error Codes
--
{# enum cudaError as Status
    { cudaSuccess as Success }
    with prefix="cudaError" deriving (Eq, Show) #}

--------------------------------------------------------------------------------
-- Exceptions
--------------------------------------------------------------------------------

data CUDAException
  = ExitCode Status
  | UserError String
  deriving Typeable

instance Exception CUDAException

instance Show CUDAException where
  showsPrec _ (ExitCode  s) = showString ("CUDA Exception: " ++ describe s)
  showsPrec _ (UserError s) = showString ("CUDA Exception: " ++ s)

-- |
-- Raise a CUDAException in the IO Monad
--
cudaError :: String -> IO a
cudaError s = throwIO (UserError s)

--------------------------------------------------------------------------------
-- Helper Functions
--------------------------------------------------------------------------------

-- |
-- Return the descriptive string associated with a particular error code
--
{# fun pure unsafe cudaGetErrorString as describe
    { cFromEnum `Status' } -> `String' #}
--
-- Logically, this must be a pure function, returning a pointer to a statically
-- defined string constant.
--

-- |
-- Return the results of a function on successful execution, otherwise return
-- the error string associated with the return code
--
resultIfOk :: (Status, a) -> IO a
resultIfOk (status,result) =
    case status of
        Success -> return  result
        _       -> throwIO (ExitCode status)

-- |
-- Return the error string associated with an unsuccessful return code,
-- otherwise Nothing
--
nothingIfOk :: Status -> IO ()
nothingIfOk status =
    case status of
        Success -> return  ()
        _       -> throwIO (ExitCode status)

{-# LANGUAGE ForeignFunctionInterface #-}
--------------------------------------------------------------------------------
-- |
-- Module    : Foreign.CUDA.Runtime.Error
-- Copyright : (c) 2009 Trevor L. McDonell
-- License   : BSD
--
-- Error handling functions
--
--------------------------------------------------------------------------------

module Foreign.CUDA.Runtime.Error
  (
    Status(..),
    describe,
    resultIfOk,
    nothingIfOk
  )
  where

import Foreign
import Foreign.C

import Foreign.CUDA.Internal.C2HS

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

--------------------------------------------------------------------------------
-- Data Types
--------------------------------------------------------------------------------

--
-- Error Codes
--
{# enum cudaError as Status
    { cudaSuccess as Success }
    with prefix="cudaError" deriving (Eq, Show) #}

--------------------------------------------------------------------------------
-- Functions
--------------------------------------------------------------------------------

-- |
-- Return the descriptive string associated with a particular error code
--
{# fun pure unsafe cudaGetErrorString as describe
    { cFromEnum `Status' } -> `String' #}
--
-- Logically, this must be a pure function, returning a pointer to a statically
-- defined string constant.
--

-- |
-- Return the results of a function on successful execution, otherwise return
-- the error string associated with the return code
--
resultIfOk :: (Status, a) -> Either String a
resultIfOk (status,result) =
    case status of
        Success -> Right result
        _       -> Left (describe status)

-- |
-- Return the error string associated with an unsuccessful return code,
-- otherwise Nothing
--
nothingIfOk :: Status -> Maybe String
nothingIfOk = nothingIf (== Success) describe


Fix documenation to Editable.

Fix documenation to Editable.

{-# LANGUAGE CPP #-}
-- -*-haskell-*-
--  GIMP Toolkit (GTK) Interface Editable
--
--  Author : Axel Simon, Duncan Coutts
--
--  Created: 30 July 2004
--
--  Copyright (C) 1999-2005 Axel Simon, Duncan Coutts
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public
--  License as published by the Free Software Foundation; either
--  version 2.1 of the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
-- |
-- Maintainer  : gtk2hs-users@lists.sourceforge.net
-- Stability   : provisional
-- Portability : portable (depends on GHC)
--
-- Interface for text-editing widgets
--
module Graphics.UI.Gtk.Entry.Editable (
-- * Detail
--
-- | The 'Editable' interface is an interface which should be implemented by
-- text editing widgets, such as 'Entry'.
-- It contains functions for generically manipulating an editable
-- widget, a large number of action signals used for key bindings, and several
-- signals that an application can connect to to modify the behavior of a
-- widget.
--

-- * Class Hierarchy
-- |
-- @
-- |  GInterface
-- |   +----Editable
-- @

-- * Types
  Editable,
  EditableClass,
  castToEditable, gTypeEditable,
  toEditable,

-- * Methods
  editableSelectRegion,
  editableGetSelectionBounds,
  editableInsertText,
  editableDeleteText,
  editableGetChars,
  editableCutClipboard,
  editableCopyClipboard,
  editablePasteClipboard,
  editableDeleteSelection,
  editableSetEditable,
  editableGetEditable,
  editableSetPosition,
  editableGetPosition,

-- * Attributes
  editablePosition,
  editableEditable,

-- * Signals
  onEditableChanged,
  afterEditableChanged,
  onDeleteText,
  afterDeleteText,
  stopDeleteText,
  onInsertText,
  afterInsertText,
  stopInsertText
  ) where

import Control.Monad    (liftM)

import System.Glib.FFI
import System.Glib.UTFString
import System.Glib.Attributes
{#import Graphics.UI.Gtk.Types#}
{#import Graphics.UI.Gtk.Signals#}

{# context lib="gtk" prefix="gtk" #}

--------------------
-- Methods

-- | Selects a region of text. The characters that are selected are those
-- characters at positions from @startPos@ up to, but not including @endPos@.
-- If @endPos@ is negative, then the the characters selected will be those
-- characters from @startPos@ to the end of the text.
--
-- Calling this function with @start@=1 and @end@=4 it will mark \"ask\" in
-- the string \"Haskell\".
--
editableSelectRegion :: EditableClass self => self
 -> Int   -- ^ @start@ - the starting position.
 -> Int   -- ^ @end@ - the end position.
 -> IO ()
editableSelectRegion self start end =
  {# call editable_select_region #}
    (toEditable self)
    (fromIntegral start)
    (fromIntegral end)

-- | Gets the current selection bounds, if there is a selection.
--
editableGetSelectionBounds :: EditableClass self => self
 -> IO (Int,Int) -- ^ @(start, end)@ - the starting and end positions. This
                 -- pair is not ordered. The @end@ index represents the
                 -- position of the cursor. The @start@ index is the other end
                 -- of the selection. If both numbers are equal there is in
                 -- fact no selection.
editableGetSelectionBounds self =
  alloca $ \startPtr ->
  alloca $ \endPtr -> do
  {# call unsafe editable_get_selection_bounds #}
    (toEditable self)
    startPtr
    endPtr
  start <- liftM fromIntegral $ peek startPtr
  end   <- liftM fromIntegral $ peek endPtr
  return (start,end)

-- | Inserts text at a given position.
--
editableInsertText :: EditableClass self => self
 -> String -- ^ @newText@ - the text to insert.
 -> Int    -- ^ @position@ - the position at which to insert the text.
 -> IO Int -- ^ returns the position after the newly inserted text.
editableInsertText self newText position =
  with (fromIntegral position) $ \positionPtr ->
  withUTFStringLen newText $ \(newTextPtr, newTextLength) -> do
  {# call editable_insert_text #}
    (toEditable self)
    newTextPtr
    (fromIntegral newTextLength)
    positionPtr
  position <- peek positionPtr
  return (fromIntegral position)

-- | Deletes a sequence of characters. The characters that are deleted are
-- those characters at positions from @startPos@ up to, but not including
-- @endPos@. If @endPos@ is negative, then the the characters deleted will be
-- those characters from @startPos@ to the end of the text.
--
editableDeleteText :: EditableClass self => self
 -> Int   -- ^ @startPos@ - the starting position.
 -> Int   -- ^ @endPos@ - the end position.
 -> IO ()
editableDeleteText self startPos endPos =
  {# call editable_delete_text #}
    (toEditable self)
    (fromIntegral startPos)
    (fromIntegral endPos)

-- | Retrieves a sequence of characters. The characters that are retrieved are
-- those characters at positions from @startPos@ up to, but not including
-- @endPos@. If @endPos@ is negative, then the the characters retrieved will be
-- those characters from @startPos@ to the end of the text.
--
editableGetChars :: EditableClass self => self
 -> Int       -- ^ @startPos@ - the starting position.
 -> Int       -- ^ @endPos@ - the end position.
 -> IO String -- ^ returns the characters in the indicated region.
editableGetChars self startPos endPos =
  {# call unsafe editable_get_chars #}
    (toEditable self)
    (fromIntegral startPos)
    (fromIntegral endPos)
  >>= readUTFString

-- | Causes the characters in the current selection to be copied to the
-- clipboard and then deleted from the widget.
--
editableCutClipboard :: EditableClass self => self -> IO ()
editableCutClipboard self =
  {# call editable_cut_clipboard #}
    (toEditable self)

-- | Causes the characters in the current selection to be copied to the
-- clipboard.
--
editableCopyClipboard :: EditableClass self => self -> IO ()
editableCopyClipboard self =
  {# call editable_copy_clipboard #}
    (toEditable self)

-- | Causes the contents of the clipboard to be pasted into the given widget
-- at the current cursor position.
--
editablePasteClipboard :: EditableClass self => self -> IO ()
editablePasteClipboard self =
  {# call editable_paste_clipboard #}
    (toEditable self)

-- | Deletes the current contents of the widgets selection and disclaims the
-- selection.
--
editableDeleteSelection :: EditableClass self => self -> IO ()
editableDeleteSelection self =
  {# call editable_delete_selection #}
    (toEditable self)

-- | Sets the cursor position.
--
editableSetPosition :: EditableClass self => self
 -> Int   -- ^ @position@ - the position of the cursor. The cursor is
          -- displayed before the character with the given (base 0) index in
          -- the widget. The value must be less than or equal to the number of
          -- characters in the widget. A value of -1 indicates that the
          -- position should be set after the last character in the entry.
 -> IO ()
editableSetPosition self position =
  {# call editable_set_position #}
    (toEditable self)
    (fromIntegral position)

-- | Retrieves the current cursor position.
--
editableGetPosition :: EditableClass self => self
 -> IO Int -- ^ returns the position of the cursor. The cursor is displayed
           -- before the character with the given (base 0) index in the widget.
           -- The value will be less than or equal to the number of characters
           -- in the widget. Note that this position is in characters, not in
           -- bytes.
editableGetPosition self =
  liftM fromIntegral $
  {# call unsafe editable_get_position #}
    (toEditable self)

-- | Determines if the user can edit the text in the editable widget or not.
--
editableSetEditable :: EditableClass self => self
 -> Bool  -- ^ @isEditable@ - @True@ if the user is allowed to edit the text
          -- in the widget.
 -> IO ()
editableSetEditable self isEditable =
  {# call editable_set_editable #}
    (toEditable self)
    (fromBool isEditable)

-- | Retrieves whether the text is editable. See 'editableSetEditable'.
--
editableGetEditable :: EditableClass self => self -> IO Bool
editableGetEditable self =
  liftM toBool $
  {# call editable_get_editable #}
    (toEditable self)

--------------------
-- Attributes

-- | \'position\' property. See 'editableGetPosition' and
-- 'editableSetPosition'
--
editablePosition :: EditableClass self => Attr self Int
editablePosition = newAttr
  editableGetPosition
  editableSetPosition

-- | \'editable\' property. See 'editableGetEditable' and
-- 'editableSetEditable'
--
editableEditable :: EditableClass self => Attr self Bool
editableEditable = newAttr
  editableGetEditable
  editableSetEditable

--------------------
-- Signals

-- | The 'onEditableChanged' signal is emitted at the end of a single
-- user-visible operation on the contents of the 'Editable'.
--
-- * For inctance, a paste operation that replaces the contents of the
--   selection will cause only one signal emission (even though it is
--   implemented by first deleting the selection, then inserting the new
--   content, and may cause multiple 'onEditableInserText' signals to be
--   emitted).
--
onEditableChanged, afterEditableChanged :: EditableClass ec => ec -> IO () ->
                                     IO (ConnectId ec)
onEditableChanged = connect_NONE__NONE "changed" False
afterEditableChanged = connect_NONE__NONE "changed" True

-- | Emitted when a piece of text is deleted from the 'Editable' widget.
--
-- * See 'onInsertText' for information on how to use this signal.
--
onDeleteText, afterDeleteText :: EditableClass self => self
 -> (Int -> Int -> IO ()) -- ^ @(\startPos endPos -> ...)@
 -> IO (ConnectId self)
onDeleteText = connect_INT_INT__NONE "delete_text" False
afterDeleteText = connect_INT_INT__NONE "delete_text" True

-- | Stop the current signal that deletes text.
stopDeleteText :: EditableClass self => ConnectId self -> IO ()
stopDeleteText (ConnectId _ obj) =
  signalStopEmission obj "delete_text"

-- | Emitted when a piece of text is inserted into the 'Editable' widget.
--
-- * The connected signal receives the text that is inserted, together with
--   the position in the entry widget. The return value should be the position
--   in the entry widget that lies past the recently inserted text (i.e.
--   you should return the given position plus the length of the string).
--
-- * To modify the text that the user inserts, you need to connect to this
--   signal, modify the text the way you want and then call
--   'editableInsertText'. To avoid that this signal handler is called
--   recursively, you need to temporarily block it using
--   'signalBlock'. After the default signal
--   handler has inserted your modified text, it is important that you
--   prevent the default handler from being executed again when this signal
--   handler returns. To stop the current signal, use 'stopInsertText'.
--   The following code is an example of how to turn all input into uppercase:
--
--   > idRef <- newIORef undefined
--   > id <- onInsertText entry $ \str pos -> do
--   >   id <- readIORef idRef
--   >   signalBlock id
--   >   pos' <- editableInsertText entry (map toUpper str) pos
--   >   signalUnblock id
--   >   stopInsertText id
--   >   return pos'
--   > writeIORef idRef id
--
--   Note that the 'afterInsertText' function is not very useful, except to
--   track editing actions.
--
onInsertText, afterInsertText :: EditableClass self => self
 -> (String -> Int -> IO Int)
 -> IO (ConnectId self)
onInsertText obj handler =
  connect_PTR_INT_PTR__NONE "insert_text" False obj
  (\strPtr strLen posPtr -> do
    str <- if strLen<0 then peekUTFString strPtr
           else peekUTFStringLen (strPtr, strLen)
    pos <- peek (posPtr :: Ptr {#type gint#})
    pos' <- handler str (fromIntegral pos)
    poke (posPtr :: Ptr {#type gint#}) (fromIntegral pos')
  )
afterInsertText obj handler =
  connect_PTR_INT_PTR__NONE "insert_text" True obj
  (\strPtr strLen posPtr -> do
    str <- if strLen<0 then peekUTFString strPtr
           else peekUTFStringLen (strPtr, strLen)
    pos <- peek (posPtr :: Ptr {#type gint#})
    pos' <- handler str (fromIntegral pos)
    poke (posPtr :: Ptr {#type gint#}) (fromIntegral pos')
  )

-- | Stop the current signal that inserts text.
stopInsertText :: EditableClass self => ConnectId self -> IO ()
stopInsertText (ConnectId _ obj) =
  signalStopEmission obj "insert_text"

{-# LANGUAGE CPP #-}
-- -*-haskell-*-
--  GIMP Toolkit (GTK) Interface Editable
--
--  Author : Axel Simon, Duncan Coutts
--
--  Created: 30 July 2004
--
--  Copyright (C) 1999-2005 Axel Simon, Duncan Coutts
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public
--  License as published by the Free Software Foundation; either
--  version 2.1 of the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
-- |
-- Maintainer  : gtk2hs-users@lists.sourceforge.net
-- Stability   : provisional
-- Portability : portable (depends on GHC)
--
-- Interface for text-editing widgets
--
module Graphics.UI.Gtk.Entry.Editable (
-- * Detail
--
-- | The 'Editable' interface is an interface which should be implemented by
-- text editing widgets, such as 'Entry'.
-- It contains functions for generically manipulating an editable
-- widget, a large number of action signals used for key bindings, and several
-- signals that an application can connect to to modify the behavior of a
-- widget.
--

-- * Class Hierarchy
-- |
-- @
-- |  GInterface
-- |   +----Editable
-- @

-- * Types
  Editable,
  EditableClass,
  castToEditable, gTypeEditable,
  toEditable,

-- * Methods
  editableSelectRegion,
  editableGetSelectionBounds,
  editableInsertText,
  editableDeleteText,
  editableGetChars,
  editableCutClipboard,
  editableCopyClipboard,
  editablePasteClipboard,
  editableDeleteSelection,
  editableSetEditable,
  editableGetEditable,
  editableSetPosition,
  editableGetPosition,

-- * Attributes
  editablePosition,
  editableEditable,

-- * Signals
  onEditableChanged,
  afterEditableChanged,
  onDeleteText,
  afterDeleteText,
  stopDeleteText,
  onInsertText,
  afterInsertText,
  stopInsertText
  ) where

import Control.Monad    (liftM)

import System.Glib.FFI
import System.Glib.UTFString
import System.Glib.Attributes
{#import Graphics.UI.Gtk.Types#}
{#import Graphics.UI.Gtk.Signals#}

{# context lib="gtk" prefix="gtk" #}

--------------------
-- Methods

-- | Selects a region of text. The characters that are selected are those
-- characters at positions from @startPos@ up to, but not including @endPos@.
-- If @endPos@ is negative, then the the characters selected will be those
-- characters from @startPos@ to the end of the text.
--
-- Calling this function with @start@=1 and @end@=4 it will mark \"ask\" in
-- the string \"Haskell\".
--
editableSelectRegion :: EditableClass self => self
 -> Int   -- ^ @start@ - the starting position.
 -> Int   -- ^ @end@ - the end position.
 -> IO ()
editableSelectRegion self start end =
  {# call editable_select_region #}
    (toEditable self)
    (fromIntegral start)
    (fromIntegral end)

-- | Gets the current selection bounds, if there is a selection.
--
editableGetSelectionBounds :: EditableClass self => self
 -> IO (Int,Int) -- ^ @(start, end)@ - the starting and end positions. This
                 -- pair is not ordered. The @end@ index represents the
                 -- position of the cursor. The @start@ index is the other end
                 -- of the selection. If both numbers are equal there is in
                 -- fact no selection.
editableGetSelectionBounds self =
  alloca $ \startPtr ->
  alloca $ \endPtr -> do
  {# call unsafe editable_get_selection_bounds #}
    (toEditable self)
    startPtr
    endPtr
  start <- liftM fromIntegral $ peek startPtr
  end   <- liftM fromIntegral $ peek endPtr
  return (start,end)

-- | Inserts text at a given position.
--
editableInsertText :: EditableClass self => self
 -> String -- ^ @newText@ - the text to insert.
 -> Int    -- ^ @position@ - the position at which to insert the text.
 -> IO Int -- ^ returns the position after the newly inserted text.
editableInsertText self newText position =
  with (fromIntegral position) $ \positionPtr ->
  withUTFStringLen newText $ \(newTextPtr, newTextLength) -> do
  {# call editable_insert_text #}
    (toEditable self)
    newTextPtr
    (fromIntegral newTextLength)
    positionPtr
  position <- peek positionPtr
  return (fromIntegral position)

-- | Deletes a sequence of characters. The characters that are deleted are
-- those characters at positions from @startPos@ up to, but not including
-- @endPos@. If @endPos@ is negative, then the the characters deleted will be
-- those characters from @startPos@ to the end of the text.
--
editableDeleteText :: EditableClass self => self
 -> Int   -- ^ @startPos@ - the starting position.
 -> Int   -- ^ @endPos@ - the end position.
 -> IO ()
editableDeleteText self startPos endPos =
  {# call editable_delete_text #}
    (toEditable self)
    (fromIntegral startPos)
    (fromIntegral endPos)

-- | Retrieves a sequence of characters. The characters that are retrieved are
-- those characters at positions from @startPos@ up to, but not including
-- @endPos@. If @endPos@ is negative, then the the characters retrieved will be
-- those characters from @startPos@ to the end of the text.
--
editableGetChars :: EditableClass self => self
 -> Int       -- ^ @startPos@ - the starting position.
 -> Int       -- ^ @endPos@ - the end position.
 -> IO String -- ^ returns the characters in the indicated region.
editableGetChars self startPos endPos =
  {# call unsafe editable_get_chars #}
    (toEditable self)
    (fromIntegral startPos)
    (fromIntegral endPos)
  >>= readUTFString

-- | Causes the characters in the current selection to be copied to the
-- clipboard and then deleted from the widget.
--
editableCutClipboard :: EditableClass self => self -> IO ()
editableCutClipboard self =
  {# call editable_cut_clipboard #}
    (toEditable self)

-- | Causes the characters in the current selection to be copied to the
-- clipboard.
--
editableCopyClipboard :: EditableClass self => self -> IO ()
editableCopyClipboard self =
  {# call editable_copy_clipboard #}
    (toEditable self)

-- | Causes the contents of the clipboard to be pasted into the given widget
-- at the current cursor position.
--
editablePasteClipboard :: EditableClass self => self -> IO ()
editablePasteClipboard self =
  {# call editable_paste_clipboard #}
    (toEditable self)

-- | Deletes the current contents of the widgets selection and disclaims the
-- selection.
--
editableDeleteSelection :: EditableClass self => self -> IO ()
editableDeleteSelection self =
  {# call editable_delete_selection #}
    (toEditable self)

-- | Sets the cursor position.
--
editableSetPosition :: EditableClass self => self
 -> Int   -- ^ @position@ - the position of the cursor. The cursor is
          -- displayed before the character with the given (base 0) index in
          -- the widget. The value must be less than or equal to the number of
          -- characters in the widget. A value of -1 indicates that the
          -- position should be set after the last character in the entry.
 -> IO ()
editableSetPosition self position =
  {# call editable_set_position #}
    (toEditable self)
    (fromIntegral position)

-- | Retrieves the current cursor position.
--
editableGetPosition :: EditableClass self => self
 -> IO Int -- ^ returns the position of the cursor. The cursor is displayed
           -- before the character with the given (base 0) index in the widget.
           -- The value will be less than or equal to the number of characters
           -- in the widget. Note that this position is in characters, not in
           -- bytes.
editableGetPosition self =
  liftM fromIntegral $
  {# call unsafe editable_get_position #}
    (toEditable self)

-- | Determines if the user can edit the text in the editable widget or not.
--
editableSetEditable :: EditableClass self => self
 -> Bool  -- ^ @isEditable@ - @True@ if the user is allowed to edit the text
          -- in the widget.
 -> IO ()
editableSetEditable self isEditable =
  {# call editable_set_editable #}
    (toEditable self)
    (fromBool isEditable)

-- | Retrieves whether the text is editable. See 'editableSetEditable'.
--
editableGetEditable :: EditableClass self => self -> IO Bool
editableGetEditable self =
  liftM toBool $
  {# call editable_get_editable #}
    (toEditable self)

--------------------
-- Attributes

-- | \'position\' property. See 'editableGetPosition' and
-- 'editableSetPosition'
--
editablePosition :: EditableClass self => Attr self Int
editablePosition = newAttr
  editableGetPosition
  editableSetPosition

-- | \'editable\' property. See 'editableGetEditable' and
-- 'editableSetEditable'
--
editableEditable :: EditableClass self => Attr self Bool
editableEditable = newAttr
  editableGetEditable
  editableSetEditable

--------------------
-- Signals

-- | Emitted when the settings of the 'Editable' widget changes.
--
onEditableChanged, afterEditableChanged :: EditableClass ec => ec -> IO () ->
                                     IO (ConnectId ec)
onEditableChanged = connect_NONE__NONE "changed" False
afterEditableChanged = connect_NONE__NONE "changed" True

-- | Emitted when a piece of text is deleted from the 'Editable' widget.
--
-- * See 'onInsertText' for information on how to use this signal.
--
onDeleteText, afterDeleteText :: EditableClass self => self
 -> (Int -> Int -> IO ()) -- ^ @(\startPos endPos -> ...)@
 -> IO (ConnectId self)
onDeleteText = connect_INT_INT__NONE "delete_text" False
afterDeleteText = connect_INT_INT__NONE "delete_text" True

-- | Stop the current signal that deletes text.
stopDeleteText :: EditableClass self => ConnectId self -> IO ()
stopDeleteText (ConnectId _ obj) =
  signalStopEmission obj "delete_text"

-- | Emitted when a piece of text is inserted into the 'Editable' widget.
--
-- * The connected signal receives the text that is inserted, together with
--   the position in the entry widget. The return value should be the position
--   in the entry widget that lies past the recently inserted text (i.e.
--   you should return the given position plus the length of the string).
--
-- * To modify the text that the user inserts, you need to connect to this
--   signal, modify the text the way you want and then call
--   'editableInsertText'. To avoid that this signal handler is called
--   recursively, you need to temporarily block it using
--   'signalBlock'. After the default signal
--   handler has inserted your modified text, it is important that you
--   prevent the default handler from being executed again when this signal
--   handler returns. To stop the current signal, use 'stopInsertText'.
--   The following code is an example of how to turn all input into uppercase:
--
--   > idRef <- newIORef undefined
--   > id <- onInsertText entry $ \str pos -> do
--   >   id <- readIORef idRef
--   >   signalBlock id
--   >   pos' <- editableInsertText entry (map toUpper str) pos
--   >   signalUnblock id
--   >   stopInsertText id
--   >   return pos'
--   > writeIORef idRef id
--
--   Note that the 'afterInsertText' function is not very useful, except to
--   track editing actions.
--
onInsertText, afterInsertText :: EditableClass self => self
 -> (String -> Int -> IO Int)
 -> IO (ConnectId self)
onInsertText obj handler =
  connect_PTR_INT_PTR__NONE "insert_text" False obj
  (\strPtr strLen posPtr -> do
    str <- if strLen<0 then peekUTFString strPtr
           else peekUTFStringLen (strPtr, strLen)
    pos <- peek (posPtr :: Ptr {#type gint#})
    pos' <- handler str (fromIntegral pos)
    poke (posPtr :: Ptr {#type gint#}) (fromIntegral pos')
  )
afterInsertText obj handler =
  connect_PTR_INT_PTR__NONE "insert_text" True obj
  (\strPtr strLen posPtr -> do
    str <- if strLen<0 then peekUTFString strPtr
           else peekUTFStringLen (strPtr, strLen)
    pos <- peek (posPtr :: Ptr {#type gint#})
    pos' <- handler str (fromIntegral pos)
    poke (posPtr :: Ptr {#type gint#}) (fromIntegral pos')
  )

-- | Stop the current signal that inserts text.
stopInsertText :: EditableClass self => ConnectId self -> IO ()
stopInsertText (ConnectId _ obj) =
  signalStopEmission obj "insert_text"


name function parameter alternatives consistently

Ignore-this: f3c4fd17b1950b62fd03036546c368df

darcs-hash:20091210065127-9241b-c04f6518b01fac2ec208a709034375a86ea633ad.gz

{-# LANGUAGE ForeignFunctionInterface #-}
--------------------------------------------------------------------------------
-- |
-- Module    : Foreign.CUDA.Driver.Exec
-- Copyright : (c) 2009 Trevor L. McDonell
-- License   : BSD
--
-- Kernel execution control for low-level driver interface
--
--------------------------------------------------------------------------------

module Foreign.CUDA.Driver.Exec
  (
    Fun, FunParam(..), FunAttribute(..), newFun, withFun,
    requires, setBlockShape, setSharedSize, setParams, launch
  )
  where

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

-- Friends
import Foreign.CUDA.Internal.C2HS
import Foreign.CUDA.Driver.Error
import Foreign.CUDA.Driver.Stream               (Stream, withStream)

-- System
import Foreign
import Foreign.C
import Data.Maybe
import Control.Monad                            (zipWithM)

--------------------------------------------------------------------------------
-- Data Types
--------------------------------------------------------------------------------

-- |
-- A __global__ device function
--
{# pointer *CUfunction as Fun foreign newtype #}
withFun :: Fun -> (Ptr Fun -> IO a) -> IO a

newFun :: IO Fun
newFun = Fun `fmap` mallocForeignPtrBytes (sizeOf (undefined :: Ptr ()))

-- |
-- Function attributes
--
{# enum CUfunction_attribute as FunAttribute
    { underscoreToCase
    , MAX_THREADS_PER_BLOCK as MaxKernelThreadsPerBlock }
    with prefix="CU_FUNC_ATTRIBUTE" deriving (Eq, Show) #}

-- |
-- Kernel function parameters
--
data Storable a => FunParam a
    = IArg Int
    | FArg Float
    | VArg a
--  | TRef Texture

--------------------------------------------------------------------------------
-- Execution Control
--------------------------------------------------------------------------------

-- |
-- Returns the value of the selected attribute requirement for the given kernel
--
requires :: Fun -> FunAttribute -> IO (Either String Int)
requires fn att = withFun fn $ \f -> (resultIfOk `fmap` cuFuncGetAttribute att f)

{# fun unsafe cuFuncGetAttribute
  { alloca-   `Int'          peekIntConv*
  , cFromEnum `FunAttribute'
  , castPtr   `Ptr Fun'                   } -> `Status' cToEnum #}

-- |
-- Specify the (x,y,z) dimensions of the thread blocks that are created when the
-- given kernel function is lanched
--
setBlockShape :: Fun -> (Int,Int,Int) -> IO (Maybe String)
setBlockShape fn (x,y,z) = withFun fn $ \f -> (nothingIfOk `fmap` cuFuncSetBlockShape f x y z)

{# fun unsafe cuFuncSetBlockShape
  { castPtr `Ptr Fun'
  ,         `Int'
  ,         `Int'
  ,         `Int'     } -> `Status' cToEnum #}

-- |
-- Set the number of bytes of dynamic shared memory to be available to each
-- thread block when the function is launched
--
setSharedSize :: Fun -> Integer -> IO (Maybe String)
setSharedSize fn bytes = withFun fn $ \f -> (nothingIfOk `fmap` cuFuncSetSharedSize f bytes)

{# fun unsafe cuFuncSetSharedSize
  { castPtr  `Ptr Fun'
  , cIntConv `Integer' } -> `Status' cToEnum #}

-- |
-- Invoke the kernel on a size (w,h) grid of blocks. Each block contains the
-- number of threads specified by a previous call to `setBlockShape'. The launch
-- may also be associated with a specific `Stream'.
--
launch :: Fun -> (Int,Int) -> Maybe Stream -> IO (Maybe String)
launch fn (w,h) mst =
  withFun fn $ \f ->
  nothingIfOk `fmap` case mst of
    Nothing -> cuLaunchGridAsync f w h nullPtr
    Just st -> (withStream st $ \s -> cuLaunchGridAsync f w h s)

{# fun unsafe cuLaunchGridAsync
  { castPtr `Ptr Fun'
  ,         `Int'
  ,         `Int'
  , castPtr `Ptr Stream' } -> `Status' cToEnum #}

--------------------------------------------------------------------------------
-- Kernel function parameters
--------------------------------------------------------------------------------

-- |
-- Set the parameters that will specified next time the kernel is invoked
--
setParams :: Storable a => Fun -> [FunParam a] -> IO (Maybe [String])
setParams fn prs =
  withFun fn $ \f ->
  cuParamSetSize f (last offsets) >>= \rv ->
  case nothingIfOk rv of
    Just err -> return (Just [err])
    Nothing  -> (maybeNull . catMaybes) `fmap` zipWithM (set f) offsets prs
  where
    maybeNull [] = Nothing
    maybeNull x  = Just x

    offsets = scanl (\a b -> a + size b) 0 prs

    size (IArg v)    = sizeOf v
    size (FArg v)    = sizeOf v
    size (VArg v)    = sizeOf v

    set f o (IArg v) = nothingIfOk `fmap` cuParamSeti f o v
    set f o (FArg v) = nothingIfOk `fmap` cuParamSetf f o v
    set f o (VArg v) = with v $ \p -> (nothingIfOk `fmap` cuParamSetv f o p (sizeOf v))

{# fun unsafe cuParamSetSize
  { castPtr `Ptr Fun'
  ,         `Int'     } -> `Status' cToEnum #}

{# fun unsafe cuParamSeti
  { castPtr `Ptr Fun'
  ,         `Int'
  ,         `Int'     } -> `Status' cToEnum #}

{# fun unsafe cuParamSetf
  { castPtr `Ptr Fun'
  ,         `Int'
  ,         `Float'   } -> `Status' cToEnum #}

{# fun unsafe cuParamSetv
  `Storable a' =>
  { castPtr `Ptr Fun'
  ,         `Int'
  , castPtr `Ptr a'
  ,         `Int'     } -> `Status' cToEnum #}

{-# LANGUAGE ForeignFunctionInterface #-}
--------------------------------------------------------------------------------
-- |
-- Module    : Foreign.CUDA.Driver.Exec
-- Copyright : (c) 2009 Trevor L. McDonell
-- License   : BSD
--
-- Kernel execution control for low-level driver interface
--
--------------------------------------------------------------------------------

module Foreign.CUDA.Driver.Exec
  (
    Fun, FunParam(..), FunAttribute(..), newFun, withFun,
    requires, setBlockShape, setSharedSize, setParams, launch
  )
  where

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

-- Friends
import Foreign.CUDA.Internal.C2HS
import Foreign.CUDA.Driver.Error
import Foreign.CUDA.Driver.Stream               (Stream, withStream)

-- System
import Foreign
import Foreign.C
import Data.Maybe
import Control.Monad                            (zipWithM)

--------------------------------------------------------------------------------
-- Data Types
--------------------------------------------------------------------------------

-- |
-- A __global__ device function
--
{# pointer *CUfunction as Fun foreign newtype #}
withFun :: Fun -> (Ptr Fun -> IO a) -> IO a

newFun :: IO Fun
newFun = Fun `fmap` mallocForeignPtrBytes (sizeOf (undefined :: Ptr ()))

-- |
-- Function attributes
--
{# enum CUfunction_attribute as FunAttribute
    { underscoreToCase
    , MAX_THREADS_PER_BLOCK as MaxKernelThreadsPerBlock }
    with prefix="CU_FUNC_ATTRIBUTE" deriving (Eq, Show) #}

-- |
-- Kernel function parameters
--
data Storable a => FunParam a
    = IVal Int
    | FVal Float
    | VArg a
--  | TRef Texture

--------------------------------------------------------------------------------
-- Execution Control
--------------------------------------------------------------------------------

-- |
-- Returns the value of the selected attribute requirement for the given kernel
--
requires :: Fun -> FunAttribute -> IO (Either String Int)
requires fn att = withFun fn $ \f -> (resultIfOk `fmap` cuFuncGetAttribute att f)

{# fun unsafe cuFuncGetAttribute
  { alloca-   `Int'          peekIntConv*
  , cFromEnum `FunAttribute'
  , castPtr   `Ptr Fun'                   } -> `Status' cToEnum #}

-- |
-- Specify the (x,y,z) dimensions of the thread blocks that are created when the
-- given kernel function is lanched
--
setBlockShape :: Fun -> (Int,Int,Int) -> IO (Maybe String)
setBlockShape fn (x,y,z) = withFun fn $ \f -> (nothingIfOk `fmap` cuFuncSetBlockShape f x y z)

{# fun unsafe cuFuncSetBlockShape
  { castPtr `Ptr Fun'
  ,         `Int'
  ,         `Int'
  ,         `Int'     } -> `Status' cToEnum #}

-- |
-- Set the number of bytes of dynamic shared memory to be available to each
-- thread block when the function is launched
--
setSharedSize :: Fun -> Integer -> IO (Maybe String)
setSharedSize fn bytes = withFun fn $ \f -> (nothingIfOk `fmap` cuFuncSetSharedSize f bytes)

{# fun unsafe cuFuncSetSharedSize
  { castPtr  `Ptr Fun'
  , cIntConv `Integer' } -> `Status' cToEnum #}

-- |
-- Invoke the kernel on a size (w,h) grid of blocks. Each block contains the
-- number of threads specified by a previous call to `setBlockShape'. The launch
-- may also be associated with a specific `Stream'.
--
launch :: Fun -> (Int,Int) -> Maybe Stream -> IO (Maybe String)
launch fn (w,h) mst =
  withFun fn $ \f ->
  nothingIfOk `fmap` case mst of
    Nothing -> cuLaunchGridAsync f w h nullPtr
    Just st -> (withStream st $ \s -> cuLaunchGridAsync f w h s)

{# fun unsafe cuLaunchGridAsync
  { castPtr `Ptr Fun'
  ,         `Int'
  ,         `Int'
  , castPtr `Ptr Stream' } -> `Status' cToEnum #}

--------------------------------------------------------------------------------
-- Kernel function parameters
--------------------------------------------------------------------------------

-- |
-- Set the parameters that will specified next time the kernel is invoked
--
setParams :: Storable a => Fun -> [FunParam a] -> IO (Maybe [String])
setParams fn prs =
  withFun fn $ \f ->
  cuParamSetSize f (last offsets) >>= \rv ->
  case nothingIfOk rv of
    Just err -> return (Just [err])
    Nothing  -> (maybeNull . catMaybes) `fmap` zipWithM (set f) offsets prs
  where
    maybeNull [] = Nothing
    maybeNull x  = Just x

    offsets = scanl (\a b -> a + size b) 0 prs

    size (IVal v)    = sizeOf v
    size (FVal v)    = sizeOf v
    size (VArg v)    = sizeOf v

    set f o (IVal v) = nothingIfOk `fmap` cuParamSeti f o v
    set f o (FVal v) = nothingIfOk `fmap` cuParamSetf f o v
    set f o (VArg v) = with v $ \p -> (nothingIfOk `fmap` cuParamSetv f o p (sizeOf v))

{# fun unsafe cuParamSetSize
  { castPtr `Ptr Fun'
  ,         `Int'     } -> `Status' cToEnum #}

{# fun unsafe cuParamSeti
  { castPtr `Ptr Fun'
  ,         `Int'
  ,         `Int'     } -> `Status' cToEnum #}

{# fun unsafe cuParamSetf
  { castPtr `Ptr Fun'
  ,         `Int'
  ,         `Float'   } -> `Status' cToEnum #}

{# fun unsafe cuParamSetv
  `Storable a' =>
  { castPtr `Ptr Fun'
  ,         `Int'
  , castPtr `Ptr a'
  ,         `Int'     } -> `Status' cToEnum #}


fix double stable pointer free causing segfaults in some situations

{-# LANGUAGE CPP #-}
{-# CFILES events.c #-}
module Graphics.UI.Gtk.WebKit.DOM.EventTargetClosures
       (EventName(..), SaferEventListener(..), EventListener(..), unEventListener, EventListenerClass(..),
       eventListenerNew, eventListenerNewAsync, eventListenerNewSync, eventListenerRelease) where
import Control.Monad.Reader (ReaderT)
import System.Glib.FFI (newStablePtr, freeStablePtr, StablePtr, Ptr(..), toBool, CInt(..), CChar,
        withForeignPtr, fromBool)
import System.Glib.UTFString
import Control.Applicative
{#import Graphics.UI.Gtk.WebKit.Types#}
import System.Glib.GError
import Control.Monad (void)

newtype EventName t e = EventName String
newtype SaferEventListener t e = SaferEventListener EventListener

{# pointer *GClosure newtype #}

data EventListener = EventListener (Ptr GClosure) (StablePtr (Ptr GObject -> Ptr GObject -> IO ()))

unEventListener (EventListener p _) = p

class EventListenerClass a where
  toEventListener :: a -> EventListener

instance EventListenerClass EventListener where
  toEventListener a = a

foreign import ccall unsafe "gtk2hs_closure_new"
  gtk2hs_closure_new :: StablePtr a -> IO (Ptr GClosure)

eventListenerNew :: EventClass event => (event -> IO ()) -> IO EventListener
eventListenerNew callback = do
  sptr <- newStablePtr action
  gclosurePtr <- gtk2hs_closure_new sptr
  return $ EventListener gclosurePtr sptr
  where action :: Ptr GObject -> Ptr GObject -> IO ()
        action obj1 obj2 =
          failOnGError $
          makeNewGObject (GObject, objectUnrefFromMainloop) (return obj2) >>= \obj2' ->
          makeNewGObject (GObject, objectUnrefFromMainloop) (return obj1) >>= \obj1' ->
          callback (unsafeCastGObject obj2')

eventListenerNewAsync :: EventClass event => (event -> IO ()) -> IO EventListener
eventListenerNewAsync = eventListenerNew

eventListenerNewSync :: EventClass event => (event -> IO ()) -> IO EventListener
eventListenerNewSync = eventListenerNew

foreign import ccall unsafe "g_closure_unref"
  g_closure_unref :: Ptr GClosure -> IO ()

eventListenerRelease :: EventListener -> IO ()
eventListenerRelease (EventListener gclosurePtr sptr) = do
  g_closure_unref gclosurePtr
  freeStablePtr sptr