TSem.hs

-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Concurrent.STM.TSem
-- Copyright   :  (c) The University of Glasgow 2012
-- License     :  BSD-style (see the file libraries/base/LICENSE)
-- 
-- Maintainer  :  libraries@haskell.org
-- Stability   :  experimental
-- Portability :  non-portable (requires STM)
--
-- 'TSem': transactional semaphores.
--
-----------------------------------------------------------------------------

{-# LANGUAGE DeriveDataTypeable #-}
module Control.Concurrent.STM.TSem (
      TSem, newTSem, waitTSem, signalTSem
  ) where

import Control.Concurrent.STM
import Control.Monad
import Data.Typeable
import Control.Exception

-- | 'TSem' is a transactional semaphore.  It holds a certain number
-- of units, and units may be acquired or released by 'waitTSem' and
-- 'signalTSem' respectively.  When the 'TSem' is empty, 'waitTSem'
-- blocks.
--
-- Note that 'TSem' has no concept of fairness, and there is no
-- guarantee that threads blocked in `waitTSem` will be unblocked in
-- the same order; in fact they will all be unblocked at the same time
-- and will fight over the 'TSem'.  Hence 'TSem' is not suitable if
-- you expect there to be a high number of threads contending for the
-- resource.  However, like other STM abstractions, 'TSem' is
-- composable.
--
newtype TSem = TSem (TVar Int)
  deriving (Eq, Typeable)

newTSem :: Int -> STM TSem
newTSem i = fmap TSem (newTVar i)

waitTSem :: TSem -> STM ()
waitTSem (TSem t) = do
  i <- readTVar t
  when (i <= 0) retry
  writeTVar t $! (i-1)

signalTSem :: TSem -> STM ()
signalTSem (TSem t) = do
  i <- readTVar t
  writeTVar t $! i+1