GHC threading bug in QSem

[Chris Kuklewicz]

The code assumes newQsem is never given a negative argument without ever
documenting this fact.

http://www.haskell.org/ghc/docs/latest/html/libraries/base/src/Control-Concurrent-QSem.html#waitQSem

change not only
     putMVar sem (0, blocked++[block])
to
     putMVar sem (avail, blocked++[block])
in waitQSem

but also change signalQSem to

> signalQSem :: QSemN -> IO ()
> signalQSem (QSemN sem) = modifyMVar_ free sem
>  where free (0,(b:bs)) = putMVar b () >> return (0,bs)
>        free (avail,blocked) = return (avail+1,blocked)

Neil: To allow negative values you have to change signalQSem and waitQSem.

And really folks, the waitQSem(N) and signalQSem(N) should be exception safe and
this is not currently true.  They should all be using the modifyMVar_ idiom —
currently an exception such as killThread between the take and put will leave
the semaphore perpetually empty which is not a valid state.

I also hereby lobby that a non-blocking "trySem" be added, and while
Control.Concurrent is getting updated I think that Neil's last concurrency
puzzle would have been helped by having a non-blocking "tryReadChan" in
Control.Concurrent.Chan (note that the isEmptyChan is not useful for making
non-blocking read), and how about Control.Concurrent.Pony ?

"Control.Concurrent.SampleVar" is also not exception safe.



Neil Mitchell 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
> _______________________________________________
> Glasgow-haskell-users mailing list
> Glasgow-haskell-users at haskell.org
> http://www.haskell.org/mailman/listinfo/glasgow-haskell-users