X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=Control%2FConcurrent%2FQSemN.hs;h=df3fa4207b754958c8d523f71a4e66beeb2ef10f;hb=3d4f3f4b8bc5571d3015816671457c88c0e697c3;hp=7ee6142e947b2f3c2e1bec2352517931b3e1506f;hpb=f779a4eeb052cfbe9eeaffd1366c8a4ff3b25703;p=ghc-base.git diff --git a/Control/Concurrent/QSemN.hs b/Control/Concurrent/QSemN.hs index 7ee6142..df3fa42 100644 --- a/Control/Concurrent/QSemN.hs +++ b/Control/Concurrent/QSemN.hs @@ -24,6 +24,7 @@ module Control.Concurrent.QSemN import Prelude import Control.Concurrent.MVar +import Control.Exception ( block ) import Data.Typeable #include "Typeable.h" @@ -35,6 +36,7 @@ newtype QSemN = QSemN (MVar (Int,[(Int,MVar ())])) INSTANCE_TYPEABLE0(QSemN,qSemNTc,"QSemN") -- |Build a new 'QSemN' with a supplied initial quantity. +-- The initial quantity must be at least 0. newQSemN :: Int -> IO QSemN newQSemN initial = if initial < 0 @@ -44,29 +46,30 @@ newQSemN initial = -- |Wait for the specified quantity to become available waitQSemN :: QSemN -> Int -> IO () -waitQSemN (QSemN sem) sz = do +waitQSemN (QSemN sem) sz = block $ do (avail,blocked) <- takeMVar sem -- gain ex. access - if (avail - sz) >= 0 then + let remaining = avail - sz + if remaining >= 0 then -- discharging 'sz' still leaves the semaphore -- in an 'unblocked' state. - putMVar sem (avail-sz,blocked) + putMVar sem (remaining,blocked) else do - block <- newEmptyMVar - putMVar sem (avail, blocked++[(sz,block)]) - takeMVar block + b <- newEmptyMVar + putMVar sem (avail, blocked++[(sz,b)]) + takeMVar b -- |Signal that a given quantity is now available from the 'QSemN'. signalQSemN :: QSemN -> Int -> IO () -signalQSemN (QSemN sem) n = do +signalQSemN (QSemN sem) n = block $ do (avail,blocked) <- takeMVar sem (avail',blocked') <- free (avail+n) blocked - putMVar sem (avail',blocked') + avail' `seq` putMVar sem (avail',blocked') where free avail [] = return (avail,[]) - free avail ((req,block):blocked) + free avail ((req,b):blocked) | avail >= req = do - putMVar block () + putMVar b () free (avail-req) blocked | otherwise = do (avail',blocked') <- free avail blocked - return (avail',(req,block):blocked') + return (avail',(req,b):blocked')