{-# LANGUAGE CPP, BangPatterns,
             MagicHash, UnboxedTuples, ScopedTypeVariables #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Concurrent.MVar.Strict
-- 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)
--
-- Synchronising, strict variables
--
-- Values placed in an MVar are evaluated to head normal form
-- before being placed in the MVar, preventing a common source of
-- space-leaks involving synchronising variables.
--
-----------------------------------------------------------------------------

module Control.Concurrent.MVar.Strict
        (
          -- * @MVar@s
          MVar          -- abstract
        , newEmptyMVar  -- :: IO (MVar a)
        , newMVar       -- :: a -> IO (MVar a)
        , takeMVar      -- :: MVar a -> IO a
        , putMVar       -- :: MVar a -> a -> IO ()
        , readMVar      -- :: MVar a -> IO a
        , swapMVar      -- :: MVar a -> a -> IO a
        , tryTakeMVar   -- :: MVar a -> IO (Maybe a)
        , tryPutMVar    -- :: MVar a -> a -> IO Bool
        , isEmptyMVar   -- :: MVar a -> IO Bool
        , withMVar      -- :: MVar a -> (a -> IO b) -> IO b
        , modifyMVar_   -- :: MVar a -> (a -> IO a) -> IO ()
        , modifyMVar    -- :: MVar a -> (a -> IO (a,b)) -> IO b
        , addMVarFinalizer -- :: MVar a -> IO () -> IO ()
    ) where

import Control.Concurrent.MVar ( newEmptyMVar, takeMVar, 
                  tryTakeMVar, isEmptyMVar, addMVarFinalizer
                )
import GHC.Exts
import GHC.Base
import GHC.MVar (MVar(MVar))

import Control.Exception as Exception
-- import Control.Parallel.Strategies
import Control.DeepSeq

