projects
/
ghc-base.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Use explicit language extensions & remove extension fields from base.cabal
[ghc-base.git]
/
Control
/
Concurrent
/
QSem.hs
diff --git
a/Control/Concurrent/QSem.hs
b/Control/Concurrent/QSem.hs
index
cc78470
..
22f6c0c
100644
(file)
--- a/
Control/Concurrent/QSem.hs
+++ b/
Control/Concurrent/QSem.hs
@@
-1,3
+1,5
@@
+{-# LANGUAGE CPP #-}
+
-----------------------------------------------------------------------------
-- |
-- Module : Control.Concurrent.QSem
-----------------------------------------------------------------------------
-- |
-- Module : Control.Concurrent.QSem
@@
-22,6
+24,7
@@
module Control.Concurrent.QSem
import Prelude
import Control.Concurrent.MVar
import Prelude
import Control.Concurrent.MVar
+import Control.Exception ( mask_ )
import Data.Typeable
#include "Typeable.h"
import Data.Typeable
#include "Typeable.h"
@@
-35,7
+38,7
@@
import Data.Typeable
-- |A 'QSem' is a simple quantity semaphore, in which the available
-- \"quantity\" is always dealt with in units of one.
-- |A 'QSem' is a simple quantity semaphore, in which the available
-- \"quantity\" is always dealt with in units of one.
-newtype QSem = QSem (MVar (Int, [MVar ()]))
+newtype QSem = QSem (MVar (Int, [MVar ()])) deriving Eq
INSTANCE_TYPEABLE0(QSem,qSemTc,"QSem")
INSTANCE_TYPEABLE0(QSem,qSemTc,"QSem")
@@
-50,12
+53,13
@@
newQSem initial =
-- |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) = mask_ $ 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',[])
else do
else do
- block <- newEmptyMVar
+ b <- newEmptyMVar
{-
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
@@
-65,16
+69,17
@@
waitQSem (QSem sem) = do
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) = mask_ $ 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)
- (block:blocked') -> do
+ (b:blocked') -> do
putMVar sem (0,blocked')
putMVar sem (0,blocked')
- putMVar block ()
+ putMVar b ()