Patch submitted by: Bas van Dijk <v.dijk.bas@gmail.com>
Modified slightly by me to remove non-functional changes.
import Prelude
import Control.Concurrent.MVar
import Prelude
import Control.Concurrent.MVar
+import Control.Exception ( block )
import Data.Typeable
#include "Typeable.h"
import Data.Typeable
#include "Typeable.h"
-- |Wait for a unit to become available
waitQSem :: QSem -> IO ()
-- |Wait for a unit to become available
waitQSem :: QSem -> IO ()
-waitQSem (QSem sem) = do
+waitQSem (QSem sem) = block $ do
(avail,blocked) <- takeMVar sem -- gain ex. access
if avail > 0 then
(avail,blocked) <- takeMVar sem -- gain ex. access
if avail > 0 then
- putMVar sem (avail-1,[])
+ let avail' = avail-1
+ in avail' `seq` putMVar sem (avail',[])
{-
Stuff the reader at the back of the queue,
so as to preserve waiting order. A signalling
{-
Stuff the reader at the back of the queue,
so as to preserve waiting order. A signalling
The version of waitQSem given in the paper could
lead to starvation.
-}
The version of waitQSem given in the paper could
lead to starvation.
-}
- putMVar sem (0, blocked++[block])
- takeMVar block
+ putMVar sem (0, blocked++[b])
+ takeMVar b
-- |Signal that a unit of the 'QSem' is available
signalQSem :: QSem -> IO ()
-- |Signal that a unit of the 'QSem' is available
signalQSem :: QSem -> IO ()
-signalQSem (QSem sem) = do
+signalQSem (QSem sem) = block $ do
(avail,blocked) <- takeMVar sem
case blocked of
(avail,blocked) <- takeMVar sem
case blocked of
- [] -> putMVar sem (avail+1,[])
+ [] -> let avail' = avail+1
+ in avail' `seq` putMVar sem (avail',blocked)