module Control.Parallel.OpenCL.Context(
CLContext, CLContextProperty(..),
clCreateContext, clCreateContextFromType, clRetainContext, clReleaseContext,
clGetContextReferenceCount, clGetContextDevices, clGetContextProperties )
where
import Foreign(
Ptr, FunPtr, nullPtr, castPtr, alloca, allocaArray, peek, peekArray,
ptrToIntPtr, intPtrToPtr, withArray )
import Foreign.C.Types
import Foreign.C.String( CString, peekCString )
import Foreign.Storable( sizeOf )
import Control.Parallel.OpenCL.Types(
CLuint, CLint, CLDeviceType_, CLContextInfo_, CLContextProperty_, CLDeviceID,
CLContext, CLDeviceType, CLPlatformID, bitmaskFromFlags, getCLValue, getEnumCL,
whenSuccess, wrapCheckSuccess, wrapPError, wrapGetInfo )
type ContextCallback = CString -> Ptr () -> CSize -> Ptr () -> IO ()
foreign import CALLCONV "wrapper" wrapContextCallback ::
ContextCallback -> IO (FunPtr ContextCallback)
foreign import CALLCONV "clCreateContext" raw_clCreateContext ::
Ptr CLContextProperty_ -> CLuint -> Ptr CLDeviceID -> FunPtr ContextCallback ->
Ptr () -> Ptr CLint -> IO CLContext
foreign import CALLCONV "clCreateContextFromType" raw_clCreateContextFromType ::
Ptr CLContextProperty_ -> CLDeviceType_ -> FunPtr ContextCallback ->
Ptr () -> Ptr CLint -> IO CLContext
foreign import CALLCONV "clRetainContext" raw_clRetainContext ::
CLContext -> IO CLint
foreign import CALLCONV "clReleaseContext" raw_clReleaseContext ::
CLContext -> IO CLint
foreign import CALLCONV "clGetContextInfo" raw_clGetContextInfo ::
CLContext -> CLContextInfo_ -> CSize -> Ptr () -> Ptr CSize -> IO CLint
data CLContextProperties = CL_CONTEXT_PLATFORM_
| CL_GL_CONTEXT_KHR_
| CL_EGL_DISPLAY_KHR_
| CL_GLX_DISPLAY_KHR_
| CL_WGL_HDC_KHR_
| CL_CGL_SHAREGROUP_KHR_
instance Enum CLContextProperties where
fromEnum CL_CONTEXT_PLATFORM_ = 4228
fromEnum CL_GL_CONTEXT_KHR_ = 8200
fromEnum CL_EGL_DISPLAY_KHR_ = 8201
fromEnum CL_GLX_DISPLAY_KHR_ = 8202
fromEnum CL_WGL_HDC_KHR_ = 8203
fromEnum CL_CGL_SHAREGROUP_KHR_ = 8204
toEnum 4228 = CL_CONTEXT_PLATFORM_
toEnum 8200 = CL_GL_CONTEXT_KHR_
toEnum 8201 = CL_EGL_DISPLAY_KHR_
toEnum 8202 = CL_GLX_DISPLAY_KHR_
toEnum 8203 = CL_WGL_HDC_KHR_
toEnum 8204 = CL_CGL_SHAREGROUP_KHR_
toEnum unmatched = error ("CLContextProperties.toEnum: Cannot match " ++ show unmatched)
data CLContextProperty = CL_CONTEXT_PLATFORM CLPlatformID
| CL_CGL_SHAREGROUP_KHR (Ptr ())
| CL_GL_CONTEXT_KHR (Ptr ())
| CL_EGL_DISPLAY_KHR (Ptr ())
| CL_GLX_DISPLAY_KHR (Ptr ())
| CL_WGL_HDC_KHR (Ptr ())
deriving( Show )
packProperty :: CLContextProperty -> [CLContextProperty_]
packProperty (CL_CONTEXT_PLATFORM pid) = [ getCLValue CL_CONTEXT_PLATFORM_
, fromIntegral . ptrToIntPtr $ pid ]
packProperty (CL_CGL_SHAREGROUP_KHR ptr) = [ getCLValue CL_CGL_SHAREGROUP_KHR_
, fromIntegral . ptrToIntPtr $ ptr ]
packProperty (CL_GL_CONTEXT_KHR ptr) = [ getCLValue CL_GL_CONTEXT_KHR_
, fromIntegral . ptrToIntPtr $ ptr ]
packProperty (CL_EGL_DISPLAY_KHR ptr) = [ getCLValue CL_EGL_DISPLAY_KHR_
, fromIntegral . ptrToIntPtr $ ptr ]
packProperty (CL_GLX_DISPLAY_KHR ptr) = [ getCLValue CL_GLX_DISPLAY_KHR_
, fromIntegral . ptrToIntPtr $ ptr ]
packProperty (CL_WGL_HDC_KHR ptr) = [ getCLValue CL_WGL_HDC_KHR_
, fromIntegral . ptrToIntPtr $ ptr ]
packContextProperties :: [CLContextProperty] -> [CLContextProperty_]
packContextProperties [] = [0]
packContextProperties (x:xs) = packProperty x ++ packContextProperties xs
unpackContextProperties :: [CLContextProperty_] -> [CLContextProperty]
unpackContextProperties [] = error "non-exhaustive Context Property list"
unpackContextProperties [x]
| x == 0 = []
| otherwise = error "non-exhaustive Context Property list"
unpackContextProperties (x:y:xs) = let ys = unpackContextProperties xs
in case getEnumCL x of
CL_CONTEXT_PLATFORM_
-> CL_CONTEXT_PLATFORM
(intPtrToPtr . fromIntegral $ y) : ys
CL_CGL_SHAREGROUP_KHR_
-> CL_CGL_SHAREGROUP_KHR
(intPtrToPtr . fromIntegral $ y) : ys
CL_GL_CONTEXT_KHR_
-> CL_GL_CONTEXT_KHR
(intPtrToPtr . fromIntegral $ y) : ys
CL_EGL_DISPLAY_KHR_
-> CL_EGL_DISPLAY_KHR
(intPtrToPtr . fromIntegral $ y) : ys
CL_GLX_DISPLAY_KHR_
-> CL_GLX_DISPLAY_KHR
(intPtrToPtr . fromIntegral $ y) : ys
CL_WGL_HDC_KHR_
-> CL_WGL_HDC_KHR
(intPtrToPtr . fromIntegral $ y) : ys
mkContextCallback :: (String -> IO ()) -> ContextCallback
mkContextCallback f msg _ _ _ = peekCString msg >>= f
clCreateContext :: [CLContextProperty] -> [CLDeviceID] -> (String -> IO ())
-> IO CLContext
clCreateContext [] devs f = withArray devs $ \pdevs ->
wrapPError $ \perr -> do
fptr <- wrapContextCallback $ mkContextCallback f
raw_clCreateContext nullPtr cndevs pdevs fptr nullPtr perr
where
cndevs = fromIntegral . length $ devs
clCreateContext props devs f = withArray devs $ \pdevs ->
wrapPError $ \perr -> do
fptr <- wrapContextCallback $ mkContextCallback f
withArray (packContextProperties props) $ \pprops ->
raw_clCreateContext pprops cndevs pdevs fptr nullPtr perr
where
cndevs = fromIntegral . length $ devs
clCreateContextFromType :: [CLContextProperty] -> [CLDeviceType]
-> (String -> IO ()) -> IO CLContext
clCreateContextFromType [] xs f = wrapPError $ \perr -> do
fptr <- wrapContextCallback $ mkContextCallback f
raw_clCreateContextFromType nullPtr types fptr nullPtr perr
where
types = bitmaskFromFlags xs
clCreateContextFromType props xs f = wrapPError $ \perr -> do
fptr <- wrapContextCallback $ mkContextCallback f
withArray (packContextProperties props) $ \pprops ->
raw_clCreateContextFromType pprops types fptr nullPtr perr
where
types = bitmaskFromFlags xs
clRetainContext :: CLContext -> IO Bool
clRetainContext ctx = wrapCheckSuccess $ raw_clRetainContext ctx
clReleaseContext :: CLContext -> IO Bool
clReleaseContext ctx = wrapCheckSuccess $ raw_clReleaseContext ctx
getContextInfoSize :: CLContext -> CLContextInfo_ -> IO CSize
getContextInfoSize ctx infoid = alloca $ \(value_size :: Ptr CSize) -> do
whenSuccess (raw_clGetContextInfo ctx infoid 0 nullPtr value_size)
$ peek value_size
data CLContextInfo = CL_CONTEXT_REFERENCE_COUNT
| CL_CONTEXT_DEVICES
| CL_CONTEXT_PROPERTIES
instance Enum CLContextInfo where
fromEnum CL_CONTEXT_REFERENCE_COUNT = 4224
fromEnum CL_CONTEXT_DEVICES = 4225
fromEnum CL_CONTEXT_PROPERTIES = 4226
toEnum 4224 = CL_CONTEXT_REFERENCE_COUNT
toEnum 4225 = CL_CONTEXT_DEVICES
toEnum 4226 = CL_CONTEXT_PROPERTIES
toEnum unmatched = error ("CLContextInfo.toEnum: Cannot match " ++ show unmatched)
clGetContextReferenceCount :: CLContext -> IO CLuint
clGetContextReferenceCount ctx =
wrapGetInfo (\(dat :: Ptr CLuint) ->
raw_clGetContextInfo ctx infoid size (castPtr dat)) id
where
infoid = getCLValue CL_CONTEXT_REFERENCE_COUNT
size = fromIntegral $ sizeOf (0::CLuint)
clGetContextDevices :: CLContext -> IO [CLDeviceID]
clGetContextDevices ctx = do
size <- getContextInfoSize ctx infoid
let n = (fromIntegral size) `div` elemSize
allocaArray n $ \(buff :: Ptr CLDeviceID) -> do
whenSuccess (raw_clGetContextInfo ctx infoid size (castPtr buff) nullPtr)
$ peekArray n buff
where
infoid = getCLValue CL_CONTEXT_DEVICES
elemSize = sizeOf (nullPtr :: CLDeviceID)
clGetContextProperties :: CLContext -> IO [CLContextProperty]
clGetContextProperties ctx = do
size <- getContextInfoSize ctx infoid
let n = (fromIntegral size) `div` elemSize
if n == 0
then return []
else allocaArray n $ \(buff :: Ptr CLContextProperty_) ->
whenSuccess (raw_clGetContextInfo ctx infoid size (castPtr buff) nullPtr)
$ fmap unpackContextProperties $ peekArray n buff
where
infoid = getCLValue CL_CONTEXT_PROPERTIES
elemSize = sizeOf (nullPtr :: CLDeviceID)