{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE CPP, MagicHash, UnboxedTuples #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Control.Monad.STM -- Copyright : (c) The University of Glasgow 2004 -- License : BSD-style (see the file libraries/base/LICENSE) -- -- Maintainer : libraries@haskell.org -- Stability : experimental -- Portability : non-portable (requires STM) -- -- Software Transactional Memory: a modular composable concurrency -- abstraction. See -- -- * /Composable memory transactions/, by Tim Harris, Simon Marlow, Simon -- Peyton Jones, and Maurice Herlihy, in -- /ACM Conference on Principles and Practice of Parallel Programming/ 2005. -- <https://www.microsoft.com/en-us/research/publication/composable-memory-transactions/> -- -- This module only defines the 'STM' monad; you probably want to -- import "Control.Concurrent.STM" (which exports "Control.Monad.STM"). -- -- Note that invariant checking (namely the @always@ and @alwaysSucceeds@ -- functions) has been removed. See ticket [#14324](https://ghc.haskell.org/trac/ghc/ticket/14324) and -- the [removal proposal](https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0011-deprecate-stm-invariants.rst). -- Existing users are encouraged to encapsulate their STM operations in safe -- abstractions which can perform the invariant checking without help from the -- runtime system. ----------------------------------------------------------------------------- module Control.Monad.STM ( STM, atomically, #ifdef __GLASGOW_HASKELL__ retry, orElse, check, #endif throwSTM, catchSTM ) where #ifdef __GLASGOW_HASKELL__ #if ! (MIN_VERSION_base(4,3,0)) import GHC.Conc hiding (catchSTM) import Control.Monad ( MonadPlus(..) ) import Control.Exception #else import GHC.Conc #endif import GHC.Exts import Control.Monad.Fix #else import Control.Sequential.STM #endif #ifdef __GLASGOW_HASKELL__ #if ! (MIN_VERSION_base(4,3,0)) import Control.Applicative import Control.Monad (ap) #endif #endif #ifdef __GLASGOW_HASKELL__ #if ! (MIN_VERSION_base(4,3,0)) instance MonadPlus STM where mzero = retry mplus = orElse instance Applicative STM where pure = return (<*>) = ap instance Alternative STM where empty = retry (<|>) = orElse #endif -- | Check that the boolean condition is true and, if not, 'retry'. -- -- In other words, @check b = unless b retry@. -- -- @since 2.1.1 check :: Bool -> STM () check :: Bool -> STM () check Bool b = if Bool b then forall (m :: * -> *) a. Monad m => a -> m a return () else forall a. STM a retry #endif #if ! (MIN_VERSION_base(4,3,0)) -- |Exception handling within STM actions. catchSTM :: Exception e => STM a -> (e -> STM a) -> STM a catchSTM (STM m) handler = STM $ catchSTM# m handler' where handler' e = case fromException e of Just e' -> case handler e' of STM m' -> m' Nothing -> raiseIO# e -- | A variant of 'throw' that can only be used within the 'STM' monad. -- -- Throwing an exception in @STM@ aborts the transaction and propagates the -- exception. (Note: Allocation effects, such as 'newTVar' are not rolled back -- when this happens. All other effects are discarded. See <https://gitlab.haskell.org/ghc/ghc/-/issues/18453 ghc#18453.>) -- -- Although 'throwSTM' has a type that is an instance of the type of 'throw', the -- two functions are subtly different: -- -- > throw e `seq` x ===> throw e -- > throwSTM e `seq` x ===> x -- -- The first example will cause the exception @e@ to be raised, -- whereas the second one won\'t. In fact, 'throwSTM' will only cause -- an exception to be raised when it is used within the 'STM' monad. -- The 'throwSTM' variant should be used in preference to 'throw' to -- raise an exception within the 'STM' monad because it guarantees -- ordering with respect to other 'STM' operations, whereas 'throw' -- does not. throwSTM :: Exception e => e -> STM a throwSTM e = STM $ raiseIO# (toException e) #endif data STMret a = STMret (State# RealWorld) a liftSTM :: STM a -> State# RealWorld -> STMret a liftSTM :: forall a. STM a -> State# RealWorld -> STMret a liftSTM (STM State# RealWorld -> (# State# RealWorld, a #) m) = \State# RealWorld s -> case State# RealWorld -> (# State# RealWorld, a #) m State# RealWorld s of (# State# RealWorld s', a r #) -> forall a. State# RealWorld -> a -> STMret a STMret State# RealWorld s' a r -- | @since 2.3 instance MonadFix STM where mfix :: forall a. (a -> STM a) -> STM a mfix a -> STM a k = forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> STM a STM forall a b. (a -> b) -> a -> b $ \State# RealWorld s -> let ans :: STMret a ans = forall a. STM a -> State# RealWorld -> STMret a liftSTM (a -> STM a k a r) State# RealWorld s STMret State# RealWorld _ a r = STMret a ans in case STMret a ans of STMret State# RealWorld s' a x -> (# State# RealWorld s', a x #)