CLGLBuffer.hs

{-# LANGUAGE ScopedTypeVariables #-}
module Rendering.CLGLBuffer where
import Control.Parallel.CLUtil
import Foreign.Ptr (nullPtr)
import Foreign.Storable (Storable(sizeOf))
import Graphics.GLUtil.BufferObjects
import Graphics.Rendering.OpenGL (deleteObjectName, BufferObject, BufferTarget(..))
import Rendering.CLGLInterop

data CLGLBuffer a = CLGLBuffer { asVBO      :: BufferObject
                               , asCLBuffer :: CLBuffer a }

allocCLGLBuffer :: forall a. Storable a => Int -> CL (CLGLBuffer a)
allocCLGLBuffer n = do vbo <- liftIO $ fromPtr ArrayBuffer numBytes nullPtr
                       _ <- registerCleanup $ deleteObjectName vbo
                       buf <- bufferFromGL vbo
                       return $ CLGLBuffer vbo buf
  where numBytes = n * sizeOf (undefined::a)

instance HasCLMem (CLGLBuffer a) where
  getCLMem = getCLMem . asCLBuffer

CLGLImage.hs

{-# LANGUAGE ConstraintKinds, DataKinds, ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Rendering.CLGLImage where
import Control.Parallel.CLUtil
import Control.Parallel.CLUtil.Image
import Data.Proxy
import Graphics.GLUtil.Textures
import Graphics.GLUtil.TypeMapping
import Graphics.Rendering.OpenGL (deleteObjectName, TextureObject)
import qualified Graphics.Rendering.OpenGL as GL
import Rendering.CLGLInterop

data CLGLImage n a = CLGLImage { asTexture :: TextureObject
                               , asImage   :: CLImage n a }

-- | A 'CLGLImage' with one channel per pixel.
type CLGLImage1 = CLGLImage OneChan

-- | A 'CLGLImage' with two channels per pixel.
type CLGLImage2 = CLGLImage TwoChan

-- | A 'CLGLImage' with three channels per pixel.
type CLGLImage3 = CLGLImage ThreeChan

-- | A 'CLGLImage' with four channels per pixel.
type CLGLImage4 = CLGLImage FourChan

allocCLGLImage :: forall n b. (HasGLType b, ValidImage n b)
               => Int -> Int -> CL (CLGLImage n b)
allocCLGLImage w h = do t <- liftIO $ freshTexture w h colors pixType
                        _ <- registerCleanup $ deleteObjectName t
                        img <- imageFromGL2D t
                        return $ CLGLImage t img
  where colors = case numChan (Proxy::Proxy n) of
                   1 -> TexMono
                   2 -> TexRG
                   3 -> TexRGB
                   4 -> TexRGBA
                   _ -> error $ "No texture pixel format compatible "++
                                "with desired CLImage type"
        pixType = Proxy::Proxy b

instance HasCLMem (CLGLImage n a) where
  getCLMem = getCLMem . asImage

instance HasGLType HalfFloat where glType _ = GL.HalfFloat

CLGLInterop.hs

{-# LANGUAGE ForeignFunctionInterface, ScopedTypeVariables #-}
module Rendering.CLGLInterop (initFromGL, bufferFromGL, imageFromGL2D,
                              withGLObjects, withGLObjectsT) where
import Control.Monad.Trans.Class
import Control.Parallel.CLUtil
import Control.Parallel.CLUtil.Async (waitReleaseEvent)
import Foreign.Marshal.Alloc (alloca)
import Foreign.Ptr (nullPtr, Ptr)
import Foreign.Storable (Storable(peek, sizeOf))
import Graphics.Rendering.OpenGL
import Graphics.Rendering.OpenGL.Raw.Core31
import Unsafe.Coerce

-- Mac OS X OpenCL-OpenGL interop
foreign import ccall "CGLGetCurrentContext"
  cGLGetCurrentContext :: IO (Ptr ())

foreign import ccall "CGLGetShareGroup"
  cGLGetShareGroup :: Ptr () -> IO (Ptr ())

initFromGL :: CLDeviceType -> IO OpenCLState
initFromGL devType = 
  do dev:_ <- clGetDeviceIDs nullPtr devType
     shareGroup <- cGLGetCurrentContext >>= cGLGetShareGroup
     context <- clCreateContext [CL_CGL_SHAREGROUP_KHR shareGroup]
                                [dev]
                                putStrLn
     q <- clCreateCommandQueue context dev []
     return $ OpenCLState dev context q

imageFromGL2D :: TextureObject -> CL (CLImage n a)
imageFromGL2D tex =
  do c <- clContext `fmap` ask
     img <- liftIO $ 
       do textureBinding Texture2D $= Just tex
          TextureSize2D w h <- get $ textureSize2D Texture2D 0
          textureBinding Texture2D $= Nothing
          flush
          CLImage (fromIntegral w, fromIntegral h, 1) `fmap`
            clCreateFromGLTexture2D c [CL_MEM_READ_WRITE] 
                                    gl_TEXTURE_2D (0::CInt) t
     _ <- registerCleanup $ clReleaseMemObject (imageObject img) >> return ()
     return img
  where t = unsafeCoerce tex :: GLuint

bufferFromGL :: forall a. Storable a => BufferObject -> CL (CLBuffer a)
bufferFromGL bo = 
  do c <- clContext `fmap` ask
     buf <- liftIO $
       do bindBuffer ArrayBuffer $= Just bo
          n <- alloca $ \ptr ->
            do glGetBufferParameteriv gl_ARRAY_BUFFER gl_BUFFER_SIZE ptr
               peek ptr :: IO GLint
          bindBuffer ArrayBuffer $= Nothing
          flush
          CLBuffer (fromIntegral n `quot` sizeOf (undefined::a)) `fmap`
            clCreateFromGLBuffer c [CL_MEM_READ_WRITE] b
     _ <- registerCleanup $ clReleaseMemObject (bufferObject buf) >> return ()
     return buf
  where b = unsafeCoerce bo :: GLuint

withGLObjects :: [CLMem] -> CL r -> CL r
withGLObjects obs m = 
  do q <- clQueue `fmap` ask
     liftIO $ clEnqueueAcquireGLObjects q obs [] >>= waitReleaseEvent
     r <- m
     liftIO $ clEnqueueReleaseGLObjects q obs [] >>= waitReleaseEvent
     return r

withGLObjectsT :: (MonadTrans t, Monad (t CL)) => [CLMem] -> t CL r -> t CL r
withGLObjectsT obs m =
  do q <- lift $ clQueue `fmap` ask
     lift . liftIO $ clEnqueueAcquireGLObjects q obs [] >>= waitReleaseEvent
     r <- m
     lift . liftIO $ clEnqueueReleaseGLObjects q obs [] >>= waitReleaseEvent
     return r