[commit: base] master: Add atomicReadMVar to Control.Concurrent.MVar and friends. (c464def)

[Edward Z. Yang]

Repository : ssh://darcs.haskell.org//srv/darcs/packages/base

On branch  : master

https://github.com/ghc/packages-base/commit/c464def32f8ba65927ecfcbe34a5f06c21774ecc

>---------------------------------------------------------------

commit c464def32f8ba65927ecfcbe34a5f06c21774ecc
Author: Edward Z. Yang <ezyang at mit.edu>
Date:   Fri Jun 14 14:19:58 2013 -0700

    Add atomicReadMVar to Control.Concurrent.MVar and friends.
    
    Also renumber thread statuses as necessary.
    
    Signed-off-by: Edward Z. Yang <ezyang at mit.edu>

>---------------------------------------------------------------

 Control/Concurrent/MVar.hs |    3 ++-
 GHC/Conc/Sync.lhs          |   10 ++++++----
 GHC/MVar.hs                |   10 ++++++++++
 3 files changed, 18 insertions(+), 5 deletions(-)

diff --git a/Control/Concurrent/MVar.hs b/Control/Concurrent/MVar.hs
index 75dc74a..1bccc1e 100644
--- a/Control/Concurrent/MVar.hs
+++ b/Control/Concurrent/MVar.hs
@@ -142,6 +142,7 @@ module Control.Concurrent.MVar
         , modifyMVarMasked_
         , modifyMVarMasked
 #ifndef __HUGS__
+        , atomicReadMVar
         , mkWeakMVar
         , addMVarFinalizer
 #endif
@@ -155,7 +156,7 @@ import Hugs.ConcBase ( MVar, newEmptyMVar, newMVar, takeMVar, putMVar,
 
 #ifdef __GLASGOW_HASKELL__
 import GHC.MVar ( MVar(..), newEmptyMVar, newMVar, takeMVar, putMVar,
-                  tryTakeMVar, tryPutMVar, isEmptyMVar
+                  tryTakeMVar, tryPutMVar, isEmptyMVar, atomicReadMVar
                 )
 import qualified GHC.MVar
 import GHC.Weak
diff --git a/GHC/Conc/Sync.lhs b/GHC/Conc/Sync.lhs
index eb70e56..73e129a 100644
--- a/GHC/Conc/Sync.lhs
+++ b/GHC/Conc/Sync.lhs
@@ -475,11 +475,13 @@ threadStatus (ThreadId t) = IO $ \s ->
         -- NB. keep these in sync with includes/Constants.h
      mk_stat 0  = ThreadRunning
      mk_stat 1  = ThreadBlocked BlockedOnMVar
-     mk_stat 2  = ThreadBlocked BlockedOnBlackHole
-     mk_stat 6  = ThreadBlocked BlockedOnSTM
-     mk_stat 10 = ThreadBlocked BlockedOnForeignCall
+     mk_stat 2  = ThreadBlocked BlockedOnMVar -- XXX distinguish?
+     mk_stat 3  = ThreadBlocked BlockedOnBlackHole
+     mk_stat 7  = ThreadBlocked BlockedOnSTM
      mk_stat 11 = ThreadBlocked BlockedOnForeignCall
-     mk_stat 12 = ThreadBlocked BlockedOnException
+     mk_stat 12 = ThreadBlocked BlockedOnForeignCall
+     mk_stat 13 = ThreadBlocked BlockedOnException
+     -- NB. these are hardcoded in rts/PrimOps.cmm
      mk_stat 16 = ThreadFinished
      mk_stat 17 = ThreadDied
      mk_stat _  = ThreadBlocked BlockedOnOther
diff --git a/GHC/MVar.hs b/GHC/MVar.hs
index b256c59..6a892db 100644
--- a/GHC/MVar.hs
+++ b/GHC/MVar.hs
@@ -23,6 +23,7 @@ module GHC.MVar (
         , newMVar
         , newEmptyMVar
         , takeMVar
+        , atomicReadMVar
         , putMVar
         , tryTakeMVar
         , tryPutMVar
@@ -88,6 +89,15 @@ newMVar value =
 takeMVar :: MVar a -> IO a
 takeMVar (MVar mvar#) = IO $ \ s# -> takeMVar# mvar# s#
 
+-- |Atomically read the contents of an 'MVar'.  If the 'MVar' is
+-- currently empty, 'atomicReadMVar' will wait until its full.
+-- 'atomicReadMVar' is guaranteed to receive the next 'putMVar'.
+--
+-- 'atomicReadMVar' is multiple-wakeup, so when multiple readers are
+-- blocked on an 'MVar', all of them are woken up at the same time.
+atomicReadMVar :: MVar a -> IO a
+atomicReadMVar (MVar mvar#) = IO $ \ s# -> atomicReadMVar# mvar# s#
+
 -- |Put a value into an 'MVar'.  If the 'MVar' is currently full,
 -- 'putMVar' will wait until it becomes empty.
 --