QSem fails with negative quantities

The following program should always give 100 (I think). It doesn't:

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

With a 2 processor machine on Windows, using GHC 6.8.3 and 6.10.2 and +RTS -N3 I usually get 100, but occasionally get answers such as 49, 82, 95. With +RTS -N2 it almost always works.

From reading the implementation of QSem, it doesn't seem that negative availability was considered. A quick look suggests a better implementation might be:

-- 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)

Marking as severity major because it can cause incorrect parallel behaviour.

Trac metadata

Trac field	Value
Version	6.10.2
Type	Bug
TypeOfFailure	OtherFailure
Priority	normal
Resolution	Unresolved
Component	libraries/base
Test case
Differential revisions
BlockedBy
Related
Blocking
CC
Operating system
Architecture