GHC threading bug in QSem

[Neil Mitchell]

I've now raised a ticket to track this issue:
http://hackage.haskell.org/trac/ghc/ticket/3159

Thanks, Neil

On Wed, Apr 8, 2009 at 11:26 AM, Neil Mitchell <ndmitchell at gmail.com> wrote:
> 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
>