From 1127922b72ce9f2e57dd4e77e303be6804ae9c3a Mon Sep 17 00:00:00 2001 From: Simon Marlow Date: Thu, 8 Jul 2010 14:58:19 +0000 Subject: [PATCH] Async-exception safety, and avoid space leaks Patch submitted by: Bas van Dijk Modified slightly by me to remove non-functional changes. --- Control/Concurrent/QSem.hs | 21 ++++++++++++--------- 1 file changed, 12 insertions(+), 9 deletions(-) diff --git a/Control/Concurrent/QSem.hs b/Control/Concurrent/QSem.hs index cc78470..c009aaf 100644 --- a/Control/Concurrent/QSem.hs +++ b/Control/Concurrent/QSem.hs @@ -22,6 +22,7 @@ module Control.Concurrent.QSem import Prelude import Control.Concurrent.MVar +import Control.Exception ( block ) import Data.Typeable #include "Typeable.h" @@ -50,12 +51,13 @@ newQSem initial = -- |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 - putMVar sem (avail-1,[]) + let avail' = avail-1 + in avail' `seq` putMVar sem (avail',[]) else do - block <- newEmptyMVar + b <- newEmptyMVar {- Stuff the reader at the back of the queue, so as to preserve waiting order. A signalling @@ -65,16 +67,17 @@ waitQSem (QSem sem) = do 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 () -signalQSem (QSem sem) = do +signalQSem (QSem sem) = block $ do (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 block () + putMVar b () -- 1.7.10.4