{-# LANGUAGE DeriveDataTypeable, PatternGuards #-}
module Control.Concurrent.FairRWLock
( RWLock, RWLockException(..), RWLockExceptionKind(..),FRW(..),LockKind(..),TMap,TSet
, new
, withRead, withWrite
, acquireRead, acquireWrite
, releaseRead, releaseWrite
, peekLock, checkLock
) where
import Control.Applicative(liftA2)
import Control.Concurrent
import Control.Exception(Exception,bracket_,onException,evaluate,uninterruptibleMask_,mask_,throw)
import Control.Monad((>=>),join,forM_)
import Data.Sequence((<|),(|>),(><),Seq,ViewL(..),ViewR(..))
import qualified Data.Sequence as Seq(empty,viewl,viewr,breakl,spanl)
import qualified Data.Foldable as F(toList)
import Data.Map(Map)
import qualified Data.Map as Map
import Data.Set(Set)
import qualified Data.Set as Set
import Data.Typeable(Typeable)
type TMap = Map ThreadId Int
type TSet = Set ThreadId
data LockKind = ReaderKind { LockKind -> TSet
unRK :: TSet }
| WriterKind { LockKind -> ThreadId
unWK :: ThreadId }
deriving (LockKind -> LockKind -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LockKind -> LockKind -> Bool
$c/= :: LockKind -> LockKind -> Bool
== :: LockKind -> LockKind -> Bool
$c== :: LockKind -> LockKind -> Bool
Eq,Eq LockKind
LockKind -> LockKind -> Bool
LockKind -> LockKind -> Ordering
LockKind -> LockKind -> LockKind
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: LockKind -> LockKind -> LockKind
$cmin :: LockKind -> LockKind -> LockKind
max :: LockKind -> LockKind -> LockKind
$cmax :: LockKind -> LockKind -> LockKind
>= :: LockKind -> LockKind -> Bool
$c>= :: LockKind -> LockKind -> Bool
> :: LockKind -> LockKind -> Bool
$c> :: LockKind -> LockKind -> Bool
<= :: LockKind -> LockKind -> Bool
$c<= :: LockKind -> LockKind -> Bool
< :: LockKind -> LockKind -> Bool
$c< :: LockKind -> LockKind -> Bool
compare :: LockKind -> LockKind -> Ordering
$ccompare :: LockKind -> LockKind -> Ordering
Ord,Int -> LockKind -> ShowS
[LockKind] -> ShowS
LockKind -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LockKind] -> ShowS
$cshowList :: [LockKind] -> ShowS
show :: LockKind -> String
$cshow :: LockKind -> String
showsPrec :: Int -> LockKind -> ShowS
$cshowsPrec :: Int -> LockKind -> ShowS
Show)
type LockQ = Seq (LockKind,MVar ())
data LockUser =
FreeLock
| Readers { LockUser -> TMap
readerCounts :: TMap
, LockUser -> Maybe ((ThreadId, MVar ()), LockQ)
queueR :: Maybe ( (ThreadId,MVar ())
, LockQ )
}
| Writer { LockUser -> ThreadId
writerID :: ThreadId
, LockUser -> Int
writerCount
, LockUser -> Int
readerCount :: !Int
, LockUser -> LockQ
queue :: LockQ }
deriving (LockUser -> LockUser -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LockUser -> LockUser -> Bool
$c/= :: LockUser -> LockUser -> Bool
== :: LockUser -> LockUser -> Bool
$c== :: LockUser -> LockUser -> Bool
Eq,Typeable)
newtype RWLock = RWL (MVar LockUser)
data RWLockException = RWLockException ThreadId RWLockExceptionKind String
deriving (Int -> RWLockException -> ShowS
[RWLockException] -> ShowS
RWLockException -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RWLockException] -> ShowS
$cshowList :: [RWLockException] -> ShowS
show :: RWLockException -> String
$cshow :: RWLockException -> String
showsPrec :: Int -> RWLockException -> ShowS
$cshowsPrec :: Int -> RWLockException -> ShowS
Show,Typeable)
data RWLockExceptionKind = RWLock'acquireWrite | RWLock'releaseWrite
| RWLock'acquireRead | RWLock'releaseRead
deriving (Int -> RWLockExceptionKind -> ShowS
[RWLockExceptionKind] -> ShowS
RWLockExceptionKind -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RWLockExceptionKind] -> ShowS
$cshowList :: [RWLockExceptionKind] -> ShowS
show :: RWLockExceptionKind -> String
$cshow :: RWLockExceptionKind -> String
showsPrec :: Int -> RWLockExceptionKind -> ShowS
$cshowsPrec :: Int -> RWLockExceptionKind -> ShowS
Show,Typeable)
instance Exception RWLockException
data FRW = F | R TMap | W (ThreadId,(Int,Int)) deriving (Int -> FRW -> ShowS
[FRW] -> ShowS
FRW -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FRW] -> ShowS
$cshowList :: [FRW] -> ShowS
show :: FRW -> String
$cshow :: FRW -> String
showsPrec :: Int -> FRW -> ShowS
$cshowsPrec :: Int -> FRW -> ShowS
Show)
new :: IO RWLock
new :: IO RWLock
new = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap MVar LockUser -> RWLock
RWL (forall a. a -> IO (MVar a)
newMVar LockUser
FreeLock)
withRead :: RWLock -> IO a -> IO a
withRead :: forall a. RWLock -> IO a -> IO a
withRead = 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_ RWLock -> IO ()
acquireRead (RWLock -> IO (Either RWLockException ())
releaseRead forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a e. Exception e => e -> a
throw forall (m :: * -> *) a. Monad m => a -> m a
return)
withWrite :: RWLock -> IO a -> IO a
withWrite :: forall a. RWLock -> IO a -> IO a
withWrite = 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_ RWLock -> IO ()
acquireWrite (RWLock -> IO (Either RWLockException ())
releaseWrite forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a e. Exception e => e -> a
throw forall (m :: * -> *) a. Monad m => a -> m a
return)
peekLock :: RWLock -> IO (FRW,[LockKind])
peekLock :: RWLock -> IO (FRW, [LockKind])
peekLock (RWL MVar LockUser
rwlVar) = forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar LockUser
rwlVar forall a b. (a -> b) -> a -> b
$ \ LockUser
rwd -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
case LockUser
rwd of
LockUser
FreeLock -> (FRW
F,[])
Readers { readerCounts :: LockUser -> TMap
readerCounts=TMap
rcs, queueR :: LockUser -> Maybe ((ThreadId, MVar ()), LockQ)
queueR=Maybe ((ThreadId, MVar ()), LockQ)
qr } -> (TMap -> FRW
R TMap
rcs,forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\((ThreadId
t,MVar ()
_),LockQ
q) -> ThreadId -> LockKind
WriterKind ThreadId
t forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst (forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList LockQ
q)) Maybe ((ThreadId, MVar ()), LockQ)
qr)
Writer { writerID :: LockUser -> ThreadId
writerID=ThreadId
it, writerCount :: LockUser -> Int
writerCount=Int
wc, readerCount :: LockUser -> Int
readerCount=Int
rc, queue :: LockUser -> LockQ
queue=LockQ
q } -> ((ThreadId, (Int, Int)) -> FRW
W (ThreadId
it,(Int
rc,Int
wc)), forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst (forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList LockQ
q))
checkLock :: RWLock -> IO (Int,Int)
checkLock :: RWLock -> IO (Int, Int)
checkLock (RWL MVar LockUser
rwlVar) = do
ThreadId
me <- IO ThreadId
myThreadId
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar LockUser
rwlVar forall a b. (a -> b) -> a -> b
$ \ LockUser
rwd -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
case LockUser
rwd of
LockUser
FreeLock -> (Int
0,Int
0)
Readers { readerCounts :: LockUser -> TMap
readerCounts=TMap
rcs } ->
case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ThreadId
me TMap
rcs of
Maybe Int
Nothing -> (Int
0,Int
0)
Just Int
rc -> (Int
rc,Int
0)
Writer { writerID :: LockUser -> ThreadId
writerID=ThreadId
it, writerCount :: LockUser -> Int
writerCount=Int
wc, readerCount :: LockUser -> Int
readerCount=Int
rc } ->
if ThreadId
itforall a. Eq a => a -> a -> Bool
==ThreadId
me then (Int
rc,Int
wc) else (Int
0,Int
0)
releaseRead :: RWLock -> IO (Either RWLockException ())
releaseRead :: RWLock -> IO (Either RWLockException ())
releaseRead (RWL MVar LockUser
rwlVar) = forall a. IO a -> IO a
mask_ forall a b. (a -> b) -> a -> b
$ do
ThreadId
me <- IO ThreadId
myThreadId
Bool -> ThreadId -> MVar LockUser -> IO (Either RWLockException ())
releaseRead' Bool
False ThreadId
me MVar LockUser
rwlVar
releaseRead' :: Bool -> ThreadId -> MVar LockUser -> IO (Either RWLockException ())
releaseRead' :: Bool -> ThreadId -> MVar LockUser -> IO (Either RWLockException ())
releaseRead' Bool
abandon ThreadId
me MVar LockUser
rwlVar = forall a. IO a -> IO a
uninterruptibleMask_ forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar LockUser
rwlVar forall a b. (a -> b) -> a -> b
$ \ LockUser
rwd -> do
let impossible :: Show x => String -> x -> IO a
impossible :: forall x a. Show x => String -> x -> IO a
impossible String
s x
x = forall a e. Exception e => e -> a
throw
(ThreadId -> RWLockExceptionKind -> String -> RWLockException
RWLockException ThreadId
me (if Bool
abandon then RWLockExceptionKind
RWLock'acquireRead else RWLockExceptionKind
RWLock'releaseRead) (forall x. Show x => String -> x -> String
imp String
s x
x))
err :: Show x => String -> x -> IO (LockUser,Either RWLockException ())
err :: forall x.
Show x =>
String -> x -> IO (LockUser, Either RWLockException ())
err String
s x
x = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((,) LockUser
rwd) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$
(ThreadId -> RWLockExceptionKind -> String -> RWLockException
RWLockException ThreadId
me (if Bool
abandon then RWLockExceptionKind
RWLock'acquireRead else RWLockExceptionKind
RWLock'releaseRead) (String
sforall a. [a] -> [a] -> [a]
++String
" : "forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> String
show x
x))
ret :: LockUser -> IO (LockUser,Either RWLockException ())
ret :: LockUser -> IO (LockUser, Either RWLockException ())
ret LockUser
x = forall (m :: * -> *) a. Monad m => a -> m a
return (LockUser
x,forall a b. b -> Either a b
Right ())
dropReader :: LockQ -> IO LockQ
dropReader :: LockQ -> IO LockQ
dropReader LockQ
q = do
let inR :: (LockKind, b) -> Bool
inR (ReaderKind TSet
rcs,b
_) = forall a. Ord a => a -> Set a -> Bool
Set.member ThreadId
me TSet
rcs
inR (LockKind, b)
_ = Bool
False
(LockQ
pre,LockQ
myselfPost) = forall a. (a -> Bool) -> Seq a -> (Seq a, Seq a)
Seq.breakl forall {b}. (LockKind, b) -> Bool
inR LockQ
q
case forall a. Seq a -> ViewL a
Seq.viewl LockQ
myselfPost of
ViewL (LockKind, MVar ())
EmptyL ->
forall x a. Show x => String -> x -> IO a
impossible String
"failure to abandon acquireRead, RWLock locked by other thread(s) and this thread is not in queue" ThreadId
me
(LockKind
myself,MVar ()
mblock) :< LockQ
post -> do
let rcs' :: TSet
rcs' = forall a. Ord a => a -> Set a -> Set a
Set.delete ThreadId
me (LockKind -> TSet
unRK LockKind
myself)
forall a. a -> IO a
evaluate forall a b. (a -> b) -> a -> b
$ if forall a. Set a -> Bool
Set.null TSet
rcs' then LockQ
pre forall a. Seq a -> Seq a -> Seq a
>< LockQ
post else LockQ
pre forall a. Seq a -> Seq a -> Seq a
>< ((TSet -> LockKind
ReaderKind TSet
rcs',MVar ()
mblock) forall a. a -> Seq a -> Seq a
<| LockQ
post)
case LockUser
rwd of
LockUser
FreeLock | Bool
abandon ->
forall x a. Show x => String -> x -> IO a
impossible String
"acquireRead interrupted with unlocked RWLock" ThreadId
me
| Bool
otherwise ->
forall x.
Show x =>
String -> x -> IO (LockUser, Either RWLockException ())
err String
"cannot releaseRead lock from unlocked RWLock" ThreadId
me
w :: LockUser
w@(Writer { writerID :: LockUser -> ThreadId
writerID=ThreadId
it, readerCount :: LockUser -> Int
readerCount=Int
rc, queue :: LockUser -> LockQ
queue=LockQ
q }) | ThreadId
itforall a. Eq a => a -> a -> Bool
==ThreadId
me -> do
case Int
rc of
Int
0 | Bool
abandon ->
forall x a. Show x => String -> x -> IO a
impossible String
"acquireRead interrupted with write lock but not read lock" (ThreadId
me,ThreadId
it)
| Bool
otherwise ->
forall x.
Show x =>
String -> x -> IO (LockUser, Either RWLockException ())
err String
"releaseRead when holding write lock but not read lock" (ThreadId
me,ThreadId
it)
Int
_ -> do
Int
rc' <- forall a. a -> IO a
evaluate forall a b. (a -> b) -> a -> b
$ forall a. Enum a => a -> a
pred Int
rc
LockUser -> IO (LockUser, Either RWLockException ())
ret (LockUser
w { readerCount :: Int
readerCount=Int
rc' })
| Bool
abandon -> do
LockQ
q' <- LockQ -> IO LockQ
dropReader LockQ
q
LockUser -> IO (LockUser, Either RWLockException ())
ret (LockUser
w { queue :: LockQ
queue=LockQ
q' })
| Bool
otherwise ->
forall x.
Show x =>
String -> x -> IO (LockUser, Either RWLockException ())
err String
"releaseRead called when not read locked " ThreadId
me
r :: LockUser
r@(Readers { readerCounts :: LockUser -> TMap
readerCounts=TMap
rcs,queueR :: LockUser -> Maybe ((ThreadId, MVar ()), LockQ)
queueR=Maybe ((ThreadId, MVar ()), LockQ)
qR }) ->
case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ThreadId
me TMap
rcs of
Just Int
1 -> do
let rcs' :: TMap
rcs' = forall k a. Ord k => k -> Map k a -> Map k a
Map.delete ThreadId
me TMap
rcs
if forall k a. Map k a -> Bool
Map.null TMap
rcs'
then case Maybe ((ThreadId, MVar ()), LockQ)
qR of
Maybe ((ThreadId, MVar ()), LockQ)
Nothing ->
LockUser -> IO (LockUser, Either RWLockException ())
ret LockUser
FreeLock
Just ((ThreadId
wid,MVar ()
mblock),LockQ
q) -> do
forall a. MVar a -> a -> IO ()
putMVar MVar ()
mblock ()
LockUser -> IO (LockUser, Either RWLockException ())
ret (Writer { writerID :: ThreadId
writerID=ThreadId
wid, writerCount :: Int
writerCount=Int
1, readerCount :: Int
readerCount=Int
0, queue :: LockQ
queue=LockQ
q })
else LockUser -> IO (LockUser, Either RWLockException ())
ret (LockUser
r { readerCounts :: TMap
readerCounts=TMap
rcs' })
Just Int
rc -> do
Int
rc' <- forall a. a -> IO a
evaluate forall a b. (a -> b) -> a -> b
$ forall a. Enum a => a -> a
pred Int
rc
TMap
rcs' <- forall a. a -> IO a
evaluate forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ThreadId
me Int
rc' TMap
rcs
LockUser -> IO (LockUser, Either RWLockException ())
ret (LockUser
r { readerCounts :: TMap
readerCounts=TMap
rcs' })
Maybe Int
Nothing | Bool
abandon ->
case Maybe ((ThreadId, MVar ()), LockQ)
qR of
Maybe ((ThreadId, MVar ()), LockQ)
Nothing ->
forall x a. Show x => String -> x -> IO a
impossible String
"acquireRead interrupted not holding lock and with no queue" (ThreadId
me,TMap
rcs)
Just ((ThreadId, MVar ())
w,LockQ
q) -> do
LockQ
q' <- LockQ -> IO LockQ
dropReader LockQ
q
LockUser -> IO (LockUser, Either RWLockException ())
ret (LockUser
r { queueR :: Maybe ((ThreadId, MVar ()), LockQ)
queueR = forall a. a -> Maybe a
Just ((ThreadId, MVar ())
w,LockQ
q') })
| Bool
otherwise ->
forall x.
Show x =>
String -> x -> IO (LockUser, Either RWLockException ())
err String
"releaseRead called with read lock held by others" (ThreadId
me,TMap
rcs)
releaseWrite :: RWLock -> IO (Either RWLockException ())
releaseWrite :: RWLock -> IO (Either RWLockException ())
releaseWrite (RWL MVar LockUser
rwlVar) = forall a. IO a -> IO a
mask_ forall a b. (a -> b) -> a -> b
$ do
ThreadId
me <- IO ThreadId
myThreadId
Bool -> ThreadId -> MVar LockUser -> IO (Either RWLockException ())
releaseWrite' Bool
False ThreadId
me MVar LockUser
rwlVar
releaseWrite' :: Bool -> ThreadId -> MVar LockUser -> IO (Either RWLockException ())
releaseWrite' :: Bool -> ThreadId -> MVar LockUser -> IO (Either RWLockException ())
releaseWrite' Bool
abandon ThreadId
me MVar LockUser
rwlVar = forall a. IO a -> IO a
uninterruptibleMask_ forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar LockUser
rwlVar forall a b. (a -> b) -> a -> b
$ \ LockUser
rwd -> do
let impossible :: Show x => String -> x -> IO a
impossible :: forall x a. Show x => String -> x -> IO a
impossible String
s x
x = forall a e. Exception e => e -> a
throw
(ThreadId -> RWLockExceptionKind -> String -> RWLockException
RWLockException ThreadId
me (if Bool
abandon then RWLockExceptionKind
RWLock'acquireWrite else RWLockExceptionKind
RWLock'releaseWrite) (forall x. Show x => String -> x -> String
imp String
s x
x))
err :: Show x => String -> x -> IO (LockUser,Either RWLockException ())
err :: forall x.
Show x =>
String -> x -> IO (LockUser, Either RWLockException ())
err String
s x
x = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((,) LockUser
rwd) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$
(ThreadId -> RWLockExceptionKind -> String -> RWLockException
RWLockException ThreadId
me (if Bool
abandon then RWLockExceptionKind
RWLock'acquireWrite else RWLockExceptionKind
RWLock'releaseWrite) (String
sforall a. [a] -> [a] -> [a]
++String
" : "forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> String
show x
x))
ret :: LockUser -> IO (LockUser,Either RWLockException ())
ret :: LockUser -> IO (LockUser, Either RWLockException ())
ret LockUser
x = forall (m :: * -> *) a. Monad m => a -> m a
return (LockUser
x,forall a b. b -> Either a b
Right ())
dropWriter :: LockQ -> IO LockQ
dropWriter :: LockQ -> IO LockQ
dropWriter LockQ
q = do
let inW :: (LockKind, b) -> Bool
inW (WriterKind ThreadId
it,b
_) = ThreadId
meforall a. Eq a => a -> a -> Bool
==ThreadId
it
inW (LockKind, b)
_ = Bool
False
(LockQ
pre,LockQ
myselfPost) = forall a. (a -> Bool) -> Seq a -> (Seq a, Seq a)
Seq.breakl forall {b}. (LockKind, b) -> Bool
inW LockQ
q
case forall a. Seq a -> ViewL a
Seq.viewl LockQ
myselfPost of
ViewL (LockKind, MVar ())
EmptyL ->
forall x a. Show x => String -> x -> IO a
impossible String
"failure to abandon acquireWrite, RWLock locked by other and not in queue" ThreadId
me
(LockKind, MVar ())
_ :< LockQ
post ->
forall a. a -> IO a
evaluate forall a b. (a -> b) -> a -> b
$ LockQ
preforall a. Seq a -> Seq a -> Seq a
><LockQ
post
case LockUser
rwd of
LockUser
FreeLock | Bool
abandon ->
forall x a. Show x => String -> x -> IO a
impossible String
"acquireWrite interrupted with unlocked RWLock" ThreadId
me
| Bool
otherwise ->
forall x.
Show x =>
String -> x -> IO (LockUser, Either RWLockException ())
err String
"cannot releaseWrite lock from unlocked RWLock" ThreadId
me
w :: LockUser
w@(Writer { writerID :: LockUser -> ThreadId
writerID=ThreadId
it, writerCount :: LockUser -> Int
writerCount=Int
wc, readerCount :: LockUser -> Int
readerCount=Int
rc, queue :: LockUser -> LockQ
queue=LockQ
q }) | ThreadId
itforall a. Eq a => a -> a -> Bool
==ThreadId
me -> do
case (Int
wc,Int
rc) of
(Int
1,Int
0) -> LockUser -> IO (LockUser, Either RWLockException ())
ret forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LockQ -> IO LockUser
promote LockQ
q
(Int, Int)
_ | Bool
abandon -> forall x a. Show x => String -> x -> IO a
impossible String
"acquireWrite interrupted with write lock and bad RWLock state" (ThreadId
me,ThreadId
it,Int
wc,Int
rc)
(Int
1,Int
_) -> LockUser -> IO (LockUser, Either RWLockException ())
ret forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int -> LockQ -> IO LockUser
promoteReader Int
rc LockQ
q
(Int
_,Int
_) -> LockUser -> IO (LockUser, Either RWLockException ())
ret (LockUser
w { writerCount :: Int
writerCount=(forall a. Enum a => a -> a
pred Int
wc) })
| Bool
abandon -> do
LockQ
q' <- LockQ -> IO LockQ
dropWriter LockQ
q
LockUser -> IO (LockUser, Either RWLockException ())
ret (LockUser
w { queue :: LockQ
queue=LockQ
q' })
| Bool
otherwise -> do
forall x.
Show x =>
String -> x -> IO (LockUser, Either RWLockException ())
err String
"cannot releaseWrite when not not holding the write lock" (ThreadId
me,ThreadId
it)
Readers { readerCounts :: LockUser -> TMap
readerCounts=TMap
rcs} | Bool -> Bool
not Bool
abandon ->
forall x.
Show x =>
String -> x -> IO (LockUser, Either RWLockException ())
err String
"cannot releaseWrite when RWLock is read locked" (ThreadId
me,TMap
rcs)
Readers { readerCounts :: LockUser -> TMap
readerCounts=TMap
rcs, queueR :: LockUser -> Maybe ((ThreadId, MVar ()), LockQ)
queueR=Maybe ((ThreadId, MVar ()), LockQ)
Nothing } ->
forall x a. Show x => String -> x -> IO a
impossible String
"failure to abandon acquireWrite, RWLock read locked and no queue" (ThreadId
me,TMap
rcs)
r :: LockUser
r@(Readers { readerCounts :: LockUser -> TMap
readerCounts=TMap
rcs, queueR :: LockUser -> Maybe ((ThreadId, MVar ()), LockQ)
queueR=Just (w :: (ThreadId, MVar ())
w@(ThreadId
it,MVar ()
_),LockQ
q) }) | ThreadId
itforall a. Eq a => a -> a -> Bool
==ThreadId
me -> do
(TMap
rcs'new,Maybe ((ThreadId, MVar ()), LockQ)
qr) <- LockQ -> IO (TMap, Maybe ((ThreadId, MVar ()), LockQ))
splitReaders LockQ
q
LockUser -> IO (LockUser, Either RWLockException ())
ret (LockUser
r { readerCounts :: TMap
readerCounts=forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union TMap
rcs TMap
rcs'new, queueR :: Maybe ((ThreadId, MVar ()), LockQ)
queueR=Maybe ((ThreadId, MVar ()), LockQ)
qr })
| Bool
otherwise -> do
LockQ
q' <- LockQ -> IO LockQ
dropWriter LockQ
q
LockUser -> IO (LockUser, Either RWLockException ())
ret (LockUser
r { queueR :: Maybe ((ThreadId, MVar ()), LockQ)
queueR=forall a. a -> Maybe a
Just ((ThreadId, MVar ())
w,LockQ
q') })
where
promoteReader :: Int -> LockQ -> IO LockUser
promoteReader :: Int -> LockQ -> IO LockUser
promoteReader Int
rc LockQ
q = do
(TMap
rcs'new, Maybe ((ThreadId, MVar ()), LockQ)
qr) <- LockQ -> IO (TMap, Maybe ((ThreadId, MVar ()), LockQ))
splitReaders LockQ
q
let rcs :: TMap
rcs = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ThreadId
me Int
rc TMap
rcs'new
forall (m :: * -> *) a. Monad m => a -> m a
return (Readers { readerCounts :: TMap
readerCounts=TMap
rcs, queueR :: Maybe ((ThreadId, MVar ()), LockQ)
queueR=Maybe ((ThreadId, MVar ()), LockQ)
qr })
promote :: LockQ -> IO LockUser
promote :: LockQ -> IO LockUser
promote LockQ
qIn = do
case forall a. Seq a -> ViewL a
Seq.viewl LockQ
qIn of
ViewL (LockKind, MVar ())
EmptyL -> forall (m :: * -> *) a. Monad m => a -> m a
return LockUser
FreeLock
(WriterKind ThreadId
it,MVar ()
mblock) :< LockQ
qOut -> do
forall a. MVar a -> a -> IO ()
putMVar MVar ()
mblock ()
forall (m :: * -> *) a. Monad m => a -> m a
return (Writer { writerID :: ThreadId
writerID=ThreadId
it, writerCount :: Int
writerCount=Int
1, readerCount :: Int
readerCount=Int
0, queue :: LockQ
queue=LockQ
qOut })
ViewL (LockKind, MVar ())
_ -> do
(TMap
rcs,Maybe ((ThreadId, MVar ()), LockQ)
qr) <- LockQ -> IO (TMap, Maybe ((ThreadId, MVar ()), LockQ))
splitReaders LockQ
qIn
forall (m :: * -> *) a. Monad m => a -> m a
return (Readers { readerCounts :: TMap
readerCounts=TMap
rcs, queueR :: Maybe ((ThreadId, MVar ()), LockQ)
queueR=Maybe ((ThreadId, MVar ()), LockQ)
qr })
splitReaders :: LockQ -> IO (TMap,Maybe ((ThreadId,MVar ()),LockQ))
splitReaders :: LockQ -> IO (TMap, Maybe ((ThreadId, MVar ()), LockQ))
splitReaders LockQ
qIn = do
let (LockQ
more'Readers,LockQ
qTail) = forall a. (a -> Bool) -> Seq a -> (Seq a, Seq a)
Seq.spanl forall {b}. (LockKind, b) -> Bool
isReader LockQ
qIn
([LockKind]
rks,[MVar ()]
mblocks) = forall a b. [(a, b)] -> ([a], [b])
unzip (forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList LockQ
more'Readers)
rcs :: TMap
rcs = forall k a. [(k, a)] -> Map k a
Map.fromDistinctAscList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (\ThreadId
k -> (ThreadId
k,Int
1)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map LockKind -> TSet
unRK forall a b. (a -> b) -> a -> b
$ [LockKind]
rks
qr :: Maybe ((ThreadId, MVar ()), LockQ)
qr = case forall a. Seq a -> ViewL a
Seq.viewl LockQ
qTail of
ViewL (LockKind, MVar ())
EmptyL -> forall a. Maybe a
Nothing
(LockKind
wk,MVar ()
mblock) :< LockQ
qOut -> forall a. a -> Maybe a
Just ((LockKind -> ThreadId
unWK LockKind
wk,MVar ()
mblock),LockQ
qOut)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [MVar ()]
mblocks (\MVar ()
mblock -> forall a. MVar a -> a -> IO ()
putMVar MVar ()
mblock ())
forall (m :: * -> *) a. Monad m => a -> m a
return (TMap
rcs,Maybe ((ThreadId, MVar ()), LockQ)
qr)
where
isReader :: (LockKind, b) -> Bool
isReader (ReaderKind {},b
_) = Bool
True
isReader (LockKind, b)
_ = Bool
False
acquireRead :: RWLock -> IO ()
acquireRead :: RWLock -> IO ()
acquireRead (RWL MVar LockUser
rwlVar) = forall a. IO a -> IO a
mask_ forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar LockUser
rwlVar forall a b. (a -> b) -> a -> b
$ \ LockUser
rwd -> do
ThreadId
me <- IO ThreadId
myThreadId
let safeBlock :: MVar a -> IO a
safeBlock MVar a
mblock = (forall a. MVar a -> IO a
readMVar MVar a
mblock) forall a b. IO a -> IO b -> IO a
`onException` (Bool -> ThreadId -> MVar LockUser -> IO (Either RWLockException ())
releaseRead' Bool
True ThreadId
me MVar LockUser
rwlVar)
case LockUser
rwd of
LockUser
FreeLock ->
forall (m :: * -> *) a. Monad m => a -> m a
return ( Readers { readerCounts :: TMap
readerCounts=forall k a. k -> a -> Map k a
Map.singleton ThreadId
me Int
1, queueR :: Maybe ((ThreadId, MVar ()), LockQ)
queueR=forall a. Maybe a
Nothing }
, forall (m :: * -> *) a. Monad m => a -> m a
return () )
w :: LockUser
w@(Writer { writerID :: LockUser -> ThreadId
writerID=ThreadId
it, readerCount :: LockUser -> Int
readerCount=Int
rc, queue :: LockUser -> LockQ
queue=LockQ
q }) | ThreadId
it forall a. Eq a => a -> a -> Bool
== ThreadId
me -> do
Int
rc' <- forall a. a -> IO a
evaluate forall a b. (a -> b) -> a -> b
$ forall a. Enum a => a -> a
succ Int
rc
forall (m :: * -> *) a. Monad m => a -> m a
return ( LockUser
w { readerCount :: Int
readerCount=Int
rc' }
, forall (m :: * -> *) a. Monad m => a -> m a
return () )
| Bool
otherwise -> do
(LockQ
q',MVar ()
mblock) <- LockQ -> ThreadId -> IO (LockQ, MVar ())
enterQueueR LockQ
q ThreadId
me
forall (m :: * -> *) a. Monad m => a -> m a
return ( LockUser
w { queue :: LockQ
queue = LockQ
q' }
, forall a. MVar a -> IO a
safeBlock MVar ()
mblock )
r :: LockUser
r@(Readers { readerCounts :: LockUser -> TMap
readerCounts=TMap
rcs }) | Just Int
rc <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ThreadId
me TMap
rcs -> do
Int
rc' <- forall a. a -> IO a
evaluate forall a b. (a -> b) -> a -> b
$ forall a. Enum a => a -> a
succ Int
rc
TMap
rcs' <- forall a. a -> IO a
evaluate forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ThreadId
me Int
rc' TMap
rcs
forall (m :: * -> *) a. Monad m => a -> m a
return ( LockUser
r { readerCounts :: TMap
readerCounts=TMap
rcs' }
, forall (m :: * -> *) a. Monad m => a -> m a
return () )
r :: LockUser
r@(Readers { readerCounts :: LockUser -> TMap
readerCounts=TMap
rcs, queueR :: LockUser -> Maybe ((ThreadId, MVar ()), LockQ)
queueR=Maybe ((ThreadId, MVar ()), LockQ)
Nothing }) -> do
TMap
rcs' <- forall a. a -> IO a
evaluate forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ThreadId
me Int
1 TMap
rcs
forall (m :: * -> *) a. Monad m => a -> m a
return ( LockUser
r { readerCounts :: TMap
readerCounts=TMap
rcs' }
, forall (m :: * -> *) a. Monad m => a -> m a
return () )
r :: LockUser
r@(Readers { queueR :: LockUser -> Maybe ((ThreadId, MVar ()), LockQ)
queueR=Just ((ThreadId, MVar ())
w,LockQ
q) }) -> do
(LockQ
q',MVar ()
mblock) <- LockQ -> ThreadId -> IO (LockQ, MVar ())
enterQueueR LockQ
q ThreadId
me
forall (m :: * -> *) a. Monad m => a -> m a
return ( LockUser
r { queueR :: Maybe ((ThreadId, MVar ()), LockQ)
queueR=forall a. a -> Maybe a
Just ((ThreadId, MVar ())
w,LockQ
q') }
, forall a. MVar a -> IO a
safeBlock MVar ()
mblock )
where
enterQueueR :: LockQ -> ThreadId -> IO (LockQ,MVar ())
enterQueueR :: LockQ -> ThreadId -> IO (LockQ, MVar ())
enterQueueR LockQ
qIn ThreadId
me = do
case forall a. Seq a -> ViewR a
Seq.viewr LockQ
qIn of
LockQ
pre :> (ReaderKind TSet
rcs,MVar ()
mblock) -> do
TSet
rcs' <- TSet -> IO TSet
addMe TSet
rcs
forall (m :: * -> *) a. Monad m => a -> m a
return (LockQ
pre forall a. Seq a -> a -> Seq a
|> (TSet -> LockKind
ReaderKind TSet
rcs', MVar ()
mblock),MVar ()
mblock)
ViewR (LockKind, MVar ())
_ -> do
MVar ()
mblock <- forall a. IO (MVar a)
newEmptyMVar
forall (m :: * -> *) a. Monad m => a -> m a
return (LockQ
qIn forall a. Seq a -> a -> Seq a
|> (TSet -> LockKind
ReaderKind (forall a. a -> Set a
Set.singleton ThreadId
me),MVar ()
mblock), MVar ()
mblock)
where
addMe :: TSet -> IO TSet
addMe :: TSet -> IO TSet
addMe TSet
rcs | forall a. Ord a => a -> Set a -> Bool
Set.member ThreadId
me TSet
rcs = forall a. HasCallStack => String -> a
error (forall x. Show x => String -> x -> String
imp String
"enterQueueR.addMe when already in set" ThreadId
me)
| Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Ord a => a -> Set a -> Set a
Set.insert ThreadId
me TSet
rcs)
acquireReadPriority :: RWLock -> IO ()
acquireReadPriority :: RWLock -> IO ()
acquireReadPriority (RWL MVar LockUser
rwlVar) = forall a. IO a -> IO a
uninterruptibleMask_ forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar LockUser
rwlVar forall a b. (a -> b) -> a -> b
$ \ LockUser
rwd -> do
ThreadId
me <- IO ThreadId
myThreadId
let safeBlock :: MVar a -> IO a
safeBlock MVar a
mblock = (forall a. MVar a -> IO a
readMVar MVar a
mblock) forall a b. IO a -> IO b -> IO a
`onException` (Bool -> ThreadId -> MVar LockUser -> IO (Either RWLockException ())
releaseRead' Bool
True ThreadId
me MVar LockUser
rwlVar)
case LockUser
rwd of
LockUser
FreeLock ->
forall (m :: * -> *) a. Monad m => a -> m a
return ( Readers { readerCounts :: TMap
readerCounts=forall k a. k -> a -> Map k a
Map.singleton ThreadId
me Int
1, queueR :: Maybe ((ThreadId, MVar ()), LockQ)
queueR=forall a. Maybe a
Nothing }
, forall (m :: * -> *) a. Monad m => a -> m a
return () )
w :: LockUser
w@(Writer { writerID :: LockUser -> ThreadId
writerID=ThreadId
it, readerCount :: LockUser -> Int
readerCount=Int
rc, queue :: LockUser -> LockQ
queue=LockQ
q }) | ThreadId
it forall a. Eq a => a -> a -> Bool
== ThreadId
me -> do
Int
rc' <- forall a. a -> IO a
evaluate forall a b. (a -> b) -> a -> b
$ forall a. Enum a => a -> a
succ Int
rc
forall (m :: * -> *) a. Monad m => a -> m a
return ( LockUser
w { readerCount :: Int
readerCount=Int
rc' }
, forall (m :: * -> *) a. Monad m => a -> m a
return () )
| Bool
otherwise -> do
(LockQ
q',MVar ()
mblock) <- ThreadId -> LockQ -> IO (LockQ, MVar ())
enterQueueL ThreadId
me LockQ
q
forall (m :: * -> *) a. Monad m => a -> m a
return ( LockUser
w { queue :: LockQ
queue = LockQ
q' }
, forall a. MVar a -> IO a
safeBlock MVar ()
mblock )
r :: LockUser
r@(Readers { readerCounts :: LockUser -> TMap
readerCounts=TMap
rcs }) -> do
case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ThreadId
me TMap
rcs of
Just Int
rc -> do
Int
rc' <- forall a. a -> IO a
evaluate forall a b. (a -> b) -> a -> b
$ forall a. Enum a => a -> a
succ Int
rc
TMap
rcs' <- forall a. a -> IO a
evaluate forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ThreadId
me Int
rc' TMap
rcs
forall (m :: * -> *) a. Monad m => a -> m a
return ( LockUser
r { readerCounts :: TMap
readerCounts=TMap
rcs' }
, forall (m :: * -> *) a. Monad m => a -> m a
return () )
Maybe Int
Nothing -> do
TMap
rcs' <- forall a. a -> IO a
evaluate forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ThreadId
me Int
1 TMap
rcs
forall (m :: * -> *) a. Monad m => a -> m a
return ( LockUser
r { readerCounts :: TMap
readerCounts=TMap
rcs' }
, forall (m :: * -> *) a. Monad m => a -> m a
return () )
where
enterQueueL :: ThreadId -> LockQ -> IO (LockQ,MVar ())
enterQueueL :: ThreadId -> LockQ -> IO (LockQ, MVar ())
enterQueueL ThreadId
me LockQ
qIn = do
case forall a. Seq a -> ViewL a
Seq.viewl LockQ
qIn of
(ReaderKind TSet
rcs,MVar ()
mblock) :< LockQ
post -> do
TSet
rcs' <- TSet -> IO TSet
addMe TSet
rcs
forall (m :: * -> *) a. Monad m => a -> m a
return ((TSet -> LockKind
ReaderKind TSet
rcs', MVar ()
mblock) forall a. a -> Seq a -> Seq a
<| LockQ
post,MVar ()
mblock)
ViewL (LockKind, MVar ())
_ -> do
MVar ()
mblock <- forall a. IO (MVar a)
newEmptyMVar
forall (m :: * -> *) a. Monad m => a -> m a
return ((TSet -> LockKind
ReaderKind (forall a. a -> Set a
Set.singleton ThreadId
me),MVar ()
mblock) forall a. a -> Seq a -> Seq a
<| LockQ
qIn , MVar ()
mblock)
where
addMe :: TSet -> IO TSet
addMe :: TSet -> IO TSet
addMe TSet
rcs | forall a. Ord a => a -> Set a -> Bool
Set.member ThreadId
me TSet
rcs = forall a. HasCallStack => String -> a
error (forall x. Show x => String -> x -> String
imp String
"enterQueueL.addMe when already in set" ThreadId
me)
| Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Ord a => a -> Set a -> Set a
Set.insert ThreadId
me TSet
rcs)
acquireWrite :: RWLock -> IO ()
acquireWrite :: RWLock -> IO ()
acquireWrite rwl :: RWLock
rwl@(RWL MVar LockUser
rwlVar) = forall a. IO a -> IO a
mask_ forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar LockUser
rwlVar forall a b. (a -> b) -> a -> b
$ \ LockUser
rwd -> do
ThreadId
me <- IO ThreadId
myThreadId
let safeBlock :: MVar a -> IO a
safeBlock MVar a
mblock = (forall a. MVar a -> IO a
takeMVar MVar a
mblock) forall a b. IO a -> IO b -> IO a
`onException` (Bool -> ThreadId -> MVar LockUser -> IO (Either RWLockException ())
releaseWrite' Bool
True ThreadId
me MVar LockUser
rwlVar)
case LockUser
rwd of
LockUser
FreeLock ->
forall (m :: * -> *) a. Monad m => a -> m a
return ( Writer { writerID :: ThreadId
writerID=ThreadId
me, writerCount :: Int
writerCount=Int
1, readerCount :: Int
readerCount=Int
0, queue :: LockQ
queue=forall a. Seq a
Seq.empty }
, forall (m :: * -> *) a. Monad m => a -> m a
return () )
w :: LockUser
w@(Writer { writerID :: LockUser -> ThreadId
writerID=ThreadId
it, writerCount :: LockUser -> Int
writerCount=Int
wc, queue :: LockUser -> LockQ
queue=LockQ
q }) | ThreadId
itforall a. Eq a => a -> a -> Bool
==ThreadId
me ->
forall (m :: * -> *) a. Monad m => a -> m a
return ( LockUser
w { writerCount :: Int
writerCount=(forall a. Enum a => a -> a
succ Int
wc) }
, forall (m :: * -> *) a. Monad m => a -> m a
return () )
| Bool
otherwise -> do
MVar ()
mblock <- forall a. IO (MVar a)
newEmptyMVar
LockQ
q' <- forall a. a -> IO a
evaluate forall a b. (a -> b) -> a -> b
$ LockQ
q forall a. Seq a -> a -> Seq a
|> (ThreadId -> LockKind
WriterKind ThreadId
me,MVar ()
mblock)
forall (m :: * -> *) a. Monad m => a -> m a
return ( LockUser
w { queue :: LockQ
queue=LockQ
q' }
, forall a. MVar a -> IO a
safeBlock MVar ()
mblock )
Readers { readerCounts :: LockUser -> TMap
readerCounts=TMap
rcs } | Just Int
rc <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ThreadId
me TMap
rcs -> do
forall (m :: * -> *) a. Monad m => a -> m a
return ( LockUser
rwd
, forall a. Int -> IO a -> IO a
withoutReads Int
rc (RWLock -> IO ()
acquireWrite RWLock
rwl) )
r :: LockUser
r@(Readers { queueR :: LockUser -> Maybe ((ThreadId, MVar ()), LockQ)
queueR=Maybe ((ThreadId, MVar ()), LockQ)
Nothing }) -> do
MVar ()
mblock <- forall a. IO (MVar a)
newEmptyMVar
let qr :: Maybe ((ThreadId, MVar ()), Seq a)
qr = forall a. a -> Maybe a
Just ((ThreadId
me,MVar ()
mblock),forall a. Seq a
Seq.empty)
forall (m :: * -> *) a. Monad m => a -> m a
return ( LockUser
r { queueR :: Maybe ((ThreadId, MVar ()), LockQ)
queueR=forall {a}. Maybe ((ThreadId, MVar ()), Seq a)
qr }
, forall a. MVar a -> IO a
safeBlock MVar ()
mblock )
r :: LockUser
r@(Readers { queueR :: LockUser -> Maybe ((ThreadId, MVar ()), LockQ)
queueR=Just ((ThreadId, MVar ())
w,LockQ
q) }) -> do
MVar ()
mblock <- forall a. IO (MVar a)
newEmptyMVar
LockQ
q' <- forall a. a -> IO a
evaluate forall a b. (a -> b) -> a -> b
$ LockQ
q forall a. Seq a -> a -> Seq a
|> (ThreadId -> LockKind
WriterKind ThreadId
me,MVar ()
mblock)
forall (m :: * -> *) a. Monad m => a -> m a
return ( LockUser
r { queueR :: Maybe ((ThreadId, MVar ()), LockQ)
queueR=forall a. a -> Maybe a
Just ((ThreadId, MVar ())
w,LockQ
q') }
, forall a. MVar a -> IO a
safeBlock MVar ()
mblock )
where
withoutReads :: Int -> IO a -> IO a
withoutReads :: forall a. Int -> IO a -> IO a
withoutReads Int
n IO a
x = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) forall a. a -> a
id (forall a. Int -> a -> [a]
replicate Int
n forall a. IO a -> IO a
withoutRead) forall a b. (a -> b) -> a -> b
$ IO a
x
withoutRead :: IO a -> IO a
withoutRead :: forall a. IO a -> IO a
withoutRead = forall a b c. IO a -> IO b -> IO c -> IO c
bracket_ (RWLock -> IO (Either RWLockException ())
releaseRead RWLock
rwl forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a e. Exception e => e -> a
throw forall (m :: * -> *) a. Monad m => a -> m a
return) (RWLock -> IO ()
acquireReadPriority RWLock
rwl)
imp :: Show x => String -> x -> String
imp :: forall x. Show x => String -> x -> String
imp String
s x
x = String
"FairRWLock impossible error: "forall a. [a] -> [a] -> [a]
++String
sforall a. [a] -> [a] -> [a]
++String
" : "forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> String
show x
x