summaryrefslogtreecommitdiff
path: root/Control/Concurrent/MVar/Strict.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Control/Concurrent/MVar/Strict.hs')
-rw-r--r--Control/Concurrent/MVar/Strict.hs22
1 files changed, 12 insertions, 10 deletions
diff --git a/Control/Concurrent/MVar/Strict.hs b/Control/Concurrent/MVar/Strict.hs
index 84e1e3e..3802a19 100644
--- a/Control/Concurrent/MVar/Strict.hs
+++ b/Control/Concurrent/MVar/Strict.hs
@@ -11,7 +11,7 @@
--
-- Synchronising, strict variables
--
--- Values placed in an MVar are evaluated to weak-head normal form
+-- 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.
--
@@ -44,6 +44,7 @@ import GHC.IOBase
import Prelude
import Control.Exception as Exception
+import Control.Parallel.Strategies
-- |Put a value into an 'MVar'. If the 'MVar' is currently full,
-- 'putMVar' will wait until it becomes empty.
@@ -59,9 +60,9 @@ import Control.Exception as Exception
-- woken up in FIFO order. This is useful for providing
-- fairness properties of abstractions built using 'MVar's.
--
-putMVar :: MVar a -> a -> IO ()
+putMVar :: NFData a => MVar a -> a -> IO ()
#ifndef __HADDOCK__
-putMVar (MVar mvar#) !x = IO $ \ s# -> -- strict!
+putMVar (MVar mvar#) !x = rnf x `seq` IO $ \ s# -> -- strict!
case putMVar# mvar# x s# of
s2# -> (# s2#, () #)
#endif
@@ -70,7 +71,7 @@ putMVar (MVar mvar#) !x = IO $ \ s# -> -- strict!
-- attempts to put the value @a@ into the 'MVar', returning 'True' if
-- it was successful, or 'False' otherwise.
--
-tryPutMVar :: MVar a -> a -> IO Bool
+tryPutMVar :: NFData a => MVar a -> a -> IO Bool
#ifndef __HADDOCK__
tryPutMVar (MVar mvar#) !x = IO $ \ s# -> -- strict!
case tryPutMVar# mvar# x s# of
@@ -79,7 +80,7 @@ tryPutMVar (MVar mvar#) !x = IO $ \ s# -> -- strict!
#endif
-- |Create an 'MVar' which contains the supplied value.
-newMVar :: a -> IO (MVar a)
+newMVar :: NFData a => a -> IO (MVar a)
newMVar value =
newEmptyMVar >>= \ mvar ->
putMVar mvar value >>
@@ -89,7 +90,7 @@ newMVar value =
This is a combination of 'takeMVar' and 'putMVar'; ie. it takes the value
from the 'MVar', puts it back, and also returns it.
-}
-readMVar :: MVar a -> IO a
+readMVar :: NFData a => MVar a -> IO a
readMVar m = block $ do
a <- takeMVar m
putMVar m a
@@ -101,7 +102,7 @@ readMVar m = block $ do
another process can put something in the 'MVar' after the take
happens but before the put does.
-}
-swapMVar :: MVar a -> a -> IO a
+swapMVar :: NFData a => MVar a -> a -> IO a
swapMVar mvar new = block $ do
old <- takeMVar mvar
putMVar mvar new
@@ -116,7 +117,7 @@ swapMVar mvar new = block $ do
{-# INLINE withMVar #-}
-- inlining has been reported to have dramatic effects; see
-- http://www.haskell.org//pipermail/haskell/2006-May/017907.html
-withMVar :: MVar a -> (a -> IO b) -> IO b
+withMVar :: NFData a => MVar a -> (a -> IO b) -> IO b
withMVar m io = block $ do
a <- takeMVar m
b <- Exception.catch (unblock (io a))
@@ -130,7 +131,7 @@ withMVar m io = block $ do
exception is raised during the operation.
-}
{-# INLINE modifyMVar_ #-}
-modifyMVar_ :: MVar a -> (a -> IO a) -> IO ()
+modifyMVar_ :: NFData a => MVar a -> (a -> IO a) -> IO ()
modifyMVar_ m io = block $ do
a <- takeMVar m
a' <- Exception.catch (unblock (io a))
@@ -142,10 +143,11 @@ modifyMVar_ m io = block $ do
returned (@b@) in addition to the modified value of the 'MVar'.
-}
{-# INLINE modifyMVar #-}
-modifyMVar :: MVar a -> (a -> IO (a,b)) -> IO b
+modifyMVar :: NFData a => MVar a -> (a -> IO (a,b)) -> IO b
modifyMVar m io = block $ do
a <- takeMVar m
(a',b) <- Exception.catch (unblock (io a))
(\e -> do putMVar m a; throw e)
putMVar m a'
return b
+