{-# LANGUAGE DeriveDataTypeable, PatternGuards #-}
{-| Provides a fair RWLock, similar to one from Java, which is itself documented at
 <http://download.oracle.com/javase/7/docs/api/java/util/concurrent/locks/ReentrantReadWriteLock.html>

 There are complicated policy choices that have to be made.  The policy choices here are different
from the ones for the RWLock in concurrent-extras.

 The 'FairRWLock' may be in a free unlocked state, it may be in a read locked state, or it may be a
write locked state.  Many running threads may hold the read lock and execute concurrently.  Only one
running thread may hold the write lock.  The scheduling is a fair FIFO queue that avoids starvation.

 When in the read lock state the first 'acquireWrite' will block, and subsequent 'acquireRead' and
'acquireWrite' will queue in order.  When in the write locked state all other threads trying to
'acquireWrite' or 'acquireRead' will queue in order.

 'FairRWLock' allows recursive write locks, and it allows recursive read locks, and it allows the
write lock holding thread to acquire read locks.  When the current writer also holds read locks and
then releases its last write lock it will immediately convert to the read locked state (and other
waiting readers may join it).  When a reader acquires a write lock it will (1) release all its read
locks, (2) wait to acquire the write lock, (3) retake the same number of read locks released in (1).

 The preferred way to use this API is sticking to 'new', 'withRead', and 'withWrite'.

 No sequence of calling acquire on a single RWLock should lead to deadlock.  Exceptions, espcially
from 'killThread', do not break 'withRead' or 'withWrite'.  The 'withRead' and 'withWrite' ensure
all locks get released when exiting due to an exception.

 The readers and writers are always identified by their 'ThreadId'.  Each thread that calls
'acquireRead' must later call 'releaseRead' from the same thread.  Each thread that calls
'acquireWrite' must later call 'releaseWrite' from the same thread. The main way to misuse a
FairRWLock is to call a release without having called an acquire.  This is reported in the (Left
error) outcomes from 'releaseRead' and 'releaseWrite'.  Only if the 'FairRWLock' has a bug and finds
itself in an impossible state then it will throw an error.

-}
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)

-- Try to make most impossible data states unrepresentable
type TMap = Map ThreadId Int -- nonempty, all values > 0
type TSet = Set ThreadId     -- nonempty

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)

-- LockQ may be empty
-- No duplicate ThreadIds in LockKinds
-- MVar () will be created empty, released once with putMVar
type LockQ = Seq (LockKind,MVar ())

data LockUser = 
    FreeLock
  | Readers { LockUser -> TMap
readerCounts :: TMap -- re-entrant count of reader locks held be each thread
            , LockUser -> Maybe ((ThreadId, MVar ()), LockQ)
queueR :: Maybe ( (ThreadId,MVar ())    -- empty or queue with leading Writer
                              , LockQ )
            }
  | Writer { LockUser -> ThreadId
writerID :: ThreadId
           , LockUser -> Int
writerCount           -- re-entrant writer locks held by writerID, at least 1
           , LockUser -> Int
readerCount :: !Int   -- re-entrant reader locks held by writerID, at least 0
           , 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)


-- | Opaque type of the fair RWLock.
newtype RWLock = RWL (MVar LockUser)

-- | Exception type thrown or returned by this module.  \"Impossible\" conditions get the error thrown
--  and usage problems get the error returned.
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)

-- | Operation in which error arose, 
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

-- | Observable state of holder(s) of lock(s).  The W returns a pair of Ints where the first is number of
-- read locks (at least 0) and the second is the number of write locks held (at least 1).  The R
-- returns a map from thread id to the number of read locks held (at least 1).
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)

-- | Create a new RWLock which starts in a free and unlocked state.
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)

-- | This is by far the preferred way to acquire a read lock.  This uses bracket_ to ensure
-- acquireRead and releaseRead are called correctly around the passed command.
--
-- This ought to ensure releaseRead will not return a (Left error), but if it does then this error
-- will be thrown.
--
-- This can block and be safely interrupted.
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)

-- | This is by far the preferred way to acquire a write lock.  This uses bracket_ to ensure
-- acquireWrite and releaseWrite are called correctly around the passed command.
--
-- This ought to ensure releaseWrite will not return a (Left error), but if it does then this error
-- will be thrown.
--
-- This can block and be safely interrupted.
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)