-- |Put a value into an 'MVar'.  If the 'MVar' is currently full,
-- 'putMVar' will wait until it becomes empty.
--
-- There are two further important properties of 'putMVar':
--
--   * 'putMVar' is single-wakeup.  That is, if there are multiple
--     threads blocked in 'putMVar', and the 'MVar' becomes empty,
--     only one thread will be woken up.  The runtime guarantees that
--     the woken thread completes its 'putMVar' operation.
--
--   * When multiple threads are blocked on an 'MVar', they are
--     woken up in FIFO order.  This is useful for providing
--     fairness properties of abstractions built using 'MVar's.
--
putMVar  :: NFData a => MVar a -> a -> IO ()
#ifndef __HADDOCK__
putMVar :: MVar a -> a -> IO ()
putMVar (MVar MVar# RealWorld a
mvar#) !a
x = a -> ()
forall a. NFData a => a -> ()
rnf a
x () -> IO () -> IO ()
`seq` (State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, () #)) -> IO ())
-> (State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ State# RealWorld
s# -> -- strict!
    case MVar# RealWorld a -> a -> State# RealWorld -> State# RealWorld
forall d a. MVar# d a -> a -> State# d -> State# d
putMVar# MVar# RealWorld a
mvar# a
x State# RealWorld
s# of
        State# RealWorld
s2# -> (# State# RealWorld
s2#, () #)
#endif

-- | A non-blocking version of 'putMVar'.  The 'tryPutMVar' function
-- attempts to put the value @a@ into the 'MVar', returning 'True' if
-- it was successful, or 'False' otherwise.
--
tryPutMVar  :: NFData a => MVar a -> a -> IO Bool
#ifndef __HADDOCK__
tryPutMVar :: MVar a -> a -> IO Bool
tryPutMVar (MVar MVar# RealWorld a
mvar#) !a
x = (State# RealWorld -> (# State# RealWorld, Bool #)) -> IO Bool
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, Bool #)) -> IO Bool)
-> (State# RealWorld -> (# State# RealWorld, Bool #)) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \ State# RealWorld
s# -> -- strict!
    case MVar# RealWorld a
-> a -> State# RealWorld -> (# State# RealWorld, Int# #)
forall d a. MVar# d a -> a -> State# d -> (# State# d, Int# #)
tryPutMVar# MVar# RealWorld a
mvar# a
x State# RealWorld
s# of
        (# State# RealWorld
s, Int#
0# #) -> (# State# RealWorld
s, Bool
False #)
        (# State# RealWorld
s, Int#
_  #) -> (# State# RealWorld
s, Bool
True #)
#endif

-- |Create an 'MVar' which contains the supplied value.
newMVar :: NFData a => a -> IO (MVar a)
newMVar :: a -> IO (MVar a)
newMVar a
value =
    IO (MVar a)
forall a. IO (MVar a)
newEmptyMVar        IO (MVar a) -> (MVar a -> IO (MVar a)) -> IO (MVar a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ MVar a
mvar ->
    MVar a -> a -> IO ()
forall a. NFData a => MVar a -> a -> IO ()
putMVar MVar a
mvar a
value  IO () -> IO (MVar a) -> IO (MVar a)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
    MVar a -> IO (MVar a)
forall (m :: * -> *) a. Monad m => a -> m a
return MVar a
mvar

{-|
  This is a combination of 'takeMVar' and 'putMVar'; ie. it takes the value
  from the 'MVar', puts it back, and also returns it.
-}
readMVar :: NFData a => MVar a -> IO a
readMVar :: MVar a -> IO a
readMVar MVar a
m = ((forall a. IO a -> IO a) -> IO a) -> IO a
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask (((forall a. IO a -> IO a) -> IO a) -> IO a)
-> ((forall a. IO a -> IO a) -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
_ -> do
    a
a <- MVar a -> IO a
forall a. MVar a -> IO a
takeMVar MVar a
m
    MVar a -> a -> IO ()
forall a. NFData a => MVar a -> a -> IO ()
putMVar MVar a
m a
a
    a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

{-|
  Take a value from an 'MVar', put a new value into the 'MVar' and
  return the value taken. Note that there is a race condition whereby
  another process can put something in the 'MVar' after the take
  happens but before the put does.
-}
swapMVar :: NFData a => MVar a -> a -> IO a
swapMVar :: MVar a -> a -> IO a
swapMVar MVar a
mvar a
new = ((forall a. IO a -> IO a) -> IO a) -> IO a
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask (((forall a. IO a -> IO a) -> IO a) -> IO a)
-> ((forall a. IO a -> IO a) -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
_ -> do
    a
old <- MVar a -> IO a
forall a. MVar a -> IO a
takeMVar MVar a
mvar
    MVar a -> a -> IO ()
forall a. NFData a => MVar a -> a -> IO ()
putMVar MVar a
mvar a
new
    a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
old

{-|
  'withMVar' is a safe wrapper for operating on the contents of an
  'MVar'.  This operation is exception-safe: it will replace the
  original contents of the 'MVar' if an exception is raised (see
  "Control.Exception").
-}
{-# INLINE withMVar #-}
-- inlining has been reported to have dramatic effects; see
-- http://www.haskell.org//pipermail/haskell/2006-May/017907.html
withMVar :: NFData a => MVar a -> (a -> IO b) -> IO b
withMVar :: MVar a -> (a -> IO b) -> IO b
withMVar MVar a
m a -> IO b
io = ((forall a. IO a -> IO a) -> IO b) -> IO b
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask (((forall a. IO a -> IO a) -> IO b) -> IO b)
-> ((forall a. IO a -> IO a) -> IO b) -> IO b
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
unmask -> do
    a
a <- MVar a -> IO a
forall a. MVar a -> IO a
takeMVar MVar a
m
    b
b <- IO b -> (SomeException -> IO b) -> IO b
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
Exception.catch (IO b -> IO b
forall a. IO a -> IO a
unmask (a -> IO b
io a
a))
            (\(SomeException
e :: SomeException) -> do MVar a -> a -> IO ()
forall a. NFData a => MVar a -> a -> IO ()
putMVar MVar a
m a
a; SomeException -> IO b
forall a e. Exception e => e -> a
throw SomeException
e)
    MVar a -> a -> IO ()
forall a. NFData a => MVar a -> a -> IO ()
putMVar MVar a
m a
a
    b -> IO b
forall (m :: * -> *) a. Monad m => a -> m a
return b
b

{-|
  A safe wrapper for modifying the contents of an 'MVar'.  Like 'withMVar', 
  'modifyMVar' will replace the original contents of the 'MVar' if an
  exception is raised during the operation.
-}
{-# INLINE modifyMVar_ #-}
modifyMVar_ :: NFData a => MVar a -> (a -> IO a) -> IO ()
modifyMVar_ :: MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar a
m a -> IO a
io = ((forall a. IO a -> IO a) -> IO ()) -> IO ()
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask (((forall a. IO a -> IO a) -> IO ()) -> IO ())
-> ((forall a. IO a -> IO a) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
unmask -> do
    a
a  <- MVar a -> IO a
forall a. MVar a -> IO a
takeMVar MVar a
m
    a
a' <- IO a -> (SomeException -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
Exception.catch (IO a -> IO a
forall a. IO a -> IO a
unmask (a -> IO a
io a
a))
            (\(SomeException
e :: SomeException) -> do MVar a -> a -> IO ()
forall a. NFData a => MVar a -> a -> IO ()
putMVar MVar a
m a
a; SomeException -> IO a
forall a e. Exception e => e -> a
throw SomeException
e)
    MVar a -> a -> IO ()
forall a. NFData a => MVar a -> a -> IO ()
putMVar MVar a
m a
a'

{-|
  A slight variation on 'modifyMVar_' that allows a value to be
  returned (@b@) in addition to the modified value of the 'MVar'.
-}
{-# INLINE modifyMVar #-}
modifyMVar :: NFData a => MVar a -> (a -> IO (a,b)) -> IO b
modifyMVar :: MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar a
m a -> IO (a, b)
io = ((forall a. IO a -> IO a) -> IO b) -> IO b
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask (((forall a. IO a -> IO a) -> IO b) -> IO b)
-> ((forall a. IO a -> IO a) -> IO b) -> IO b
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
unmask -> do
    a
a      <- MVar a -> IO a
forall a. MVar a -> IO a
takeMVar MVar a
m
    (a
a',b
b) <- IO (a, b) -> (SomeException -> IO (a, b)) -> IO (a, b)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
Exception.catch (IO (a, b) -> IO (a, b)
forall a. IO a -> IO a
unmask (a -> IO (a, b)
io a
a))
                (\(SomeException
e :: SomeException) -> do MVar a -> a -> IO ()
forall a. NFData a => MVar a -> a -> IO ()
putMVar MVar a
m a
a; SomeException -> IO (a, b)
forall a e. Exception e => e -> a
throw SomeException
e)
    MVar a -> a -> IO ()
forall a. NFData a => MVar a -> a -> IO ()
putMVar MVar a
m a
a'
    b -> IO b
forall (m :: * -> *) a. Monad m => a -> m a
return b
b