Permalink
Browse files

Add back new working QSem and QSemN implementations (#7417)

We decided not to break existing users without providing an easy
migration path.  For the time being I've made these implementations,
which fix the bugs in the old versions and perform reasonably well.

In due course we should move the concurrency functionality, including
these modules, out of base and into a separate package.
  • Loading branch information...
simonmar committed Dec 10, 2012
1 parent 1bfecaf commit ea3abf16eda97e573ee63fb08ce330d3aeceaeae
Showing with 467 additions and 0 deletions.
  1. +4 −0 Control/Concurrent.hs
  2. +133 −0 Control/Concurrent/QSem.hs
  3. +127 −0 Control/Concurrent/QSemN.hs
  4. +2 −0 base.cabal
  5. +3 −0 tests/all.T
  6. +88 −0 tests/qsem001.hs
  7. +110 −0 tests/qsemn001.hs
View
@@ -72,6 +72,8 @@ module Control.Concurrent (
module Control.Concurrent.MVar,
module Control.Concurrent.Chan,
+ module Control.Concurrent.QSem,
+ module Control.Concurrent.QSemN,
#ifdef __GLASGOW_HASKELL__
-- * Bound Threads
@@ -137,6 +139,8 @@ import Hugs.ConcBase
import Control.Concurrent.MVar
import Control.Concurrent.Chan
+import Control.Concurrent.QSem
+import Control.Concurrent.QSemN
#ifdef __HUGS__
type ThreadId = ()
View
@@ -0,0 +1,133 @@
+{-# LANGUAGE Trustworthy #-}
+{-# LANGUAGE CPP #-}
+#ifdef __GLASGOW_HASKELL__
+{-# LANGUAGE DeriveDataTypeable, BangPatterns #-}
+#endif
+{-# OPTIONS_GHC -funbox-strict-fields #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module : Control.Concurrent.QSem
+-- Copyright : (c) The University of Glasgow 2001
+-- License : BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : non-portable (concurrency)
+--
+-- Simple quantity semaphores.
+--
+-----------------------------------------------------------------------------
+
+module Control.Concurrent.QSem
+ ( -- * Simple Quantity Semaphores
+ QSem, -- abstract
+ newQSem, -- :: Int -> IO QSem
+ waitQSem, -- :: QSem -> IO ()
+ signalQSem -- :: QSem -> IO ()
+ ) where
+
+import Control.Concurrent.MVar ( MVar, newEmptyMVar, takeMVar, tryTakeMVar
+ , putMVar, newMVar, tryPutMVar)
+import Control.Exception
+import Data.Maybe
+
+-- | 'QSem' is a quantity semaphore in which the resource is aqcuired
+-- and released in units of one. It provides guaranteed FIFO ordering
+-- for satisfying blocked `waitQSem` calls.
+--
+-- The pattern
+--
+-- > bracket_ waitQSem signalQSem (...)
+--
+-- is safe; it never loses a unit of the resource.
+--
+data QSem = QSem !(MVar (Int, [MVar ()], [MVar ()]))
+
+-- The semaphore state (i, xs, ys):
+--
+-- i is the current resource value
+--
+-- (xs,ys) is the queue of blocked threads, where the queue is
+-- given by xs ++ reverse ys. We can enqueue new blocked threads
+-- by consing onto ys, and dequeue by removing from the head of xs.
+--
+-- A blocked thread is represented by an empty (MVar ()). To unblock
+-- the thread, we put () into the MVar.
+--
+-- A thread can dequeue itself by also putting () into the MVar, which
+-- it must do if it receives an exception while blocked in waitQSem.
+-- This means that when unblocking a thread in signalQSem we must
+-- first check whether the MVar is already full; the MVar lock on the
+-- semaphore itself resolves race conditions between signalQSem and a
+-- thread attempting to dequeue itself.
+
+-- |Build a new 'QSem' with a supplied initial quantity.
+-- The initial quantity must be at least 0.
+newQSem :: Int -> IO QSem
+newQSem initial
+ | initial < 0 = fail "newQSem: Initial quantity must be non-negative"
+ | otherwise = do
+ sem <- newMVar (initial, [], [])
+ return (QSem sem)
+
+-- |Wait for a unit to become available
+waitQSem :: QSem -> IO ()
+waitQSem (QSem m) =
+ mask_ $ do
+ (i,b1,b2) <- takeMVar m
+ if i == 0
+ then do
+ b <- newEmptyMVar
+ putMVar m (i, b1, b:b2)
+ wait b
+ else do
+ let !z = i-1
+ putMVar m (z, b1, b2)
+ return ()
+ where
+ wait b = takeMVar b `onException` do
+ (uninterruptibleMask_ $ do -- Note [signal uninterruptible]
+ (i,b1,b2) <- takeMVar m
+ r <- tryTakeMVar b
+ r' <- if isJust r
+ then signal (i,b1,b2)
+ else do putMVar b (); return (i,b1,b2)
+ putMVar m r')
+
+-- |Signal that a unit of the 'QSem' is available
+signalQSem :: QSem -> IO ()
+signalQSem (QSem m) =
+ uninterruptibleMask_ $ do -- Note [signal uninterruptible]
+ r <- takeMVar m
+ r' <- signal r
+ putMVar m r'
+
+-- Note [signal uninterruptible]
+--
+-- If we have
+--
+-- bracket waitQSem signalQSem (...)
+--
+-- and an exception arrives at the signalQSem, then we must not lose
+-- the resource. The signalQSem is masked by bracket, but taking
+-- the MVar might block, and so it would be interruptible. Hence we
+-- need an uninterruptibleMask here.
+--
+-- This isn't ideal: during high contention, some threads won't be
+-- interruptible. The QSemSTM implementation has better behaviour
+-- here, but it performs much worse than this one in some
+-- benchmarks.
+
+signal :: (Int,[MVar ()],[MVar ()]) -> IO (Int,[MVar ()],[MVar ()])
+signal (i,a1,a2) =
+ if i == 0
+ then loop a1 a2
+ else let !z = i+1 in return (z, a1, a2)
+ where
+ loop [] [] = return (1, [], [])
+ loop [] b2 = loop (reverse b2) []
+ loop (b:bs) b2 = do
+ r <- tryPutMVar b ()
+ if r then return (0, bs, b2)
+ else loop bs b2
View
@@ -0,0 +1,127 @@
+{-# LANGUAGE Trustworthy #-}
+{-# LANGUAGE CPP #-}
+#ifdef __GLASGOW_HASKELL__
+{-# LANGUAGE DeriveDataTypeable, BangPatterns #-}
+#endif
+{-# OPTIONS_GHC -funbox-strict-fields #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module : Control.Concurrent.QSemN
+-- Copyright : (c) The University of Glasgow 2001
+-- License : BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : non-portable (concurrency)
+--
+-- Quantity semaphores in which each thread may wait for an arbitrary
+-- \"amount\".
+--
+-----------------------------------------------------------------------------
+
+module Control.Concurrent.QSemN
+ ( -- * General Quantity Semaphores
+ QSemN, -- abstract
+ newQSemN, -- :: Int -> IO QSemN
+ waitQSemN, -- :: QSemN -> Int -> IO ()
+ signalQSemN -- :: QSemN -> Int -> IO ()
+ ) where
+
+import Control.Concurrent.MVar ( MVar, newEmptyMVar, takeMVar, tryTakeMVar
+ , putMVar, newMVar
+ , tryPutMVar, isEmptyMVar)
+import Data.Typeable
+import Control.Exception
+import Data.Maybe
+
+-- | 'QSemN' is a quantity semaphore in which the resource is aqcuired
+-- and released in units of one. It provides guaranteed FIFO ordering
+-- for satisfying blocked `waitQSemN` calls.
+--
+-- The pattern
+--
+-- > bracket_ (waitQSemN n) (signalQSemN n) (...)
+--
+-- is safe; it never loses any of the resource.
+--
+data QSemN = QSemN !(MVar (Int, [(Int, MVar ())], [(Int, MVar ())]))
+ deriving Typeable
+
+-- The semaphore state (i, xs, ys):
+--
+-- i is the current resource value
+--
+-- (xs,ys) is the queue of blocked threads, where the queue is
+-- given by xs ++ reverse ys. We can enqueue new blocked threads
+-- by consing onto ys, and dequeue by removing from the head of xs.
+--
+-- A blocked thread is represented by an empty (MVar ()). To unblock
+-- the thread, we put () into the MVar.
+--
+-- A thread can dequeue itself by also putting () into the MVar, which
+-- it must do if it receives an exception while blocked in waitQSemN.
+-- This means that when unblocking a thread in signalQSemN we must
+-- first check whether the MVar is already full; the MVar lock on the
+-- semaphore itself resolves race conditions between signalQSemN and a
+-- thread attempting to dequeue itself.
+
+-- |Build a new 'QSemN' with a supplied initial quantity.
+-- The initial quantity must be at least 0.
+newQSemN :: Int -> IO QSemN
+newQSemN initial
+ | initial < 0 = fail "newQSemN: Initial quantity must be non-negative"
+ | otherwise = do
+ sem <- newMVar (initial, [], [])
+ return (QSemN sem)
+
+-- |Wait for the specified quantity to become available
+waitQSemN :: QSemN -> Int -> IO ()
+waitQSemN (QSemN m) sz =
+ mask_ $ do
+ (i,b1,b2) <- takeMVar m
+ let z = i-sz
+ if z < 0
+ then do
+ b <- newEmptyMVar
+ putMVar m (i, b1, (sz,b):b2)
+ wait b
+ else do
+ putMVar m (z, b1, b2)
+ return ()
+ where
+ wait b = do
+ takeMVar b `onException`
+ (uninterruptibleMask_ $ do -- Note [signal uninterruptible]
+ (i,b1,b2) <- takeMVar m
+ r <- tryTakeMVar b
+ r' <- if isJust r
+ then signal sz (i,b1,b2)
+ else do putMVar b (); return (i,b1,b2)
+ putMVar m r')
+
+-- |Signal that a given quantity is now available from the 'QSemN'.
+signalQSemN :: QSemN -> Int -> IO ()
+signalQSemN (QSemN m) sz = uninterruptibleMask_ $ do
+ r <- takeMVar m
+ r' <- signal sz r
+ putMVar m r'
+
+signal :: Int
+ -> (Int,[(Int,MVar ())],[(Int,MVar ())])
+ -> IO (Int,[(Int,MVar ())],[(Int,MVar ())])
+
+signal sz0 (i,a1,a2) = loop (sz0 + i) a1 a2
+ where
+ loop 0 bs b2 = return (0, bs, b2)
+ loop sz [] [] = return (sz, [], [])
+ loop sz [] b2 = loop sz (reverse b2) []
+ loop sz ((j,b):bs) b2
+ | j > sz = do
+ r <- isEmptyMVar b
+ if r then return (sz, (j,b):bs, b2)
+ else loop sz bs b2
+ | otherwise = do
+ r <- tryPutMVar b ()
+ if r then loop (sz-j) bs b2
+ else loop sz bs b2
View
@@ -120,6 +120,8 @@ Library {
Control.Concurrent,
Control.Concurrent.Chan,
Control.Concurrent.MVar,
+ Control.Concurrent.QSem,
+ Control.Concurrent.QSemN,
Control.Exception,
Control.Exception.Base
Control.Monad,
View
@@ -118,3 +118,6 @@ test('4006', if_msys(expect_fail), compile_and_run, [''])
test('5943', normal, compile_and_run, [''])
test('T5962', normal, compile_and_run, [''])
test('T7034', normal, compile_and_run, [''])
+
+test('qsem001', normal, compile_and_run, [''])
+test('qsemn001', normal, compile_and_run, [''])
View
@@ -0,0 +1,88 @@
+{-# LANGUAGE CPP #-}
+import Control.Concurrent.QSem as OldQ
+
+import Control.Concurrent.Chan
+import Control.Concurrent (forkIO, threadDelay, killThread, yield)
+import Control.Concurrent.MVar
+import Control.Exception
+import Control.Monad
+
+new = newQSem
+wait = waitQSem
+signal = signalQSem
+
+--------
+-- dummy test-framework
+
+type Assertion = IO ()
+
+x @?= y = when (x /= y) $ error (show x ++ " /= " ++ show y)
+
+testCase :: String -> IO () -> IO ()
+testCase n io = putStrLn ("test " ++ n) >> io
+
+defaultMain = sequence
+------
+
+main = defaultMain tests
+
+tests = [
+ testCase "sem1" sem1,
+ testCase "sem2" sem2,
+ testCase "sem_kill" sem_kill,
+ testCase "sem_fifo" sem_fifo,
+ testCase "sem_bracket" sem_bracket
+ ]
+
+sem1 :: Assertion
+sem1 = do
+ q <- new 0
+ signal q
+ wait q
+
+sem2 :: Assertion
+sem2 = do
+ q <- new 0
+ signal q
+ signal q
+ wait q
+ wait q
+
+sem_fifo :: Assertion
+sem_fifo = do
+ c <- newChan
+ q <- new 0
+ t1 <- forkIO $ do wait q; writeChan c 'a'
+ threadDelay 10000
+ t2 <- forkIO $ do wait q; writeChan c 'b'
+ threadDelay 10000
+ t3 <- forkIO $ do wait q; writeChan c 'c'
+ threadDelay 10000
+ signal q
+ a <- readChan c
+ signal q
+ b <- readChan c
+ signal q
+ c <- readChan c
+ [a,b,c] @?= "abc"
+
+sem_kill :: Assertion
+sem_kill = do
+ q <- new 0
+ t <- forkIO $ do wait q
+ threadDelay 100000
+ killThread t
+ m <- newEmptyMVar
+ t <- forkIO $ do wait q; putMVar m ()
+ signal q
+ takeMVar m
+
+
+sem_bracket :: Assertion
+sem_bracket = do
+ q <- new 1
+ ts <- forM [1..100000] $ \n -> do
+ forkIO $ do bracket_ (wait q) (signal q) (return ())
+ mapM_ killThread ts
+ wait q
+
Oops, something went wrong.

0 comments on commit ea3abf1

Please sign in to comment.