barrucadu/dejafu
1
1
Fork 0
mirror of https://github.com/barrucadu/dejafu.git synced 2024-11-26 09:20:36 +03:00
Code Issues Projects Releases Wiki Activity

Merge pull request #289 from dfinity-lab/gip/boundedchan_locks

Browse Source 
BoundedChan and locks primitives
This commit is contained in:
Michael Walker 2018-11-28 18:58:03 +00:00 committed by GitHub
commit 88278ca471
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
5 changed files with 818 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
concurrency/Control/Concurrent/Classy.hs
View File

@ -24,19 +24,25 @@
module Control.Concurrent.Classy
( module Control.Monad.Conc.Class
, module Control.Concurrent.Classy.Chan
, module Control.Concurrent.Classy.BoundedChan
, module Control.Concurrent.Classy.CRef
, module Control.Concurrent.Classy.IORef
, module Control.Concurrent.Classy.MVar
, module Control.Concurrent.Classy.STM
, module Control.Concurrent.Classy.QSem
, module Control.Concurrent.Classy.QSemN
, module Control.Concurrent.Classy.Lock
, module Control.Concurrent.Classy.RWLock
) where
import Control.Concurrent.Classy.BoundedChan
import Control.Concurrent.Classy.Chan
import Control.Concurrent.Classy.CRef
import Control.Concurrent.Classy.IORef
import Control.Concurrent.Classy.Lock
import Control.Concurrent.Classy.MVar
import Control.Concurrent.Classy.QSem
import Control.Concurrent.Classy.QSemN
import Control.Concurrent.Classy.RWLock
import Control.Concurrent.Classy.STM
import Control.Monad.Conc.Class

207
concurrency/Control/Concurrent/Classy/BoundedChan.hs Normal file
View File

