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