{-# 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
(LockKind -> LockKind -> Bool)
-> (LockKind -> LockKind -> Bool) -> Eq LockKind
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
Eq LockKind
-> (LockKind -> LockKind -> Ordering)
-> (LockKind -> LockKind -> Bool)
-> (LockKind -> LockKind -> Bool)
-> (LockKind -> LockKind -> Bool)
-> (LockKind -> LockKind -> Bool)
-> (LockKind -> LockKind -> LockKind)
-> (LockKind -> LockKind -> LockKind)
-> Ord 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
$cp1Ord :: Eq LockKind
Ord,Int -> LockKind -> ShowS
[LockKind] -> ShowS
LockKind -> String
(Int -> LockKind -> ShowS)
-> (LockKind -> String) -> ([LockKind] -> ShowS) -> Show LockKind
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
(LockUser -> LockUser -> Bool)
-> (LockUser -> LockUser -> Bool) -> Eq LockUser
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
(Int -> RWLockException -> ShowS)
-> (RWLockException -> String)
-> ([RWLockException] -> ShowS)
-> Show RWLockException
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
(Int -> RWLockExceptionKind -> ShowS)
-> (RWLockExceptionKind -> String)
-> ([RWLockExceptionKind] -> ShowS)
-> Show RWLockExceptionKind
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
(Int -> FRW -> ShowS)
-> (FRW -> String) -> ([FRW] -> ShowS) -> Show FRW
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 = (MVar LockUser -> RWLock) -> IO (MVar LockUser) -> IO RWLock
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap MVar LockUser -> RWLock
RWL (LockUser -> IO (MVar LockUser)
forall a. a -> IO (MVar a)
newMVar LockUser
FreeLock)
withRead :: RWLock -> IO a -> IO a
withRead :: RWLock -> IO a -> IO a
withRead = (IO () -> IO () -> IO a -> IO a)
-> (RWLock -> IO ()) -> (RWLock -> IO ()) -> RWLock -> IO a -> IO a
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 IO () -> IO () -> IO a -> IO a
forall a b c. IO a -> IO b -> IO c -> IO c
bracket_ RWLock -> IO ()
acquireRead (RWLock -> IO (Either RWLockException ())
releaseRead (RWLock -> IO (Either RWLockException ()))
-> (Either RWLockException () -> IO ()) -> RWLock -> IO ()
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (RWLockException -> IO ())
-> (() -> IO ()) -> Either RWLockException () -> IO ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either RWLockException -> IO ()
forall a e. Exception e => e -> a
throw () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return)
withWrite :: RWLock -> IO a -> IO a
withWrite :: RWLock -> IO a -> IO a
withWrite = (IO () -> IO () -> IO a -> IO a)
-> (RWLock -> IO ()) -> (RWLock -> IO ()) -> RWLock -> IO a -> IO a
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 IO () -> IO () -> IO a -> IO a
forall a b c. IO a -> IO b -> IO c -> IO c
bracket_ RWLock -> IO ()
acquireWrite (RWLock -> IO (Either RWLockException ())
releaseWrite (RWLock -> IO (Either RWLockException ()))
-> (Either RWLockException () -> IO ()) -> RWLock -> IO ()
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (RWLockException -> IO ())
-> (() -> IO ()) -> Either RWLockException () -> IO ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either RWLockException -> IO ()
forall a e. Exception e => e -> a
throw () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return)
peekLock :: RWLock -> IO (FRW,[LockKind])
peekLock :: RWLock -> IO (FRW, [LockKind])
peekLock (RWL MVar LockUser
rwlVar) = MVar LockUser
-> (LockUser -> IO (FRW, [LockKind])) -> IO (FRW, [LockKind])
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar LockUser
rwlVar ((LockUser -> IO (FRW, [LockKind])) -> IO (FRW, [LockKind]))
-> (LockUser -> IO (FRW, [LockKind])) -> IO (FRW, [LockKind])
forall a b. (a -> b) -> a -> b
$ \ LockUser
rwd -> (FRW, [LockKind]) -> IO (FRW, [LockKind])
forall (m :: * -> *) a. Monad m => a -> m a
return ((FRW, [LockKind]) -> IO (FRW, [LockKind]))
-> (FRW, [LockKind]) -> IO (FRW, [LockKind])
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,[LockKind]
-> (((ThreadId, MVar ()), LockQ) -> [LockKind])
-> Maybe ((ThreadId, MVar ()), LockQ)
-> [LockKind]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\((ThreadId
t,MVar ()
_),LockQ
q) -> ThreadId -> LockKind
WriterKind ThreadId
t LockKind -> [LockKind] -> [LockKind]
forall a. a -> [a] -> [a]
: ((LockKind, MVar ()) -> LockKind)
-> [(LockKind, MVar ())] -> [LockKind]
forall a b. (a -> b) -> [a] -> [b]
map (LockKind, MVar ()) -> LockKind
forall a b. (a, b) -> a
fst (LockQ -> [(LockKind, MVar ())]
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)), ((LockKind, MVar ()) -> LockKind)
-> [(LockKind, MVar ())] -> [LockKind]
forall a b. (a -> b) -> [a] -> [b]
map (LockKind, MVar ()) -> LockKind
forall a b. (a, b) -> a
fst (LockQ -> [(LockKind, MVar ())]
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
MVar LockUser -> (LockUser -> IO (Int, Int)) -> IO (Int, Int)
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar LockUser
rwlVar ((LockUser -> IO (Int, Int)) -> IO (Int, Int))
-> (LockUser -> IO (Int, Int)) -> IO (Int, Int)
forall a b. (a -> b) -> a -> b
$ \ LockUser
rwd -> (Int, Int) -> IO (Int, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Int, Int) -> IO (Int, Int)) -> (Int, Int) -> IO (Int, Int)
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 ThreadId -> TMap -> Maybe Int
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
itThreadId -> ThreadId -> Bool
forall 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) = IO (Either RWLockException ()) -> IO (Either RWLockException ())
forall a. IO a -> IO a
mask_ (IO (Either RWLockException ()) -> IO (Either RWLockException ()))
-> IO (Either RWLockException ()) -> IO (Either RWLockException ())
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 = IO (Either RWLockException ()) -> IO (Either RWLockException ())
forall a. IO a -> IO a
uninterruptibleMask_ (IO (Either RWLockException ()) -> IO (Either RWLockException ()))
-> ((LockUser -> IO (LockUser, Either RWLockException ()))
-> IO (Either RWLockException ()))
-> (LockUser -> IO (LockUser, Either RWLockException ()))
-> IO (Either RWLockException ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar LockUser
-> (LockUser -> IO (LockUser, Either RWLockException ()))
-> IO (Either RWLockException ())
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar LockUser
rwlVar ((LockUser -> IO (LockUser, Either RWLockException ()))
-> IO (Either RWLockException ()))
-> (LockUser -> IO (LockUser, Either RWLockException ()))
-> IO (Either RWLockException ())
forall a b. (a -> b) -> a -> b
$ \ LockUser
rwd -> do
let impossible :: Show x => String -> x -> IO a
impossible :: String -> x -> IO a
impossible String
s x
x = RWLockException -> IO a
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) (String -> x -> String
forall x. Show x => String -> x -> String
imp String
s x
x))
err :: Show x => String -> x -> IO (LockUser,Either RWLockException ())
err :: String -> x -> IO (LockUser, Either RWLockException ())
err String
s x
x = (LockUser, Either RWLockException ())
-> IO (LockUser, Either RWLockException ())
forall (m :: * -> *) a. Monad m => a -> m a
return ((LockUser, Either RWLockException ())
-> IO (LockUser, Either RWLockException ()))
-> (RWLockException -> (LockUser, Either RWLockException ()))
-> RWLockException
-> IO (LockUser, Either RWLockException ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((,) LockUser
rwd) (Either RWLockException ()
-> (LockUser, Either RWLockException ()))
-> (RWLockException -> Either RWLockException ())
-> RWLockException
-> (LockUser, Either RWLockException ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RWLockException -> Either RWLockException ()
forall a b. a -> Either a b
Left (RWLockException -> IO (LockUser, Either RWLockException ()))
-> RWLockException -> IO (LockUser, Either RWLockException ())
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
sString -> ShowS
forall a. [a] -> [a] -> [a]
++String
" : "String -> ShowS
forall a. [a] -> [a] -> [a]
++x -> String
forall a. Show a => a -> String
show x
x))
ret :: LockUser -> IO (LockUser,Either RWLockException ())
ret :: LockUser -> IO (LockUser, Either RWLockException ())
ret LockUser
x = (LockUser, Either RWLockException ())
-> IO (LockUser, Either RWLockException ())
forall (m :: * -> *) a. Monad m => a -> m a
return (LockUser
x,() -> Either RWLockException ()
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
_) = ThreadId -> TSet -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member ThreadId
me TSet
rcs
inR (LockKind, b)
_ = Bool
False
(LockQ
pre,LockQ
myselfPost) = ((LockKind, MVar ()) -> Bool) -> LockQ -> (LockQ, LockQ)
forall a. (a -> Bool) -> Seq a -> (Seq a, Seq a)
Seq.breakl (LockKind, MVar ()) -> Bool
forall b. (LockKind, b) -> Bool
inR LockQ
q
case LockQ -> ViewL (LockKind, MVar ())
forall a. Seq a -> ViewL a
Seq.viewl LockQ
myselfPost of
ViewL (LockKind, MVar ())
EmptyL ->
String -> ThreadId -> IO LockQ
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' = ThreadId -> TSet -> TSet
forall a. Ord a => a -> Set a -> Set a
Set.delete ThreadId
me (LockKind -> TSet
unRK LockKind
myself)
LockQ -> IO LockQ
forall a. a -> IO a
evaluate (LockQ -> IO LockQ) -> LockQ -> IO LockQ
forall a b. (a -> b) -> a -> b
$ if TSet -> Bool
forall a. Set a -> Bool
Set.null TSet
rcs' then LockQ
pre LockQ -> LockQ -> LockQ
forall a. Seq a -> Seq a -> Seq a
>< LockQ
post else LockQ
pre LockQ -> LockQ -> LockQ
forall a. Seq a -> Seq a -> Seq a
>< ((TSet -> LockKind
ReaderKind TSet
rcs',MVar ()
mblock) (LockKind, MVar ()) -> LockQ -> LockQ
forall a. a -> Seq a -> Seq a
<| LockQ
post)
case LockUser
rwd of
LockUser
FreeLock | Bool
abandon ->
String -> ThreadId -> IO (LockUser, Either RWLockException ())
forall x a. Show x => String -> x -> IO a
impossible String
"acquireRead interrupted with unlocked RWLock" ThreadId
me
| Bool
otherwise ->
String -> ThreadId -> IO (LockUser, Either RWLockException ())
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
itThreadId -> ThreadId -> Bool
forall a. Eq a => a -> a -> Bool
==ThreadId
me -> do
case Int
rc of
Int
0 | Bool
abandon ->
String
-> (ThreadId, ThreadId) -> IO (LockUser, Either RWLockException ())
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 ->
String
-> (ThreadId, ThreadId) -> IO (LockUser, Either RWLockException ())
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' <- Int -> IO Int
forall a. a -> IO a
evaluate (Int -> IO Int) -> Int -> IO Int
forall a b. (a -> b) -> a -> b
$ Int -> Int
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 ->
String -> ThreadId -> IO (LockUser, Either RWLockException ())
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 ThreadId -> TMap -> Maybe Int
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' = ThreadId -> TMap -> TMap
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete ThreadId
me TMap
rcs
if TMap -> Bool
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
MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
mblock ()
LockUser -> IO (LockUser, Either RWLockException ())
ret (Writer :: ThreadId -> Int -> Int -> LockQ -> LockUser
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' <- Int -> IO Int
forall a. a -> IO a
evaluate (Int -> IO Int) -> Int -> IO Int
forall a b. (a -> b) -> a -> b
$ Int -> Int
forall a. Enum a => a -> a
pred Int
rc
TMap
rcs' <- TMap -> IO TMap
forall a. a -> IO a
evaluate (TMap -> IO TMap) -> TMap -> IO TMap
forall a b. (a -> b) -> a -> b
$ ThreadId -> Int -> TMap -> TMap
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 ->
String
-> (ThreadId, TMap) -> IO (LockUser, Either RWLockException ())
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 = ((ThreadId, MVar ()), LockQ) -> Maybe ((ThreadId, MVar ()), LockQ)
forall a. a -> Maybe a
Just ((ThreadId, MVar ())
w,LockQ
q') })
| Bool
otherwise ->
String
-> (ThreadId, TMap) -> IO (LockUser, Either RWLockException ())
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) = IO (Either RWLockException ()) -> IO (Either RWLockException ())
forall a. IO a -> IO a
mask_ (IO (Either RWLockException ()) -> IO (Either RWLockException ()))
-> IO (Either RWLockException ()) -> IO (Either RWLockException ())
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 = IO (Either RWLockException ()) -> IO (Either RWLockException ())
forall a. IO a -> IO a
uninterruptibleMask_ (IO (Either RWLockException ()) -> IO (Either RWLockException ()))
-> ((LockUser -> IO (LockUser, Either RWLockException ()))
-> IO (Either RWLockException ()))
-> (LockUser -> IO (LockUser, Either RWLockException ()))
-> IO (Either RWLockException ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar LockUser
-> (LockUser -> IO (LockUser, Either RWLockException ()))
-> IO (Either RWLockException ())
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar LockUser
rwlVar ((LockUser -> IO (LockUser, Either RWLockException ()))
-> IO (Either RWLockException ()))
-> (LockUser -> IO (LockUser, Either RWLockException ()))
-> IO (Either RWLockException ())
forall a b. (a -> b) -> a -> b
$ \ LockUser
rwd -> do
let impossible :: Show x => String -> x -> IO a
impossible :: String -> x -> IO a
impossible String
s x
x = RWLockException -> IO a
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) (String -> x -> String
forall x. Show x => String -> x -> String
imp String
s x
x))
err :: Show x => String -> x -> IO (LockUser,Either RWLockException ())
err :: String -> x -> IO (LockUser, Either RWLockException ())
err String
s x
x = (LockUser, Either RWLockException ())
-> IO (LockUser, Either RWLockException ())
forall (m :: * -> *) a. Monad m => a -> m a
return ((LockUser, Either RWLockException ())
-> IO (LockUser, Either RWLockException ()))
-> (RWLockException -> (LockUser, Either RWLockException ()))
-> RWLockException
-> IO (LockUser, Either RWLockException ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((,) LockUser
rwd) (Either RWLockException ()
-> (LockUser, Either RWLockException ()))
-> (RWLockException -> Either RWLockException ())
-> RWLockException
-> (LockUser, Either RWLockException ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RWLockException -> Either RWLockException ()
forall a b. a -> Either a b
Left (RWLockException -> IO (LockUser, Either RWLockException ()))
-> RWLockException -> IO (LockUser, Either RWLockException ())
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
sString -> ShowS
forall a. [a] -> [a] -> [a]
++String
" : "String -> ShowS
forall a. [a] -> [a] -> [a]
++x -> String
forall a. Show a => a -> String
show x
x))
ret :: LockUser -> IO (LockUser,Either RWLockException ())
ret :: LockUser -> IO (LockUser, Either RWLockException ())
ret LockUser
x = (LockUser, Either RWLockException ())
-> IO (LockUser, Either RWLockException ())
forall (m :: * -> *) a. Monad m => a -> m a
return (LockUser
x,() -> Either RWLockException ()
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
meThreadId -> ThreadId -> Bool
forall a. Eq a => a -> a -> Bool
==ThreadId
it
inW (LockKind, b)
_ = Bool
False
(LockQ
pre,LockQ
myselfPost) = ((LockKind, MVar ()) -> Bool) -> LockQ -> (LockQ, LockQ)
forall a. (a -> Bool) -> Seq a -> (Seq a, Seq a)
Seq.breakl (LockKind, MVar ()) -> Bool
forall b. (LockKind, b) -> Bool
inW LockQ
q
case LockQ -> ViewL (LockKind, MVar ())
forall a. Seq a -> ViewL a
Seq.viewl LockQ
myselfPost of
ViewL (LockKind, MVar ())
EmptyL ->
String -> ThreadId -> IO LockQ
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 ->
LockQ -> IO LockQ
forall a. a -> IO a
evaluate (LockQ -> IO LockQ) -> LockQ -> IO LockQ
forall a b. (a -> b) -> a -> b
$ LockQ
preLockQ -> LockQ -> LockQ
forall a. Seq a -> Seq a -> Seq a
><LockQ
post
case LockUser
rwd of
LockUser
FreeLock | Bool
abandon ->
String -> ThreadId -> IO (LockUser, Either RWLockException ())
forall x a. Show x => String -> x -> IO a
impossible String
"acquireWrite interrupted with unlocked RWLock" ThreadId
me
| Bool
otherwise ->
String -> ThreadId -> IO (LockUser, Either RWLockException ())
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
itThreadId -> ThreadId -> Bool
forall 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 (LockUser -> IO (LockUser, Either RWLockException ()))
-> IO LockUser -> IO (LockUser, Either RWLockException ())
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LockQ -> IO LockUser
promote LockQ
q
(Int, Int)
_ | Bool
abandon -> String
-> (ThreadId, ThreadId, Int, Int)
-> IO (LockUser, Either RWLockException ())
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 (LockUser -> IO (LockUser, Either RWLockException ()))
-> IO LockUser -> IO (LockUser, Either RWLockException ())
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=(Int -> Int
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
String
-> (ThreadId, ThreadId) -> IO (LockUser, Either RWLockException ())
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 ->
String
-> (ThreadId, TMap) -> IO (LockUser, Either RWLockException ())
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 } ->
String
-> (ThreadId, TMap) -> IO (LockUser, Either RWLockException ())
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
itThreadId -> ThreadId -> Bool
forall 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=TMap -> TMap -> TMap
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=((ThreadId, MVar ()), LockQ) -> Maybe ((ThreadId, MVar ()), LockQ)
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 = ThreadId -> Int -> TMap -> TMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ThreadId
me Int
rc TMap
rcs'new
LockUser -> IO LockUser
forall (m :: * -> *) a. Monad m => a -> m a
return (Readers :: TMap -> Maybe ((ThreadId, MVar ()), LockQ) -> LockUser
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 LockQ -> ViewL (LockKind, MVar ())
forall a. Seq a -> ViewL a
Seq.viewl LockQ
qIn of
ViewL (LockKind, MVar ())
EmptyL -> LockUser -> IO LockUser
forall (m :: * -> *) a. Monad m => a -> m a
return LockUser
FreeLock
(WriterKind ThreadId
it,MVar ()
mblock) :< LockQ
qOut -> do
MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
mblock ()
LockUser -> IO LockUser
forall (m :: * -> *) a. Monad m => a -> m a
return (Writer :: ThreadId -> Int -> Int -> LockQ -> LockUser
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
LockUser -> IO LockUser
forall (m :: * -> *) a. Monad m => a -> m a
return (Readers :: TMap -> Maybe ((ThreadId, MVar ()), LockQ) -> LockUser
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) = ((LockKind, MVar ()) -> Bool) -> LockQ -> (LockQ, LockQ)
forall a. (a -> Bool) -> Seq a -> (Seq a, Seq a)
Seq.spanl (LockKind, MVar ()) -> Bool
forall b. (LockKind, b) -> Bool
isReader LockQ
qIn
([LockKind]
rks,[MVar ()]
mblocks) = [(LockKind, MVar ())] -> ([LockKind], [MVar ()])
forall a b. [(a, b)] -> ([a], [b])
unzip (LockQ -> [(LockKind, MVar ())]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList LockQ
more'Readers)
rcs :: TMap
rcs = [(ThreadId, Int)] -> TMap
forall k a. [(k, a)] -> Map k a
Map.fromDistinctAscList ([(ThreadId, Int)] -> TMap)
-> ([LockKind] -> [(ThreadId, Int)]) -> [LockKind] -> TMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ThreadId -> (ThreadId, Int)) -> [ThreadId] -> [(ThreadId, Int)]
forall a b. (a -> b) -> [a] -> [b]
map (\ThreadId
k -> (ThreadId
k,Int
1)) ([ThreadId] -> [(ThreadId, Int)])
-> ([LockKind] -> [ThreadId]) -> [LockKind] -> [(ThreadId, Int)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TSet -> [ThreadId]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (TSet -> [ThreadId])
-> ([LockKind] -> TSet) -> [LockKind] -> [ThreadId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TSet] -> TSet
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ([TSet] -> TSet) -> ([LockKind] -> [TSet]) -> [LockKind] -> TSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LockKind -> TSet) -> [LockKind] -> [TSet]
forall a b. (a -> b) -> [a] -> [b]
map LockKind -> TSet
unRK ([LockKind] -> TMap) -> [LockKind] -> TMap
forall a b. (a -> b) -> a -> b
$ [LockKind]
rks
qr :: Maybe ((ThreadId, MVar ()), LockQ)
qr = case LockQ -> ViewL (LockKind, MVar ())
forall a. Seq a -> ViewL a
Seq.viewl LockQ
qTail of
ViewL (LockKind, MVar ())
EmptyL -> Maybe ((ThreadId, MVar ()), LockQ)
forall a. Maybe a
Nothing
(LockKind
wk,MVar ()
mblock) :< LockQ
qOut -> ((ThreadId, MVar ()), LockQ) -> Maybe ((ThreadId, MVar ()), LockQ)
forall a. a -> Maybe a
Just ((LockKind -> ThreadId
unWK LockKind
wk,MVar ()
mblock),LockQ
qOut)
[MVar ()] -> (MVar () -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [MVar ()]
mblocks (\MVar ()
mblock -> MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
mblock ())
(TMap, Maybe ((ThreadId, MVar ()), LockQ))
-> IO (TMap, Maybe ((ThreadId, MVar ()), LockQ))
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) = IO () -> IO ()
forall a. IO a -> IO a
mask_ (IO () -> IO ())
-> ((LockUser -> IO (LockUser, IO ())) -> IO ())
-> (LockUser -> IO (LockUser, IO ()))
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ()) -> IO ())
-> ((LockUser -> IO (LockUser, IO ())) -> IO (IO ()))
-> (LockUser -> IO (LockUser, IO ()))
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar LockUser -> (LockUser -> IO (LockUser, IO ())) -> IO (IO ())
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar LockUser
rwlVar ((LockUser -> IO (LockUser, IO ())) -> IO ())
-> (LockUser -> IO (LockUser, IO ())) -> IO ()
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 = (MVar a -> IO a
forall a. MVar a -> IO a
readMVar MVar a
mblock) IO a -> IO (Either RWLockException ()) -> IO a
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 ->
(LockUser, IO ()) -> IO (LockUser, IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return ( Readers :: TMap -> Maybe ((ThreadId, MVar ()), LockQ) -> LockUser
Readers { readerCounts :: TMap
readerCounts=ThreadId -> Int -> TMap
forall k a. k -> a -> Map k a
Map.singleton ThreadId
me Int
1, queueR :: Maybe ((ThreadId, MVar ()), LockQ)
queueR=Maybe ((ThreadId, MVar ()), LockQ)
forall a. Maybe a
Nothing }
, () -> IO ()
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 ThreadId -> ThreadId -> Bool
forall a. Eq a => a -> a -> Bool
== ThreadId
me -> do
Int
rc' <- Int -> IO Int
forall a. a -> IO a
evaluate (Int -> IO Int) -> Int -> IO Int
forall a b. (a -> b) -> a -> b
$ Int -> Int
forall a. Enum a => a -> a
succ Int
rc
(LockUser, IO ()) -> IO (LockUser, IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return ( LockUser
w { readerCount :: Int
readerCount=Int
rc' }
, () -> IO ()
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
(LockUser, IO ()) -> IO (LockUser, IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return ( LockUser
w { queue :: LockQ
queue = LockQ
q' }
, MVar () -> IO ()
forall a. MVar a -> IO a
safeBlock MVar ()
mblock )
r :: LockUser
r@(Readers { readerCounts :: LockUser -> TMap
readerCounts=TMap
rcs }) | Just Int
rc <- ThreadId -> TMap -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ThreadId
me TMap
rcs -> do
Int
rc' <- Int -> IO Int
forall a. a -> IO a
evaluate (Int -> IO Int) -> Int -> IO Int
forall a b. (a -> b) -> a -> b
$ Int -> Int
forall a. Enum a => a -> a
succ Int
rc
TMap
rcs' <- TMap -> IO TMap
forall a. a -> IO a
evaluate (TMap -> IO TMap) -> TMap -> IO TMap
forall a b. (a -> b) -> a -> b
$ ThreadId -> Int -> TMap -> TMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ThreadId
me Int
rc' TMap
rcs
(LockUser, IO ()) -> IO (LockUser, IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return ( LockUser
r { readerCounts :: TMap
readerCounts=TMap
rcs' }
, () -> IO ()
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' <- TMap -> IO TMap
forall a. a -> IO a
evaluate (TMap -> IO TMap) -> TMap -> IO TMap
forall a b. (a -> b) -> a -> b
$ ThreadId -> Int -> TMap -> TMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ThreadId
me Int
1 TMap
rcs
(LockUser, IO ()) -> IO (LockUser, IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return ( LockUser
r { readerCounts :: TMap
readerCounts=TMap
rcs' }
, () -> IO ()
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
(LockUser, IO ()) -> IO (LockUser, IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return ( LockUser
r { queueR :: Maybe ((ThreadId, MVar ()), LockQ)
queueR=((ThreadId, MVar ()), LockQ) -> Maybe ((ThreadId, MVar ()), LockQ)
forall a. a -> Maybe a
Just ((ThreadId, MVar ())
w,LockQ
q') }
, MVar () -> IO ()
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 LockQ -> ViewR (LockKind, MVar ())
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
(LockQ, MVar ()) -> IO (LockQ, MVar ())
forall (m :: * -> *) a. Monad m => a -> m a
return (LockQ
pre LockQ -> (LockKind, MVar ()) -> LockQ
forall a. Seq a -> a -> Seq a
|> (TSet -> LockKind
ReaderKind TSet
rcs', MVar ()
mblock),MVar ()
mblock)
ViewR (LockKind, MVar ())
_ -> do
MVar ()
mblock <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
(LockQ, MVar ()) -> IO (LockQ, MVar ())
forall (m :: * -> *) a. Monad m => a -> m a
return (LockQ
qIn LockQ -> (LockKind, MVar ()) -> LockQ
forall a. Seq a -> a -> Seq a
|> (TSet -> LockKind
ReaderKind (ThreadId -> TSet
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 | ThreadId -> TSet -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member ThreadId
me TSet
rcs = String -> IO TSet
forall a. HasCallStack => String -> a
error (String -> ThreadId -> String
forall x. Show x => String -> x -> String
imp String
"enterQueueR.addMe when already in set" ThreadId
me)
| Bool
otherwise = TSet -> IO TSet
forall (m :: * -> *) a. Monad m => a -> m a
return (ThreadId -> TSet -> TSet
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) = IO () -> IO ()
forall a. IO a -> IO a
uninterruptibleMask_ (IO () -> IO ())
-> ((LockUser -> IO (LockUser, IO ())) -> IO ())
-> (LockUser -> IO (LockUser, IO ()))
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ()) -> IO ())
-> ((LockUser -> IO (LockUser, IO ())) -> IO (IO ()))
-> (LockUser -> IO (LockUser, IO ()))
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar LockUser -> (LockUser -> IO (LockUser, IO ())) -> IO (IO ())
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar LockUser
rwlVar ((LockUser -> IO (LockUser, IO ())) -> IO ())
-> (LockUser -> IO (LockUser, IO ())) -> IO ()
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 = (MVar a -> IO a
forall a. MVar a -> IO a
readMVar MVar a
mblock) IO a -> IO (Either RWLockException ()) -> IO a
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 ->
(LockUser, IO ()) -> IO (LockUser, IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return ( Readers :: TMap -> Maybe ((ThreadId, MVar ()), LockQ) -> LockUser
Readers { readerCounts :: TMap
readerCounts=ThreadId -> Int -> TMap
forall k a. k -> a -> Map k a
Map.singleton ThreadId
me Int
1, queueR :: Maybe ((ThreadId, MVar ()), LockQ)
queueR=Maybe ((ThreadId, MVar ()), LockQ)
forall a. Maybe a
Nothing }
, () -> IO ()
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 ThreadId -> ThreadId -> Bool
forall a. Eq a => a -> a -> Bool
== ThreadId
me -> do
Int
rc' <- Int -> IO Int
forall a. a -> IO a
evaluate (Int -> IO Int) -> Int -> IO Int
forall a b. (a -> b) -> a -> b
$ Int -> Int
forall a. Enum a => a -> a
succ Int
rc
(LockUser, IO ()) -> IO (LockUser, IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return ( LockUser
w { readerCount :: Int
readerCount=Int
rc' }
, () -> IO ()
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
(LockUser, IO ()) -> IO (LockUser, IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return ( LockUser
w { queue :: LockQ
queue = LockQ
q' }
, MVar () -> IO ()
forall a. MVar a -> IO a
safeBlock MVar ()
mblock )
r :: LockUser
r@(Readers { readerCounts :: LockUser -> TMap
readerCounts=TMap
rcs }) -> do
case ThreadId -> TMap -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ThreadId
me TMap
rcs of
Just Int
rc -> do
Int
rc' <- Int -> IO Int
forall a. a -> IO a
evaluate (Int -> IO Int) -> Int -> IO Int
forall a b. (a -> b) -> a -> b
$ Int -> Int
forall a. Enum a => a -> a
succ Int
rc
TMap
rcs' <- TMap -> IO TMap
forall a. a -> IO a
evaluate (TMap -> IO TMap) -> TMap -> IO TMap
forall a b. (a -> b) -> a -> b
$ ThreadId -> Int -> TMap -> TMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ThreadId
me Int
rc' TMap
rcs
(LockUser, IO ()) -> IO (LockUser, IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return ( LockUser
r { readerCounts :: TMap
readerCounts=TMap
rcs' }
, () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return () )
Maybe Int
Nothing -> do
TMap
rcs' <- TMap -> IO TMap
forall a. a -> IO a
evaluate (TMap -> IO TMap) -> TMap -> IO TMap
forall a b. (a -> b) -> a -> b
$ ThreadId -> Int -> TMap -> TMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ThreadId
me Int
1 TMap
rcs
(LockUser, IO ()) -> IO (LockUser, IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return ( LockUser
r { readerCounts :: TMap
readerCounts=TMap
rcs' }
, () -> IO ()
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 LockQ -> ViewL (LockKind, MVar ())
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
(LockQ, MVar ()) -> IO (LockQ, MVar ())
forall (m :: * -> *) a. Monad m => a -> m a
return ((TSet -> LockKind
ReaderKind TSet
rcs', MVar ()
mblock) (LockKind, MVar ()) -> LockQ -> LockQ
forall a. a -> Seq a -> Seq a
<| LockQ
post,MVar ()
mblock)
ViewL (LockKind, MVar ())
_ -> do
MVar ()
mblock <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
(LockQ, MVar ()) -> IO (LockQ, MVar ())
forall (m :: * -> *) a. Monad m => a -> m a
return ((TSet -> LockKind
ReaderKind (ThreadId -> TSet
forall a. a -> Set a
Set.singleton ThreadId
me),MVar ()
mblock) (LockKind, MVar ()) -> LockQ -> LockQ
forall a. a -> Seq a -> Seq a
<| LockQ
qIn , MVar ()
mblock)
where
addMe :: TSet -> IO TSet
addMe :: TSet -> IO TSet
addMe TSet
rcs | ThreadId -> TSet -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member ThreadId
me TSet
rcs = String -> IO TSet
forall a. HasCallStack => String -> a
error (String -> ThreadId -> String
forall x. Show x => String -> x -> String
imp String
"enterQueueL.addMe when already in set" ThreadId
me)
| Bool
otherwise = TSet -> IO TSet
forall (m :: * -> *) a. Monad m => a -> m a
return (ThreadId -> TSet -> TSet
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) = IO () -> IO ()
forall a. IO a -> IO a
mask_ (IO () -> IO ())
-> ((LockUser -> IO (LockUser, IO ())) -> IO ())
-> (LockUser -> IO (LockUser, IO ()))
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ()) -> IO ())
-> ((LockUser -> IO (LockUser, IO ())) -> IO (IO ()))
-> (LockUser -> IO (LockUser, IO ()))
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar LockUser -> (LockUser -> IO (LockUser, IO ())) -> IO (IO ())
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar LockUser
rwlVar ((LockUser -> IO (LockUser, IO ())) -> IO ())
-> (LockUser -> IO (LockUser, IO ())) -> IO ()
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 = (MVar a -> IO a
forall a. MVar a -> IO a
takeMVar MVar a
mblock) IO a -> IO (Either RWLockException ()) -> IO a
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 ->
(LockUser, IO ()) -> IO (LockUser, IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return ( Writer :: ThreadId -> Int -> Int -> LockQ -> LockUser
Writer { writerID :: ThreadId
writerID=ThreadId
me, writerCount :: Int
writerCount=Int
1, readerCount :: Int
readerCount=Int
0, queue :: LockQ
queue=LockQ
forall a. Seq a
Seq.empty }
, () -> IO ()
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
itThreadId -> ThreadId -> Bool
forall a. Eq a => a -> a -> Bool
==ThreadId
me ->
(LockUser, IO ()) -> IO (LockUser, IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return ( LockUser
w { writerCount :: Int
writerCount=(Int -> Int
forall a. Enum a => a -> a
succ Int
wc) }
, () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return () )
| Bool
otherwise -> do
MVar ()
mblock <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
LockQ
q' <- LockQ -> IO LockQ
forall a. a -> IO a
evaluate (LockQ -> IO LockQ) -> LockQ -> IO LockQ
forall a b. (a -> b) -> a -> b
$ LockQ
q LockQ -> (LockKind, MVar ()) -> LockQ
forall a. Seq a -> a -> Seq a
|> (ThreadId -> LockKind
WriterKind ThreadId
me,MVar ()
mblock)
(LockUser, IO ()) -> IO (LockUser, IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return ( LockUser
w { queue :: LockQ
queue=LockQ
q' }
, MVar () -> IO ()
forall a. MVar a -> IO a
safeBlock MVar ()
mblock )
Readers { readerCounts :: LockUser -> TMap
readerCounts=TMap
rcs } | Just Int
rc <- ThreadId -> TMap -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ThreadId
me TMap
rcs -> do
(LockUser, IO ()) -> IO (LockUser, IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return ( LockUser
rwd
, Int -> IO () -> IO ()
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 <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
let qr :: Maybe ((ThreadId, MVar ()), Seq a)
qr = ((ThreadId, MVar ()), Seq a) -> Maybe ((ThreadId, MVar ()), Seq a)
forall a. a -> Maybe a
Just ((ThreadId
me,MVar ()
mblock),Seq a
forall a. Seq a
Seq.empty)
(LockUser, IO ()) -> IO (LockUser, IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return ( LockUser
r { queueR :: Maybe ((ThreadId, MVar ()), LockQ)
queueR=Maybe ((ThreadId, MVar ()), LockQ)
forall a. Maybe ((ThreadId, MVar ()), Seq a)
qr }
, MVar () -> IO ()
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 <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
LockQ
q' <- LockQ -> IO LockQ
forall a. a -> IO a
evaluate (LockQ -> IO LockQ) -> LockQ -> IO LockQ
forall a b. (a -> b) -> a -> b
$ LockQ
q LockQ -> (LockKind, MVar ()) -> LockQ
forall a. Seq a -> a -> Seq a
|> (ThreadId -> LockKind
WriterKind ThreadId
me,MVar ()
mblock)
(LockUser, IO ()) -> IO (LockUser, IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return ( LockUser
r { queueR :: Maybe ((ThreadId, MVar ()), LockQ)
queueR=((ThreadId, MVar ()), LockQ) -> Maybe ((ThreadId, MVar ()), LockQ)
forall a. a -> Maybe a
Just ((ThreadId, MVar ())
w,LockQ
q') }
, MVar () -> IO ()
forall a. MVar a -> IO a
safeBlock MVar ()
mblock )
where
withoutReads :: Int -> IO a -> IO a
withoutReads :: Int -> IO a -> IO a
withoutReads Int
n IO a
x = ((IO a -> IO a) -> (IO a -> IO a) -> IO a -> IO a)
-> (IO a -> IO a) -> [IO a -> IO a] -> IO a -> IO a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (IO a -> IO a) -> (IO a -> IO a) -> IO a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) IO a -> IO a
forall a. a -> a
id (Int -> (IO a -> IO a) -> [IO a -> IO a]
forall a. Int -> a -> [a]
replicate Int
n IO a -> IO a
forall a. IO a -> IO a
withoutRead) (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ IO a
x
withoutRead :: IO a -> IO a
withoutRead :: IO a -> IO a
withoutRead = IO () -> IO () -> IO a -> IO a
forall a b c. IO a -> IO b -> IO c -> IO c
bracket_ (RWLock -> IO (Either RWLockException ())
releaseRead RWLock
rwl IO (Either RWLockException ())
-> (Either RWLockException () -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (RWLockException -> IO ())
-> (() -> IO ()) -> Either RWLockException () -> IO ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either RWLockException -> IO ()
forall a e. Exception e => e -> a
throw () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return) (RWLock -> IO ()
acquireReadPriority RWLock
rwl)
imp :: Show x => String -> x -> String
imp :: String -> x -> String
imp String
s x
x = String
"FairRWLock impossible error: "String -> ShowS
forall a. [a] -> [a] -> [a]
++String
sString -> ShowS
forall a. [a] -> [a] -> [a]
++String
" : "String -> ShowS
forall a. [a] -> [a] -> [a]
++x -> String
forall a. Show a => a -> String
show x
x