diff --git a/OpenCL.cabal b/OpenCL.cabal --- a/OpenCL.cabal +++ b/OpenCL.cabal @@ -1,5 +1,5 @@ Name: OpenCL -Version: 1.0.3.1 +Version: 1.0.3.2 License: BSD3 License-File: LICENSE Author: Luis Cabellos @@ -34,7 +34,7 @@ Build-tools: c2hs hs-Source-Dirs: src ghc-options: -Wall - Build-Depends: base >=4.0 && < 5, bytestring -any, mtl==2.0.* + Build-Depends: base >=4.0 && < 5, bytestring -any, mtl==2.* Exposed-Modules: Control.Parallel.OpenCL Control.Parallel.OpenCL.Query @@ -58,7 +58,15 @@ Frameworks: OpenCL if os(windows) - cpp-options: -DCALLCONV=stdcall + cpp-options: -DCALLCONV=stdcall -Iinclude + include-dirs: include + -- this is needed for linking executables, but not for ghci -lOpenCL: + extra-libraries: OpenCL + -- NOTE: if extra-libraries fails without finding library! Yo can use: + --ghc-options: -lOpenCL + --ld-options: -lOpenCL + -- NOTE: include-dirs without -Iinclude seems to fail too with GHC 7.4.1! + Test-suite tests type: exitcode-stdio-1.0 diff --git a/README.org b/README.org --- a/README.org +++ b/README.org @@ -36,10 +36,10 @@ There is an simple working example in the examples folder. You can create an executable using: - : ghc --make -lOpenCL examples/example01.hs + : ghc --make examples/example01.hs ** Using ghci It's possible to use GHCi with OpenCL, e.g.: - : ghci -lOpenCL examples/example01.hs + : ghci examples/example01.hs diff --git a/src/Control/Parallel/OpenCL/Context.chs b/src/Control/Parallel/OpenCL/Context.chs --- a/src/Control/Parallel/OpenCL/Context.chs +++ b/src/Control/Parallel/OpenCL/Context.chs @@ -39,14 +39,15 @@ where -- ----------------------------------------------------------------------------- -import Foreign( - Ptr, FunPtr, nullPtr, castPtr, alloca, allocaArray, peek, peekArray, +import Foreign( + Ptr, FunPtr, nullPtr, castPtr, alloca, allocaArray, peek, peekArray, ptrToIntPtr, intPtrToPtr, withArray ) -import Foreign.C.Types( CSize ) +import Foreign.C.Types -- expose FFI type constructors, the final imported list + -- depends on final architecture import Foreign.C.String( CString, peekCString ) import Foreign.Storable( sizeOf ) -import Control.Parallel.OpenCL.Types( - CLuint, CLint, CLDeviceType_, CLContextInfo_, CLContextProperty_, CLDeviceID, +import Control.Parallel.OpenCL.Types( + CLuint, CLint, CLDeviceType_, CLContextInfo_, CLContextProperty_, CLDeviceID, CLContext, CLDeviceType, CLPlatformID, bitmaskFromFlags, getCLValue, getEnumCL, whenSuccess, wrapCheckSuccess, wrapPError, wrapGetInfo ) @@ -59,19 +60,19 @@ -- ----------------------------------------------------------------------------- type ContextCallback = CString -> Ptr () -> CSize -> Ptr () -> IO () -foreign import CALLCONV "wrapper" wrapContextCallback :: +foreign import CALLCONV "wrapper" wrapContextCallback :: ContextCallback -> IO (FunPtr ContextCallback) foreign import CALLCONV "clCreateContext" raw_clCreateContext :: - Ptr CLContextProperty_ -> CLuint -> Ptr CLDeviceID -> FunPtr ContextCallback -> + Ptr CLContextProperty_ -> CLuint -> Ptr CLDeviceID -> FunPtr ContextCallback -> Ptr () -> Ptr CLint -> IO CLContext -foreign import CALLCONV "clCreateContextFromType" raw_clCreateContextFromType :: - Ptr CLContextProperty_ -> CLDeviceType_ -> FunPtr ContextCallback -> +foreign import CALLCONV "clCreateContextFromType" raw_clCreateContextFromType :: + Ptr CLContextProperty_ -> CLDeviceType_ -> FunPtr ContextCallback -> Ptr () -> Ptr CLint -> IO CLContext -foreign import CALLCONV "clRetainContext" raw_clRetainContext :: +foreign import CALLCONV "clRetainContext" raw_clRetainContext :: CLContext -> IO CLint -foreign import CALLCONV "clReleaseContext" raw_clReleaseContext :: +foreign import CALLCONV "clReleaseContext" raw_clReleaseContext :: CLContext -> IO CLint -foreign import CALLCONV "clGetContextInfo" raw_clGetContextInfo :: +foreign import CALLCONV "clGetContextInfo" raw_clGetContextInfo :: CLContext -> CLContextInfo_ -> CSize -> Ptr () -> Ptr CSize -> IO CLint -- ----------------------------------------------------------------------------- @@ -94,7 +95,7 @@ {#enum CLContextProperties {upcaseFirstLetter} #} -- | Specifies a context property name and its corresponding value. -data CLContextProperty = CL_CONTEXT_PLATFORM CLPlatformID +data CLContextProperty = CL_CONTEXT_PLATFORM CLPlatformID -- ^ Specifies the platform to use. #ifdef CL_VERSION_1_1 | CL_CGL_SHAREGROUP_KHR (Ptr ()) @@ -132,30 +133,44 @@ unpackContextProperties :: [CLContextProperty_] -> [CLContextProperty] unpackContextProperties [] = error "non-exhaustive Context Property list" -unpackContextProperties [x] +unpackContextProperties [x] | x == 0 = [] | otherwise = error "non-exhaustive Context Property list" -unpackContextProperties (x:y:xs) = let ys = unpackContextProperties xs +unpackContextProperties (x:y:xs) = let ys = unpackContextProperties xs in case getEnumCL x of - CL_CONTEXT_PLATFORM_ - -> CL_CONTEXT_PLATFORM + CL_CONTEXT_PLATFORM_ + -> CL_CONTEXT_PLATFORM (intPtrToPtr . fromIntegral $ y) : ys #ifdef CL_VERSION_1_1 - CL_CGL_SHAREGROUP_KHR_ - -> CL_CGL_SHAREGROUP_KHR + CL_CGL_SHAREGROUP_KHR_ + -> CL_CGL_SHAREGROUP_KHR (intPtrToPtr . fromIntegral $ y) : ys +#ifndef __APPLE__ + 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 #endif - +#endif + -- ----------------------------------------------------------------------------- mkContextCallback :: (String -> IO ()) -> ContextCallback mkContextCallback f msg _ _ _ = peekCString msg >>= f -- | Creates an OpenCL context. --- An OpenCL context is created with one or more devices. Contexts are used by --- the OpenCL runtime for managing objects such as command-queues, memory, --- program and kernel objects and for executing kernels on one or more devices +-- An OpenCL context is created with one or more devices. Contexts are used by +-- the OpenCL runtime for managing objects such as command-queues, memory, +-- program and kernel objects and for executing kernels on one or more devices -- specified in the context. -clCreateContext :: [CLContextProperty] -> [CLDeviceID] -> (String -> IO ()) +clCreateContext :: [CLContextProperty] -> [CLDeviceID] -> (String -> IO ()) -> IO CLContext clCreateContext [] devs f = withArray devs $ \pdevs -> wrapPError $ \perr -> do @@ -167,13 +182,13 @@ wrapPError $ \perr -> do fptr <- wrapContextCallback $ mkContextCallback f withArray (packContextProperties props) $ \pprops -> - raw_clCreateContext pprops cndevs pdevs fptr nullPtr perr + raw_clCreateContext pprops cndevs pdevs fptr nullPtr perr where cndevs = fromIntegral . length $ devs --- | Create an OpenCL context from a device type that identifies the specific +-- | Create an OpenCL context from a device type that identifies the specific -- device(s) to use. -clCreateContextFromType :: [CLContextProperty] -> [CLDeviceType] +clCreateContextFromType :: [CLContextProperty] -> [CLDeviceType] -> (String -> IO ()) -> IO CLContext clCreateContextFromType [] xs f = wrapPError $ \perr -> do fptr <- wrapContextCallback $ mkContextCallback f @@ -182,31 +197,31 @@ types = bitmaskFromFlags xs clCreateContextFromType props xs f = wrapPError $ \perr -> do fptr <- wrapContextCallback $ mkContextCallback f - withArray (packContextProperties props) $ \pprops -> + withArray (packContextProperties props) $ \pprops -> raw_clCreateContextFromType pprops types fptr nullPtr perr where types = bitmaskFromFlags xs -- | Increment the context reference count. --- 'clCreateContext' and 'clCreateContextFromType' perform an implicit retain. --- This is very helpful for 3rd party libraries, which typically get a context --- passed to them by the application. However, it is possible that the --- application may delete the context without informing the library. Allowing --- functions to attach to (i.e. retain) and release a context solves the +-- 'clCreateContext' and 'clCreateContextFromType' perform an implicit retain. +-- This is very helpful for 3rd party libraries, which typically get a context +-- passed to them by the application. However, it is possible that the +-- application may delete the context without informing the library. Allowing +-- functions to attach to (i.e. retain) and release a context solves the -- problem of a context being used by a library no longer being valid. --- Returns 'True' if the function is executed successfully, or 'False' if +-- Returns 'True' if the function is executed successfully, or 'False' if -- context is not a valid OpenCL context. clRetainContext :: CLContext -> IO Bool -clRetainContext ctx = wrapCheckSuccess $ raw_clRetainContext ctx +clRetainContext ctx = wrapCheckSuccess $ raw_clRetainContext ctx -- | Decrement the context reference count. --- After the context reference count becomes zero and all the objects attached --- to context (such as memory objects, command-queues) are released, the +-- After the context reference count becomes zero and all the objects attached +-- to context (such as memory objects, command-queues) are released, the -- context is deleted. --- Returns 'True' if the function is executed successfully, or 'False' if +-- Returns 'True' if the function is executed successfully, or 'False' if -- context is not a valid OpenCL context. clReleaseContext :: CLContext -> IO Bool -clReleaseContext ctx = wrapCheckSuccess $ raw_clReleaseContext ctx +clReleaseContext ctx = wrapCheckSuccess $ raw_clReleaseContext ctx getContextInfoSize :: CLContext -> CLContextInfo_ -> IO CSize getContextInfoSize ctx infoid = alloca $ \(value_size :: Ptr CSize) -> do @@ -222,8 +237,8 @@ #endc {#enum CLContextInfo {upcaseFirstLetter} #} --- | Return the context reference count. The reference count returned should be --- considered immediately stale. It is unsuitable for general use in +-- | Return the context reference count. The reference count returned should be +-- considered immediately stale. It is unsuitable for general use in -- applications. This feature is provided for identifying memory leaks. -- -- This function execute OpenCL clGetContextInfo with 'CL_CONTEXT_REFERENCE_COUNT'. @@ -231,7 +246,7 @@ clGetContextReferenceCount ctx = wrapGetInfo (\(dat :: Ptr CLuint) -> raw_clGetContextInfo ctx infoid size (castPtr dat)) id - where + where infoid = getCLValue CL_CONTEXT_REFERENCE_COUNT size = fromIntegral $ sizeOf (0::CLuint) @@ -241,8 +256,8 @@ clGetContextDevices :: CLContext -> IO [CLDeviceID] clGetContextDevices ctx = do size <- getContextInfoSize ctx infoid - let n = (fromIntegral size) `div` elemSize - + let n = (fromIntegral size) `div` elemSize + allocaArray n $ \(buff :: Ptr CLDeviceID) -> do whenSuccess (raw_clGetContextInfo ctx infoid size (castPtr buff) nullPtr) $ peekArray n buff @@ -253,9 +268,9 @@ clGetContextProperties :: CLContext -> IO [CLContextProperty] clGetContextProperties ctx = do size <- getContextInfoSize ctx infoid - let n = (fromIntegral size) `div` elemSize - - if n == 0 + 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) @@ -263,5 +278,5 @@ where infoid = getCLValue CL_CONTEXT_PROPERTIES elemSize = sizeOf (nullPtr :: CLDeviceID) - + -- ----------------------------------------------------------------------------- diff --git a/src/Control/Parallel/OpenCL/Query.chs b/src/Control/Parallel/OpenCL/Query.chs --- a/src/Control/Parallel/OpenCL/Query.chs +++ b/src/Control/Parallel/OpenCL/Query.chs @@ -67,7 +67,8 @@ -- ----------------------------------------------------------------------------- import Foreign( Ptr, nullPtr, castPtr, alloca, allocaArray, peek, peekArray ) import Foreign.C.String( CString, peekCString ) -import Foreign.C.Types( CSize ) +import Foreign.C.Types -- expose FFI type constructors, the final imported list + -- depends on final architecture import Foreign.Storable( sizeOf ) import Control.Parallel.OpenCL.Types( CLbool, CLint, CLuint, CLulong, CLPlatformInfo_, CLDeviceType_, diff --git a/src/Control/Parallel/OpenCL/Types.chs b/src/Control/Parallel/OpenCL/Types.chs --- a/src/Control/Parallel/OpenCL/Types.chs +++ b/src/Control/Parallel/OpenCL/Types.chs @@ -114,9 +114,15 @@ type CLAddressingMode_ = {#type cl_addressing_mode#} -- ----------------------------------------------------------------------------- + +-- * NOTE: Apple lags behind official Khronos header files #c enum CLError { +#ifdef __APPLE__ + cL_PLATFORM_NOT_FOUND_KHR=-1001, +#else cL_PLATFORM_NOT_FOUND_KHR=CL_PLATFORM_NOT_FOUND_KHR, +#endif cL_BUILD_PROGRAM_FAILURE=CL_BUILD_PROGRAM_FAILURE, cL_COMPILER_NOT_AVAILABLE=CL_COMPILER_NOT_AVAILABLE, cL_DEVICE_NOT_AVAILABLE=CL_DEVICE_NOT_AVAILABLE,