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