{-# LANGUAGE Safe #-}
{-# LANGUAGE BangPatterns #-}

-----------------------------------------------------------------------------
-- |
-- 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   :  stable
-- 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 acquired
-- 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.
--
newtype 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 :: Int -> IO QSem
newQSem Int
initial
  | Int
initial Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = String -> IO QSem
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"newQSem: Initial quantity must be non-negative"
  | Bool
otherwise   = do
      MVar (Int, [MVar ()], [MVar ()])
sem <- (Int, [MVar ()], [MVar ()])
-> IO (MVar (Int, [MVar ()], [MVar ()]))
forall a. a -> IO (MVar a)
newMVar (Int
initial, [], [])
      QSem -> IO QSem
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (MVar (Int, [MVar ()], [MVar ()]) -> QSem
QSem MVar (Int, [MVar ()], [MVar ()])
sem)

-- |Wait for a unit to become available
waitQSem :: QSem -> IO ()
waitQSem :: QSem -> IO ()
waitQSem (QSem MVar (Int, [MVar ()], [MVar ()])
m) =
  IO () -> IO ()
forall a. IO a -> IO a
mask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    (Int
i,[MVar ()]
b1,[MVar ()]
b2) <- MVar (Int, [MVar ()], [MVar ()]) -> IO (Int, [MVar ()], [MVar ()])
forall a. MVar a -> IO a
takeMVar MVar (Int, [MVar ()], [MVar ()])
m
    if Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
       then do
         MVar ()
b <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
         MVar (Int, [MVar ()], [MVar ()])
-> (Int, [MVar ()], [MVar ()]) -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Int, [MVar ()], [MVar ()])
m (Int
i, [MVar ()]
b1, MVar ()
bMVar () -> [MVar ()] -> [MVar ()]
forall a. a -> [a] -> [a]
:[MVar ()]
b2)
         MVar () -> IO ()
wait MVar ()
b
       else do
         let !z :: Int
z = Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1
         MVar (Int, [MVar ()], [MVar ()])
-> (Int, [MVar ()], [MVar ()]) -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Int, [MVar ()], [MVar ()])
m (Int
z, [MVar ()]
b1, [MVar ()]
b2)
         () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    wait :: MVar () -> IO ()
wait MVar ()
b = MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
b IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`onException`
                (IO () -> IO ()
forall a. IO a -> IO a
uninterruptibleMask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do -- Note [signal uninterruptible]
                   (Int
i,[MVar ()]
b1,[MVar ()]
b2) <- MVar (Int, [MVar ()], [MVar ()]) -> IO (Int, [MVar ()], [MVar ()])
forall a. MVar a -> IO a
takeMVar MVar (Int, [MVar ()], [MVar ()])
m
                   Maybe ()
r <- MVar () -> IO (Maybe ())
forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar ()
b
                   (Int, [MVar ()], [MVar ()])
r' <- if Maybe () -> Bool
forall a. Maybe a -> Bool
isJust Maybe ()
r
                            then (Int, [MVar ()], [MVar ()]) -> IO (Int, [MVar ()], [MVar ()])
signal (Int
i,[MVar ()]
b1,[MVar ()]
b2)
                            else do MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
b (); (Int, [MVar ()], [MVar ()]) -> IO (Int, [MVar ()], [MVar ()])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
i,[MVar ()]
b1,[MVar ()]
b2)
                   MVar (Int, [MVar ()], [MVar ()])
-> (Int, [MVar ()], [MVar ()]) -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Int, [MVar ()], [MVar ()])
m (Int, [MVar ()], [MVar ()])
r')

-- |Signal that a unit of the 'QSem' is available
signalQSem :: QSem -> IO ()
signalQSem :: QSem -> IO ()
signalQSem (QSem MVar (Int, [MVar ()], [MVar ()])
m) =
  IO () -> IO ()
forall a. IO a -> IO a
uninterruptibleMask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do -- Note [signal uninterruptible]
    (Int, [MVar ()], [MVar ()])
r <- MVar (Int, [MVar ()], [MVar ()]) -> IO (Int, [MVar ()], [MVar ()])
forall a. MVar a -> IO a
takeMVar MVar (Int, [MVar ()], [MVar ()])
m
    (Int, [MVar ()], [MVar ()])
r' <- (Int, [MVar ()], [MVar ()]) -> IO (Int, [MVar ()], [MVar ()])
signal (Int, [MVar ()], [MVar ()])
r
    MVar (Int, [MVar ()], [MVar ()])
-> (Int, [MVar ()], [MVar ()]) -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Int, [MVar ()], [MVar ()])
m (Int, [MVar ()], [MVar ()])
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 :: (Int, [MVar ()], [MVar ()]) -> IO (Int, [MVar ()], [MVar ()])
signal (Int
i,[MVar ()]
a1,[MVar ()]
a2) =
 if Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
   then [MVar ()] -> [MVar ()] -> IO (Int, [MVar ()], [MVar ()])
forall {a}.
Num a =>
[MVar ()] -> [MVar ()] -> IO (a, [MVar ()], [MVar ()])
loop [MVar ()]
a1 [MVar ()]
a2
   else let !z :: Int
z = Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1 in (Int, [MVar ()], [MVar ()]) -> IO (Int, [MVar ()], [MVar ()])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
z, [MVar ()]
a1, [MVar ()]
a2)
 where
   loop :: [MVar ()] -> [MVar ()] -> IO (a, [MVar ()], [MVar ()])
loop [] [] = (a, [MVar ()], [MVar ()]) -> IO (a, [MVar ()], [MVar ()])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
1, [], [])
   loop [] [MVar ()]
b2 = [MVar ()] -> [MVar ()] -> IO (a, [MVar ()], [MVar ()])
loop ([MVar ()] -> [MVar ()]
forall a. [a] -> [a]
reverse [MVar ()]
b2) []
   loop (MVar ()
b:[MVar ()]
bs) [MVar ()]
b2 = do
     Bool
r <- MVar () -> () -> IO Bool
forall a. MVar a -> a -> IO Bool
tryPutMVar MVar ()
b ()
     if Bool
r then (a, [MVar ()], [MVar ()]) -> IO (a, [MVar ()], [MVar ()])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
0, [MVar ()]
bs, [MVar ()]
b2)
          else [MVar ()] -> [MVar ()] -> IO (a, [MVar ()], [MVar ()])
loop [MVar ()]
bs [MVar ()]
b2