Question

I’m doing some proof-of-concept work for a fairly complex video game I’d like to write in Haskell using the HOpenGL library. I started by writing a module that implements client-server event based communication. My problem appears when I try to hook it up to a simple program to draw clicks on the screen.

The event library uses a list of TChans made into a priority queue for communication. It returns an “out” queue and an “in” queue corresponding to server-bound and client-bound messages. Sending and receiving events are done in separate threads using forkIO. Testing the event library without the OpenGL part shows it communicating successfully. Here’s the code I used to test it:

-- Client connects to server at localhost with 3 priorities in the priority queue
do { (outQueue, inQueue) <- client Nothing 3
   -- send 'Click' events until terminated, the server responds with the coords negated
   ; mapM_ (\x -> atomically $ writeThing outQueue (lookupPriority x) x)
           (repeat (Click (fromIntegral 2) (fromIntegral 4)))
   }

This produces the expected output, namely a whole lot of send and receive events. I don’t think the problem lies with the Event handling library.

The OpenGL part of the code checks the incoming queue for new events in the displayCallback and then calls the event’s associated handler. I can get one event (the Init event, which simply clears the screen) to be caught by the displayCallback, but after that nothing is caught. Here’s the relevant code:

atomically $ PQ.writeThing inqueue (Events.lookupPriority Events.Init) Events.Init
    GLUT.mainLoop

render pqueue =
    do  event <- atomically $
            do  e <- PQ.getThing pqueue
                case e of
                    Nothing -> retry
                    Just event -> return event
        putStrLn $ "Got event"
        (Events.lookupHandler event Events.Client) event
        GL.flush
        GLUT.swapBuffers

So my theories as to why this is happening are:

• The display callback is blocking all of the sending and receiving threads on the retry.
• The queues are not being returned properly, so that the queues that the client reads are different than the ones that the OpenGL part reads.

Are there any other reasons why this could be happening?

The complete code for this is too long to post on here although not too long (5 files under 100 lines each), however it is all on GitHub here.

Edit 1:
The client is run from within the main function in the HOpenGL code like so:

main =
    do  args <- getArgs
        let ip = args !! 0
        let priorities = args !! 1
        (progname, _) <- GLUT.getArgsAndInitialize
        -- Run the client here and bind the queues to use for communication
        (outqueue, inqueue) <- Client.client (Just ip) priorities
        GLUT.createWindow "Hello World"
        GLUT.initialDisplayMode $= [GLUT.DoubleBuffered, GLUT.RGBAMode]
        GLUT.keyboardMouseCallback $= Just (keyboardMouse outqueue)
        GLUT.displayCallback $= render inqueue
        PQ.writeThing inqueue (Events.lookupPriority Events.Init) Events.Init
        GLUT.mainLoop

The only flag I pass to GHC when I compile the code is -package GLUT.

Edit 2:
I cleaned up the code on Github a bit. I removed acceptInput since it wasn’t doing anything really and the Client code isn’t supposed to be listening for events of its own anyway, that’s why it’s returning the queues.

Edit 3:
I’m clarifying my question a little bit. I took what I learned from @Shang and @Laar and kind of ran with it. I changed the threads in Client.hs to use forkOS instead of forkIO (and used -threaded at ghc), and it looks like the events are being communicated successfully, however they are not being received in the display callback. I also tried calling postRedisplay at the end of the display callback but I don’t think it ever gets called (because I think the retry is blocking the entire OpenGL thread).

Would the retry in the display callback block the entire OpenGL thread? If it does, would it be safe to fork the display callback into a new thread? I don’t imagine it would, since the possibility exists that multiple things could be trying to draw to the screen at the same time, but I might be able to handle that with a lock. Another solution would be to convert the lookupHandler function to return a function wrapped in a Maybe, and just do nothing if there aren’t any events. I feel like that would be less than ideal as I’d then essentially have a busy loop which was something I was trying to avoid.

Edit 4:
Forgot to mention I used -threaded at ghc when I did the forkOS.

Edit 5:
I went and did a test of my theory that the retry in the render function (display callback) was blocking all of OpenGL. I rewrote the render function so it didn’t block anymore, and it worked like I wanted it to work. One click in the screen gives two points, one from the server and from the original click. Here’s the code for the new render function (note: it’s not in Github):

render pqueue =
    do  event <- atomically $ PQ.getThing pqueue
        case (Events.lookupHandler event Events.Client) of
            Nothing -> return ()
            Just handler -> 
                do  let e = case event of {Just e' -> e'}
                    handler e
                    return ()
        GL.flush
        GLUT.swapBuffers
        GLUT.postRedisplay Nothing

I tried it with and without the postRedisplay, and it only works with it. The problem now becomes that this pegs the CPU at 100% because it’s a busy loop. In Edit 4 I proposed threading off the display callback. I’m still thinking of a way to do that.

A note since I haven’t mentioned it yet. Anybody looking to build/run the code should do it like this:

$ ghc -threaded -package GLUT helloworldOGL.hs -o helloworldOGL
$ ghc server.hs -o server
-- one or the other, I usually do 0.0.0.0
$ ./server "localhost" 3
$ ./server "0.0.0.0" 3
$ ./helloworldOGL "localhost" 3

Edit 6: Solution
A solution! Going along with the threads, I decided to make a thread in the OpenGL code that checked for events, blocking if there aren’t any, and then calling the handler followed by postRedisplay. Here it is:

checkEvents pqueue = forever $
    do  event <- atomically $
            do  e <- PQ.getThing pqueue
                case e of
                    Nothing -> retry
                    Just event -> return event
        putStrLn $ "Got event"
        (Events.lookupHandler event Events.Client) event
        GLUT.postRedisplay Nothing

The display callback is simply:

render = GLUT.swapBuffers

And it works, it doesn’t peg the CPU for 100% and events are handled promptly. I’m posting this here because I couldn’t have done it without the other answers and I feel bad taking the rep when the answers were both very helpful, so I’m accepting @Laar’s answer since he has the lower Rep.

Answer 1

One possible cause could be the use of threading.

OpenGL uses thread local storage for it’s context. Therefore all calls using OpenGL should be made from the same OS thread. HOpenGL (and OpenGLRaw too) is a relatively simple binding around the OpenGL library and is not providing any protection or workarounds to this ‘problem’.

On the other hand are you using forkIO to create a light weight haskell thread. This thread is not guaranteed to stay on the same OS thread. Therefore the RTS might switch it to another OS thread where the thread local OpenGL-context is not available. To resolve this problem there is the forkOS function, which creates a bound haskell thread. This bound haskell thread will always run on the same OS thread and thus having its thread local state available. The documentation about this can be found in the ‘Bound Threads’ section of Control.Concurrent, forkOS can also be found there.

edits:

With the current testing code this problem is not present, as you’re not using -threaded. (removed incorrect reasoning)