-- | Observe which threads are holding the lock and which threads are waiting (in order).  This is
-- particularly useful for writing tests.
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))

-- | checkLocks return a pair of numbers, the first is the count of read locks this thread holds,
-- the second is the number of write locks that this thread holds.  This may be useful for sanity
-- checking complex usage of RWLocks.
--
-- This may block and be safely interrupted.
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)

-- | A thread that calls acquireRead must later call releaseRead once for each call to acquireRead.
--
-- If this thread has not previous called acquireRead then releaseRead will do nothing and return a
-- (Left error).
--
-- This can block but cannot be interrupted.
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 -- False to indicate call is from releaseRead

-- The (abandon :: Bool) is False if called from releaseRead (from user API).
-- The (abandon :: Bool) is True if called as handler when acquireRead[Priority] interrupted by exception (internal use).
-- 
-- There are 14 cases.
-- Four ERROR cases from misuse of releaseRead, Three IMPOSSIBLE cases (from interruptions), Seven normal cases:
-- Lock is Free, ERROR if releaseRead or IMPOSSIBLE if interrupted -- 1 and 2
-- I have write lock, I have no read lock, ERROR if releaseRead or IMPOSSIBLE if interrupted -- 3 and 4
--                  , I have at least one read lock, just decrement the counter  -- 5
-- Someone else has write lock, abandoning my acquireWrite  -- 6
--                            , releaseRead called in ERROR -- 7
-- Read lock held, I have 1 read lock, no other readers, change to FreeLock -- 8
--                                                     , change to next Writer -- 9
--                                   , remove and leave to other readers -- 10
--               , I have more than one read lock, just decrement the counter -- 11
--               , I have no read lock, abandoning with no queue is IMPOSSIBLE  -- 12
--                                    , abandoning from queue past next writer  -- 13
--                                    , releaseRead called in ERROR -- 14
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 ())

      -- if there is a bug then dropReader may find an impossible situation when abandoning a thread, and throw an error
      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) -- safe unRK call
            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 -> {- 1 -}
      forall x a. Show x => String -> x -> IO a
impossible String
"acquireRead interrupted with unlocked RWLock" ThreadId
me

             | Bool
otherwise -> {- 2 -}
      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 -> {- 3 -}
              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 -> {- 4 -}
              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 {- 5 -}
          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' })

    {-ditto-}                                           | Bool
abandon -> do {- 6 -}
      LockQ
q' <- LockQ -> IO LockQ
dropReader LockQ
q
      LockUser -> IO (LockUser, Either RWLockException ())
ret (LockUser
w { queue :: LockQ
queue=LockQ
q' })

    {-ditto-}                                           | Bool
otherwise -> {- 7 -}
      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 -> {- 8 -}
                     LockUser -> IO (LockUser, Either RWLockException ())
ret LockUser
FreeLock

                   Just ((ThreadId
wid,MVar ()
mblock),LockQ
q) -> do {- 9 -}
                     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' }) {- 10 -}

        Just Int
rc -> do {- 11 -}
          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 -> {- 12 -}
              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) -> {- 13 -} 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') })

        {-ditto-} | Bool
otherwise -> {- 14 -}
          forall x.
Show x =>
String -> x -> IO (LockUser, Either RWLockException ())
err String
"releaseRead called with read lock held by others" (ThreadId
me,TMap
rcs)

-- | A thread that calls acquireWrite must later call releaseWrite once for each call to acquireWrite.
--
-- If this thread has not previous called acquireWrite then releaseWrite will do nothing and return
-- a (Left error).
--
-- This can block but cannot be interrupted.
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  -- False to indicate call is from releaseWrite

-- Nine non-impossible cases, plus one impossible case
-- Lock is Free
-- I have write lock, I only had 1 write lock and no read locks, promote from LockQ
--                  , I only had 1 write lock and some read locks, convert me to reader and promote leading readers
--                  , I have many write locks, just decrement the counter
-- Someone else has write lock, abandoning my acquireWrite
--                            , releaseWrite called in error
-- Read lock held, releaseWrite called in error
--               , with no queue, abandoning acquireWrite is IMPOSSIBLE
--               , abandoning my leading acquireWrite
--               , abandoning my non-leading acquireWrite
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  -- if abandon then this is the only valid case
        (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) })

    {-ditto-}                                                          | Bool
abandon -> do
      LockQ
