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( CSize )
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_
instance Enum CLContextProperties where
fromEnum CL_CONTEXT_PLATFORM_ = 4228
toEnum 4228 = CL_CONTEXT_PLATFORM_
toEnum unmatched = error ("CLContextProperties.toEnum: Cannot match " ++ show unmatched)
data CLContextProperty = CL_CONTEXT_PLATFORM CLPlatformID
deriving( Show )
packContextProperties :: [CLContextProperty] -> [CLContextProperty_]
packContextProperties [] = [0]
packContextProperties (CL_CONTEXT_PLATFORM pid : xs) = getCLValue CL_CONTEXT_PLATFORM_
: (fromIntegral . ptrToIntPtr $ pid)
: 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
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)