build/create program functions

build/create program functions

-- -----------------------------------------------------------------------------
-- This file is part of Haskell-Opencl.

-- Haskell-Opencl is free software: you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.

-- Haskell-Opencl 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 General Public License for more details.

-- You should have received a copy of the GNU General Public License
-- along with Haskell-Opencl.  If not, see <http://www.gnu.org/licenses/>.
-- -----------------------------------------------------------------------------
{-# LANGUAGE ForeignFunctionInterface, ScopedTypeVariables #-}
module System.GPU.OpenCL.Program(
  -- * Types
  CLProgram,
  -- * Functions
  clCreateProgramWithSource, clRetainProgram, clReleaseProgram,
  clUnloadCompiler, clBuildProgram
  ) where

-- -----------------------------------------------------------------------------
import Foreign
import Foreign.C.Types
import Foreign.C.String( CString, withCString, newCString )
import System.GPU.OpenCL.Types(
  CLint, CLuint, CLProgram, CLContext, CLDeviceID, CLError(..),
  wrapCheckSuccess, wrapPError )

#include <CL/cl.h>

-- -----------------------------------------------------------------------------
type BuildCallback = CLProgram -> Ptr () -> IO ()
foreign import ccall "clCreateProgramWithSource" raw_clCreateProgramWithSource ::
  CLContext -> CLuint -> Ptr CString -> Ptr CSize -> Ptr CLint -> IO CLProgram
foreign import ccall "clCreateProgramWithBinary" raw_clCreateProgramWithBinary ::
  CLContext -> CLuint -> Ptr CLDeviceID -> Ptr CSize -> Ptr (Ptr Word8) -> Ptr CLint -> Ptr CLint -> IO CLProgram
foreign import ccall "clRetainProgram" raw_clRetainProgram ::
  CLProgram -> IO CLint
foreign import ccall "clReleaseProgram" raw_clReleaseProgram ::
  CLProgram -> IO CLint
foreign import ccall "clBuildProgram" raw_clBuildProgram ::
  CLProgram -> CLuint -> Ptr CLDeviceID -> CString -> FunPtr BuildCallback -> Ptr () -> IO CLint
foreign import ccall "clUnloadCompiler" raw_clUnloadCompiler ::
  IO CLint
foreign import ccall "clGetProgramInfo" raw_clGetProgramInfo ::
  CLProgram -> CLuint -> CSize -> Ptr () -> Ptr CSize -> IO CLint
foreign import ccall "clGetProgramBuildInfo"  raw_clGetProgramBuildInfo ::
  CLProgram -> CLuint -> CSize -> Ptr () -> Ptr CSize -> IO CLint

-- -----------------------------------------------------------------------------
clCreateProgramWithSource :: CLContext -> String -> IO (Either CLError CLProgram)
clCreateProgramWithSource ctx source = wrapPError $ \perr -> do
  let strings = lines source
      count = fromIntegral $ length strings
  cstrings <- mapM newCString strings
  prog <- withArray cstrings $ \srcArray -> do
    raw_clCreateProgramWithSource ctx count srcArray nullPtr perr
  mapM_ free cstrings
  return prog

-- | Increments the program reference count. 'clRetainProgram' returns 'True' if
-- the function is executed successfully. It returns 'False' if program is not a
-- valid program object.
clRetainProgram :: CLProgram -> IO Bool
clRetainProgram prg = wrapCheckSuccess $ raw_clRetainProgram prg

-- | Decrements the program reference count. The program object is deleted after
-- all kernel objects associated with program have been deleted and the program
-- reference count becomes zero. 'clReleseProgram' returns 'True' if
-- the function is executed successfully. It returns 'False' if program is not a
-- valid program object.
clReleaseProgram :: CLProgram -> IO Bool
clReleaseProgram prg = wrapCheckSuccess $ raw_clReleaseProgram prg

-- | Allows the implementation to release the resources allocated by the OpenCL
-- compiler. This is a hint from the application and does not guarantee that the
-- compiler will not be used in the future or that the compiler will actually be
-- unloaded by the implementation. Calls to 'clBuildProgram' after
-- 'clUnloadCompiler' will reload the compiler, if necessary, to build the
-- appropriate program executable.
clUnloadCompiler :: IO ()
clUnloadCompiler = raw_clUnloadCompiler >> return ()

{-| Builds (compiles and links) a program executable from the program source or
binary. OpenCL allows program executables to be built using the source or the
binary. The build options are categorized as pre-processor options, options for
math intrinsics, options that control optimization and miscellaneous
options. This specification defines a standard set of options that must be
supported by an OpenCL compiler when building program executables online or
offline. These may be extended by a set of vendor- or platform-specific options.

 * Preprocessor Options

These options control the OpenCL preprocessor which is run on each program
source before actual compilation. -D options are processed in the order they are
given in the options argument to clBuildProgram.

 [-D name] Predefine name as a macro, with definition 1.

 [-D name=definition] The contents of definition are tokenized and processed as
if they appeared during translation phase three in a `#define' directive. In
particular, the definition will be truncated by embedded newline characters.

 [-I dir] Add the directory dir to the list of directories to be searched for
header files.

 * Math Intrinsics Options

These options control compiler behavior regarding floating-point
arithmetic. These options trade off between speed and correctness.

 [-cl-single-precision-constant] Treat double precision floating-point constant
as single precision constant.

 [-cl-denorms-are-zero] This option controls how single precision and double
precision denormalized numbers are handled. If specified as a build option, the
single precision denormalized numbers may be flushed to zero and if the optional
extension for double precision is supported, double precision denormalized
numbers may also be flushed to zero. This is intended to be a performance hint
and the OpenCL compiler can choose not to flush denorms to zero if the device
supports single precision (or double precision) denormalized numbers.

This option is ignored for single precision numbers if the device does not
support single precision denormalized numbers i.e. 'CL_FP_DENORM' bit is not set
in 'CL_DEVICE_SINGLE_FP_CONFIG'.

This option is ignored for double precision numbers if the device does not
support double precision or if it does support double precison but
'CL_FP_DENORM' bit is not set in 'CL_DEVICE_DOUBLE_FP_CONFIG'.

This flag only applies for scalar and vector single precision floating-point
variables and computations on these floating-point variables inside a
program. It does not apply to reading from or writing to image objects.

 * Optimization Options

These options control various sorts of optimizations. Turning on optimization
flags makes the compiler attempt to improve the performance and/or code size at
the expense of compilation time and possibly the ability to debug the program.

 [-cl-opt-disable] This option disables all optimizations. The default is
optimizations are enabled.

 [-cl-strict-aliasing] This option allows the compiler to assume the strictest
aliasing rules.

The following options control compiler behavior regarding floating-point
arithmetic. These options trade off between performance and correctness and must
be specifically enabled. These options are not turned on by default since it can
result in incorrect output for programs which depend on an exact implementation
of IEEE 754 rules/specifications for math functions.

 [-cl-mad-enable] Allow a * b + c to be replaced by a mad. The mad computes a *
b + c with reduced accuracy. For example, some OpenCL devices implement mad as
truncate the result of a * b before adding it to c.

 [-cl-no-signed-zeros] Allow optimizations for floating-point arithmetic that
ignore the signedness of zero. IEEE 754 arithmetic specifies the behavior of
distinct +0.0 and -0.0 values, which then prohibits simplification of
expressions such as x+0.0 or 0.0*x (even with -clfinite-math only). This option
implies that the sign of a zero result isn't significant.

 [-cl-unsafe-math-optimizations] Allow optimizations for floating-point
arithmetic that (a) assume that arguments and results are valid, (b) may violate
IEEE 754 standard and (c) may violate the OpenCL numerical compliance
requirements as defined in section 7.4 for single-precision floating-point,
section 9.3.9 for double-precision floating-point, and edge case behavior in
section 7.5. This option includes the -cl-no-signed-zeros and -cl-mad-enable
options.

 [-cl-finite-math-only] Allow optimizations for floating-point arithmetic that
assume that arguments and results are not NaNs or ±∞. This option may violate
the OpenCL numerical compliance requirements defined in in section 7.4 for
single-precision floating-point, section 9.3.9 for double-precision
floating-point, and edge case behavior in section 7.5.

 [-cl-fast-relaxed-math] Sets the optimization options -cl-finite-math-only and
-cl-unsafe-math-optimizations. This allows optimizations for floating-point
arithmetic that may violate the IEEE 754 standard and the OpenCL numerical
compliance requirements defined in the specification in section 7.4 for
single-precision floating-point, section 9.3.9 for double-precision
floating-point, and edge case behavior in section 7.5. This option causes the
preprocessor macro __FAST_RELAXED_MATH__ to be defined in the OpenCL program.

 * Options to Request or Suppress Warnings

Warnings are diagnostic messages that report constructions which are not
inherently erroneous but which are risky or suggest there may have been an
error. The following languageindependent options do not enable specific warnings
but control the kinds of diagnostics produced by the OpenCL compiler.

 [-w] Inhibit all warning messages.

 [-Werror] Make all warnings into errors.

clBuildProgram returns the following errors when fails:

 * 'CL_INVALID_PROGRAM' if program is not a valid program object.

 * 'CL_INVALID_DEVICE' if OpenCL devices listed in device_list are not in the
list of devices associated with program.

 * 'CL_INVALID_BINARY' if program is created with
'clCreateWithProgramWithBinary' and devices listed in device_list do not have a
valid program binary loaded.

 * 'CL_INVALID_BUILD_OPTIONS' if the build options specified by options are
invalid.

 * 'CL_INVALID_OPERATION' if the build of a program executable for any of the
devices listed in device_list by a previous call to 'clBuildProgram' for program
has not completed.

 * 'CL_COMPILER_NOT_AVAILABLE' if program is created with
'clCreateProgramWithSource' and a compiler is not available
i.e. 'CL_DEVICE_COMPILER_AVAILABLE' specified in the table of OpenCL Device
Queries for 'clGetDeviceCompilerAvailable' is set to 'False'.

 * 'CL_BUILD_PROGRAM_FAILURE' if there is a failure to build the program
executable. This error will be returned if 'clBuildProgram' does not return
until the build has completed.

 * 'CL_INVALID_OPERATION' if there are kernel objects attached to program.

 * 'CL_OUT_OF_HOST_MEMORY' if there is a failure to allocate resources required
by the OpenCL implementation on the host.
-}
clBuildProgram :: CLProgram -> [CLDeviceID] -> String -> IO (Either CLError ())
clBuildProgram prg devs opts = allocaArray ndevs $ \pdevs -> do
  pokeArray pdevs devs
  withCString opts $ \copts -> do
    errcode <- raw_clBuildProgram prg cndevs pdevs copts nullFunPtr nullPtr
    if errcode == (fromIntegral . fromEnum $ CL_SUCCESS)
      then return $ Right ()
      else return . Left . toEnum . fromIntegral $ errcode
    where
      ndevs = length devs
      cndevs = fromIntegral ndevs

-- -----------------------------------------------------------------------------

-- -----------------------------------------------------------------------------
-- This file is part of Haskell-Opencl.

-- Haskell-Opencl is free software: you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.

-- Haskell-Opencl 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 General Public License for more details.

-- You should have received a copy of the GNU General Public License
-- along with Haskell-Opencl.  If not, see <http://www.gnu.org/licenses/>.
-- -----------------------------------------------------------------------------
{-# LANGUAGE ForeignFunctionInterface, ScopedTypeVariables #-}
module System.GPU.OpenCL.Program(
  -- * Types
  CLProgram
  ) where

-- -----------------------------------------------------------------------------
import Foreign
import Foreign.C.Types
import Foreign.C.String( CString )
import System.GPU.OpenCL.Types(
  CLint, CLuint, CLProgram, CLContext, CLDeviceID )

#include <CL/cl.h>

-- -----------------------------------------------------------------------------
type BuildCallback = CString -> Ptr () -> CSize -> Ptr () -> IO ()
foreign import ccall "wrapper" wrapBuildCallback ::
  BuildCallback -> IO (FunPtr BuildCallback)
foreign import ccall "clCreateProgramWithSource" raw_clCreateProgramWithSource ::
  CLContext -> CLuint -> Ptr CString -> Ptr CSize -> Ptr CLint -> IO CLProgram
foreign import ccall "clCreateProgramWithBinary" raw_clCreateProgramWithBinary ::
  CLContext -> CLuint -> Ptr CLDeviceID -> Ptr CSize -> Ptr (Ptr Word8) -> Ptr CLint -> Ptr CLint -> IO CLProgram
foreign import ccall "clRetainProgram" raw_clRetainProgram ::
  CLProgram -> IO CLint
foreign import ccall "clReleaseProgram" raw_clReleaseProgram ::
  CLProgram -> IO CLint
foreign import ccall "clBuildProgram" raw_clBuildProgram ::
  CLProgram -> CLuint -> Ptr CLDeviceID -> CString -> FunPtr BuildCallback -> Ptr () -> IO CLint
foreign import ccall "clUnloadCompiler" raw_clUnloadCompiler ::
  IO CLint
foreign import ccall "clGetProgramInfo" raw_clGetProgramInfo ::
  CLProgram -> CLuint -> CSize -> Ptr () -> Ptr CSize -> IO CLint
foreign import ccall "clGetProgramBuildInfo"  raw_clGetProgramBuildInfo ::
  CLProgram -> CLuint -> CSize -> Ptr () -> Ptr CSize -> IO CLint

-- -----------------------------------------------------------------------------


Check if the prog was linked with -threaded and if so fail on initialisation

-- -*-haskell-*-
--  GIMP Toolkit (GTK) General
--
--  Author : Axel Simon, Manuel M. T. Chakravarty
--
--  Created: 8 December 1998
--
--  Version $Revision: 1.13 $ from $Date: 2005/11/06 19:10:16 $
--
--  Copyright (C) 2000..2005 Axel Simon, Manuel M. T. Chakravarty
--
--  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.
--
-- TODO
--
-- quitAddDestroy, quitAdd, quitRemove
--
-- |
-- Maintainer  : gtk2hs-users@lists.sourceforge.net
-- Stability   : provisional
-- Portability : portable (depends on GHC)
--
-- library initialization, main event loop, and events
--
module Graphics.UI.Gtk.General.General (
--  getDefaultLanguage,
  initGUI,
  eventsPending,
  mainGUI,
  mainLevel,
  mainQuit,
  mainIteration,
  mainIterationDo,
  grabAdd,
  grabGetCurrent,
  grabRemove,
  Priority,
  priorityLow,
  priorityDefaultIdle,
  priorityHighIdle,
  priorityDefault,
  priorityHigh,
  timeoutAdd,
  timeoutAddFull,
  timeoutRemove,
  idleAdd,
  idleRemove,
  inputAdd,
  inputRemove,
  IOCondition,
  HandlerId
  ) where

import System.Environment (getProgName, getArgs)
import Control.Monad      (liftM, mapM, when)
import Control.Exception  (ioError, Exception(ErrorCall))
import Control.Concurrent (rtsSupportsBoundThreads)

import System.Glib.FFI
import System.Glib.UTFString
import System.Glib.GObject		(DestroyNotify, mkFunPtrDestroyNotify)
import System.Glib.MainLoop
import Graphics.UI.Gtk.Abstract.Object	(makeNewObject)
{#import Graphics.UI.Gtk.Types#}
{#import Graphics.UI.Gtk.Signals#}

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

{-
-- | Retreive the current language.
-- * This function returns a String which's pointer can be used later on for
--   comarisions.
--
--getDefaultLanguage :: IO String
--getDefaultLanguage = do
--  strPtr <- {#call unsafe get_default_language#}
--  str <- peekUTFString strPtr
--  destruct strPtr
--  return str
-}

-- We compile this module using -#includ"gtk/wingtk.h" to bypass the win32 abi
-- check however we do not compile users programs with this headder so if
-- initGUI was ever inlined in a users program, then that program would not
-- bypass the abi check and would fail on startup. So to stop that we must
-- prevent initGUI from being inlined.
{-# NOINLINE initGUI #-}
-- | Initialize the GUI binding.
--
-- * This function initialized the GUI toolkit and parses all Gtk
--   specific arguments. The remaining arguments are returned. If the
--   initialization of the toolkit fails for whatever reason, an exception
--   is thrown.
--
-- * Throws: @ErrorCall \"Cannot initialize GUI.\"@
--
initGUI :: IO [String]
initGUI = do
  when rtsSupportsBoundThreads
    (fail $ "initGUI: Gtk2Hs does not currently support the threaded RTS\n"
         ++ "see http://haskell.org/gtk2hs/archives/2005/07/24/writing-multi-threaded-guis/2/\n"
	 ++ "Please relink your program without using the '-threaded' flag.")
  prog <- getProgName
  args <- getArgs
  let allArgs = (prog:args)
  withMany withUTFString allArgs $ \addrs  ->
    withArrayLen       addrs   $ \argc argv ->
    with	       argv    $ \argvp ->
    with	       argc    $ \argcp -> do
      res <- {#call unsafe init_check#} (castPtr argcp) (castPtr argvp)
      if (toBool res) then do
        argc'   <- peek argcp
        argv'   <- peek argvp
        _:addrs'  <- peekArray argc' argv'  -- drop the program name
        mapM peekUTFString addrs'
        else error "Cannot initialize GUI."

-- | Inquire the number of events pending on the event queue
--
eventsPending :: IO Int
eventsPending  = liftM fromIntegral {#call unsafe events_pending#}

-- | Run the Gtk+ main event loop.
--
mainGUI :: IO ()
mainGUI  = {#call main#}

-- | Inquire the main loop level.
--
-- * Callbacks that take more time to process can call 'mainIteration' to keep
-- the GUI responsive. Each time the main loop is restarted this way, the main
-- loop counter is increased. This function returns this counter.
--
mainLevel :: IO Int
mainLevel  = liftM (toEnum.fromEnum) {#call unsafe main_level#}

-- | Exit the main event loop.
--
mainQuit :: IO ()
mainQuit  = {#call main_quit#}

-- | Process an event, block if necessary.
--
-- * Returns @True@ if 'mainQuit' was called while processing the event.
--
mainIteration :: IO Bool
mainIteration  = liftM toBool {#call main_iteration#}

-- | Process a single event.
--
-- * Called with @True@, this function behaves as 'mainIteration' in that it
-- waits until an event is available for processing. It will return
-- immediately, if passed @False@.
--
-- * Returns @True@ if the 'mainQuit' was called while processing the event.
--
mainIterationDo :: Bool -> IO Bool
mainIterationDo blocking =
  liftM toBool $ {#call main_iteration_do#} (fromBool blocking)

-- | add a grab widget
--
grabAdd :: WidgetClass wd => wd -> IO ()
grabAdd  = {#call grab_add#} . toWidget

-- | inquire current grab widget
--
grabGetCurrent :: IO (Maybe Widget)
grabGetCurrent  = do
  wPtr <- {#call grab_get_current#}
  if (wPtr==nullPtr) then return Nothing else
    liftM Just $ makeNewObject mkWidget (return wPtr)

-- | remove a grab widget
--
grabRemove :: WidgetClass w => w -> IO ()
grabRemove  = {#call grab_remove#} . toWidget

-- -*-haskell-*-
--  GIMP Toolkit (GTK) General
--
--  Author : Axel Simon, Manuel M. T. Chakravarty
--
--  Created: 8 December 1998
--
--  Version $Revision: 1.13 $ from $Date: 2005/11/06 19:10:16 $
--
--  Copyright (C) 2000..2005 Axel Simon, Manuel M. T. Chakravarty
--
--  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.
--
-- TODO
--
-- quitAddDestroy, quitAdd, quitRemove
--
-- |
-- Maintainer  : gtk2hs-users@lists.sourceforge.net
-- Stability   : provisional
-- Portability : portable (depends on GHC)
--
-- library initialization, main event loop, and events
--
module Graphics.UI.Gtk.General.General (
--  getDefaultLanguage,
  initGUI,
  eventsPending,
  mainGUI,
  mainLevel,
  mainQuit,
  mainIteration,
  mainIterationDo,
  grabAdd,
  grabGetCurrent,
  grabRemove,
  Priority,
  priorityLow,
  priorityDefaultIdle,
  priorityHighIdle,
  priorityDefault,
  priorityHigh,
  timeoutAdd,
  timeoutAddFull,
  timeoutRemove,
  idleAdd,
  idleRemove,
  inputAdd,
  inputRemove,
  IOCondition,
  HandlerId
  ) where

import System   (getProgName, getArgs)
import Monad	(liftM, mapM)
import Control.Exception (ioError, Exception(ErrorCall))

import System.Glib.FFI
import System.Glib.UTFString
import System.Glib.GObject		(DestroyNotify, mkFunPtrDestroyNotify)
import System.Glib.MainLoop
import Graphics.UI.Gtk.Abstract.Object	(makeNewObject)
{#import Graphics.UI.Gtk.Types#}
{#import Graphics.UI.Gtk.Signals#}

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

{-
-- | Retreive the current language.
-- * This function returns a String which's pointer can be used later on for
--   comarisions.
--
--getDefaultLanguage :: IO String
--getDefaultLanguage = do
--  strPtr <- {#call unsafe get_default_language#}
--  str <- peekUTFString strPtr
--  destruct strPtr
--  return str
-}

-- We compile this module using -#includ"gtk/wingtk.h" to bypass the win32 abi
-- check however we do not compile users programs with this headder so if
-- initGUI was ever inlined in a users program, then that program would not
-- bypass the abi check and would fail on startup. So to stop that we must
-- prevent initGUI from being inlined.
{-# NOINLINE initGUI #-}
-- | Initialize the GUI binding.
--
-- * This function initialized the GUI toolkit and parses all Gtk
--   specific arguments. The remaining arguments are returned. If the
--   initialization of the toolkit fails for whatever reason, an exception
--   is thrown.
--
-- * Throws: @ErrorCall \"Cannot initialize GUI.\"@
--
initGUI :: IO [String]
initGUI = do
  prog <- getProgName
  args <- getArgs
  let allArgs = (prog:args)
  withMany withUTFString allArgs $ \addrs  ->
    withArrayLen       addrs   $ \argc argv ->
    with	       argv    $ \argvp ->
    with	       argc    $ \argcp -> do
      res <- {#call unsafe init_check#} (castPtr argcp) (castPtr argvp)
      if (toBool res) then do
        argc'   <- peek argcp
        argv'   <- peek argvp
        _:addrs'  <- peekArray argc' argv'  -- drop the program name
        mapM peekUTFString addrs'
        else error "Cannot initialize GUI."

-- | Inquire the number of events pending on the event queue
--
eventsPending :: IO Int
eventsPending  = liftM fromIntegral {#call unsafe events_pending#}

-- | Run the Gtk+ main event loop.
--
mainGUI :: IO ()
mainGUI  = {#call main#}

-- | Inquire the main loop level.
--
-- * Callbacks that take more time to process can call 'mainIteration' to keep
-- the GUI responsive. Each time the main loop is restarted this way, the main
-- loop counter is increased. This function returns this counter.
--
mainLevel :: IO Int
mainLevel  = liftM (toEnum.fromEnum) {#call unsafe main_level#}

-- | Exit the main event loop.
--
mainQuit :: IO ()
mainQuit  = {#call main_quit#}

-- | Process an event, block if necessary.
--
-- * Returns @True@ if 'mainQuit' was called while processing the event.
--
mainIteration :: IO Bool
mainIteration  = liftM toBool {#call main_iteration#}

-- | Process a single event.
--
-- * Called with @True@, this function behaves as 'mainIteration' in that it
-- waits until an event is available for processing. It will return
-- immediately, if passed @False@.
--
-- * Returns @True@ if the 'mainQuit' was called while processing the event.
--
mainIterationDo :: Bool -> IO Bool
mainIterationDo blocking =
  liftM toBool $ {#call main_iteration_do#} (fromBool blocking)

-- | add a grab widget
--
grabAdd :: WidgetClass wd => wd -> IO ()
grabAdd  = {#call grab_add#} . toWidget

-- | inquire current grab widget
--
grabGetCurrent :: IO (Maybe Widget)
grabGetCurrent  = do
  wPtr <- {#call grab_get_current#}
  if (wPtr==nullPtr) then return Nothing else
    liftM Just $ makeNewObject mkWidget (return wPtr)

-- | remove a grab widget
--
grabRemove :: WidgetClass w => w -> IO ()
grabRemove  = {#call grab_remove#} . toWidget


UncommentGValueCharFunctions

UncommentGValueCharFunctions

-- -*-haskell-*-
--  GIMP Toolkit (GTK) GValueTypes
--
--  Author : Axel Simon
--
--  Created: 1 June 2001
--
--  Copyright (c) 1999..2002 Axel Simon
--
--  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)
--
-- This is used by the implementation of properties and by the
-- 'Graphics.UI.Gtk.TreeList.TreeModel' and
-- related modules.
--
module System.Glib.GValueTypes (
  valueSetUInt,
  valueGetUInt,
  valueSetInt,
  valueGetInt,
  valueSetUInt64,
  valueGetUInt64,
  valueSetInt64,
  valueGetInt64,
  valueSetUChar,
  valueGetUChar,
  valueSetChar,
  valueGetChar,
  valueSetBool,
  valueGetBool,
  valueSetPointer,
  valueGetPointer,
  valueSetFloat,
  valueGetFloat,
  valueSetDouble,
  valueGetDouble,
  valueSetEnum,
  valueGetEnum,
  valueSetFlags,
  valueGetFlags,
  valueSetString,
  valueGetString,
  valueSetMaybeString,
  valueGetMaybeString,
  valueSetBoxed,
  valueGetBoxed,
  valueSetGObject,
  valueGetGObject,
  valueSetMaybeGObject,
  valueGetMaybeGObject,
  ) where

import Control.Monad	(liftM)

import System.Glib.FFI
import System.Glib.Flags
import System.Glib.UTFString
{#import System.Glib.GValue#}		(GValue(GValue))
import System.Glib.GObject

{# context lib="glib" prefix="g" #}

valueSetUInt :: GValue -> Word -> IO ()
valueSetUInt gvalue value =
  {# call unsafe value_set_uint #} gvalue (fromIntegral value)

valueGetUInt :: GValue -> IO Word
valueGetUInt gvalue =
  liftM fromIntegral $
  {# call unsafe value_get_uint #} gvalue

valueSetInt :: GValue -> Int -> IO ()
valueSetInt gvalue value =
  {# call unsafe value_set_int #} gvalue (fromIntegral value)

valueGetInt :: GValue -> IO Int
valueGetInt gvalue =
  liftM fromIntegral $
  {# call unsafe value_get_int #} gvalue

valueSetUInt64 :: GValue -> Word64 -> IO ()
valueSetUInt64 gvalue value =
  {# call unsafe value_set_uint64 #} gvalue (fromIntegral value)

valueGetUInt64 :: GValue -> IO Word64
valueGetUInt64 gvalue =
  liftM fromIntegral $
  {# call unsafe value_get_uint64 #} gvalue

valueSetInt64 :: GValue -> Int64 -> IO ()
valueSetInt64 gvalue value =
  {# call unsafe value_set_int64 #} gvalue (fromIntegral value)

valueGetInt64 :: GValue -> IO Int64
valueGetInt64 gvalue =
  liftM fromIntegral $
  {# call unsafe value_get_int64 #} gvalue

valueSetUChar :: GValue -> Word8 -> IO ()
valueSetUChar gvalue value =
  {# call unsafe value_set_uchar #} gvalue (fromIntegral value)

valueGetUChar :: GValue -> IO Word8
valueGetUChar gvalue =
  liftM fromIntegral $ {# call unsafe value_get_uchar #} gvalue

--these belong somewhere else, are in new c2hs's C2HS module
cToEnum :: (Integral i, Enum e) => i -> e
cToEnum  = toEnum . fromIntegral

cFromEnum :: (Enum e, Integral i) => e -> i
cFromEnum  = fromIntegral . fromEnum

--valueSetChar :: GValue -> {#type gchar#} -> IO ()
valueSetChar :: GValue -> Char -> IO ()
valueSetChar gvalue value =
  {# call unsafe value_set_char #} gvalue (cFromEnum value)

--valueGetChar :: GValue -> IO {#type gchar#}
valueGetChar :: GValue -> IO Char
valueGetChar gvalue =
  liftM cToEnum $ {# call unsafe value_get_char #} gvalue

valueSetBool :: GValue -> Bool -> IO ()
valueSetBool gvalue value =
  {# call unsafe value_set_boolean #} gvalue (fromBool value)

valueGetBool :: GValue -> IO Bool
valueGetBool gvalue =
  liftM toBool $
  {# call  unsafe value_get_boolean #} gvalue

-- These functions should probably never be used as they are dangerous.
--
valueSetPointer :: GValue -> (Ptr ()) -> IO ()
valueSetPointer gvalue value =
  {# call unsafe value_set_pointer #} gvalue value

valueGetPointer :: GValue -> IO (Ptr ())
valueGetPointer gvalue =
  {# call unsafe value_get_pointer #} gvalue

valueSetFloat :: GValue -> Float -> IO ()
valueSetFloat gvalue value =
  {# call unsafe value_set_float #} gvalue (realToFrac value)

valueGetFloat :: GValue -> IO Float
valueGetFloat gvalue =
  liftM realToFrac $
  {# call unsafe value_get_float #} gvalue

valueSetDouble :: GValue -> Double -> IO ()
valueSetDouble gvalue value =
  {# call unsafe value_set_double #} gvalue (realToFrac value)

valueGetDouble :: GValue -> IO Double
valueGetDouble gvalue =
  liftM realToFrac $
  {# call unsafe value_get_double #} gvalue

valueSetEnum :: Enum enum => GValue -> enum -> IO ()
valueSetEnum gvalue value =
  {# call unsafe value_set_enum #} gvalue (fromIntegral $ fromEnum value)

valueGetEnum :: Enum enum => GValue -> IO enum
valueGetEnum gvalue =
  liftM (toEnum . fromIntegral) $
  {# call unsafe value_get_enum #} gvalue

valueSetFlags :: Flags flag => GValue -> [flag] -> IO ()
valueSetFlags gvalue value =
  {# call unsafe value_set_flags #} gvalue (fromIntegral $ fromFlags value)

valueGetFlags :: Flags flag => GValue -> IO [flag]
valueGetFlags gvalue =
  liftM (toFlags . fromIntegral) $
  {# call unsafe value_get_flags #} gvalue

valueSetString :: GValue -> String -> IO ()
valueSetString gvalue str =
  withUTFString str $ \strPtr ->
  {# call unsafe value_set_string #} gvalue strPtr

valueGetString :: GValue -> IO String
valueGetString gvalue = do
  strPtr <- {# call unsafe value_get_string #} gvalue
  if strPtr == nullPtr
    then return ""
    else peekUTFString strPtr

valueSetMaybeString :: GValue -> Maybe String -> IO ()
valueSetMaybeString gvalue (Just str) =
  withUTFString str $ \strPtr ->
  {# call unsafe value_set_string #} gvalue strPtr

valueSetMaybeString gvalue Nothing =
  {# call unsafe value_set_static_string #} gvalue nullPtr

valueGetMaybeString :: GValue -> IO (Maybe String)
valueGetMaybeString gvalue =
  {# call unsafe value_get_string #} gvalue
  >>= maybePeek peekUTFString

valueSetBoxed :: (boxed -> (Ptr boxed -> IO ()) -> IO ()) -> GValue -> boxed -> IO ()
valueSetBoxed with gvalue boxed =
  with boxed $ \boxedPtr -> do
  {# call unsafe g_value_set_boxed #} gvalue (castPtr boxedPtr)

valueGetBoxed :: (Ptr boxed -> IO boxed) -> GValue -> IO boxed
valueGetBoxed peek gvalue =
  {# call unsafe g_value_get_boxed #} gvalue >>= peek . castPtr

-- for some weird reason the API says that gv is a gpointer, not a GObject
--
valueSetGObject :: GObjectClass gobj => GValue -> gobj -> IO ()
valueSetGObject gvalue obj =
  withForeignPtr ((unGObject.toGObject) obj) $ \objPtr ->
    {# call unsafe g_value_set_object #} gvalue (castPtr objPtr)

-- Unsafe because it performs an unchecked downcast. Only for internal use.
--
valueGetGObject :: GObjectClass gobj => GValue -> IO gobj
valueGetGObject gvalue =
  liftM unsafeCastGObject $
  makeNewGObject mkGObject $
  throwIfNull "GValue.valueGetObject: extracting invalid object" $
  liftM castPtr $
  {# call unsafe value_get_object #} gvalue

valueSetMaybeGObject :: GObjectClass gobj => GValue -> (Maybe gobj) -> IO ()
valueSetMaybeGObject gvalue (Just obj) = valueSetGObject gvalue obj
valueSetMaybeGObject gvalue Nothing =
    {# call unsafe g_value_set_object #} gvalue nullPtr

valueGetMaybeGObject :: GObjectClass gobj => GValue -> IO (Maybe gobj)
valueGetMaybeGObject gvalue =
  liftM (liftM unsafeCastGObject) $
  maybeNull (makeNewGObject mkGObject) $
  liftM castPtr $
  {# call unsafe value_get_object #} gvalue

-- -*-haskell-*-
--  GIMP Toolkit (GTK) GValueTypes
--
--  Author : Axel Simon
--
--  Created: 1 June 2001
--
--  Copyright (c) 1999..2002 Axel Simon
--
--  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)
--
-- This is used by the implementation of properties and by the
-- 'Graphics.UI.Gtk.TreeList.TreeModel' and
-- related modules.
--
module System.Glib.GValueTypes (
  valueSetUInt,
  valueGetUInt,
  valueSetInt,
  valueGetInt,
  valueSetUInt64,
  valueGetUInt64,
  valueSetInt64,
  valueGetInt64,
--  valueSetUChar,
--  valueGetUChar,
--  valueSetChar,
--  valueGetChar,
  valueSetBool,
  valueGetBool,
  valueSetPointer,
  valueGetPointer,
  valueSetFloat,
  valueGetFloat,
  valueSetDouble,
  valueGetDouble,
  valueSetEnum,
  valueGetEnum,
  valueSetFlags,
  valueGetFlags,
  valueSetString,
  valueGetString,
  valueSetMaybeString,
  valueGetMaybeString,
  valueSetBoxed,
  valueGetBoxed,
  valueSetGObject,
  valueGetGObject,
  valueSetMaybeGObject,
  valueGetMaybeGObject,
  ) where

import Control.Monad	(liftM)

import System.Glib.FFI
import System.Glib.Flags
import System.Glib.UTFString
{#import System.Glib.GValue#}		(GValue(GValue))
import System.Glib.GObject

{# context lib="glib" prefix="g" #}

valueSetUInt :: GValue -> Word -> IO ()
valueSetUInt gvalue value =
  {# call unsafe value_set_uint #} gvalue (fromIntegral value)

valueGetUInt :: GValue -> IO Word
valueGetUInt gvalue =
  liftM fromIntegral $
  {# call unsafe value_get_uint #} gvalue

valueSetInt :: GValue -> Int -> IO ()
valueSetInt gvalue value =
  {# call unsafe value_set_int #} gvalue (fromIntegral value)

valueGetInt :: GValue -> IO Int
valueGetInt gvalue =
  liftM fromIntegral $
  {# call unsafe value_get_int #} gvalue

valueSetUInt64 :: GValue -> Word64 -> IO ()
valueSetUInt64 gvalue value =
  {# call unsafe value_set_uint64 #} gvalue (fromIntegral value)

valueGetUInt64 :: GValue -> IO Word64
valueGetUInt64 gvalue =
  liftM fromIntegral $
  {# call unsafe value_get_uint64 #} gvalue

valueSetInt64 :: GValue -> Int64 -> IO ()
valueSetInt64 gvalue value =
  {# call unsafe value_set_int64 #} gvalue (fromIntegral value)

valueGetInt64 :: GValue -> IO Int64
valueGetInt64 gvalue =
  liftM fromIntegral $
  {# call unsafe value_get_int64 #} gvalue

{-
valueSetUChar :: GValue -> Word8 -> IO ()
valueSetUChar gvalue value =
  {# call unsafe value_set_uchar #} gvalue value

valueGetUChar :: GValue -> IO Word8
valueGetUChar gvalue =
  {# call unsafe value_get_uchar #} gvalue

valueSetChar :: GValue -> {#type gchar#} -> IO ()
valueSetChar gvalue value =
  {# call unsafe value_set_char #} gvalue value

valueGetChar :: GValue -> IO {#type gchar#}
valueGetChar gvalue =
  {# call unsafe value_get_char #} gvalue
-}

valueSetBool :: GValue -> Bool -> IO ()
valueSetBool gvalue value =
  {# call unsafe value_set_boolean #} gvalue (fromBool value)

valueGetBool :: GValue -> IO Bool
valueGetBool gvalue =
  liftM toBool $
  {# call  unsafe value_get_boolean #} gvalue

-- These functions should probably never be used as they are dangerous.
--
valueSetPointer :: GValue -> (Ptr ()) -> IO ()
valueSetPointer gvalue value =
  {# call unsafe value_set_pointer #} gvalue value

valueGetPointer :: GValue -> IO (Ptr ())
valueGetPointer gvalue =
  {# call unsafe value_get_pointer #} gvalue

valueSetFloat :: GValue -> Float -> IO ()
valueSetFloat gvalue value =
  {# call unsafe value_set_float #} gvalue (realToFrac value)

valueGetFloat :: GValue -> IO Float
valueGetFloat gvalue =
  liftM realToFrac $
  {# call unsafe value_get_float #} gvalue

valueSetDouble :: GValue -> Double -> IO ()
valueSetDouble gvalue value =
  {# call unsafe value_set_double #} gvalue (realToFrac value)

valueGetDouble :: GValue -> IO Double
valueGetDouble gvalue =
  liftM realToFrac $
  {# call unsafe value_get_double #} gvalue

valueSetEnum :: Enum enum => GValue -> enum -> IO ()
valueSetEnum gvalue value =
  {# call unsafe value_set_enum #} gvalue (fromIntegral $ fromEnum value)

valueGetEnum :: Enum enum => GValue -> IO enum
valueGetEnum gvalue =
  liftM (toEnum . fromIntegral) $
  {# call unsafe value_get_enum #} gvalue

valueSetFlags :: Flags flag => GValue -> [flag] -> IO ()
valueSetFlags gvalue value =
  {# call unsafe value_set_flags #} gvalue (fromIntegral $ fromFlags value)

valueGetFlags :: Flags flag => GValue -> IO [flag]
valueGetFlags gvalue =
  liftM (toFlags . fromIntegral) $
  {# call unsafe value_get_flags #} gvalue

valueSetString :: GValue -> String -> IO ()
valueSetString gvalue str =
  withUTFString str $ \strPtr ->
  {# call unsafe value_set_string #} gvalue strPtr

valueGetString :: GValue -> IO String
valueGetString gvalue = do
  strPtr <- {# call unsafe value_get_string #} gvalue
  if strPtr == nullPtr
    then return ""
    else peekUTFString strPtr

valueSetMaybeString :: GValue -> Maybe String -> IO ()
valueSetMaybeString gvalue (Just str) =
  withUTFString str $ \strPtr ->
  {# call unsafe value_set_string #} gvalue strPtr

valueSetMaybeString gvalue Nothing =
  {# call unsafe value_set_static_string #} gvalue nullPtr

valueGetMaybeString :: GValue -> IO (Maybe String)
valueGetMaybeString gvalue =
  {# call unsafe value_get_string #} gvalue
  >>= maybePeek peekUTFString

valueSetBoxed :: (boxed -> (Ptr boxed -> IO ()) -> IO ()) -> GValue -> boxed -> IO ()
valueSetBoxed with gvalue boxed =
  with boxed $ \boxedPtr -> do
  {# call unsafe g_value_set_boxed #} gvalue (castPtr boxedPtr)

valueGetBoxed :: (Ptr boxed -> IO boxed) -> GValue -> IO boxed
valueGetBoxed peek gvalue =
  {# call unsafe g_value_get_boxed #} gvalue >>= peek . castPtr

-- for some weird reason the API says that gv is a gpointer, not a GObject
--
valueSetGObject :: GObjectClass gobj => GValue -> gobj -> IO ()
valueSetGObject gvalue obj =
  withForeignPtr ((unGObject.toGObject) obj) $ \objPtr ->
    {# call unsafe g_value_set_object #} gvalue (castPtr objPtr)

-- Unsafe because it performs an unchecked downcast. Only for internal use.
--
valueGetGObject :: GObjectClass gobj => GValue -> IO gobj
valueGetGObject gvalue =
  liftM unsafeCastGObject $
  makeNewGObject mkGObject $
  throwIfNull "GValue.valueGetObject: extracting invalid object" $
  liftM castPtr $
  {# call unsafe value_get_object #} gvalue

valueSetMaybeGObject :: GObjectClass gobj => GValue -> (Maybe gobj) -> IO ()
valueSetMaybeGObject gvalue (Just obj) = valueSetGObject gvalue obj
valueSetMaybeGObject gvalue Nothing =
    {# call unsafe g_value_set_object #} gvalue nullPtr

valueGetMaybeGObject :: GObjectClass gobj => GValue -> IO (Maybe gobj)
valueGetMaybeGObject gvalue =
  liftM (liftM unsafeCastGObject) $
  maybeNull (makeNewGObject mkGObject) $
  liftM castPtr $
  {# call unsafe value_get_object #} gvalue


Allocate a number of elements of storable type

Ignore-this: cfaff0d90d5147d8e29ce74131c3dde9
- Changes from allocated a specific number of bytes. This matches the behaviour
  of the FFI, rather the standard C-like behaviour.

darcs-hash:20091216111720-9241b-265acb706d96ccf961713812d16dea463b6c084a.gz

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

module Foreign.CUDA.Driver.Marshal
  (
    DevicePtr, HostPtr, AllocFlag(..), withHostPtr,
    malloc, free, mallocHost, freeHost,
    peekArray, peekArrayAsync, pokeArray, pokeArrayAsync, memset,
    getDevicePtr
  )
  where

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

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

-- System
import Foreign                           hiding (peekArray, pokeArray, malloc, free)
import Foreign.C
import Control.Monad                            (liftM)
import Unsafe.Coerce

#c
typedef enum CUmemhostalloc_option_enum {
    CU_MEMHOSTALLOC_OPTION_PORTABLE       = CU_MEMHOSTALLOC_PORTABLE,
    CU_MEMHOSTALLOC_OPTION_DEVICE_MAPPED  = CU_MEMHOSTALLOC_DEVICEMAP,
    CU_MEMHOSTALLOC_OPTION_WRITE_COMBINED = CU_MEMHOSTALLOC_WRITECOMBINED
} CUmemhostalloc_option;
#endc

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

-- |
-- A reference to memory allocated on the device
--
newtype DevicePtr a = DevicePtr { useDevicePtr :: {# type CUdeviceptr #}}

instance Storable (DevicePtr a) where
  sizeOf _      = sizeOf    (undefined :: {# type CUdeviceptr #})
  alignment _   = alignment (undefined :: {# type CUdeviceptr #})
  peek p        = DevicePtr `fmap` peek (castPtr p)
  poke p v      = poke (castPtr p) (useDevicePtr v)

-- |
-- A reference to memory on the host that is page-locked and directly-accessible
-- from the device. Since the memory can be accessed directly, it can be read or
-- written at a much higher bandwidth than pageable memory from the traditional
-- malloc.
--
-- The driver automatically accelerates calls to functions such as `memcpy'
-- which reference page-locked memory.
--
newtype HostPtr a = HostPtr (ForeignPtr a)

withHostPtr :: HostPtr a -> (Ptr a -> IO b) -> IO b
withHostPtr (HostPtr hptr) = withForeignPtr hptr

newHostPtr :: IO (HostPtr a)
newHostPtr = HostPtr `fmap` mallocForeignPtrBytes (sizeOf (undefined :: Ptr ()))

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

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

-- |
-- 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.
--
-- 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.
--
mallocHost :: Storable a => [AllocFlag] -> Int -> IO (HostPtr a)
mallocHost flags = doMalloc undefined
  where
    doMalloc :: Storable a' => a' -> Int -> IO (HostPtr a')
    doMalloc x n =
      newHostPtr >>= \hp -> withHostPtr hp $ \p ->
      cuMemHostAlloc p (n * sizeOf x) flags >>= nothingIfOk >>
      return hp

{# fun unsafe cuMemHostAlloc
  { with'* `Ptr a'
  ,        `Int'
  , combineBitMasks `[AllocFlag]' } -> `Status' cToEnum #}
  where with' = with . castPtr

-- |
-- Free a section of page-locked host memory
--
freeHost :: HostPtr a -> IO ()
freeHost hp = withHostPtr hp $ \p -> (nothingIfOk =<< cuMemFreeHost p)

{# fun unsafe cuMemFreeHost
  { castPtr `Ptr a' } -> `Status' cToEnum #}

--------------------------------------------------------------------------------
-- 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 suitably aligned for any type, and is not cleared.
--
malloc :: Storable a => Int -> IO (DevicePtr a)
malloc = doMalloc undefined
  where
    doMalloc :: Storable a' => a' -> Int -> IO (DevicePtr a')
    doMalloc x n = resultIfOk =<< cuMemAlloc (n * sizeOf x)

{# fun unsafe cuMemAlloc
  { alloca-  `DevicePtr a' dptr*
  ,          `Int'               } -> `Status' cToEnum #}
  where dptr = liftM DevicePtr . peek

-- |
-- Release a section of device memory
--
free :: DevicePtr a -> IO ()
free dp = nothingIfOk =<< cuMemFree dp

{# fun unsafe cuMemFree
  { useDevicePtr `DevicePtr a' } -> `Status' cToEnum #}

--------------------------------------------------------------------------------
-- Transfer
--------------------------------------------------------------------------------

-- |
-- 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 = doPeek undefined dptr
  where
    doPeek :: Storable a' => a' -> DevicePtr a' -> IO ()
    doPeek x _ = nothingIfOk =<< cuMemcpyDtoH hptr dptr (n * sizeOf x)

{# fun unsafe cuMemcpyDtoH
  { castPtr      `Ptr a'
  , useDevicePtr `DevicePtr a'
  ,              `Int'         } -> `Status' cToEnum #}

-- |
-- Copy memory from the device asynchronously, possibly associated with a
-- particular stream. The destination host memory must be page-locked (allocated
-- by mallocHost)
--
peekArrayAsync :: Storable a => Int -> DevicePtr a -> Ptr a -> Maybe Stream -> IO ()
peekArrayAsync n dptr hptr mst = doPeek undefined dptr
  where
    doPeek :: Storable a' => a' -> DevicePtr a' -> IO ()
    doPeek x _ =
      nothingIfOk =<< case mst of
        Nothing -> cuMemcpyDtoHAsync hptr dptr (n * sizeOf x) (Stream nullPtr)
        Just st -> cuMemcpyDtoHAsync hptr dptr (n * sizeOf x) st

{# fun unsafe cuMemcpyDtoHAsync
  { castPtr      `Ptr a'
  , useDevicePtr `DevicePtr a'
  ,              `Int'
  , useStream    `Stream'  } -> `Status' cToEnum #}

-- |
-- 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 = doPoke undefined dptr
  where
    doPoke :: Storable a' => a' -> DevicePtr a' -> IO ()
    doPoke x _ = nothingIfOk =<< cuMemcpyHtoD dptr hptr (n * sizeOf x)

{# fun unsafe cuMemcpyHtoD
  { useDevicePtr `DevicePtr a'
  , castPtr      `Ptr a'
  ,              `Int'         } -> `Status' cToEnum #}

-- |
-- Copy memory onto the device asynchronously, possibly associated with a
-- particular stream. The source host memory must be page-locked (allocated by
-- mallocHost)
--
pokeArrayAsync :: Storable a => Int -> Ptr a -> DevicePtr a -> Maybe Stream -> IO ()
pokeArrayAsync n hptr dptr mst = dopoke undefined dptr
  where
    dopoke :: Storable a' => a' -> DevicePtr a' -> IO ()
    dopoke x _ =
      nothingIfOk =<< case mst of
        Nothing -> cuMemcpyHtoDAsync dptr hptr (n * sizeOf x) (Stream nullPtr)
        Just st -> cuMemcpyHtoDAsync dptr hptr (n * sizeOf x) st

{# fun unsafe cuMemcpyHtoDAsync
  { useDevicePtr `DevicePtr a'
  , castPtr      `Ptr a'
  ,              `Int'
  , useStream    `Stream'  } -> `Status' cToEnum #}

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

-- |
-- Set a number of data elements to the specified value, which may be either 8-,
-- 16-, or 32-bits wide.
--
memset :: Storable a => DevicePtr a -> Int -> a -> IO ()
memset dptr n val = case sizeOf val of
    1 -> nothingIfOk =<< cuMemsetD8  dptr val n
    2 -> nothingIfOk =<< cuMemsetD16 dptr val n
    4 -> nothingIfOk =<< cuMemsetD32 dptr val n
    _ -> cudaError "can only memset 8-, 16-, and 32-bit values"

--
-- We use unsafe coerce below to reinterpret the bits of the value to memset as,
-- into the integer type required by the setting functions.
--
{# fun unsafe cuMemsetD8
  { useDevicePtr `DevicePtr a'
  , unsafeCoerce `a'
  ,              `Int'         } -> `Status' cToEnum #}

{# fun unsafe cuMemsetD16
  { useDevicePtr `DevicePtr a'
  , unsafeCoerce `a'
  ,              `Int'         } -> `Status' cToEnum #}

{# fun unsafe cuMemsetD32
  { useDevicePtr `DevicePtr a'
  , unsafeCoerce `a'
  ,              `Int'         } -> `Status' cToEnum #}

-- |
-- Return the device pointer associated with a mapped, pinned host buffer, which
-- was allocated with the DEVICE_MAPPED option.
--
-- Currently, no options are supported and this must be empty.
--
getDevicePtr :: [AllocFlag] -> HostPtr a -> IO (DevicePtr a)
getDevicePtr flags hptr = withHostPtr hptr $ \hp -> (resultIfOk =<< cuMemHostGetDevicePointer hp flags)

{# fun unsafe cuMemHostGetDevicePointer
  { alloca-         `DevicePtr a' dptr*
  , castPtr         `Ptr a'
  , combineBitMasks `[AllocFlag]'       } -> `Status' cToEnum #}
  where dptr = liftM DevicePtr . peek

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

module Foreign.CUDA.Driver.Marshal
  (
    DevicePtr, HostPtr, AllocFlag(..), withHostPtr,
    malloc, free, mallocHost, freeHost,
    peekArray, peekArrayAsync, pokeArray, pokeArrayAsync, memset,
    getDevicePtr
  )
  where

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

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

-- System
import Foreign                           hiding (peekArray, pokeArray, malloc, free)
import Foreign.C
import Control.Monad                            (liftM)
import Unsafe.Coerce

#c
typedef enum CUmemhostalloc_option_enum {
    CU_MEMHOSTALLOC_OPTION_PORTABLE       = CU_MEMHOSTALLOC_PORTABLE,
    CU_MEMHOSTALLOC_OPTION_DEVICE_MAPPED  = CU_MEMHOSTALLOC_DEVICEMAP,
    CU_MEMHOSTALLOC_OPTION_WRITE_COMBINED = CU_MEMHOSTALLOC_WRITECOMBINED
} CUmemhostalloc_option;
#endc

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

-- |
-- A reference to memory allocated on the device
--
newtype DevicePtr a = DevicePtr { useDevicePtr :: {# type CUdeviceptr #}}

instance Storable (DevicePtr a) where
  sizeOf _      = sizeOf    (undefined :: {# type CUdeviceptr #})
  alignment _   = alignment (undefined :: {# type CUdeviceptr #})
  peek p        = DevicePtr `fmap` peek (castPtr p)
  poke p v      = poke (castPtr p) (useDevicePtr v)

-- |
-- A reference to memory on the host that is page-locked and directly-accessible
-- from the device. Since the memory can be accessed directly, it can be read or
-- written at a much higher bandwidth than pageable memory from the traditional
-- malloc.
--
-- The driver automatically accelerates calls to functions such as `memcpy'
-- which reference page-locked memory.
--
newtype HostPtr a = HostPtr (ForeignPtr a)

withHostPtr :: HostPtr a -> (Ptr a -> IO b) -> IO b
withHostPtr (HostPtr hptr) = withForeignPtr hptr

newHostPtr :: IO (HostPtr a)
newHostPtr = HostPtr `fmap` mallocForeignPtrBytes (sizeOf (undefined :: Ptr ()))

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

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

-- |
-- Allocate a section of linear memory on the host which is page-locked and
-- directly accessible from the device. 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.
--
mallocHost :: [AllocFlag] -> Int -> IO (HostPtr a)
mallocHost flags bytes =
  newHostPtr >>= \hp -> withHostPtr hp $ \p ->
  cuMemHostAlloc p bytes flags >>= nothingIfOk >>
  return hp

{# fun unsafe cuMemHostAlloc
  { with'* `Ptr a'
  ,        `Int'
  , combineBitMasks `[AllocFlag]' } -> `Status' cToEnum #}
  where with' = with . castPtr

-- |
-- Free a section of page-locked host memory
--
freeHost :: HostPtr a -> IO ()
freeHost hp = withHostPtr hp $ \p -> (nothingIfOk =<< cuMemFreeHost p)

{# fun unsafe cuMemFreeHost
  { castPtr `Ptr a' } -> `Status' cToEnum #}

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

-- |
-- Allocate a section of linear memory on the device, and return a reference to
-- it. The memory is suitably aligned for any type, and is not cleared.
--
malloc :: Int -> IO (DevicePtr a)
malloc bytes = resultIfOk =<< cuMemAlloc bytes

{# fun unsafe cuMemAlloc
  { alloca-  `DevicePtr a' dptr*
  ,          `Int'               } -> `Status' cToEnum #}
  where dptr = liftM DevicePtr . peek

-- |
-- Release a section of device memory
--
free :: DevicePtr a -> IO ()
free dp = nothingIfOk =<< cuMemFree dp

{# fun unsafe cuMemFree
  { useDevicePtr `DevicePtr a' } -> `Status' cToEnum #}

--------------------------------------------------------------------------------
-- Transfer
--------------------------------------------------------------------------------

-- |
-- 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 = doPeek undefined dptr
  where
    doPeek :: Storable a' => a' -> DevicePtr a' -> IO ()
    doPeek x _ = nothingIfOk =<< cuMemcpyDtoH hptr dptr (n * sizeOf x)

{# fun unsafe cuMemcpyDtoH
  { castPtr      `Ptr a'
  , useDevicePtr `DevicePtr a'
  ,              `Int'         } -> `Status' cToEnum #}

-- |
-- Copy memory from the device asynchronously, possibly associated with a
-- particular stream. The destination host memory must be page-locked (allocated
-- by mallocHost)
--
peekArrayAsync :: Storable a => Int -> DevicePtr a -> Ptr a -> Maybe Stream -> IO ()
peekArrayAsync n dptr hptr mst = doPeek undefined dptr
  where
    doPeek :: Storable a' => a' -> DevicePtr a' -> IO ()
    doPeek x _ =
      nothingIfOk =<< case mst of
        Nothing -> cuMemcpyDtoHAsync hptr dptr (n * sizeOf x) (Stream nullPtr)
        Just st -> cuMemcpyDtoHAsync hptr dptr (n * sizeOf x) st

{# fun unsafe cuMemcpyDtoHAsync
  { castPtr      `Ptr a'
  , useDevicePtr `DevicePtr a'
  ,              `Int'
  , useStream    `Stream'  } -> `Status' cToEnum #}

-- |
-- 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 = doPoke undefined dptr
  where
    doPoke :: Storable a' => a' -> DevicePtr a' -> IO ()
    doPoke x _ = nothingIfOk =<< cuMemcpyHtoD dptr hptr (n * sizeOf x)

{# fun unsafe cuMemcpyHtoD
  { useDevicePtr `DevicePtr a'
  , castPtr      `Ptr a'
  ,              `Int'         } -> `Status' cToEnum #}

-- |
-- Copy memory onto the device asynchronously, possibly associated with a
-- particular stream. The source host memory must be page-locked (allocated by
-- mallocHost)
--
pokeArrayAsync :: Storable a => Int -> Ptr a -> DevicePtr a -> Maybe Stream -> IO ()
pokeArrayAsync n hptr dptr mst = dopoke undefined dptr
  where
    dopoke :: Storable a' => a' -> DevicePtr a' -> IO ()
    dopoke x _ =
      nothingIfOk =<< case mst of
        Nothing -> cuMemcpyHtoDAsync dptr hptr (n * sizeOf x) (Stream nullPtr)
        Just st -> cuMemcpyHtoDAsync dptr hptr (n * sizeOf x) st

{# fun unsafe cuMemcpyHtoDAsync
  { useDevicePtr `DevicePtr a'
  , castPtr      `Ptr a'
  ,              `Int'
  , useStream    `Stream'  } -> `Status' cToEnum #}

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

-- |
-- Set a number of data elements to the specified value, which may be either 8-,
-- 16-, or 32-bits wide.
--
memset :: Storable a => DevicePtr a -> Int -> a -> IO ()
memset dptr n val = case sizeOf val of
    1 -> nothingIfOk =<< cuMemsetD8  dptr val n
    2 -> nothingIfOk =<< cuMemsetD16 dptr val n
    4 -> nothingIfOk =<< cuMemsetD32 dptr val n
    _ -> cudaError "can only memset 8-, 16-, and 32-bit values"

--
-- We use unsafe coerce below to reinterpret the bits of the value to memset as,
-- into the integer type required by the setting functions.
--
{# fun unsafe cuMemsetD8
  { useDevicePtr `DevicePtr a'
  , unsafeCoerce `a'
  ,              `Int'         } -> `Status' cToEnum #}

{# fun unsafe cuMemsetD16
  { useDevicePtr `DevicePtr a'
  , unsafeCoerce `a'
  ,              `Int'         } -> `Status' cToEnum #}

{# fun unsafe cuMemsetD32
  { useDevicePtr `DevicePtr a'
  , unsafeCoerce `a'
  ,              `Int'         } -> `Status' cToEnum #}

-- |
-- Return the device pointer associated with a mapped, pinned host buffer, which
-- was allocated with the DEVICE_MAPPED option.
--
-- Currently, no options are supported and this must be empty.
--
getDevicePtr :: [AllocFlag] -> HostPtr a -> IO (DevicePtr a)
getDevicePtr flags hptr = withHostPtr hptr $ \hp -> (resultIfOk =<< cuMemHostGetDevicePointer hp flags)

{# fun unsafe cuMemHostGetDevicePointer
  { alloca-         `DevicePtr a' dptr*
  , castPtr         `Ptr a'
  , combineBitMasks `[AllocFlag]'       } -> `Status' cToEnum #}
  where dptr = liftM DevicePtr . peek


some fixme notes

some fixme notes

Ignore-this: ff98e0d71c907cba59a92b153947e11b

darcs-hash:20100610144843-dcabc-d811e74493d71526b7fc95bba94bb3e899010fca.gz

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

module Foreign.CUDA.Driver.Texture
  (
    Texture(..), AddressMode(..), FilterMode(..), Format,
    create, destroy,
    getPtr, getAddressMode, getFilterMode,
    setPtr, setAddressMode, setFilterMode, setFormat,

    -- Internal
    peekTex
  )
  where

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

-- Friends
import Foreign.CUDA.Ptr
import Foreign.CUDA.Driver.Error
import Foreign.CUDA.Driver.Marshal
import Foreign.CUDA.Internal.C2HS

-- System
import Foreign
import Foreign.C
import Control.Monad

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

-- |A texture reference
--
newtype Texture a = Texture { useTexture :: {# type CUtexref #}}

instance Storable (Texture a) where
  sizeOf _    = sizeOf    (undefined :: {# type CUtexref #})
  alignment _ = alignment (undefined :: {# type CUtexref #})
  peek p      = Texture `fmap` peek (castPtr p)
  poke p t    = poke (castPtr p) (useTexture t)

-- |Texture reference addressing modes
--
{# enum CUaddress_mode as AddressMode
  { underscoreToCase }
  with prefix="CU_TR_ADDRESS_MODE" deriving (Eq, Show) #}

-- |Texture reference filtering mode
--
{# enum CUfilter_mode as FilterMode
  { underscoreToCase }
  with prefix="CU_TR_FILTER_MODE" deriving (Eq, Show) #}

-- |Texture read mode options
--
#c
typedef enum CUtexture_flag_enum {
  CU_TEXTURE_FLAG_READ_AS_INTEGER        = CU_TRSF_READ_AS_INTEGER,
  CU_TEXTURE_FLAG_NORMALIZED_COORDINATES = CU_TRSF_NORMALIZED_COORDINATES
} CUtexture_flag;
#endc

{# enum CUtexture_flag as ReadMode
  { underscoreToCase }
  with prefix="CU_TEXTURE_FLAG" deriving (Eq, Show) #}

-- |Texture data formats
--
{# enum CUarray_format as TextureFormat
  { }
  with prefix="CU_AD_FORMAT" deriving (Eq, Show) #}

class Format a where
  tag      :: a -> Int
  channels :: a -> Int
  channels _ = 1

instance Format Word   where tag _ = fromEnum UNSIGNED_INT32
instance Format Word8  where tag _ = fromEnum UNSIGNED_INT8
instance Format Word16 where tag _ = fromEnum UNSIGNED_INT16
instance Format Word32 where tag _ = fromEnum UNSIGNED_INT32

instance Format Int    where tag _ = fromEnum SIGNED_INT32
instance Format Int8   where tag _ = fromEnum SIGNED_INT8
instance Format Int16  where tag _ = fromEnum SIGNED_INT16
instance Format Int32  where tag _ = fromEnum SIGNED_INT32

instance Format Float  where tag _ = fromEnum FLOAT
instance Format Double where
  tag _      = fromEnum SIGNED_INT32
  channels _ = 2
  -- __hiloint2double()

-- FIXME:
--  * half (16-bit float)
--  * vector types
--  * A Int or Word on the GPU is 32-bits, but this may not be the same bitwidth
--    as Haskell-side computations.
--

--------------------------------------------------------------------------------
-- Texture management
--------------------------------------------------------------------------------

-- |Create a new texture reference. Once created, the application must call
-- 'setPtr' to associate the reference with allocated memory. Other texture
-- reference functions are used to specify the format and interpretation to be
-- used when the memory is read through this reference.
--
create :: Format a => IO (Texture a)
create = do
  tex <- resultIfOk =<< cuTexRefCreate
  setFormat tex
  return tex

{# fun unsafe cuTexRefCreate
  { alloca- `Texture a' peekTex* } -> `Status' cToEnum #}

-- |Destroy a texture reference
--
destroy :: Texture a -> IO ()
destroy tex = nothingIfOk =<< cuTexRefDestroy tex

{# fun unsafe cuTexRefDestroy
  { useTexture `Texture a' } -> `Status' cToEnum #}

-- |Get the address associated with a texture reference
--
getPtr :: Texture a -> IO (DevicePtr a)
getPtr tex = resultIfOk =<< cuTexRefGetAddress tex

{# fun unsafe cuTexRefGetAddress
  { alloca-    `DevicePtr a' peekDevPtr*
  , useTexture `Texture a'               } -> `Status' cToEnum #}

-- |Get the addressing mode used by a texture reference, corresponding to the
-- given dimension (currently the only supported dimension values are 0 or 1).
--
getAddressMode :: Texture a -> Int -> IO AddressMode
getAddressMode tex dim = resultIfOk =<< cuTexRefGetAddressMode tex dim

{# fun unsafe cuTexRefGetAddressMode
  { alloca-    `AddressMode' peekEnum*
  , useTexture `Texture a'
  ,            `Int'                  } -> `Status' cToEnum #}

-- |Get the filtering mode used by a texture reference
--
getFilterMode :: Texture a -> IO FilterMode
getFilterMode tex = resultIfOk =<< cuTexRefGetFilterMode tex

{# fun unsafe cuTexRefGetFilterMode
  { alloca-    `FilterMode' peekEnum*
  , useTexture `Texture a'            } -> `Status' cToEnum #}

{-
-- |Get the data format and number of channel components of the bound texture
--
getFormat :: Texture a -> IO (Format, Int)
getFormat tex = do
  (status,fmt,dim) <- cuTexRefGetFormat tex
  resultIfOk (status,(fmt,dim))

{# fun unsafe cuTexRefGetFormat
  { alloca-    `Format'    peekEnum*
  , alloca-    `Int'       peekIntConv*
  , useTexture `Texture a'              } -> `Status' cToEnum #}
-}

-- |Bind a linear array address of the given size (bytes) as a texture
-- reference. Any previously bound references are unbound.
--
setPtr :: Texture a -> DevicePtr a -> Int -> IO ()
setPtr tex dptr bytes = nothingIfOk =<< cuTexRefSetAddress tex dptr bytes

{# fun unsafe cuTexRefSetAddress
  { alloca-         `Int'
  , useTexture      `Texture a'
  , useDeviceHandle `DevicePtr a'
  ,                 `Int'         } -> `Status' cToEnum #}

-- |Specify the addressing mode for the given dimension of a texture reference
--
setAddressMode :: Texture a -> Int -> AddressMode -> IO ()
setAddressMode tex dim mode = nothingIfOk =<< cuTexRefSetAddressMode tex dim mode

{# fun unsafe cuTexRefSetAddressMode
  { useTexture `Texture a'
  ,            `Int'
  , cFromEnum  `AddressMode' } -> `Status' cToEnum #}

-- |Specify the filtering mode to be used when reading memory through a texture
-- reference
--
setFilterMode :: Texture a -> FilterMode -> IO ()
setFilterMode tex mode = nothingIfOk =<< cuTexRefSetFilterMode tex mode

{# fun unsafe cuTexRefSetFilterMode
  { useTexture `Texture a'
  , cFromEnum  `FilterMode' } -> `Status' cToEnum #}

-- |Specify the format of the data to be read by the texture reference
--
setFormat :: Format a => Texture a -> IO ()
setFormat tex = doSet undefined tex
  where
    doSet :: Format b => b -> Texture b -> IO ()
    doSet fmt _ = nothingIfOk =<< cuTexRefSetFormat tex (tag fmt) (channels fmt)

{# fun unsafe cuTexRefSetFormat
  { useTexture `Texture a'
  ,            `Int'
  ,            `Int'       } -> `Status' cToEnum #}

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

peekTex :: Ptr {# type CUtexref #} -> IO (Texture a)
peekTex = liftM Texture . peek

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

module Foreign.CUDA.Driver.Texture
  (
    Texture(..), AddressMode(..), FilterMode(..), Format,
    create, destroy,
    getPtr, getAddressMode, getFilterMode,
    setPtr, setAddressMode, setFilterMode, setFormat,

    -- Internal
    peekTex
  )
  where

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

-- Friends
import Foreign.CUDA.Ptr
import Foreign.CUDA.Driver.Error
import Foreign.CUDA.Driver.Marshal
import Foreign.CUDA.Internal.C2HS

-- System
import Foreign
import Foreign.C
import Control.Monad

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

-- |A texture reference
--
newtype Texture a = Texture { useTexture :: {# type CUtexref #}}

instance Storable (Texture a) where
  sizeOf _    = sizeOf    (undefined :: {# type CUtexref #})
  alignment _ = alignment (undefined :: {# type CUtexref #})
  peek p      = Texture `fmap` peek (castPtr p)
  poke p t    = poke (castPtr p) (useTexture t)

-- |Texture reference addressing modes
--
{# enum CUaddress_mode as AddressMode
  { underscoreToCase }
  with prefix="CU_TR_ADDRESS_MODE" deriving (Eq, Show) #}

-- |Texture reference filtering mode
--
{# enum CUfilter_mode as FilterMode
  { underscoreToCase }
  with prefix="CU_TR_FILTER_MODE" deriving (Eq, Show) #}

-- |Texture read mode options
--
#c
typedef enum CUtexture_flag_enum {
  CU_TEXTURE_FLAG_READ_AS_INTEGER        = CU_TRSF_READ_AS_INTEGER,
  CU_TEXTURE_FLAG_NORMALIZED_COORDINATES = CU_TRSF_NORMALIZED_COORDINATES
} CUtexture_flag;
#endc

{# enum CUtexture_flag as ReadMode
  { underscoreToCase }
  with prefix="CU_TEXTURE_FLAG" deriving (Eq, Show) #}

-- |Texture data formats
--
{# enum CUarray_format as TextureFormat
  { }
  with prefix="CU_AD_FORMAT" deriving (Eq, Show) #}

class Format a where
  tag      :: a -> Int
  channels :: a -> Int
  channels _ = 1

instance Format Word   where tag _ = fromEnum UNSIGNED_INT32
instance Format Word8  where tag _ = fromEnum UNSIGNED_INT8
instance Format Word16 where tag _ = fromEnum UNSIGNED_INT16
instance Format Word32 where tag _ = fromEnum UNSIGNED_INT32

instance Format Int    where tag _ = fromEnum SIGNED_INT32
instance Format Int8   where tag _ = fromEnum SIGNED_INT8
instance Format Int16  where tag _ = fromEnum SIGNED_INT16
instance Format Int32  where tag _ = fromEnum SIGNED_INT32

instance Format Float  where tag _ = fromEnum FLOAT
instance Format Double where
  tag _      = fromEnum SIGNED_INT32
  channels _ = 2
  -- __hiloint2double()

-- FIXME: half (16-bit float) ??
-- FIXME: vector types ??

--------------------------------------------------------------------------------
-- Texture management
--------------------------------------------------------------------------------

-- |Create a new texture reference. Once created, the application must call
-- 'setPtr' to associate the reference with allocated memory. Other texture
-- reference functions are used to specify the format and interpretation to be
-- used when the memory is read through this reference.
--
create :: Format a => IO (Texture a)
create = do
  tex <- resultIfOk =<< cuTexRefCreate
  setFormat tex
  return tex

{# fun unsafe cuTexRefCreate
  { alloca- `Texture a' peekTex* } -> `Status' cToEnum #}

-- |Destroy a texture reference
--
destroy :: Texture a -> IO ()
destroy tex = nothingIfOk =<< cuTexRefDestroy tex

{# fun unsafe cuTexRefDestroy
  { useTexture `Texture a' } -> `Status' cToEnum #}

-- |Get the address associated with a texture reference
--
getPtr :: Texture a -> IO (DevicePtr a)
getPtr tex = resultIfOk =<< cuTexRefGetAddress tex

{# fun unsafe cuTexRefGetAddress
  { alloca-    `DevicePtr a' peekDevPtr*
  , useTexture `Texture a'               } -> `Status' cToEnum #}

-- |Get the addressing mode used by a texture reference, corresponding to the
-- given dimension (currently the only supported dimension values are 0 or 1).
--
getAddressMode :: Texture a -> Int -> IO AddressMode
getAddressMode tex dim = resultIfOk =<< cuTexRefGetAddressMode tex dim

{# fun unsafe cuTexRefGetAddressMode
  { alloca-    `AddressMode' peekEnum*
  , useTexture `Texture a'
  ,            `Int'                  } -> `Status' cToEnum #}

-- |Get the filtering mode used by a texture reference
--
getFilterMode :: Texture a -> IO FilterMode
getFilterMode tex = resultIfOk =<< cuTexRefGetFilterMode tex

{# fun unsafe cuTexRefGetFilterMode
  { alloca-    `FilterMode' peekEnum*
  , useTexture `Texture a'            } -> `Status' cToEnum #}

{-
-- |Get the data format and number of channel components of the bound texture
--
getFormat :: Texture a -> IO (Format, Int)
getFormat tex = do
  (status,fmt,dim) <- cuTexRefGetFormat tex
  resultIfOk (status,(fmt,dim))

{# fun unsafe cuTexRefGetFormat
  { alloca-    `Format'    peekEnum*
  , alloca-    `Int'       peekIntConv*
  , useTexture `Texture a'              } -> `Status' cToEnum #}
-}

-- |Bind a linear array address of the given size (bytes) as a texture
-- reference. Any previously bound references are unbound.
--
setPtr :: Texture a -> DevicePtr a -> Int -> IO ()
setPtr tex dptr bytes = nothingIfOk =<< cuTexRefSetAddress tex dptr bytes

{# fun unsafe cuTexRefSetAddress
  { alloca-         `Int'
  , useTexture      `Texture a'
  , useDeviceHandle `DevicePtr a'
  ,                 `Int'         } -> `Status' cToEnum #}

-- |Specify the addressing mode for the given dimension of a texture reference
--
setAddressMode :: Texture a -> Int -> AddressMode -> IO ()
setAddressMode tex dim mode = nothingIfOk =<< cuTexRefSetAddressMode tex dim mode

{# fun unsafe cuTexRefSetAddressMode
  { useTexture `Texture a'
  ,            `Int'
  , cFromEnum  `AddressMode' } -> `Status' cToEnum #}

-- |Specify the filtering mode to be used when reading memory through a texture
-- reference
--
setFilterMode :: Texture a -> FilterMode -> IO ()
setFilterMode tex mode = nothingIfOk =<< cuTexRefSetFilterMode tex mode

{# fun unsafe cuTexRefSetFilterMode
  { useTexture `Texture a'
  , cFromEnum  `FilterMode' } -> `Status' cToEnum #}

-- |Specify the format of the data to be read by the texture reference
--
setFormat :: Format a => Texture a -> IO ()
setFormat tex = doSet undefined tex
  where
    doSet :: Format b => b -> Texture b -> IO ()
    doSet fmt _ = nothingIfOk =<< cuTexRefSetFormat tex (tag fmt) (channels fmt)

{# fun unsafe cuTexRefSetFormat
  { useTexture `Texture a'
  ,            `Int'
  ,            `Int'       } -> `Status' cToEnum #}

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

peekTex :: Ptr {# type CUtexref #} -> IO (Texture a)
peekTex = liftM Texture . peek