q' <- LockQ -> IO LockQ
dropWriter LockQ
q
      LockUser -> IO (LockUser, Either RWLockException ())
ret (LockUser
w { queue :: LockQ
queue=LockQ
q' })

    {-ditto-}                                                          | 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 })

    {- ditto -}                                                | 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
  -- | promote when converting from write lock straight to read lock
  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 from releasing write lock
  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 })

  -- | Merge (and wake) any and all readers on left end of LockQ, and return queueR value
  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) -- unWK safe
    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

-- Six cases below:
-- Lock is Free
-- I already have write lock
-- Someone else has write lock, leads to mblock
-- I alread have read lock
-- Someone else has read lock, no pending write lock
-- Someone else has read lock, there is a pending write lock, leads to mblock

-- | Any thread may call acquireRead (even ones holding write locks).  This read lock may be
-- acquired multiple times, requiring an identical number of releaseRead calls.
--
-- All previous calls to acquireWrite by other threads will have succeeded and been released (or
-- interrupted) before this acquireRead will return.
--
-- The best way to use acquireRead is to use withRead instead to ensure releaseRead will be called
-- exactly once.
--
-- This may block and be safely interrupted.  If interrupted then the RWLock will be left unchanged.
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 () )

    {- ditto -}                                         | 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
  -- Merge adjacent readers when adding to right end of LockQ
  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
    -- Paranoid check of design assertion, TODO: remove check
    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)

-- Five cases.
-- This is not exported.  This has uninterruptibleMask_.  It is used to restore read locks released
-- during acquireWrite when acquireWrite is called while holding read locks.  If this acquireWrite
-- upgrade is going well then this thread holds the Writer lock and acquireReadPriority is identical
-- to acquireRead.  If this acquireWrite gets interrupted then acquireReadPriority will to obtain
-- the read lock or put itself at the front of the queue if another thread holds the write lock.
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
  -- Merge adjacent readers when adding to right end of LockQ
  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
    -- Paranoid check of design assertion, TODO: remove check
    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)

-- Six cases below:
-- Lock is Free
-- I already have write lock
-- Someone else has write lock, leads to waiting
-- I already have read lock
-- Someone else has read lock, there is no pending write lock, wait
-- Someone else has read lock, there is a pending write lock, wait

-- | Any thread may call acquireWrite (even ones holding read locks, but see below for interrupted
-- behavior).  This write lock may be acquired multiple times, requiring an identical number of
-- releaseWrite calls.
--
-- All previous calls to acquireRead by other threads will have succeeded and been released (or
-- interrupted) before this acquireWrite will return.
--
-- The best way to use acquireWrite is to use withWrite instead to ensure releaseWrite will be
-- called exactly once.
--
-- This may block and usually be safely interrupted.  If interrupted then the RWLock will be left
-- unchanged.  The exception to being able to interrupted when this blocks is very subtle: if this
-- thread holds read locks and calls acquireWrite then it will release those read locks and go to
-- the back of the queue to acquire the write lock (it does not get to skip the queue).  While
-- blocking waiting for the write lock to be available this thread may be interrupted.  If not
-- interrupted then the write lock will eventually be acquired, followed by re-acquiring the
-- original number of read locks.  But if acquireWrite is interrupted after releasing read locks
-- then it MUST restore those read locks on the way out.  To do this the internal error handler will
-- use 'uninterruptibleMask_' and a special version of acquireRead that skips to the front of the
-- queue; when the current lock state is a reader this works instantly but when the current lock
-- state is a writer this thread will block in an UNINTERRUPTIBLE state until the current writer is
-- finished.  Once this other writer is finished the error handler will obtain the read locks it
-- needs to allow the error propagation to continue.
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 () )

    {-ditto-}                                           | 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)

-- format impossible error strings to include standard description prefix
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

{-

subtle bug #1:

When converting from a read lock holding rc > 0 read locks to also holding a write lock, I first wrote:

replicateM_ rc (releaseRead rwl >>= either throw return)
acquireWrite rwl
replicateM_ rc (acquireRead rwl)

Imagine there are rc copies of withRead wrapped around the above:
withRead = liftA2 bracket_ acquireRead (releaseRead >=> either throw return)

Then the acquireWrite blocks and gets interrupted.
The releaseReads in the withRead will see a strange situation (not locked!) and call throw.

What is the answer? reverse the bracket for the release/acquire? Hmm..

-}