{-# LANGUAGE Safe #-}

-----------------------------------------------------------------------------
-- |
-- 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 Control.Exception
import Data.Maybe

-- | 'QSemN' is a quantity semaphore in which the resource is acquired
-- 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.
--
newtype QSemN = QSemN (MVar (Int, [(Int, MVar ())], [(Int, 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 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 :: Int -> IO QSemN
newQSemN initial :: Int
initial
  | Int
initial Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 0 = String -> IO QSemN
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "newQSemN: Initial quantity must be non-negative"
  | Bool
otherwise   = do
      MVar (Int, [(Int, MVar ())], [(Int, MVar ())])
sem <- (Int, [(Int, MVar ())], [(Int, MVar ())])
-> IO (MVar (Int, [(Int, MVar ())], [(Int, MVar ())]))
forall a. a -> IO (MVar a)
newMVar (Int
initial, [], [])
      QSemN -> IO QSemN
forall (m :: * -> *) a. Monad m => a -> m a
return (MVar (Int, [(Int, MVar ())], [(Int, MVar ())]) -> QSemN
QSemN MVar (Int, [(Int, MVar ())], [(Int, MVar ())])
sem)

-- |Wait for the specified quantity to become available
waitQSemN :: QSemN -> Int -> IO ()
waitQSemN :: QSemN -> Int -> IO ()
waitQSemN (QSemN m :: MVar (Int, [(Int, MVar ())], [(Int, MVar ())])
m) sz :: Int
sz =
  IO () -> IO ()
forall a. IO a -> IO a
mask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    (i :: Int
i,b1 :: [(Int, MVar ())]
b1,b2 :: [(Int, MVar ())]
b2) <- MVar (Int, [(Int, MVar ())], [(Int, MVar ())])
-> IO (Int, [(Int, MVar ())], [(Int, MVar ())])
forall a. MVar a -> IO a
takeMVar MVar (Int, [(Int, MVar ())], [(Int, MVar ())])
m
    let z :: Int
z = Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
sz
    if Int
z Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 0
       then do
         MVar ()
b <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
         MVar (Int, [(Int, MVar ())], [(Int, MVar ())])
-> (Int, [(Int, MVar ())], [(Int, MVar ())]) -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Int, [(Int, MVar ())], [(Int, MVar ())])
m (Int
i, [(Int, MVar ())]
b1, (Int
sz,MVar ()
b)(Int, MVar ()) -> [(Int, MVar ())] -> [(Int, MVar ())]
forall a. a -> [a] -> [a]
:[(Int, MVar ())]
b2)
         MVar () -> IO ()
wait MVar ()
b
       else do
         MVar (Int, [(Int, MVar ())], [(Int, MVar ())])
-> (Int, [(Int, MVar ())], [(Int, MVar ())]) -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Int, [(Int, MVar ())], [(Int, MVar ())])
m (Int
z, [(Int, MVar ())]
b1, [(Int, MVar ())]
b2)
         () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    wait :: MVar () -> IO ()
wait b :: MVar ()
b = do
        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]
                   (i :: Int
i,b1 :: [(Int, MVar ())]
b1,b2 :: [(Int, MVar ())]
b2) <- MVar (Int, [(Int, MVar ())], [(Int, MVar ())])
-> IO (Int, [(Int, MVar ())], [(Int, MVar ())])
forall a. MVar a -> IO a
takeMVar MVar (Int, [(Int, MVar ())], [(Int, MVar ())])
m
                   Maybe ()
r <- MVar () -> IO (Maybe ())
forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar ()
b
                   (Int, [(Int, MVar ())], [(Int, MVar ())])
r' <- if Maybe () -> Bool
forall a. Maybe a -> Bool
isJust Maybe ()
r
                            then Int
-> (Int, [(Int, MVar ())], [(Int, MVar ())])
-> IO (Int, [(Int, MVar ())], [(Int, MVar ())])
signal Int
sz (Int
i,[(Int, MVar ())]
b1,[(Int, MVar ())]
b2)
                            else do MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
b (); (Int, [(Int, MVar ())], [(Int, MVar ())])
-> IO (Int, [(Int, MVar ())], [(Int, MVar ())])
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
i,[(Int, MVar ())]
b1,[(Int, MVar ())]
b2)
                   MVar (Int, [(Int, MVar ())], [(Int, MVar ())])
-> (Int, [(Int, MVar ())], [(Int, MVar ())]) -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Int, [(Int, MVar ())], [(Int, MVar ())])
m (Int, [(Int, MVar ())], [(Int, MVar ())])
r')

