Different QSem(N)

[Bertram Felgenhauer]

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