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-Concu... 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