module Foreign.OpenCL.Bindings.Context (
createContext , createContextFromType, contextDevices, contextProperties, ContextCallback(..)
) where
import Control.Monad
import Foreign
import Foreign.C.Types
import Foreign.C.String
import Foreign.OpenCL.Bindings.Internal.Types
import Foreign.OpenCL.Bindings.Internal.Finalizers
import Foreign.OpenCL.Bindings.Internal.Error
import Foreign.OpenCL.Bindings.Internal.Util
import Foreign.OpenCL.Bindings.Internal.Logging as Log
data ContextCallback a where
NoContextCallback :: ContextCallback ()
ContextCallback :: Storable a => a -> (String -> a -> IO ()) -> ContextCallback a
createContext :: [DeviceID]
-> [ContextProperties]
-> ContextCallback a
-> IO Context
createContext devs props callback =
withArray0 0 (flattenContextProps props) $ \pps ->
withArray devs $ \devp ->
alloca $ \ep -> do
Log.debug "Invoking clCreateContext"
let ndev = fromIntegral $ length devs
ctx <- case callback of
NoContextCallback ->
clCreateContext pps ndev devp nullFunPtr nullPtr ep
ContextCallback user_data fn ->
with user_data $ \user_data_ptr -> do
let ud_ptr = castPtr user_data_ptr :: Ptr ()
cb_funptr <- mkCallback fn
clCreateContext pps ndev devp cb_funptr ud_ptr ep
checkClError_ "clCreateContext" =<< peek ep
attachFinalizer ctx
createContextFromType :: DeviceType
-> [ContextProperties]
-> ContextCallback a
-> IO Context
createContextFromType devtype properties callback =
withArray0 0 (flattenContextProps properties) $ \props ->
alloca $ \ep -> do
let typ_num = (fromIntegral $ fromEnum devtype)
ctx <- case callback of
NoContextCallback -> clCreateContextFromType
props typ_num
nullFunPtr nullPtr ep
ContextCallback user_data fn ->
with user_data $ \user_data_ptr -> do
let ud_ptr = castPtr user_data_ptr :: Ptr ()
cb_funptr <- mkCallback fn
clCreateContextFromType props typ_num cb_funptr ud_ptr ep
checkClError_ "clCreateContextFromType" =<< peek ep
attachFinalizer ctx
mkCallback :: Storable a
=> (String -> a -> IO ())
-> IO (FunPtr (Ptr CChar -> Ptr () -> ClSize -> Ptr () -> IO ()))
mkCallback fn = wrapCallback $
\errinfo _ _ user_data_ptr -> do
err_str <- peekCAString errinfo
user_data <- peek (castPtr user_data_ptr)
fn err_str user_data
foreign import CALLCONV "wrapper" wrapCallback ::
(Ptr CChar -> Ptr () -> ClSize -> Ptr () -> IO ())
-> IO (FunPtr (Ptr CChar -> Ptr () -> ClSize -> Ptr () -> IO ()))
flattenContextProps :: Num a => [ContextProperties] -> [a]
flattenContextProps = concatMap flatten
where
flatten (ContextPlatform p) = [ fromIntegral $ fromEnum ClContextPlatform
, fromIntegral $ ptrToWordPtr p]
contextDevices :: Context -> IO [DeviceID]
contextDevices context =
withForeignPtr context $ \ctx ->
getInfo (clGetContextInfo_ ctx) ContextDevices
contextProperties :: Context -> IO [ContextProperties]
contextProperties context =
withForeignPtr context $ \ctx ->
alloca $ \sp -> do
_ <- clGetContextInfo_ ctx (fromIntegral $ fromEnum ContextProperties) 0 nullPtr sp
size <- peek sp
allocaBytes (fromIntegral size) $ \pp -> do
_ <- clGetContextInfo_ ctx (fromIntegral $ fromEnum ContextProperties) (fromIntegral size) pp sp
size' <- peek sp
when (size /= fromIntegral size') $ error "Context properties size mismatch"
let n = fromIntegral size `div` sizeOf (undefined :: (CLong))
return . assembleProps =<< peekArray n (castPtr pp)
where
assembleProps :: [Int] -> [ContextProperties]
assembleProps [] = []
assembleProps (x:_) | x == 0 = []
assembleProps (x:xs) = let (y, xs') = assemble (toEnum x) xs
in y : assembleProps xs'
assemble _ [] = error "Unexpected end of context property list"
assemble ClContextPlatform (x:xs') =
let p = ContextPlatform . wordPtrToPtr $ fromIntegral x
in (p, xs')
clGetContextInfo_ = checkClError5 "clGetContextInfo"
clGetContextInfo
foreign import ccall safe "Foreign/OpenCL/Bindings/Context.chs.h clCreateContext"
clCreateContext :: ((Ptr CLong) -> (CUInt -> ((Ptr (DeviceID)) -> ((FunPtr ((Ptr CChar) -> ((Ptr ()) -> (CULong -> ((Ptr ()) -> (IO ())))))) -> ((Ptr ()) -> ((Ptr CInt) -> (IO (Ptr (CContext)))))))))
foreign import ccall safe "Foreign/OpenCL/Bindings/Context.chs.h clCreateContextFromType"
clCreateContextFromType :: ((Ptr CLong) -> (CULLong -> ((FunPtr ((Ptr CChar) -> ((Ptr ()) -> (CULong -> ((Ptr ()) -> (IO ())))))) -> ((Ptr ()) -> ((Ptr CInt) -> (IO (Ptr (CContext))))))))
foreign import ccall unsafe "Foreign/OpenCL/Bindings/Context.chs.h clGetContextInfo"
clGetContextInfo :: ((Ptr (CContext)) -> (CUInt -> (CULong -> ((Ptr ()) -> ((Ptr CULong) -> (IO CInt))))))