GHC threading bug in QSem

[Neil Mitchell]

Hi

I believe the following program should always print 100:

import Data.IORef
import Control.Concurrent

main = do
    sem <- newQSem (-99)
    r <- newIORef 0
    let incRef = atomicModifyIORef r (\a -> (a+1,a))
    sequence_ $ replicate 100 $ forkIO $ incRef >> signalQSem sem
    waitQSem sem
    v <- readIORef r
    print v

Unfortunately, it doesn't seem to. Running on a 2 processor machine,
with +RTS -N3 I usually get 100, but have got answers such as 49, 82,
95. With +RTS -N2 it doesn't seem to fail, but it does with -N4. This
is using GHC 6.10.2 on Windows. Using GHC 6.8.3, I get answers /= 100
roughly every other time.

>From reading the implementation of QSem, it doesn't seem that negative
availability was considered. I think it would be need to be changed
as:

-- Invariant: avail >= 1 ==> null blocked

waitQSem :: QSem -> IO ()
waitQSem (QSem sem) = do
   (avail,blocked) <- takeMVar sem  -- gain ex. access
   if avail > 0 then
     putMVar sem (avail-1,[])
    else do
     block <- newEmptyMVar
     putMVar sem (avail, blocked++[block])   -- changed line
     takeMVar block

signalQSem :: QSem -> IO ()
signalQSem (QSem sem) = do
   (avail,blocked) <- takeMVar sem
   -- changed below
   if null blocked || avail < 0 then
      putMVar sem (avail+1,blocked)
   else
      putMVar sem (avail, tail blocked)
      putMVar (head blocked) ()

Writing parallel code is hard, so I could have easily got this wrong.
I haven't looked at QSemN, which may need similar fixes (or may
already deal with this)

Thanks

Neil