1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
|
{-# LANGUAGE BangPatterns #-}
-----------------------------------------------------------------------------
-- |
-- 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 ( MVar, newEmptyMVar, takeMVar,
tryTakeMVar, isEmptyMVar, addMVarFinalizer
)
import GHC.Exts
import GHC.IOBase
import Prelude
-- import Control.Parallel.Strategies
import Control.DeepSeq
import Control.Exception
-- |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 mvar#) !x = rnf x `seq` IO $ \ s# -> -- strict!
case putMVar# mvar# x s# of
s2# -> (# 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 mvar#) !x = IO $ \ s# -> -- strict!
case tryPutMVar# mvar# x s# of
(# s, 0# #) -> (# s, False #)
(# s, _ #) -> (# s, True #)
#endif
-- |Create an 'MVar' which contains the supplied value.
newMVar :: NFData a => a -> IO (MVar a)
newMVar value =
newEmptyMVar >>= \ mvar ->
putMVar mvar value >>
return 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 m = block $ do
a <- takeMVar m
putMVar m a
return 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 new = block $ do
old <- takeMVar mvar
putMVar mvar new
return 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 m io = block $ do
a <- takeMVar m
b <- catch (unblock (io a))
(\ (e :: IOException) -> do putMVar m a; throw e)
putMVar m a
return 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_ m io = block $ do
a <- takeMVar m
a' <- catch (unblock (io a))
(\ (e :: IOException) -> do putMVar m a; throw e)
putMVar m 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 m io = block $ do
a <- takeMVar m
(a',b) <- catch (unblock (io a))
(\ (e :: IOException) -> do putMVar m a; throw e)
putMVar m a'
return b
|
