{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# OPTIONS_HADDOCK not-home #-}

module GHC.Internal.STM
        (
          -- * the 'STM' monad
          STM(..)
        , atomically
        , retry
        , orElse
        , throwSTM
        , catchSTM
        , unsafeIOToSTM
          -- * TVars
        , TVar(..)
        , newTVar
        , newTVarIO
        , readTVar
        , readTVarIO
        , writeTVar
        ) where

import GHC.Internal.Base
import GHC.Internal.Exception (Exception, toExceptionWithBacktrace, fromException, addExceptionContext)
import GHC.Internal.Exception.Context (ExceptionAnnotation)
import GHC.Internal.Exception.Type (WhileHandling(..))
import GHC.Internal.Stack (HasCallStack)

-- TVars are shared memory locations which support atomic memory
-- transactions.

-- |A monad supporting atomic memory transactions.
newtype STM a = STM (State# RealWorld -> (# State# RealWorld, a #))

unSTM :: STM a -> (State# RealWorld -> (# State# RealWorld, a #))
unSTM :: forall a. STM a -> State# RealWorld -> (# State# RealWorld, a #)
unSTM (STM State# RealWorld -> (# State# RealWorld, a #)
a) = State# RealWorld -> (# State# RealWorld, a #)
a

-- | @since base-4.3.0.0
instance  Functor STM where
   fmap :: forall a b. (a -> b) -> STM a -> STM b
fmap a -> b
f STM a
x = STM a
x STM a -> (a -> STM b) -> STM b
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (b -> STM b
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b -> STM b) -> (a -> b) -> a -> STM b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f)

-- | @since base-4.8.0.0
instance Applicative STM where
  {-# INLINE pure #-}
  {-# INLINE (*>) #-}
  {-# INLINE liftA2 #-}
  pure :: forall a. a -> STM a
pure a
x = a -> STM a
forall a. a -> STM a
returnSTM a
x
  <*> :: forall a b. STM (a -> b) -> STM a -> STM b
(<*>) = STM (a -> b) -> STM a -> STM b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
  liftA2 :: forall a b c. (a -> b -> c) -> STM a -> STM b -> STM c
liftA2 = (a -> b -> c) -> STM a -> STM b -> STM c
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2
  STM a
m *> :: forall a b. STM a -> STM b -> STM b
*> STM b
k = STM a -> STM b -> STM b
forall a b. STM a -> STM b -> STM b
thenSTM STM a
m STM b
k

-- | @since base-4.3.0.0
instance  Monad STM  where
    {-# INLINE (>>=)  #-}
    STM a
m >>= :: forall a b. STM a -> (a -> STM b) -> STM b
>>= a -> STM b
k     = STM a -> (a -> STM b) -> STM b
forall a b. STM a -> (a -> STM b) -> STM b
bindSTM STM a
m a -> STM b
k
    >> :: forall a b. STM a -> STM b -> STM b
(>>) = STM a -> STM b -> STM b
forall a b. STM a -> STM b -> STM b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
(*>)

-- | @since base-4.17.0.0
instance Semigroup a => Semigroup (STM a) where
    <> :: STM a -> STM a -> STM a
(<>) = (a -> a -> a) -> STM a -> STM a -> STM a
forall a b c. (a -> b -> c) -> STM a -> STM b -> STM c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> a -> a
forall a. Semigroup a => a -> a -> a
(<>)

-- | @since base-4.17.0.0
instance Monoid a => Monoid (STM a) where
    mempty :: STM a
mempty = a -> STM a
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
forall a. Monoid a => a
mempty

bindSTM :: STM a -> (a -> STM b) -> STM b
bindSTM :: forall a b. STM a -> (a -> STM b) -> STM b
bindSTM (STM State# RealWorld -> (# State# RealWorld, a #)
m) a -> STM b
k = (State# RealWorld -> (# State# RealWorld, b #)) -> STM b
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> STM a
STM ( \State# RealWorld
s ->
  case State# RealWorld -> (# State# RealWorld, a #)
m State# RealWorld
s of
    (# State# RealWorld
new_s, a
a #) -> STM b -> State# RealWorld -> (# State# RealWorld, b #)
forall a. STM a -> State# RealWorld -> (# State# RealWorld, a #)
unSTM (a -> STM b
k a
a) State# RealWorld
new_s
  )

thenSTM :: STM a -> STM b -> STM b
thenSTM :: forall a b. STM a -> STM b -> STM b
thenSTM (STM State# RealWorld -> (# State# RealWorld, a #)
m) STM b
k = (State# RealWorld -> (# State# RealWorld, b #)) -> STM b
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> STM a
STM ( \State# RealWorld
s ->
  case State# RealWorld -> (# State# RealWorld, a #)
m State# RealWorld
s of
    (# State# RealWorld
new_s, a
_ #) -> STM b -> State# RealWorld -> (# State# RealWorld, b #)
forall a. STM a -> State# RealWorld -> (# State# RealWorld, a #)
unSTM STM b
k State# RealWorld
new_s
  )

returnSTM :: a -> STM a
returnSTM :: forall a. a -> STM a
returnSTM a
x = (State# RealWorld -> (# State# RealWorld, a #)) -> STM a
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> STM a
STM (\State# RealWorld
s -> (# State# RealWorld
s, a
x #))

-- | Takes the first non-'retry'ing 'STM' action.
--
-- @since base-4.8.0.0
instance Alternative STM where
  empty :: forall a. STM a
empty = STM a
forall a. STM a
retry
  <|> :: forall a. STM a -> STM a -> STM a
(<|>) = STM a -> STM a -> STM a
forall a. STM a -> STM a -> STM a
orElse

-- | Takes the first non-'retry'ing 'STM' action.
--
-- @since base-4.3.0.0
instance MonadPlus STM

-- | Unsafely performs IO in the STM monad.  Beware: this is a highly
-- dangerous thing to do.
--
--   * The STM implementation will often run transactions multiple
--     times, so you need to be prepared for this if your IO has any
--     side effects.
--
--   * The STM implementation will abort transactions that are known to
--     be invalid and need to be restarted.  This may happen in the middle
--     of `unsafeIOToSTM`, so make sure you don't acquire any resources
--     that need releasing (exception handlers are ignored when aborting
--     the transaction).  That includes doing any IO using Handles, for
--     example.  Getting this wrong will probably lead to random deadlocks.
--
--   * The transaction may have seen an inconsistent view of memory when
--     the IO runs.  Invariants that you expect to be true throughout
--     your program may not be true inside a transaction, due to the
--     way transactions are implemented.  Normally this wouldn't be visible
--     to the programmer, but using `unsafeIOToSTM` can expose it.
--
unsafeIOToSTM :: IO a -> STM a
unsafeIOToSTM :: forall a. IO a -> STM a
unsafeIOToSTM (IO State# RealWorld -> (# State# RealWorld, a #)
m) = (State# RealWorld -> (# State# RealWorld, a #)) -> STM a
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> STM a
STM State# RealWorld -> (# State# RealWorld, a #)
m

-- | Perform a series of STM actions atomically.
--
-- Using 'atomically' inside an 'unsafePerformIO' or 'unsafeInterleaveIO'
-- subverts some of guarantees that STM provides. It makes it possible to
-- run a transaction inside of another transaction, depending on when the
-- thunk is evaluated. If a nested transaction is attempted, an exception
-- is thrown by the runtime. It is possible to safely use 'atomically' inside
-- 'unsafePerformIO' or 'unsafeInterleaveIO', but the typechecker does not
-- rule out programs that may attempt nested transactions, meaning that
-- the programmer must take special care to prevent these.
--
-- However, there are functions for creating transactional variables that
-- can always be safely called in 'unsafePerformIO'. See: 'newTVarIO',
-- 'Control.Concurrent.STM.TChan.newTChanIO',
-- 'Control.Concurrent.STM.TChan.newBroadcastTChanIO',
-- 'Control.Concurrent.STM.TQueue.newTQueueIO',
-- 'Control.Concurrent.STM.TBQueue.newTBQueueIO', and
-- 'Control.Concurrent.STM.TMVar.newTMVarIO'.
--
-- Using 'unsafePerformIO' inside of 'atomically' is also dangerous but for
-- different reasons. See 'unsafeIOToSTM' for more on this.

atomically :: STM a -> IO a
atomically :: forall a. STM a -> IO a
atomically (STM State# RealWorld -> (# State# RealWorld, a #)
m) = (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO (\State# RealWorld
s -> ((State# RealWorld -> (# State# RealWorld, a #))
-> State# RealWorld -> (# State# RealWorld, a #)
forall a.
(State# RealWorld -> (# State# RealWorld, a #))
-> State# RealWorld -> (# State# RealWorld, a #)
atomically# State# RealWorld -> (# State# RealWorld, a #)
m) State# RealWorld
s )

-- | Retry execution of the current memory transaction because it has seen
-- values in 'TVar's which mean that it should not continue (e.g. the 'TVar's
-- represent a shared buffer that is now empty).  The implementation may
-- block the thread until one of the 'TVar's that it has read from has been
-- updated. (GHC only)
retry :: STM a
retry :: forall a. STM a
retry = (State# RealWorld -> (# State# RealWorld, a #)) -> STM a
(State# RealWorld -> (# State# RealWorld, a #)) -> STM a
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> STM a
STM ((State# RealWorld -> (# State# RealWorld, a #)) -> STM a)
-> (State# RealWorld -> (# State# RealWorld, a #)) -> STM a
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s# -> State# RealWorld -> (# State# RealWorld, a #)
forall a. State# RealWorld -> (# State# RealWorld, a #)
retry# State# RealWorld
s#

-- | Compose two alternative STM actions (GHC only).
--
-- If the first action completes without retrying then it forms the result of
-- the 'orElse'. Otherwise, if the first action retries, then the second action
-- is tried in its place. If both actions retry then the 'orElse' as a whole
-- retries.
orElse :: STM a -> STM a -> STM a
orElse :: forall a. STM a -> STM a -> STM a
orElse (STM State# RealWorld -> (# State# RealWorld, a #)
m) STM a
e = (State# RealWorld -> (# State# RealWorld, a #)) -> STM a
(State# RealWorld -> (# State# RealWorld, a #)) -> STM a
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> STM a
STM ((State# RealWorld -> (# State# RealWorld, a #)) -> STM a)
-> (State# RealWorld -> (# State# RealWorld, a #)) -> STM a
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s -> (State# RealWorld -> (# State# RealWorld, a #))
-> (State# RealWorld -> (# State# RealWorld, a #))
-> State# RealWorld
-> (# State# RealWorld, a #)
forall a.
(State# RealWorld -> (# State# RealWorld, a #))
-> (State# RealWorld -> (# State# RealWorld, a #))
-> State# RealWorld
-> (# State# RealWorld, a #)
catchRetry# State# RealWorld -> (# State# RealWorld, a #)
m (STM a -> State# RealWorld -> (# State# RealWorld, a #)
forall a. STM a -> State# RealWorld -> (# State# RealWorld, a #)
unSTM STM a
e) State# RealWorld
s

-- | 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. If the exception is caught via 'catchSTM', only the changes
-- enclosed by the catch are rolled back; changes made outside of 'catchSTM'
-- persist.
--
-- If the exception is not caught inside of the 'STM', it is re-thrown by
-- 'atomically', and the entire 'STM' is rolled back.
--
-- 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 :: (HasCallStack, Exception e) => e -> STM a
throwSTM :: forall e a. (HasCallStack, Exception e) => e -> STM a
throwSTM e
e = do
    -- N.B. Typically use of unsafeIOToSTM is very much frowned upon as this
    -- is an easy way to end up with nested transactions. However, we can be
    -- certain that toExceptionWithBacktrace will not initiate a transaction.
    se <- IO SomeException -> STM SomeException
forall a. IO a -> STM a
unsafeIOToSTM (e -> IO SomeException
forall e. (HasCallStack, Exception e) => e -> IO SomeException
toExceptionWithBacktrace e
e)
    STM $ raiseIO# se

-- | Exception handling within STM actions.
--
-- @'catchSTM' m f@ catches any exception thrown by @m@ using 'throwSTM',
-- using the function @f@ to handle the exception. If an exception is
-- thrown, any changes made by @m@ are rolled back, but changes prior to
-- @m@ persist.
catchSTM :: Exception e => STM a -> (e -> STM a) -> STM a
catchSTM :: forall e a. Exception e => STM a -> (e -> STM a) -> STM a
catchSTM (STM State# RealWorld -> (# State# RealWorld, a #)
m) e -> STM a
handler = (State# RealWorld -> (# State# RealWorld, a #)) -> STM a
(State# RealWorld -> (# State# RealWorld, a #)) -> STM a
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> STM a
STM ((State# RealWorld -> (# State# RealWorld, a #)) -> STM a)
-> (State# RealWorld -> (# State# RealWorld, a #)) -> STM a
forall a b. (a -> b) -> a -> b
$ (State# RealWorld -> (# State# RealWorld, a #))
-> (SomeException -> State# RealWorld -> (# State# RealWorld, a #))
-> State# RealWorld
-> (# State# RealWorld, a #)
forall a b.
(State# RealWorld -> (# State# RealWorld, a #))
-> (b -> State# RealWorld -> (# State# RealWorld, a #))
-> State# RealWorld
-> (# State# RealWorld, a #)
catchSTM# State# RealWorld -> (# State# RealWorld, a #)
m SomeException -> State# RealWorld -> (# State# RealWorld, a #)
handler'
    where
      handler' :: SomeException -> State# RealWorld -> (# State# RealWorld, a #)
handler' SomeException
e = case SomeException -> Maybe e
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
                     Just e
e' -> STM a -> State# RealWorld -> (# State# RealWorld, a #)
forall a. STM a -> State# RealWorld -> (# State# RealWorld, a #)
unSTM (WhileHandling -> STM a -> STM a
forall e a. ExceptionAnnotation e => e -> STM a -> STM a
annotateSTM (SomeException -> WhileHandling
WhileHandling SomeException
e) (e -> STM a
handler e
e'))
                     Maybe e
Nothing -> SomeException -> State# RealWorld -> (# State# RealWorld, a #)
forall a b. a -> State# RealWorld -> (# State# RealWorld, b #)
raiseIO# SomeException
e

-- | Execute an 'STM' action, adding the given 'ExceptionContext'
-- to any thrown synchronous exceptions.
annotateSTM :: forall e a. ExceptionAnnotation e => e -> STM a -> STM a
annotateSTM :: forall e a. ExceptionAnnotation e => e -> STM a -> STM a
annotateSTM e
ann (STM State# RealWorld -> (# State# RealWorld, a #)
io) = (State# RealWorld -> (# State# RealWorld, a #)) -> STM a
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> STM a
STM ((State# RealWorld -> (# State# RealWorld, a #))
-> (SomeException -> State# RealWorld -> (# State# RealWorld, a #))
-> State# RealWorld
-> (# State# RealWorld, a #)
forall a b.
(State# RealWorld -> (# State# RealWorld, a #))
-> (b -> State# RealWorld -> (# State# RealWorld, a #))
-> State# RealWorld
-> (# State# RealWorld, a #)
catch# State# RealWorld -> (# State# RealWorld, a #)
io SomeException -> State# RealWorld -> (# State# RealWorld, a #)
handler)
  where
    handler :: SomeException -> State# RealWorld -> (# State# RealWorld, a #)
handler SomeException
se = SomeException -> State# RealWorld -> (# State# RealWorld, a #)
forall a b. a -> State# RealWorld -> (# State# RealWorld, b #)
raiseIO# (e -> SomeException -> SomeException
forall a.
ExceptionAnnotation a =>
a -> SomeException -> SomeException
addExceptionContext e
ann SomeException
se)

-- |Shared memory locations that support atomic memory transactions.
data TVar a = TVar (TVar# RealWorld a)

-- | @since base-4.8.0.0
instance Eq (TVar a) where
        (TVar TVar# RealWorld a
tvar1#) == :: TVar a -> TVar a -> Bool
== (TVar TVar# RealWorld a
tvar2#) = Int# -> Bool
isTrue# (TVar# RealWorld a -> TVar# RealWorld a -> Int#
forall s a. TVar# s a -> TVar# s a -> Int#
sameTVar# TVar# RealWorld a
tvar1# TVar# RealWorld a
tvar2#)

-- | Create a new 'TVar' holding a value supplied
newTVar :: a -> STM (TVar a)
newTVar :: forall a. a -> STM (TVar a)
newTVar a
val = (State# RealWorld -> (# State# RealWorld, TVar a #))
-> STM (TVar a)
(State# RealWorld -> (# State# RealWorld, TVar a #))
-> STM (TVar a)
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> STM a
STM ((State# RealWorld -> (# State# RealWorld, TVar a #))
 -> STM (TVar a))
-> (State# RealWorld -> (# State# RealWorld, TVar a #))
-> STM (TVar a)
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s1# ->
    case a -> State# RealWorld -> (# State# RealWorld, TVar# RealWorld a #)
forall a d. a -> State# d -> (# State# d, TVar# d a #)
newTVar# a
val State# RealWorld
s1# of
         (# State# RealWorld
s2#, TVar# RealWorld a
tvar# #) -> (# State# RealWorld
s2#, TVar# RealWorld a -> TVar a
forall a. TVar# RealWorld a -> TVar a
TVar TVar# RealWorld a
tvar# #)

-- | @IO@ version of 'newTVar'.  This is useful for creating top-level
-- 'TVar's using 'System.IO.Unsafe.unsafePerformIO', because using
-- 'atomically' inside 'System.IO.Unsafe.unsafePerformIO' isn't
-- possible.
newTVarIO :: a -> IO (TVar a)
newTVarIO :: forall a. a -> IO (TVar a)
newTVarIO a
val = (State# RealWorld -> (# State# RealWorld, TVar a #)) -> IO (TVar a)
(State# RealWorld -> (# State# RealWorld, TVar a #)) -> IO (TVar a)
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, TVar a #))
 -> IO (TVar a))
-> (State# RealWorld -> (# State# RealWorld, TVar a #))
-> IO (TVar a)
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s1# ->
    case a -> State# RealWorld -> (# State# RealWorld, TVar# RealWorld a #)
forall a d. a -> State# d -> (# State# d, TVar# d a #)
newTVar# a
val State# RealWorld
s1# of
         (# State# RealWorld
s2#, TVar# RealWorld a
tvar# #) -> (# State# RealWorld
s2#, TVar# RealWorld a -> TVar a
forall a. TVar# RealWorld a -> TVar a
TVar TVar# RealWorld a
tvar# #)

-- | Return the current value stored in a 'TVar'.
-- This is equivalent to
--
-- >  readTVarIO = atomically . readTVar
--
-- but works much faster, because it doesn't perform a complete
-- transaction, it just reads the current value of the 'TVar'.
readTVarIO :: TVar a -> IO a
readTVarIO :: forall a. TVar a -> IO a
readTVarIO (TVar TVar# RealWorld a
tvar#) = (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
(State# RealWorld -> (# State# RealWorld, a #)) -> IO a
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, a #)) -> IO a)
-> (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s# -> TVar# RealWorld a -> State# RealWorld -> (# State# RealWorld, a #)
forall d a. TVar# d a -> State# d -> (# State# d, a #)
readTVarIO# TVar# RealWorld a
tvar# State# RealWorld
s#

-- |Return the current value stored in a 'TVar'.
readTVar :: TVar a -> STM a
readTVar :: forall a. TVar a -> STM a
readTVar (TVar TVar# RealWorld a
tvar#) = (State# RealWorld -> (# State# RealWorld, a #)) -> STM a
(State# RealWorld -> (# State# RealWorld, a #)) -> STM a
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> STM a
STM ((State# RealWorld -> (# State# RealWorld, a #)) -> STM a)
-> (State# RealWorld -> (# State# RealWorld, a #)) -> STM a
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s# -> TVar# RealWorld a -> State# RealWorld -> (# State# RealWorld, a #)
forall d a. TVar# d a -> State# d -> (# State# d, a #)
readTVar# TVar# RealWorld a
tvar# State# RealWorld
s#

-- |Write the supplied value into a 'TVar'.
writeTVar :: TVar a -> a -> STM ()
writeTVar :: forall a. TVar a -> a -> STM ()
writeTVar (TVar TVar# RealWorld a
tvar#) a
val = (State# RealWorld -> (# State# RealWorld, () #)) -> STM ()
(State# RealWorld -> (# State# RealWorld, () #)) -> STM ()
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> STM a
STM ((State# RealWorld -> (# State# RealWorld, () #)) -> STM ())
-> (State# RealWorld -> (# State# RealWorld, () #)) -> STM ()
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s1# ->
    case TVar# RealWorld a -> a -> State# RealWorld -> State# RealWorld
forall d a. TVar# d a -> a -> State# d -> State# d
writeTVar# TVar# RealWorld a
tvar# a
val State# RealWorld
s1# of
         State# RealWorld
s2# -> (# State# RealWorld
s2#, () #)