Permalink
Browse files

Change over to extensible exceptions

  • Loading branch information...
1 parent 350bd51 commit 383893be4509fbbaa6e6eac857991d62be1c410c @dagit dagit committed Sep 8, 2011
View
@@ -65,7 +65,7 @@ hs-source-dirs: .
other-modules: System.OpenCL.Raw.V10.Utils
ghc-prof-options:
ghc-shared-options:
-ghc-options:
+ghc-options: -Wall
hugs-options:
nhc98-options:
jhc-options:
@@ -16,31 +16,30 @@ import Foreign
import Control.Applicative
import Data.Bits
import Data.Maybe
+import Control.Exception ( throw )
foreign import ccall "clCreateCommandQueue" raw_clCreateCommandQueue :: Context -> DeviceID -> CLbitfield -> Ptr CLint -> IO CommandQueue
-clCreateCommandQueue :: Context -> DeviceID -> CommandQueueProperties -> IO (Either ErrorCode CommandQueue)
+clCreateCommandQueue :: Context -> DeviceID -> CommandQueueProperties -> IO CommandQueue
clCreateCommandQueue ctx devid (CommandQueueProperties properties) =
- wrapErrorEither $ raw_clCreateCommandQueue ctx devid properties
+ wrapErrorPtr $ raw_clCreateCommandQueue ctx devid properties
foreign import ccall "clRetainCommandQueue" raw_clRetainCommandQueue :: CommandQueue -> IO CLint
-clRetainCommandQueue :: CommandQueue -> IO (Maybe ErrorCode)
+clRetainCommandQueue :: CommandQueue -> IO ()
clRetainCommandQueue queue = wrapError (raw_clRetainCommandQueue queue)
foreign import ccall "clReleaseCommandQueue" raw_clReleaseCommandQueue :: CommandQueue -> IO CLint
-clReleaseCommandQueue :: CommandQueue -> IO (Maybe ErrorCode)
+clReleaseCommandQueue :: CommandQueue -> IO ()
clReleaseCommandQueue queue = wrapError (raw_clReleaseCommandQueue queue)
foreign import ccall "clGetCommandQueueInfo" raw_clGetCommandQueueInfo :: CommandQueue -> CLuint -> CLsizei -> Ptr () -> Ptr CLsizei -> IO CLint
-clGetCommandQueueInfo :: CommandQueue -> CommandQueueInfo -> CLsizei -> IO (Either ErrorCode (ForeignPtr (), CLsizei))
+clGetCommandQueueInfo :: CommandQueue -> CommandQueueInfo -> CLsizei -> IO (ForeignPtr (), CLsizei)
clGetCommandQueueInfo ctx (CommandQueueInfo param_name) param_size = wrapGetInfo (raw_clGetCommandQueueInfo ctx param_name) param_size
foreign import ccall "clSetCommandQueueProperty" raw_clSetCommandQueueProperty :: CommandQueue -> CLbitfield -> CLbool -> Ptr CLbitfield -> IO CLint
-clSetCommandQueueProperty :: CommandQueue -> CommandQueueProperties -> Bool -> IO (Either ErrorCode CommandQueueProperties)
+clSetCommandQueueProperty :: CommandQueue -> CommandQueueProperties -> Bool -> IO CommandQueueProperties
clSetCommandQueueProperty queue (CommandQueueProperties properties) enable = alloca $ \old_properties -> do
err <- ErrorCode <$> raw_clSetCommandQueueProperty queue properties (if enable then clTrue else clFalse) old_properties
if err == clSuccess
- then Right . CommandQueueProperties <$> peek old_properties
- else return . Left $ err
-
-
+ then CommandQueueProperties <$> peek old_properties
+ else throw err
@@ -26,36 +26,36 @@ type ContextCallback = (CString -> Ptr () -> CLsizei -> Ptr () -> IO ())
foreign import ccall "clCreateContext" raw_clCreateContext :: Ptr (Ptr CLint) -> CLuint -> Ptr DeviceID -> FunPtr ContextCallback -> Ptr () -> Ptr CLint -> IO Context
foreign import ccall "wrapper" wrapCreateContextCallback :: ContextCallback -> IO (FunPtr ContextCallback)
-clCreateContext :: [ContextProperties] -> [DeviceID] -> ContextCallback -> Ptr () -> IO (Either ErrorCode Context)
+clCreateContext :: [ContextProperties] -> [DeviceID] -> ContextCallback -> Ptr () -> IO Context
clCreateContext properties devices pfn_notify user_dat =
allocaArray (propertiesN+1) $ \propertiesP -> allocaArray devicesN $ \devicesP -> do
pokeArray0 nullPtr propertiesP properties
pokeArray devicesP devices
fptr <- wrapCreateContextCallback pfn_notify
- wrapErrorEither $ raw_clCreateContext propertiesP (fromIntegral devicesN) devicesP fptr user_dat
+ wrapErrorPtr $ raw_clCreateContext propertiesP (fromIntegral devicesN) devicesP fptr user_dat
where propertiesN = length properties
devicesN = length devices
foreign import ccall "clCreateContextFromType" raw_clCreateContextFromType :: Ptr ContextProperties -> CLbitfield -> FunPtr ContextCallback -> Ptr a -> Ptr CLint -> IO Context
-clCreateContextFromType :: [ContextProperties] -> DeviceType -> ContextCallback -> Ptr () -> IO (Either ErrorCode Context)
+clCreateContextFromType :: [ContextProperties] -> DeviceType -> ContextCallback -> Ptr () -> IO Context
clCreateContextFromType properties (DeviceType device_type) pfn_notify user_data = allocaArray (propertiesN+1) $ \propertiesP -> do
pokeArray0 nullPtr propertiesP properties
fptr <- wrapCreateContextCallback pfn_notify
- wrapErrorEither $ raw_clCreateContextFromType propertiesP device_type fptr user_data
+ wrapErrorPtr $ raw_clCreateContextFromType propertiesP device_type fptr user_data
where propertiesN = length properties
foreign import ccall "clRetainContext" raw_clRetainContext :: Context -> IO CLint
-clRetainContext :: Context -> IO (Maybe ErrorCode)
+clRetainContext :: Context -> IO ()
clRetainContext ctx = wrapError (raw_clRetainContext ctx)
foreign import ccall "clReleaseContext" raw_clReleaseContext :: Context -> IO CLint
-clReleaseContext :: Context -> IO (Maybe ErrorCode)
+clReleaseContext :: Context -> IO ()
clReleaseContext ctx = wrapError (raw_clReleaseContext ctx)
foreign import ccall "clGetContextInfo" raw_clGetContextInfo :: Context -> CLuint -> CLsizei -> Ptr () -> Ptr CLsizei -> IO CLint
-clGetContextInfo :: Context -> ContextInfo -> CLsizei -> IO (Either ErrorCode (ForeignPtr (), CLsizei))
+clGetContextInfo :: Context -> ContextInfo -> CLsizei -> IO (ForeignPtr (), CLsizei)
clGetContextInfo ctx (ContextInfo param_name) param_size = wrapGetInfo (raw_clGetContextInfo ctx param_name) param_size
@@ -11,18 +11,17 @@ import System.OpenCL.Raw.V10.Utils
import Foreign
import Control.Applicative
import Data.Bits
+import Control.Exception ( throw )
foreign import ccall "clGetDeviceIDs" raw_clGetDeviceIDs :: PlatformID -> CLbitfield -> CLuint -> Ptr DeviceID -> Ptr CLuint -> IO CLint
-clGetDeviceIDs :: PlatformID -> DeviceType -> CLuint -> IO (Either ErrorCode [DeviceID])
-clGetDeviceIDs platform (DeviceType device_type) num_entries = alloca $ \(devices::Ptr DeviceID) -> alloca $ \(num_devices::Ptr CLuint) -> do
+clGetDeviceIDs :: PlatformID -> DeviceType -> CLuint -> IO [DeviceID]
+clGetDeviceIDs platform (DeviceType device_type) num_entries = alloca $ \devices -> alloca $ \num_devices -> do
errcode <- ErrorCode <$> raw_clGetDeviceIDs platform device_type num_entries devices num_devices
if errcode == clSuccess
- then Right <$> (peek num_devices >>= \num_devicesN -> peekArray (fromIntegral num_devicesN) devices)
- else return $ Left errcode
-
+ then peek num_devices >>= \num_devicesN -> peekArray (fromIntegral num_devicesN) devices
+ else throw errcode
+
foreign import ccall "clGetDeviceInfo" raw_clGetDeviceInfo :: DeviceID -> CLuint -> CLsizei -> Ptr () -> Ptr CLsizei -> IO CLint
-clGetDeviceInfo :: DeviceID -> DeviceInfo -> CLsizei -> IO (Either ErrorCode (ForeignPtr (), CLsizei))
+clGetDeviceInfo :: DeviceID -> DeviceInfo -> CLsizei -> IO (ForeignPtr (), CLsizei)
clGetDeviceInfo obj (DeviceInfo param_name) param_size = wrapGetInfo (raw_clGetDeviceInfo obj param_name) param_size
-
-
@@ -17,22 +17,22 @@ import Control.Applicative
foreign import ccall "clWaitForEvents" raw_clWaitForEvents :: CLuint -> Ptr Event -> IO CLint
-clWaitForEvents :: [Event] -> IO (Maybe ErrorCode)
+clWaitForEvents :: [Event] -> IO ()
clWaitForEvents evts = allocaArray nEvents $ \eventP -> pokeArray eventP evts >> (wrapError $ raw_clWaitForEvents (fromIntegral nEvents) eventP)
where nEvents = length evts
foreign import ccall "clGetEventInfo" raw_clGetEventInfo :: Event -> CLuint -> CLsizei -> Ptr () -> Ptr CLsizei -> IO CLint
-clGetEventInfo :: Event -> EventInfo -> CLsizei -> IO (Either ErrorCode (ForeignPtr (), CLsizei))
+clGetEventInfo :: Event -> EventInfo -> CLsizei -> IO (ForeignPtr (), CLsizei)
clGetEventInfo obj (EventInfo param_name) param_size = wrapGetInfo (raw_clGetEventInfo obj param_name) param_size
foreign import ccall "clRetainEvent" raw_clRetainEvent :: Event -> IO CLint
-clRetainEvent :: Event -> IO (Maybe ErrorCode)
+clRetainEvent :: Event -> IO ()
clRetainEvent evt = wrapError $ raw_clRetainEvent evt
foreign import ccall "clReleaseEvent" raw_clReleaseEvent :: Event -> IO CLint
-clReleaseEvent :: Event -> IO (Maybe ErrorCode)
+clReleaseEvent :: Event -> IO ()
clReleaseEvent evt = wrapError $ raw_clReleaseEvent evt
foreign import ccall "clGetEventProfilingInfo" raw_clGetEventProfilingInfo :: Event -> CLuint -> CLsizei -> Ptr () -> Ptr CLsizei -> IO CLint
-clGetEventProfilingInfo :: Event -> ProfilingInfo -> CLsizei -> IO (Either ErrorCode (ForeignPtr (), CLsizei))
+clGetEventProfilingInfo :: Event -> ProfilingInfo -> CLsizei -> IO (ForeignPtr (), CLsizei)
clGetEventProfilingInfo obj (ProfilingInfo param_name) param_size = wrapGetInfo (raw_clGetEventProfilingInfo obj param_name) param_size
@@ -12,10 +12,10 @@ import Foreign
import Control.Applicative
foreign import ccall "clFlush" raw_clFlush :: CommandQueue -> IO CLint
-clFlush :: CommandQueue -> IO (Maybe ErrorCode)
+clFlush :: CommandQueue -> IO ()
clFlush queue = wrapError $ raw_clFlush queue
foreign import ccall "clFinish" raw_clFinish :: CommandQueue -> IO CLint
-clFinish :: CommandQueue -> IO (Maybe ErrorCode)
+clFinish :: CommandQueue -> IO ()
clFinish queue = wrapError $ raw_clFinish queue
@@ -19,45 +19,41 @@ import Foreign
import Foreign.C
import Control.Applicative
import Data.Maybe
+import Control.Exception ( throw )
foreign import ccall "clCreateKernel" raw_clCreateKernel :: Program -> CString -> Ptr CLint -> IO Kernel
-clCreateKernel program kernel_name = wrapErrorEither $ raw_clCreateKernel program kernel_name
+clCreateKernel program kernel_name = wrapErrorPtr $ raw_clCreateKernel program kernel_name
foreign import ccall "clCreateKernelsInProgram" raw_clCreateKernelsInProgram :: Program -> CLuint -> Ptr Kernel -> Ptr CLuint -> IO CLint
-clCreateKernelsInProgram :: Program -> CLuint -> IO (Either ErrorCode [Kernel])
-clCreateKernelsInProgram program num_kernels = allocaArray (fromIntegral num_kernels) $ \kernels -> alloca $ \num_kernels_ret -> do
- err <- wrapError $ raw_clCreateKernelsInProgram program num_kernels kernels num_kernels_ret
- if err== Nothing
- then do
- nkr <- peek num_kernels_ret
- Right <$> peekArray (fromIntegral nkr) kernels
- else
- return $ Left . fromJust $ err
+clCreateKernelsInProgram :: Program -> CLuint -> IO [Kernel]
+clCreateKernelsInProgram program num_kernels = allocaArray (fromIntegral num_kernels) $ \kernels -> do
+ nkr <- fetchPtr $ raw_clCreateKernelsInProgram program num_kernels kernels
+ peekArray (fromIntegral nkr) kernels
foreign import ccall "clRetainKernel" raw_clRetainKernel :: Kernel -> IO CLint
-clRetainKernel :: Kernel -> IO (Maybe ErrorCode)
+clRetainKernel :: Kernel -> IO ()
clRetainKernel kernel = wrapError $ raw_clRetainKernel kernel
foreign import ccall "clReleaseKernel" raw_clReleaseKernel :: Kernel -> IO CLint
-clReleaseKernel :: Kernel -> IO (Maybe ErrorCode)
+clReleaseKernel :: Kernel -> IO ()
clReleaseKernel kernel = wrapError $ raw_clRetainKernel kernel
foreign import ccall "clSetKernelArg" raw_clSetKernelArg :: Kernel -> CLuint -> CLsizei -> Ptr () -> IO CLint
-clSetKernelArg :: Kernel -> CLuint -> CLsizei -> Ptr () -> IO (Maybe ErrorCode)
+clSetKernelArg :: Kernel -> CLuint -> CLsizei -> Ptr () -> IO ()
clSetKernelArg kernel arg_index arg_size arg_value =
wrapError $ raw_clSetKernelArg kernel arg_index arg_size arg_value
foreign import ccall "clGetKernelInfo" raw_clGetKernelInfo :: Kernel -> CLuint -> CLsizei -> Ptr () -> Ptr CLsizei -> IO CLint
-clGetKernelInfo :: Kernel -> KernelInfo -> CLsizei -> IO (Either ErrorCode (ForeignPtr (), CLsizei))
+clGetKernelInfo :: Kernel -> KernelInfo -> CLsizei -> IO (ForeignPtr (), CLsizei)
clGetKernelInfo kernel (KernelInfo param_name) param_value_size = wrapGetInfo (raw_clGetKernelInfo kernel param_name) param_value_size
foreign import ccall "clGetKernelWorkGroupInfo" raw_clGetKernelWorkGroupInfo :: Kernel -> DeviceID -> CLuint -> CLsizei -> Ptr () -> Ptr CLsizei -> IO CLint
-clGetKernelWorkGroupInfo :: Kernel -> DeviceID -> KernelWorkGroupInfo -> CLsizei -> IO (Either ErrorCode (ForeignPtr (), CLsizei))
+clGetKernelWorkGroupInfo :: Kernel -> DeviceID -> KernelWorkGroupInfo -> CLsizei -> IO (ForeignPtr (), CLsizei)
clGetKernelWorkGroupInfo kernel device (KernelWorkGroupInfo param_name) param_value_size = wrapGetInfo (raw_clGetKernelWorkGroupInfo kernel device param_name) param_value_size
foreign import ccall "clEnqueueNDRangeKernel" raw_clEnqueueNDRangeKernel :: CommandQueue -> Kernel -> CLuint -> Ptr CLsizei -> Ptr CLsizei -> Ptr CLsizei -> CLuint -> Ptr Event -> Ptr Event -> IO CLint
-clEnqueueNDRangeKernel :: CommandQueue -> Kernel -> [CLsizei] -> [CLsizei] -> [Event] -> IO (Either ErrorCode Event)
+clEnqueueNDRangeKernel :: CommandQueue -> Kernel -> [CLsizei] -> [CLsizei] -> [Event] -> IO Event
clEnqueueNDRangeKernel queue kernel global_work_sizeL local_work_sizeL event_wait_listL =
allocaArray work_dim $ \global_work_size ->
allocaArray work_dim $ \local_work_size ->
@@ -66,44 +62,41 @@ clEnqueueNDRangeKernel queue kernel global_work_sizeL local_work_sizeL event_wai
pokeArray global_work_size global_work_sizeL
pokeArray local_work_size local_work_sizeL
pokeArray event_wait_list event_wait_listL
- err <- wrapError $ raw_clEnqueueNDRangeKernel queue kernel (fromIntegral work_dim) nullPtr global_work_size local_work_size (fromIntegral num_events_in_wait_list) event_wait_list event
- if err == Nothing
- then Right <$> peek event
- else return $ Left . fromJust $ err
+ err <- ErrorCode <$> raw_clEnqueueNDRangeKernel queue kernel (fromIntegral work_dim) nullPtr global_work_size local_work_size (fromIntegral num_events_in_wait_list) event_wait_list event
+ if err == clSuccess
+ then peek event
+ else throw err
where work_dim = length global_work_sizeL
num_events_in_wait_list = length event_wait_listL
foreign import ccall "clEnqueueTask" raw_clEnqueueTask :: CommandQueue -> Kernel -> CLuint -> Ptr Event -> Ptr Event -> IO CLint
-clEnqueueTask :: CommandQueue -> Kernel -> [Event] -> IO (Either ErrorCode Event)
-clEnqueueTask queue kernel event_wait_listL =
+clEnqueueTask :: CommandQueue -> Kernel -> [Event] -> IO Event
+clEnqueueTask queue kernel event_wait_listL =
allocaArray num_events_in_wait_list $ \event_wait_list ->
alloca $ \event -> do
pokeArray event_wait_list event_wait_listL
- err <- wrapError $ raw_clEnqueueTask queue kernel (fromIntegral num_events_in_wait_list) event_wait_list event
- if err == Nothing
- then Right <$> peek event
- else return $ Left . fromJust $ err
+ err <- ErrorCode <$> raw_clEnqueueTask queue kernel (fromIntegral num_events_in_wait_list) event_wait_list event
+ if err == clSuccess
+ then peek event
+ else throw err
where num_events_in_wait_list = length event_wait_listL
type NKCallbackFunction = Ptr () -> IO ()
foreign import ccall "wrapper" wrapNativeKernelCallback :: NKCallbackFunction -> IO (FunPtr NKCallbackFunction)
foreign import ccall "clEnqueueNativeKernel" raw_clEnqueueNativeKernel :: FunPtr NKCallbackFunction -> Ptr () -> CLsizei -> CLuint -> Ptr Mem -> Ptr (Ptr ()) -> CLuint -> Ptr Event -> Ptr Event -> IO CLint
-clEnqueueNativeKernel :: NKCallbackFunction -> Ptr () -> CLsizei -> [Mem] -> [Ptr ()] -> [Event] -> IO (Either ErrorCode Event)
+clEnqueueNativeKernel :: NKCallbackFunction -> Ptr () -> CLsizei -> [Mem] -> [Ptr ()] -> [Event] -> IO Event
clEnqueueNativeKernel user_funcF args cb_args mem_listL args_mem_locL event_wait_listL =
allocaArray num_events_in_wait_list $ \event_wait_list ->
allocaArray num_mem_objects $ \mem_list ->
- allocaArray (length args_mem_locL) $ \args_mem_loc ->
+ allocaArray (length args_mem_locL) $ \args_mem_loc ->
alloca $ \event -> do
user_func <- wrapNativeKernelCallback user_funcF
pokeArray event_wait_list event_wait_listL
pokeArray mem_list mem_listL
pokeArray args_mem_loc args_mem_locL
- err <- wrapError $ raw_clEnqueueNativeKernel user_func args cb_args (fromIntegral num_mem_objects) mem_list args_mem_loc (fromIntegral num_events_in_wait_list) event_wait_list event
- if err == Nothing
- then Right <$> peek event
- else return $ Left . fromJust $ err
+ err <- ErrorCode <$> raw_clEnqueueNativeKernel user_func args cb_args (fromIntegral num_mem_objects) mem_list args_mem_loc (fromIntegral num_events_in_wait_list) event_wait_list event
+ if err == clSuccess
+ then peek event
+ else throw err
where num_events_in_wait_list = length event_wait_listL
num_mem_objects = length mem_listL
-
-
-
Oops, something went wrong.

0 comments on commit 383893b

Please sign in to comment.