jkarlson/OpenCLWrappers — pull request #2 by ehird (2011-11-20 20:43:36+00:00)
Title: Bag o' stuff

I had some free time and I needed to get well-acquainted with the library anyway, so I converted the code to use exceptions. Things are definitely much cleaner and simpler now IMO — even internal library definitions become much "flatter" and more readable due to not having to plumb errors around.

Then I found a bunch of bugs with -Wall and HLint, so I made the code almost completely warnings-clean (which almost universally happened by fixing bugs (mostly in the code I've added :)), not just working around the warnings...).

I'd go into greater detail here, but I'd just end up repeating the commit messages, so I'll let you check them out directly :-)

This all compiles and runs on GHC 7.0.3 here. Ironically, the machine I made these changes on doesn't do OpenCL, but I've ported heattransfer.hs to work with these changes and it fails as expected:

$ ./heattransfer
OpenCL init failed with:
OpenCL error: Device not found (-1)

The changes I made were mostly mechanical, so I expect everything else should work too.

Here's the updated heattransfer.hs; it's still not the most elegant program ever, but I think the logic is much easier to follow here, and it has the expected behaviour when an unhandled error occurs (i.e. a description of the error is printed and the program terminates):

```haskell
{-# LANGUAGE ExistentialQuantification #-}

import Prelude hiding(catch)
import System.OpenCL.Wrappers
import Foreign.Marshal
import Foreign.Storable
import Foreign.C
import Foreign.Ptr
import Control.Exception
import System.IO(withFile,hPutBuf,IOMode(..))
import System.Exit

width :: Int
width = 4098
height :: Int
height = 4098
printFreq :: Int
printFreq = 1000
iterMax :: Int
iterMax = 10000
localWorkSize :: [Int]
localWorkSize = []

bufferSize :: CLsizei
bufferSize = fromIntegral $ width*height*sizeOf (undefined :: CFloat)

handleErr :: String -> SomeCLException -> IO a
handleErr s err = do
putStrLn s
print err
exitFailure

initSystem = do
pID <- fmap head clGetPlatformIDs
[dID] <- clGetDeviceIDs pID clDeviceTypeGPU
context <- clCreateContextFromType [] clDeviceTypeGPU Nothing nullPtr
queue <- clCreateCommandQueue context dID []
return (dID,context,queue)

main = do
sys <- initSystem `catch` handleErr "OpenCL init failed with:"
buildCode sys

buildCode (dID,context,queue) = do
source <- readFile "heattransfer.cl"
program <- buildProgram (source) ("-I./ -DWIDTH=" ++ show width) context dID `catch` handleErr "Build failed with:"
createObjects (dID,context,queue,program)

createObjects' (dID,context,queue,program) = handle (handleErr "Object creation failed with:") $ do
tBuffer <- clCreateBuffer context clMemReadWrite bufferSize nullPtr
dTBuffer <- clCreateBuffer context clMemReadWrite bufferSize nullPtr
kinit <- createAsyncKernelWithParams program queue "init" [height, width] [] [tBuffer]
kcalc <- createAsyncKernelWithParams program queue "calc" [height-2, width-2] localWorkSize [tBuffer, dTBuffer]
kapply <- createAsyncKernelWithParams program queue "apply" [height-2, width-2] localWorkSize [tBuffer, dTBuffer]
hostBuffer <- mallocArray (height*width) :: IO (Ptr CFloat)
return (dID,queue,program,tBuffer,dTBuffer,kinit,kcalc,kapply,hostBuffer)

createObjects a = catch (createObjects' a) (handleErr "Object creation failed with:") >>= runCode

runCode (dID,queue,program,tBuffer,dTBuffer,kinit,kcalc,kapply,hostBuffer) = do
kinit [] `catch` handleErr "Running failed with:"
clFinish queue

DeviceInfoRetvalDeviceType (DeviceType dType) <- clGetDeviceInfo dID clDeviceType
DeviceInfoRetvalString dString <- clGetDeviceInfo dID clDriverVersion
putStrLn "Driver version"
putStrLn dString
putStrLn "Device type"
print dType
mainLoop (queue,kcalc,kapply,hostBuffer,tBuffer,dTBuffer) 0 []
clFinish queue
ProgramBuildInfoRetvalBuildStatus (BuildStatus r) <- clGetProgramBuildInfo program dID clProgramBuildStatus
putStr "Build status: " >> print r
peek hostBuffer >>= print

mainLoop (queue,kcalc,kapply,hostBuffer,tBuffer,dTBuffer) nIter events = do
if (mod nIter printFreq == 0)
then withFile ("tempOut-" ++ show nIter ++ ".dat") WriteMode (writeData hostBuffer queue tBuffer)
else return ()
ev <- kcalc events `catch` handleErr "kcalc failed with:"
ev' <- kapply [ev] `catch` handleErr "kapply failed with:"
if (nIter < iterMax)
then mainLoop (queue,kcalc,kapply,hostBuffer,tBuffer,dTBuffer) (nIter+1) [ev']
else return ()

writeData hostBuffer queue tBuffer handle = do
clFinish queue
clEnqueueReadBuffer tBuffer True 0 (fromIntegral$ width*height* sizeOf (undefined :: CFloat)) (castPtr hostBuffer) queue []
withArray (map fromIntegral [height, width] :: [CLuint]) (\x -> hPutBuf handle x (2*sizeOf (undefined::CLuint)))
a <- peek hostBuffer
hPutBuf handle hostBuffer $ (height*width*sizeOf a)
```

I'd send these commits as separate requests so you could be more selective about things, but I've tried before and I don't think GitHub lets you do that. Hopefully I can update this request to include and exclude any changes you want if I can figure it out...