
ChrisK wrote:
I think I can improve on your code.
Bertram Felgenhauer wrote:
-- | Wait for a unit to become available waitSem :: Sem -> IO () waitSem (Sem sem wakeup) = do avail' <- modifyMVar sem (\avail -> return (avail-1, avail-1))
Threads can get out of order at this point.
Is this observable, i.e. distinguishable from the threads entering 'waitSem' in a different order? I think not.
Also, killing the thread while it waits for "wakeup" below would be bad. You need an exception handler and some kind of cleanup.
True. I didn't try for exception safety, mainly because Control.Concurrent.QSem isn't currently exception safe. I would require the caller of waitSem/signalSem to call 'block' if they need exception safety, because outside any 'block', an exception might occur right before or after the semaphore operation - causing tokens (the things that the semaphore counter counts) to get unaccountably lost or created, making exception safety rather meaningless.
If you do not need to take N at a time then the untested code below has no "order bug" and is fair.
module Sem where import Control.Concurrent.MVar import Control.Monad(when,liftM2) data Sem = Sem { avail :: MVar Int -- ^ provides fast path and fair queue , lock :: MVar () } -- ^ Held while signalling the queue -- It makes no sense here to initialize with a negative number, so -- this is treated the same as initializing with 0. newSem :: Int -> IO Sem newSem init | init < 1 = liftM2 Sem newEmptyMVar (newMVar ()) | otherwise = liftM2 Sem (newMVar init) (newMVar ()) waitSem :: Sem -> IO () waitSem (Sem sem _) = block $ do avail <- takeMVar sem when (avail > 1) (signalSemN (pred avail))
These (pred avail) tokens may be lost if signalSemN blocks on the semaphore lock and an asynchronous exception is caught at that point. (withMVar uses takeMVar internally, and the fact that it's inside 'block' doesn't help - it's a blocking operation)
signalSem :: Sem -> IO () signalSem = signalSemN 1 signalSemN :: Int -> Sem -> IO () signalSemN i (Sem sem lock) | i <= 1 = return () ^^^^^^ should be i <= 0
| otherwise = withMVar lock $ \ _ -> block $ do old <- tryTakeMVar sem case old of Nothing -> putMVar sem i Just v -> putMVar sem $! succ i
^^^^^^ should be old + i
I see no way to add a fair waitSemN without changing Sem. But if I change Sem then I can make a fair waitSemN. The untested code is below:
signalSemN :: Int -> Sem -> IO () signalSemN i (Sem _ a s) | i<=0 = return () | otherwise = withMVar s $ \ _ -> block $ do
Same as above: Exceptions may creep into the withMVar, and the signalSemN call from waitSemN may thus fail.
ma <- tryTakeMVar a case ma of Nothing -> putMVar a i Just v -> putMVar a $! v+i
Trying for exception safety makes the above slightly tricky.
Indeed. I need to think about this some more.
Cheers, Chris Kuklewicz
Bertram