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

BoundedChan and locks primitives

concurrency/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

concurrency/Control/Concurrent/Classy/BoundedChan.hs

@@ -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
+
+--------------------------------------------------------------------------------

concurrency/Control/Concurrent/Classy/Lock.hs

@@ -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
+
+--------------------------------------------------------------------------------

concurrency/Control/Concurrent/Classy/RWLock.hs

@@ -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)
+
+--------------------------------------------------------------------------------

concurrency/concurrency.cabal

@@ -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