diff --git a/CHANGELOG.rst b/CHANGELOG.rst --- a/CHANGELOG.rst +++ b/CHANGELOG.rst @@ -7,6 +7,22 @@ .. _PVP: https://pvp.haskell.org/ +1.6.2.0 (2018-11-28) +-------------------- + +* Git: :tag:`concurrency-1.6.2.0` +* Hackage: :hackage:`concurrency-1.6.2.0` + +**Contributors:** :u:`gip` (:pull:`289`). + +Added +~~~~~ + +* (:pull:`289`) The ``Control.Concurrent.Classy.BoundedChan`` module. +* (:pull:`289`) The ``Control.Concurrent.Classy.Lock`` module. +* (:pull:`289`) The ``Control.Concurrent.Classy.RWLock`` module. + + 1.6.1.0 (2018-09-23) -------------------- diff --git a/Control/Concurrent/Classy.hs b/Control/Concurrent/Classy.hs --- a/Control/Concurrent/Classy.hs +++ b/Control/Concurrent/Classy.hs @@ -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 diff --git a/Control/Concurrent/Classy/BoundedChan.hs b/Control/Concurrent/Classy/BoundedChan.hs new file mode 100644 --- /dev/null +++ b/Control/Concurrent/Classy/BoundedChan.hs @@ -0,0 +1,223 @@ +-------------------------------------------------------------------------------- + +-- 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 +-- +-- 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. +-- +-- @since 1.6.2.0 +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. +-- +-- @since 1.6.2.0 +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. +-- +-- @since 1.6.2.0 +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. +-- +-- @since 1.6.2.0 +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. +-- +-- @since 1.6.2.0 +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. +-- +-- @since 1.6.2.0 +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. +-- +-- @since 1.6.2.0 +{-# 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. +-- +-- @since 1.6.2.0 +writeList2BoundedChan :: (MonadConc m) => BoundedChan m a -> [a] -> m () +writeList2BoundedChan = mapM_ . writeBoundedChan + +-------------------------------------------------------------------------------- diff --git a/Control/Concurrent/Classy/Lock.hs b/Control/Concurrent/Classy/Lock.hs new file mode 100644 --- /dev/null +++ b/Control/Concurrent/Classy/Lock.hs @@ -0,0 +1,246 @@ +-------------------------------------------------------------------------------- + +-- 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 +-- +-- 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: +-- +-- +-- +-- and: +-- +-- +-- +-- 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\". +-- +-- @since 1.6.2.0 +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. +-- +-- @since 1.6.2.0 +newLock :: (MonadConc m) => m (Lock m) +newLock = Lock <$> MVar.newMVar () + +-- | Create a lock in the \"locked\" state. +-- +-- @since 1.6.2.0 +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. +-- +-- @since 1.6.2.0 +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'. +-- +-- @since 1.6.2.0 +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. +-- +-- @since 1.6.2.0 +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'@. +-- +-- @since 1.6.2.0 +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. +-- +-- @since 1.6.2.0 +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. +-- +-- @since 1.6.2.0 +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. +-- +-- @since 1.6.2.0 +locked :: (MonadConc m) => Lock m -> m Bool +locked = MVar.isEmptyMVar . _fromLock + +-------------------------------------------------------------------------------- diff --git a/Control/Concurrent/Classy/RWLock.hs b/Control/Concurrent/Classy/RWLock.hs new file mode 100644 --- /dev/null +++ b/Control/Concurrent/Classy/RWLock.hs @@ -0,0 +1,408 @@ +-------------------------------------------------------------------------------- + +-- 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 +-- +-- 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. +-- +-- @since 1.6.2.0 +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. +-- +-- @since 1.6.2.0 +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. +-- +-- @since 1.6.2.0 +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. +-- +-- @since 1.6.2.0 +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. +-- +-- @since 1.6.2.0 +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. +-- +-- @since 1.6.2.0 +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. +-- +-- @since 1.6.2.0 +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. +-- +-- @since 1.6.2.0 +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. +-- +-- @since 1.6.2.0 +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@ +-- +-- @since 1.6.2.0 +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\". +-- +-- @since 1.6.2.0 +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. +-- +-- @since 1.6.2.0 +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. +-- +-- @since 1.6.2.0 +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. +-- +-- @since 1.6.2.0 +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. +-- +-- @since 1.6.2.0 +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@ +-- +-- @since 1.6.2.0 +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) + +-------------------------------------------------------------------------------- diff --git a/concurrency.cabal b/concurrency.cabal --- a/concurrency.cabal +++ b/concurrency.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: concurrency -version: 1.6.1.0 +version: 1.6.2.0 synopsis: Typeclasses, functions, and data types for concurrency and STM. description: @@ -32,7 +32,7 @@ source-repository this type: git location: https://github.com/barrucadu/dejafu.git - tag: concurrency-1.6.1.0 + tag: concurrency-1.6.2.0 library exposed-modules: Control.Monad.Conc.Class @@ -41,11 +41,14 @@ , 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