{-# LANGUAGE CPP
, BangPatterns
, DeriveDataTypeable
, NoImplicitPrelude
#-}
#if __GLASGOW_HASKELL__ >= 704
{-# LANGUAGE Safe #-}
#endif
module Control.Concurrent.RLock
( RLock
, new
, newAcquired
, acquire
, tryAcquire
, release
, with
, tryWith
, wait
, State
, state
) where
import Control.Applicative ( liftA2 )
import Control.Concurrent ( ThreadId, myThreadId )
import Control.Concurrent.MVar ( MVar, newMVar, takeMVar, readMVar, putMVar )
import Control.Exception ( bracket_, onException )
import Control.Monad ( return, (>>) )
import Data.Bool ( Bool(False, True), otherwise )
import Data.Eq ( Eq, (==) )
import Data.Function ( ($), (.) )
import Data.Functor ( fmap, (<$>) )
import Data.Maybe ( Maybe(Nothing, Just) )
import Data.List ( (++) )
import Data.Tuple ( fst )
import Data.Typeable ( Typeable )
import Prelude ( Integer, succ, pred, error )
import System.IO ( IO )
#if __GLASGOW_HASKELL__ < 700
import Prelude ( fromInteger )
import Control.Monad ( Monad, fail, (>>=) )
#endif
import Control.Concurrent.Lock ( Lock )
import qualified Control.Concurrent.Lock as Lock
( new, newAcquired, acquire, release, wait )
import Utils ( mask, mask_ )
newtype RLock = RLock {RLock -> MVar (State, Lock)
un :: MVar (State, Lock)}
deriving (RLock -> RLock -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RLock -> RLock -> Bool
$c/= :: RLock -> RLock -> Bool
== :: RLock -> RLock -> Bool
$c== :: RLock -> RLock -> Bool
Eq, Typeable)
type State = Maybe (ThreadId, Integer)
new :: IO RLock
new :: IO RLock
new = do Lock
lock <- IO Lock
Lock.new
MVar (State, Lock) -> RLock
RLock forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> IO (MVar a)
newMVar (forall a. Maybe a
Nothing, Lock
lock)
newAcquired :: IO RLock
newAcquired :: IO RLock
newAcquired = do ThreadId
myTID <- IO ThreadId
myThreadId
Lock
lock <- IO Lock
Lock.newAcquired
MVar (State, Lock) -> RLock
RLock forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> IO (MVar a)
newMVar (forall a. a -> Maybe a
Just (ThreadId
myTID, Integer
1), Lock
lock)
acquire :: RLock -> IO ()
acquire :: RLock -> IO ()
acquire (RLock MVar (State, Lock)
mv) = do
ThreadId
myTID <- IO ThreadId
myThreadId
forall a. IO a -> IO a
mask_ forall a b. (a -> b) -> a -> b
$ let acq :: IO ()
acq = do t :: (State, Lock)
t@(State
mb, Lock
lock) <- forall a. MVar a -> IO a
takeMVar MVar (State, Lock)
mv
case State
mb of
State
Nothing -> do Lock -> IO ()
Lock.acquire Lock
lock
forall a. MVar a -> a -> IO ()
putMVar MVar (State, Lock)
mv (forall a. a -> Maybe a
Just (ThreadId
myTID, Integer
1), Lock
lock)
Just (ThreadId
tid, Integer
n)
| ThreadId
myTID forall a. Eq a => a -> a -> Bool
== ThreadId
tid -> let !sn :: Integer
sn = forall a. Enum a => a -> a
succ Integer
n
in forall a. MVar a -> a -> IO ()
putMVar MVar (State, Lock)
mv (forall a. a -> Maybe a
Just (ThreadId
tid, Integer
sn), Lock
lock)
| Bool
otherwise -> do forall a. MVar a -> a -> IO ()
putMVar MVar (State, Lock)
mv (State, Lock)
t
Lock -> IO ()
Lock.wait Lock
lock
IO ()
acq
in IO ()
acq
tryAcquire :: RLock -> IO Bool
tryAcquire :: RLock -> IO Bool
tryAcquire (RLock MVar (State, Lock)
mv) = do
ThreadId
myTID <- IO ThreadId
myThreadId
forall a. IO a -> IO a
mask_ forall a b. (a -> b) -> a -> b
$ do
t :: (State, Lock)
t@(State
mb, Lock
lock) <- forall a. MVar a -> IO a
takeMVar MVar (State, Lock)
mv
case State
mb of
State
Nothing -> do Lock -> IO ()
Lock.acquire Lock
lock
forall a. MVar a -> a -> IO ()
putMVar MVar (State, Lock)
mv (forall a. a -> Maybe a
Just (ThreadId
myTID, Integer
1), Lock
lock)
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
Just (ThreadId
tid, Integer
n)
| ThreadId
myTID forall a. Eq a => a -> a -> Bool
== ThreadId
tid -> do let !sn :: Integer
sn = forall a. Enum a => a -> a
succ Integer
n
forall a. MVar a -> a -> IO ()
putMVar MVar (State, Lock)
mv (forall a. a -> Maybe a
Just (ThreadId
tid, Integer
sn), Lock
lock)
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
| Bool
otherwise -> do forall a. MVar a -> a -> IO ()
putMVar MVar (State, Lock)
mv (State, Lock)
t
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
release :: RLock -> IO ()
release :: RLock -> IO ()
release (RLock MVar (State, Lock)
mv) = do
ThreadId
myTID <- IO ThreadId
myThreadId
forall a. IO a -> IO a
mask_ forall a b. (a -> b) -> a -> b
$ do
t :: (State, Lock)
t@(State
mb, Lock
lock) <- forall a. MVar a -> IO a
takeMVar MVar (State, Lock)
mv
let err :: [Char] -> IO b
err [Char]
msg = do forall a. MVar a -> a -> IO ()
putMVar MVar (State, Lock)
mv (State, Lock)
t
forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Control.Concurrent.RLock.release: " forall a. [a] -> [a] -> [a]
++ [Char]
msg
case State
mb of
State
Nothing -> forall {b}. [Char] -> IO b
err [Char]
"Can't release an unacquired RLock!"
Just (ThreadId
tid, Integer
n)
| ThreadId
myTID forall a. Eq a => a -> a -> Bool
== ThreadId
tid -> if Integer
n forall a. Eq a => a -> a -> Bool
== Integer
1
then do Lock -> IO ()
Lock.release Lock
lock
forall a. MVar a -> a -> IO ()
putMVar MVar (State, Lock)
mv (forall a. Maybe a
Nothing, Lock
lock)
else let !pn :: Integer
pn = forall a. Enum a => a -> a
pred Integer
n
in forall a. MVar a -> a -> IO ()
putMVar MVar (State, Lock)
mv (forall a. a -> Maybe a
Just (ThreadId
tid, Integer
pn), Lock
lock)
| Bool
otherwise -> forall {b}. [Char] -> IO b
err [Char]
"Calling thread does not own the RLock!"
with :: RLock -> IO a -> IO a
with :: forall a. RLock -> IO a -> IO a
with = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 forall a b c. IO a -> IO b -> IO c -> IO c
bracket_ RLock -> IO ()
acquire RLock -> IO ()
release
tryWith :: RLock -> IO a -> IO (Maybe a)
tryWith :: forall a. RLock -> IO a -> IO (Maybe a)
tryWith RLock
l IO a
a = forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
Bool
acquired <- RLock -> IO Bool
tryAcquire RLock
l
if Bool
acquired
then do a
r <- forall a. IO a -> IO a
restore IO a
a forall a b. IO a -> IO b -> IO a
`onException` RLock -> IO ()
release RLock
l
RLock -> IO ()
release RLock
l
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just a
r
else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
wait :: RLock -> IO ()
wait :: RLock -> IO ()
wait RLock
l = forall a. IO a -> IO a
mask_ forall a b. (a -> b) -> a -> b
$ RLock -> IO ()
acquire RLock
l forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> RLock -> IO ()
release RLock
l
state :: RLock -> IO State
state :: RLock -> IO State
state = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. MVar a -> IO a
readMVar forall b c a. (b -> c) -> (a -> b) -> a -> c
. RLock -> MVar (State, Lock)
un