-- |Signal that a given quantity is now available from the 'QSemN'.
signalQSemN :: QSemN -> Int -> IO ()
signalQSemN :: QSemN -> Int -> IO ()
signalQSemN (QSemN m :: MVar (Int, [(Int, MVar ())], [(Int, MVar ())])
m) sz :: Int
sz = IO () -> IO ()
forall a. IO a -> IO a
uninterruptibleMask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  (Int, [(Int, MVar ())], [(Int, MVar ())])
r <- MVar (Int, [(Int, MVar ())], [(Int, MVar ())])
-> IO (Int, [(Int, MVar ())], [(Int, MVar ())])
forall a. MVar a -> IO a
takeMVar MVar (Int, [(Int, MVar ())], [(Int, MVar ())])
m
  (Int, [(Int, MVar ())], [(Int, MVar ())])
r' <- Int
-> (Int, [(Int, MVar ())], [(Int, MVar ())])
-> IO (Int, [(Int, MVar ())], [(Int, MVar ())])
signal Int
sz (Int, [(Int, MVar ())], [(Int, MVar ())])
r
  MVar (Int, [(Int, MVar ())], [(Int, MVar ())])
-> (Int, [(Int, MVar ())], [(Int, MVar ())]) -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Int, [(Int, MVar ())], [(Int, MVar ())])
m (Int, [(Int, MVar ())], [(Int, MVar ())])
r'

signal :: Int
       -> (Int,[(Int,MVar ())],[(Int,MVar ())])
       -> IO (Int,[(Int,MVar ())],[(Int,MVar ())])

signal :: Int
-> (Int, [(Int, MVar ())], [(Int, MVar ())])
-> IO (Int, [(Int, MVar ())], [(Int, MVar ())])
signal sz0 :: Int
sz0 (i :: Int
i,a1 :: [(Int, MVar ())]
a1,a2 :: [(Int, MVar ())]
a2) = Int
-> [(Int, MVar ())]
-> [(Int, MVar ())]
-> IO (Int, [(Int, MVar ())], [(Int, MVar ())])
forall a.
(Num a, Ord a) =>
a
-> [(a, MVar ())]
-> [(a, MVar ())]
-> IO (a, [(a, MVar ())], [(a, MVar ())])
loop (Int
sz0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i) [(Int, MVar ())]
a1 [(Int, MVar ())]
a2
 where
   loop :: a
-> [(a, MVar ())]
-> [(a, MVar ())]
-> IO (a, [(a, MVar ())], [(a, MVar ())])
loop 0  bs :: [(a, MVar ())]
bs b2 :: [(a, MVar ())]
b2 = (a, [(a, MVar ())], [(a, MVar ())])
-> IO (a, [(a, MVar ())], [(a, MVar ())])
forall (m :: * -> *) a. Monad m => a -> m a
return (0,  [(a, MVar ())]
bs, [(a, MVar ())]
b2)
   loop sz :: a
sz [] [] = (a, [(a, MVar ())], [(a, MVar ())])
-> IO (a, [(a, MVar ())], [(a, MVar ())])
forall (m :: * -> *) a. Monad m => a -> m a
return (a
sz, [], [])
   loop sz :: a
sz [] b2 :: [(a, MVar ())]
b2 = a
-> [(a, MVar ())]
-> [(a, MVar ())]
-> IO (a, [(a, MVar ())], [(a, MVar ())])
loop a
sz ([(a, MVar ())] -> [(a, MVar ())]
forall a. [a] -> [a]
reverse [(a, MVar ())]
b2) []
   loop sz :: a
sz ((j :: a
j,b :: MVar ()
b):bs :: [(a, MVar ())]
bs) b2 :: [(a, MVar ())]
b2
     | a
j a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
sz = do
       Bool
r <- MVar () -> IO Bool
forall a. MVar a -> IO Bool
isEmptyMVar MVar ()
b
       if Bool
r then (a, [(a, MVar ())], [(a, MVar ())])
-> IO (a, [(a, MVar ())], [(a, MVar ())])
forall (m :: * -> *) a. Monad m => a -> m a
return (a
sz, (a
j,MVar ()
b)(a, MVar ()) -> [(a, MVar ())] -> [(a, MVar ())]
forall a. a -> [a] -> [a]
:[(a, MVar ())]
bs, [(a, MVar ())]
b2)
            else a
-> [(a, MVar ())]
-> [(a, MVar ())]
-> IO (a, [(a, MVar ())], [(a, MVar ())])
loop a
sz [(a, MVar ())]
bs [(a, MVar ())]
b2
     | Bool
otherwise = do
       Bool
r <- MVar () -> () -> IO Bool
forall a. MVar a -> a -> IO Bool
tryPutMVar MVar ()
b ()
       if Bool
r then a
-> [(a, MVar ())]
-> [(a, MVar ())]
-> IO (a, [(a, MVar ())], [(a, MVar ())])
loop (a
sza -> a -> a
forall a. Num a => a -> a -> a
-a
j) [(a, MVar ())]
bs [(a, MVar ())]
b2
            else a
-> [(a, MVar ())]
-> [(a, MVar ())]
-> IO (a, [(a, MVar ())], [(a, MVar ())])
loop a
sz [(a, MVar ())]
bs [(a, MVar ())]
b2