@ -0,0 +1,207 @@
--------------------------------------------------------------------------------
-- Copyright © 2009, Galois, Inc.
-- Copyright © 2018, DFINITY Stiftung
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions
-- are met:
--
-- * Redistributions of source code must retain the above copyright
-- notice, this list of conditions and the following disclaimer.
-- * Redistributions in binary form must reproduce the above copyright
-- notice, this list of conditions and the following disclaimer in
-- the documentation and/or other materials provided with the
-- distribution.
-- * Neither the name of the Galois, Inc. nor the names of its
-- contributors may be used to endorse or promote products derived
-- from this software without specific prior written permission.
--
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
-- FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-- COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
-- INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
-- BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
-- LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-- LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
-- POSSIBILITY OF SUCH DAMAGE.
--------------------------------------------------------------------------------
-- |
-- Module : Control.Concurrent.Classy.BoundedChan
-- Copyright : © 2009 Galois Inc.
-- , © 2018 DFINITY Stiftung
-- Maintainer : DFINITY USA Research <team@dfinity.org>
--
-- Implements bounded channels. These channels differ from normal 'Chan's in
-- that they are guaranteed to contain no more than a certain number of
-- elements. This is ideal when you may be writing to a channel faster than
-- you are able to read from it.
--
-- This module supports all the functions of "Control.Concurrent.Chan" except
-- 'unGetChan' and 'dupChan', which are not supported for bounded channels.
--
-- Extra consistency: This version enforces that if thread Alice writes
-- e1 followed by e2 then e1 will be returned by readBoundedChan before e2.
-- Conversely, if thead Bob reads e1 followed by e2 then it was true that
-- writeBoundedChan e1 preceded writeBoundedChan e2.
--
-- Previous versions did not enforce this consistency: if writeBoundedChan were
-- preempted between putMVars or killThread arrived between putMVars then it
-- can fail. Similarly it might fail if readBoundedChan were stopped after putMVar
-- and before the second takeMVar. An unlucky pattern of several such deaths
-- might actually break the invariants of the array in an unrecoverable way
-- causing all future reads and writes to block.
--------------------------------------------------------------------------------
module Control.Concurrent.Classy.BoundedChan
( BoundedChan
, newBoundedChan
, writeBoundedChan
, trywriteBoundedChan
, readBoundedChan
, tryreadBoundedChan
, isEmptyBoundedChan
, writeList2BoundedChan
) where
--------------------------------------------------------------------------------
import Control.Monad (replicateM)
import Data.Array (Array, listArray, (!))
import qualified Control.Concurrent.Classy.MVar as MVar
import Control.Monad.Catch (mask_, onException)
import Control.Monad.Conc.Class (MonadConc(MVar))
--------------------------------------------------------------------------------
-- | A 'BoundedChan' is an abstract data type representing a bounded channel.
data BoundedChan m a
= BoundedChan
{ _size :: Int
, _contents :: Array Int (MVar m a)
, _writePos :: MVar m Int
, _readPos :: MVar m Int
}
deriving ()
-- TODO: check if the fields of BoundedChan could be strict / unpacked
--------------------------------------------------------------------------------
-- Versions of modifyMVar and withMVar that do not 'restore' the previous mask
-- state when running 'io', with added modification strictness.
-- The lack of 'restore' may make these perform better than the normal version.
-- Moving strictness here makes using them more pleasant.
{-# INLINE modifyMVarMask #-}
modifyMVarMask :: (MonadConc m) => MVar m a -> (a -> m (a, b)) -> m b
modifyMVarMask m callback = mask_ $ do
a <- MVar.takeMVar m
(a', b) <- callback a `onException` MVar.putMVar m a
MVar.putMVar m $! a'
pure b
{-# INLINE modifyMVarMask_ #-}
modifyMVarMask_ :: (MonadConc m) => MVar m a -> (a -> m a) -> m ()
modifyMVarMask_ m callback =
mask_ $ do
a <- MVar.takeMVar m
a' <- callback a `onException` MVar.putMVar m a
MVar.putMVar m $! a'
{-# INLINE withMVarMask #-}
withMVarMask :: (MonadConc m) => MVar m a -> (a -> m b) -> m b
withMVarMask m callback =
mask_ $ do
a <- MVar.takeMVar m
b <- callback a `onException` MVar.putMVar m a
MVar.putMVar m a
pure b
--------------------------------------------------------------------------------
-- |
-- @newBoundedChan n@ returns a channel than can contain no more than @n@
-- elements.
newBoundedChan :: (MonadConc m) => Int -> m (BoundedChan m a)
newBoundedChan x = do
entls <- replicateM x MVar.newEmptyMVar
wpos <- MVar.newMVar 0
rpos <- MVar.newMVar 0
let entries = listArray (0, x - 1) entls
pure (BoundedChan x entries wpos rpos)
-- |
-- Write an element to the channel. If the channel is full, this routine will
-- block until it is able to write. Blockers wait in a fair FIFO queue.
writeBoundedChan :: (MonadConc m) => BoundedChan m a -> a -> m ()
writeBoundedChan (BoundedChan size contents wposMV _) x =
modifyMVarMask_ wposMV $ \wpos -> do
MVar.putMVar (contents ! wpos) x
pure (succ wpos `mod` size) -- only advance when putMVar succeeds
-- |
-- A variant of 'writeBoundedChan' which, instead of blocking when the channel is
-- full, simply aborts and does not write the element. Note that this routine
-- can still block while waiting for write access to the channel.
trywriteBoundedChan :: (MonadConc m) => BoundedChan m a -> a -> m Bool
trywriteBoundedChan (BoundedChan size contents wposMV _) x =
modifyMVarMask wposMV $ \wpos -> do
success <- MVar.tryPutMVar (contents ! wpos) x
-- only advance when putMVar succeeds
let wpos' = if success then succ wpos `mod` size else wpos
pure (wpos', success)
-- |
-- Read an element from the channel. If the channel is empty, this routine
-- will block until it is able to read. Blockers wait in a fair FIFO queue.
readBoundedChan :: (MonadConc m) => BoundedChan m a -> m a
readBoundedChan (BoundedChan size contents _ rposMV) =
modifyMVarMask rposMV $ \rpos -> do
a <- MVar.takeMVar (contents ! rpos)
pure (succ rpos `mod` size, a) -- only advance when takeMVar succeeds
-- |
-- A variant of 'readBoundedChan' which, instead of blocking when the channel is
-- empty, immediately returns 'Nothing'. Otherwise, 'tryreadBoundedChan' returns
-- @'Just' a@ where @a@ is the element read from the channel. Note that this
-- routine can still block while waiting for read access to the channel.
tryreadBoundedChan :: (MonadConc m) => BoundedChan m a -> m (Maybe a)
tryreadBoundedChan (BoundedChan size contents _ rposMV) =
modifyMVarMask rposMV $ \rpos -> do
ma <- MVar.tryTakeMVar (contents ! rpos)
-- only advance when takeMVar succeeds
let rpos' = case ma of
Just _ -> succ rpos `mod` size
Nothing -> rpos
pure (rpos', ma)
-- |
-- Returns 'True' if the supplied channel is empty.
--
-- NOTE: This may block on an empty channel if there is a blocked reader.
-- NOTE: This function is deprecated.
{-# DEPRECATED isEmptyBoundedChan
"This isEmptyBoundedChan can block, no non-blocking substitute yet" #-}
isEmptyBoundedChan :: (MonadConc m) => BoundedChan m a -> m Bool
isEmptyBoundedChan (BoundedChan _ contents _ rposMV) =
withMVarMask rposMV $ \rpos ->
MVar.isEmptyMVar (contents ! rpos)
-- |
-- Write a list of elements to the channel.
-- If the channel becomes full, this routine will block until it can write.
-- Competing writers may interleave with this one.
writeList2BoundedChan :: (MonadConc m) => BoundedChan m a -> [a] -> m ()
writeList2BoundedChan = mapM_ . writeBoundedChan
--------------------------------------------------------------------------------

226
concurrency/Control/Concurrent/Classy/Lock.hs Normal file
View File

@ -0,0 +1,226 @@
--------------------------------------------------------------------------------
-- Copyright © 2010-2012 Bas van Dijk & Roel van Dijk
-- Copyright © 2018 DFINITY Stiftung
--
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions are
-- met:
--
-- * Redistributions of source code must retain the above copyright
-- notice, this list of conditions and the following disclaimer.
--
-- * Redistributions in binary form must reproduce the above
-- copyright notice, this list of conditions and the following
-- disclaimer in the documentation and/or other materials provided
-- with the distribution.
--
-- * The names of Bas van Dijk, Roel van Dijk and the names of
-- contributors may NOT be used to endorse or promote products
-- derived from this software without specific prior written
-- permission.
--
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-- A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-- OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-- LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-- DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-- THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-- (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
--------------------------------------------------------------------------------
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE UndecidableInstances #-}
--------------------------------------------------------------------------------
-- |
-- Module : Control.Concurrent.Classy.Lock
-- Copyright : © 2010-2011 Bas van Dijk & Roel van Dijk
-- , © 2018 DFINITY Stiftung
-- Maintainer : DFINITY USA Research <team@dfinity.org>
--
-- This module provides the 'Lock' synchronisation mechanism. It was inspired by
-- the Python and Java @Lock@ objects and should behave in a similar way. See:
--
-- <http://docs.python.org/3.1/library/threading.html#lock-objects>
--
-- and:
--
-- <http://java.sun.com/javase/7/docs/api/java/util/concurrent/locks/Lock.html>
--
-- All functions are /exception safe/. Throwing asynchronous exceptions will not
-- compromise the internal state of a 'Lock'.
--------------------------------------------------------------------------------
module Control.Concurrent.Classy.Lock
( -- * @Lock@
Lock
-- * Creating locks
, newLock
, newAcquired
-- * Locking and unlocking
, acquire
, tryAcquire
, release
-- * Convenience functions
, with
, tryWith
, wait
-- * Querying locks
, locked
) where
--------------------------------------------------------------------------------
import Control.Applicative (pure, (<*>))
import Control.Monad (when)
import Data.Bool (Bool, not)
import Data.Eq (Eq((==)))
import Data.Function (($), (.))
import Data.Functor (fmap, (<$>))
import Data.Maybe (Maybe(Just, Nothing), isJust)
import Data.Typeable (Typeable)
import Prelude (error)
import qualified Control.Concurrent.Classy.MVar as MVar
import Control.Monad.Catch (bracket_, mask, onException)
import Control.Monad.Conc.Class (MonadConc(MVar))
--------------------------------------------------------------------------------
-- | A lock is in one of two states: \"locked\" or \"unlocked\".
newtype Lock m
= Lock
{ _fromLock :: MVar m ()
}
deriving (Typeable)
instance (Eq (MVar m ())) => Eq (Lock m) where
(==) (Lock a) (Lock b) = a == b
--------------------------------------------------------------------------------
-- | Create a lock in the \"unlocked\" state.
newLock :: (MonadConc m) => m (Lock m)
newLock = Lock <$> MVar.newMVar ()
-- | Create a lock in the \"locked\" state.
newAcquired :: (MonadConc m) => m (Lock m)
newAcquired = Lock <$> MVar.newEmptyMVar
--------------------------------------------------------------------------------
-- |
-- Acquires the 'Lock'. Blocks if another thread has acquired the 'Lock'.
--
-- @acquire@ behaves as follows:
--
-- * When the state is \"unlocked\" @acquire@ changes the state to \"locked\".
--
-- * When the state is \"locked\" @acquire@ /blocks/ until a call to 'release'
-- in another thread wakes the calling thread. Upon awakening it will change
-- the state to \"locked\".
--
-- There are two further important properties of @acquire@:
--
-- * @acquire@ is single-wakeup. That is, if there are multiple threads blocked
-- on @acquire@ and the lock is released, only one thread will be woken up.
-- The runtime guarantees that the woken thread completes its @acquire@
-- operation.
--
-- * When multiple threads are blocked on @acquire@, they are woken up in FIFO
-- order. This is useful for providing fairness properties of abstractions
-- built using locks. Note that this differs from the Python implementation
-- where the wake-up order is undefined.
acquire :: (MonadConc m) => Lock m -> m ()
acquire = MVar.takeMVar . _fromLock
-- |
-- A non-blocking 'acquire'.
--
-- * When the state is \"unlocked\" @tryAcquire@ changes the state to \"locked\"
-- and returns 'True'.
--
-- * When the state is \"locked\" @tryAcquire@ leaves the state unchanged and
-- returns 'False'.
tryAcquire :: (MonadConc m) => Lock m -> m Bool
tryAcquire = fmap isJust . MVar.tryTakeMVar . _fromLock
-- |
-- @release@ changes the state to \"unlocked\" and returns immediately.
--
-- Note that it is an error to release a lock in the \"unlocked\" state!
--
-- If there are any threads blocked on 'acquire' the thread that first called
-- @acquire@ will be woken up.
release :: (MonadConc m) => Lock m -> m ()
release (Lock mv) = do
b <- MVar.tryPutMVar mv ()
when (not b) $
error "Control.Concurrent.Classy.Lock.release: cannot release an unlocked Lock!"
--------------------------------------------------------------------------------
-- |
-- A convenience function which first acquires the lock and then performs the
-- computation. When the computation terminates, whether normally or by raising an
-- exception, the lock is released.
--
-- Note that: @with = 'bracket_' '<$>' 'acquire' '<*>' 'release'@.
with :: (MonadConc m) => Lock m -> m a -> m a
with = bracket_ <$> acquire <*> release
-- |
-- A non-blocking 'with'. @tryWith@ is a convenience function which first tries
-- to acquire the lock. If that fails, 'Nothing' is returned. If it succeeds,
-- the computation is performed. When the computation terminates, whether
-- normally or by raising an exception, the lock is released and 'Just' the
-- result of the computation is returned.
tryWith :: (MonadConc m) => Lock m -> m a -> m (Maybe a)
tryWith l a = mask $ \restore -> do
acquired <- tryAcquire l
if acquired
then do r <- restore a `onException` release l
release l
pure (Just r)
else pure Nothing
-- |
-- * When the state is \"locked\", @wait@ /blocks/ until a call to 'release'
-- in another thread changes it to \"unlocked\".
--
-- * @wait@ is multiple-wakeup, so when multiple waiters are blocked on
-- a @Lock@, all of them are woken up at the same time.
--
-- * When the state is \"unlocked\" @wait@ returns immediately.
--
-- @wait@ does not alter the state of the lock.
wait :: (MonadConc m) => Lock m -> m ()
wait (Lock mv) = MVar.readMVar mv
--------------------------------------------------------------------------------
-- |
-- Determines if the lock is in the \"locked\" state.
--
-- Note that this is only a snapshot of the state. By the time a program reacts
-- on its result it may already be out of date.
locked :: (MonadConc m) => Lock m -> m Bool
locked = MVar.isEmptyMVar . _fromLock
--------------------------------------------------------------------------------

376
concurrency/Control/Concurrent/Classy/RWLock.hs Normal file
View File

@ -0,0 +1,376 @@
--------------------------------------------------------------------------------
-- Copyright © 2010-2012 Bas van Dijk & Roel van Dijk
-- Copyright © 2018 DFINITY Stiftung
--
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions are
-- met:
--
-- * Redistributions of source code must retain the above copyright
-- notice, this list of conditions and the following disclaimer.
--
-- * Redistributions in binary form must reproduce the above
-- copyright notice, this list of conditions and the following
-- disclaimer in the documentation and/or other materials provided
-- with the distribution.
--
-- * The names of Bas van Dijk, Roel van Dijk and the names of
-- contributors may NOT be used to endorse or promote products
-- derived from this software without specific prior written
-- permission.
--
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-- A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-- OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-- LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-- DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-- THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-- (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-------------------------------------------------------------------------------
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE UndecidableInstances #-}
-------------------------------------------------------------------------------
-- |
-- Module : Control.Concurrent.Classy.RWLock
-- Copyright : © 2010-2011 Bas van Dijk & Roel van Dijk
-- , © 2018 DFINITY Stiftung
-- Maintainer : DFINITY USA Research <team@dfinity.org>
--
-- Multiple-reader, single-writer locks. Used to protect shared resources which
-- may be concurrently read, but only sequentially written.
--
-- All functions are /exception safe/. Throwing asynchronous exceptions will not
-- compromise the internal state of an 'RWLock'. This means it is perfectly safe
-- to kill a thread that is blocking on, for example, 'acquireRead'.
-------------------------------------------------------------------------------
module Control.Concurrent.Classy.RWLock
( -- * @RWLock@
RWLock
-- * Creating locks
, newRWLock
, newAcquiredRead
, newAcquiredWrite
-- * Read access
-- ** Blocking
, acquireRead
, releaseRead
, withRead
, waitRead
-- ** Non-blocking
, tryAcquireRead
, tryWithRead
-- * Write access
-- ** Blocking
, acquireWrite
, releaseWrite
, withWrite
, waitWrite
-- ** Non-blocking
, tryAcquireWrite
, tryWithWrite
) where
-------------------------------------------------------------------------------
import Control.Applicative (pure, (<*>))
import Control.Monad (Monad, (>>))
import Data.Bool (Bool(False, True))
import Data.Eq (Eq, (==))
import Data.Function (on, ($))
import Data.Functor ((<$>))
import Data.Int (Int)
import Data.List ((++))
import Data.Maybe (Maybe(Just, Nothing))
import Data.Ord (Ord)
import Data.Typeable (Typeable)
import Prelude (String, error, pred, succ)
import Text.Read (Read)
import Text.Show (Show)
import qualified Control.Concurrent.Classy.MVar as MVar
import Control.Monad.Catch (bracket_, mask, mask_,
onException)
import Control.Monad.Conc.Class (MonadConc(MVar))
import Control.Concurrent.Classy.Lock (Lock)
import qualified Control.Concurrent.Classy.Lock as Lock
-------------------------------------------------------------------------------
-- |
-- Multiple-reader, single-writer lock. Is in one of three states:
--
-- * \"Free\": Read or write access can be acquired without blocking.
--
-- * \"Read\": One or more threads have acquired read access.
-- Blocks write access.
--
-- * \"Write\": A single thread has acquired write access.
-- Blocks other threads from acquiring both read and write access.
data RWLock m
= RWLock
{ _state :: MVar m State
, _readLock :: Lock m
, _writeLock :: Lock m
}
deriving (Typeable)
-- TODO: could the fields of RWLock be strict / unpacked?
instance (Eq (MVar m State)) => Eq (RWLock m) where
(==) = (==) `on` _state
-------------------------------------------------------------------------------
-- |
-- Internal state of the 'RWLock'.
data State
= Free
| Read !Int
| Write
deriving (Eq, Ord, Show, Read)
-------------------------------------------------------------------------------
-- |
-- Create a new 'RWLock' in the \"free\" state; either read or write access
-- can be acquired without blocking.
newRWLock :: (MonadConc m) => m (RWLock m)
newRWLock = do
state <- MVar.newMVar Free
rlock <- Lock.newLock
RWLock state rlock <$> Lock.newLock
-- |
-- Create a new 'RWLock' in the \"read\" state; only read can be acquired
-- without blocking.
newAcquiredRead :: (MonadConc m) => m (RWLock m)
newAcquiredRead = do
state <- MVar.newMVar (Read 1)
rlock <- Lock.newAcquired
RWLock state rlock <$> Lock.newLock
-- |
-- Create a new 'RWLock' in the \"write\" state; either acquiring read or
-- write will block.
newAcquiredWrite :: (MonadConc m) => m (RWLock m)
newAcquiredWrite = do
state <- MVar.newMVar Write
rlock <- Lock.newLock
RWLock state rlock <$> Lock.newAcquired
-------------------------------------------------------------------------------
-- |
-- Acquire the read lock.
--
-- Blocks if another thread has acquired write access.
-- If @acquireRead@ terminates without throwing an exception the state of
-- the 'RWLock' will be \"read\".
--
-- Implementation note: throws an exception when more than @'maxBound' :: 'Int'@
-- simultaneous threads acquire the read lock. But that is unlikely.
acquireRead :: (MonadConc m) => RWLock m -> m ()
acquireRead RWLock { _state, _readLock, _writeLock } = mask_ go
where
go = do
st <- MVar.takeMVar _state
case st of
Free -> do Lock.acquire _readLock
MVar.putMVar _state $ Read 1
(Read n) -> MVar.putMVar _state $ Read (succ n)
Write -> do MVar.putMVar _state st
Lock.wait _writeLock
go
-- |
-- Try to acquire the read lock; non blocking.
--
-- Like 'acquireRead', but doesn't block. Returns 'True' if the resulting
-- state is \"read\", 'False' otherwise.
tryAcquireRead :: (MonadConc m) => RWLock m -> m Bool
tryAcquireRead RWLock { _state, _readLock } = mask_ $ do
st <- MVar.takeMVar _state
case st of
Free -> do Lock.acquire _readLock
MVar.putMVar _state $ Read 1
pure True
Read n -> do MVar.putMVar _state $ Read (succ n)
pure True
Write -> do MVar.putMVar _state st
pure False
-- |
-- Release the read lock.
--
-- If the calling thread was the last one to relinquish read access the state
-- will revert to \"free\".
--
-- It is an error to release read access to an 'RWLock' which is not in
-- the \"read\" state.
releaseRead :: (MonadConc m) => RWLock m -> m ()
releaseRead RWLock { _state, _readLock } = mask_ $ do
st <- MVar.takeMVar _state
case st of
Read 1 -> do Lock.release _readLock
MVar.putMVar _state Free
Read n -> MVar.putMVar _state $ Read (pred n)
_ -> do MVar.putMVar _state st
throw "releaseRead" "already released"
-- |
-- A convenience function wich first acquires read access and then performs the
-- computation. When the computation terminates, whether normally or by raising
-- an exception, the read lock is released.
withRead :: (MonadConc m) => RWLock m -> m a -> m a
withRead = bracket_ <$> acquireRead <*> releaseRead
-- |
-- A non-blocking 'withRead'. First tries to acquire the lock. If that fails,
-- 'Nothing' is returned. If it succeeds, the computation is performed.
-- When the computation terminates, whether normally or by raising an exception,
-- the lock is released and 'Just' the result of the computation is returned.
tryWithRead :: (MonadConc m) => RWLock m -> m a -> m (Maybe a)
tryWithRead l a = mask $ \restore -> do
acquired <- tryAcquireRead l
if acquired
then do r <- restore a `onException` releaseRead l
releaseRead l
pure $ Just r
else pure Nothing
-- |
-- * When the state is \"write\", @waitRead@ /blocks/ until a call to
-- 'releaseWrite' in another thread changes the state to \"free\".
--
-- * When the state is \"free\" or \"read\" @waitRead@ returns immediately.
--
-- @waitRead@ does not alter the state of the lock.
--
-- Note that @waitRead@ is just a convenience function defined as:
--
-- @waitRead l = 'mask_' '$' 'acquireRead' l '>>' 'releaseRead' l@
waitRead :: (MonadConc m) => RWLock m -> m ()
waitRead l = mask_ (acquireRead l >> releaseRead l)
-------------------------------------------------------------------------------
-- |
-- Acquire the write lock.
--
-- Blocks if another thread has acquired either read or write access.
-- If @acquireWrite@ terminates without throwing an exception the state of
-- the 'RWLock' will be \"write\".
acquireWrite :: (MonadConc m) => RWLock m -> m ()
acquireWrite RWLock { _state, _readLock, _writeLock } = mask_ go'
where
go' = do
st <- MVar.takeMVar _state
case st of
Free -> do Lock.acquire _writeLock
MVar.putMVar _state Write
Read _ -> do MVar.putMVar _state st
Lock.wait _readLock
go'
Write -> do MVar.putMVar _state st
Lock.wait _writeLock
go'
-- |
-- Try to acquire the write lock; non blocking.
--
-- Like 'acquireWrite', but doesn't block.
-- Returns 'True' if the resulting state is \"write\", 'False' otherwise.
tryAcquireWrite :: (MonadConc m) => RWLock m -> m Bool
tryAcquireWrite RWLock { _state, _writeLock } = mask_ $ do
st <- MVar.takeMVar _state
case st of
Free -> do Lock.acquire _writeLock
MVar.putMVar _state Write
pure True
_ -> do MVar.putMVar _state st
pure False
-- |
-- Release the write lock.
--
-- If @releaseWrite@ terminates without throwing an exception the state
-- will be \"free\".
--
-- It is an error to release write access to an 'RWLock' which is not
-- in the \"write\" state.
releaseWrite :: (MonadConc m) => RWLock m -> m ()
releaseWrite RWLock { _state, _writeLock } = mask_ $ do
st <- MVar.takeMVar _state
case st of
Write -> do Lock.release _writeLock
MVar.putMVar _state Free
_ -> do MVar.putMVar _state st
throw "releaseWrite" "already released"
-- |
-- A convenience function wich first acquires write access and then performs
-- the computation. When the computation terminates, whether normally or by
-- raising an exception, the write lock is released.
withWrite :: (MonadConc m) => RWLock m -> m a -> m a
withWrite = bracket_ <$> acquireWrite <*> releaseWrite
-- |
-- A non-blocking 'withWrite'. First tries to acquire the lock. If that fails,
-- 'Nothing' is returned. If it succeeds, the computation is performed.
-- When the computation terminates, whether normally or by raising an exception,
-- the lock is released and 'Just' the result of the computation is returned.
tryWithWrite :: (MonadConc m) => RWLock m -> m a -> m (Maybe a)
tryWithWrite l a = mask $ \restore -> do
acquired <- tryAcquireWrite l
if acquired
then do r <- restore a `onException` releaseWrite l
releaseWrite l
pure $ Just r
else pure Nothing
-- |
-- * When the state is \"write\" or \"read\" @waitWrite@ /blocks/ until a call
-- to 'releaseWrite' or 'releaseRead' in another thread changes the state
-- to \"free\".
--
-- * When the state is \"free\" @waitWrite@ returns immediately.
--
-- @waitWrite@ does not alter the state of the lock.
--
-- Note that @waitWrite@ is just a convenience function defined as:
--
-- @waitWrite l = 'mask_' '$' 'acquireWrite' l '>>' 'releaseWrite' l@
waitWrite :: (MonadConc m) => RWLock m -> m ()
waitWrite l = mask_ (acquireWrite l >> releaseWrite l)
--------------------------------------------------------------------------------
throw :: (Monad m) => String -> String -> m a
throw func msg
= error ("Control.Concurrent.Classy.RWLock." ++ func ++ ": " ++ msg)
--------------------------------------------------------------------------------

3
concurrency/concurrency.cabal
View File

@ -41,11 +41,14 @@ library
, Control.Concurrent.Classy
, Control.Concurrent.Classy.Async
, Control.Concurrent.Classy.Chan
, Control.Concurrent.Classy.BoundedChan
, Control.Concurrent.Classy.CRef
, Control.Concurrent.Classy.IORef
, Control.Concurrent.Classy.MVar
, Control.Concurrent.Classy.QSem
, Control.Concurrent.Classy.QSemN
, Control.Concurrent.Classy.Lock
, Control.Concurrent.Classy.RWLock
, Control.Concurrent.Classy.STM
, Control.Concurrent.Classy.STM.TVar
, Control.Concurrent.Classy.STM.TMVar