{-# LANGUAGE ConstraintKinds      #-}
{-# LANGUAGE CPP                  #-}
{-# LANGUAGE DataKinds            #-}
{-# LANGUAGE KindSignatures       #-}
{-# LANGUAGE MagicHash            #-}
{-# LANGUAGE NoImplicitPrelude    #-}
{-# LANGUAGE PolyKinds            #-}
{-# LANGUAGE Rank2Types           #-}
{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE TypeFamilies         #-}
{-# LANGUAGE TypeOperators        #-}
{-# LANGUAGE UnboxedTuples        #-}
{-# LANGUAGE UndecidableInstances #-}

{-# OPTIONS_GHC -Wall #-}

-- | This library implements the ST2 monad, a type using GDP (ghosts of departed proofs)
--   to define shared regions of memory between local mutable state threads. This allows
--   us to define a region of the heap in more minute contours, with each state thread
--   having explicit access to regions in memory. This is achieved using the function `runST2`,
--   which in effects lets the user run a computation that makes use of two partially-overlapping
--   memory regions. Within that computation, the user can run sub-computations bound to one or
--   the other memory region. Furthermore, a sub-computation can move any variable that it owns
--   into the common overlap via `share`.
--
--   An example is shown in below, where one sub-computation creates two cells: one
--   private, and the other shared. A second sub-computation has unconstrained access to the
--   shared cell. Yet even though the private reference is also in scope during the second
--   sub-computation, any attempts to access it there will fail to compile.
--
-- >>> :{
-- stSharingDemo :: Bool
-- stSharingDemo = runST2 $ do
--   -- In the "left" memory region, create and return
--   -- two references; one shared, and one not shared.
--   (secret, ref) <- liftL $ do
--     unshared <- newSTRef 42
--     shared   <- share =<< newSTRef 17
--     return (unshared, shared)
--   -- In the "right" memory region, mutate the shared
--   -- reference. If we attempt to access the non-shared
--   -- reference here, the program will not compile.
--   liftR $ do
--     let mine = use (symm ref)
--     x <- readSTRef mine
--     writeSTRef mine (x + 1)
--   -- Back in the "left" memory region, verify that the
--   -- unshared reference still holds its original value.
--   liftL $ do
--     check <- readSTRef secret
--     return (check == 42)
-- :}
module Control.Monad.ST2
  ( -- * ST2 API
    ST(..), STRep
  , fixST
  , liftST

  , runST

  , STRef(..)
  , newSTRef
  , readSTRef
  , writeSTRef

  , type (∩)
  , Common
  , share
  , liftL
  , liftR
  , use
  , symm
  , runST2

    -- * Unsafe API
  , toBaseST
  , fromBaseST

  , STret
  , unsafeInterleaveST, unsafeDupableInterleaveST
  , stToPrim
  , unsafePrimToST
  , unsafeSTToPrim
  , unsafeInlineST
  , stToIO
  , ioToST
  , RealWorld
  ) where

import           Control.Applicative (Applicative(pure, (*>), (<*>), liftA2))
import           Control.Exception.Base (catch, throwIO, NonTermination(..), BlockedIndefinitelyOnMVar(..))
import           Control.Monad (Monad(return, (>>=), (>>)), ap, liftM2)
import           Control.Monad.Primitive (PrimMonad(primitive, PrimState), PrimBase(internal), primToPrim, unsafePrimToPrim, unsafeInlinePrim)
import qualified Control.Monad.ST as BaseST
import           Data.Eq (Eq((==)))
import           Data.Function (($), (.))
import           Data.Functor (Functor(fmap))
import           Data.Kind (Type)
#if !(MIN_VERSION_base(4,11,0))
import           Data.Monoid (Monoid(mempty, mappend))
#else
import           Data.Monoid (Monoid(mempty))
#endif
import           Data.Semigroup (Semigroup((<>)))
import           GHC.IO (IO(IO),unsafeDupableInterleaveIO)
import           GHC.MVar (readMVar, putMVar, newEmptyMVar)
import           GHC.Exts (State#, unsafeCoerce#, MutVar#, newMutVar#, readMutVar#, writeMutVar#, sameMutVar#, RealWorld, noDuplicate#, RuntimeRep, TYPE, Any, isTrue#)
import           GHC.Show (Show(showsPrec, showList), showString, showList__)
import           Theory.Named (type (~~))
import           Unsafe.Coerce (unsafeCoerce)
import qualified GHC.Exts as GHCExts

-- | Convert an ST2 to an ST
toBaseST :: ST s a -> BaseST.ST s a
{-# INLINE toBaseST #-}
toBaseST :: ST s a -> ST s a
toBaseST = ST s a -> ST s a
forall a b. a -> b
unsafeCoerce

-- | Convert an ST to an ST2
fromBaseST :: BaseST.ST s a -> ST s a
{-# INLINE fromBaseST #-}
fromBaseST :: ST s a -> ST s a
fromBaseST = ST s a -> ST s a
forall a b. a -> b
unsafeCoerce

-- The state-transformer monad proper.  By default the monad is strict;
-- too many people got bit by space leaks when it was lazy.

-- | The strict state-transformer monad.
-- A computation of type @'ST' s a@ transforms an internal state indexed
-- by @s@, and returns a value of type @a@.
-- The @s@ parameter is either
--
-- * an uninstantiated type variable (inside invocations of 'runST'), or
--
-- * 'RealWorld' (inside invocations of 'Control.Monad.ST.stToIO').
--
-- It serves to keep the internal states of different invocations
-- of 'runST' separate from each other and from invocations of
-- 'Control.Monad.ST.stToIO'.
--
-- The '>>=' and '>>' operations are strict in the state (though not in
-- values stored in the state).  For example,
--
-- @'runST' (writeSTRef _|_ v >>= f) = _|_@
newtype ST (s :: Type) a = ST (STRep (Any ~~ s) a)

-- | Convenience type alias for expressing ST computations
--   more succintly.
type STRep s a = State# s -> (# State# s, a #)

instance PrimMonad (ST s) where
  type PrimState (ST s) = s
  primitive :: (State# (PrimState (ST s)) -> (# State# (PrimState (ST s)), a #))
-> ST s a
primitive = STRep (Any ~~ s) a -> ST s a
forall s a. STRep (Any ~~ s) a -> ST s a
ST (STRep (Any ~~ s) a -> ST s a)
-> ((State# s -> (# State# s, a #)) -> STRep (Any ~~ s) a)
-> (State# s -> (# State# s, a #))
-> ST s a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (State# s -> (# State# s, a #)) -> STRep (Any ~~ s) a
forall s a. (State# s -> (# State# s, a #)) -> STRep (Any ~~ s) a
repToAny#
  {-# INLINE primitive #-}

instance PrimBase (ST s) where
  internal :: ST s a
-> State# (PrimState (ST s)) -> (# State# (PrimState (ST s)), a #)
internal (ST STRep (Any ~~ s) a
p) = STRep (Any ~~ s) a -> State# s -> (# State# s, a #)
forall s a. STRep (Any ~~ s) a -> State# s -> (# State# s, a #)
repFromAny# STRep (Any ~~ s) a
p
  {-# INLINE internal #-}

-- | A simple product type containing both the state thread and value inside of the 'ST'
data STret s a = STret (State# s) a

-- | 'liftST' is useful when we want a lifted result from an 'ST' computation. See
--   'fixST' below.
liftST :: ST s a -> State# s -> STret s a
liftST :: ST s a -> State# s -> STret s a
liftST (ST STRep (Any ~~ s) a
m) = \State# s
s -> case STRep (Any ~~ s) a
m (State# s -> State# (Any ~~ s)
unsafeCoerce# State# s
s) of (# State# (Any ~~ s)
s', a
r #) -> State# s -> a -> STret s a
forall s a. State# s -> a -> STret s a
STret (State# (Any ~~ s) -> State# s
unsafeCoerce# State# (Any ~~ s)
s') a
r

noDuplicateST :: ST s ()
{-# INLINE noDuplicateST #-}
noDuplicateST :: ST s ()
noDuplicateST = STRep (Any ~~ s) () -> ST s ()
forall s a. STRep (Any ~~ s) a -> ST s a
ST (STRep (Any ~~ s) () -> ST s ()) -> STRep (Any ~~ s) () -> ST s ()
forall a b. (a -> b) -> a -> b
$ \State# (Any ~~ s)
s -> (# State# (Any ~~ s) -> State# (Any ~~ s)
forall d. State# d -> State# d
noDuplicate# State# (Any ~~ s)
s, () #)

-- | 'unsafeInterleaveST' allows an 'ST' computation to be deferred
-- lazily.  When passed a value of type @ST a@, the 'ST' computation will
-- only be performed when the value of the @a@ is demanded.
{-# INLINE unsafeInterleaveST #-}
unsafeInterleaveST :: ST s a -> ST s a
unsafeInterleaveST :: ST s a -> ST s a
unsafeInterleaveST ST s a
m = ST s a -> ST s a
forall s a. ST s a -> ST s a
unsafeDupableInterleaveST (ST s ()
forall s. ST s ()
noDuplicateST ST s () -> ST s a -> ST s a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ST s a
m)

-- | 'unsafeDupableInterleaveST' allows an 'ST' computation to be deferred
-- lazily.  When passed a value of type @ST a@, the 'ST' computation will
-- only be performed when the value of the @a@ is demanded.
--
-- The computation may be performed multiple times by different threads,
-- possibly at the same time. To prevent this, use 'unsafeInterleaveST' instead.
{-# NOINLINE unsafeDupableInterleaveST #-}
-- See Note [unsafeDupableInterleaveIO should not be inlined]
-- in GHC.IO.Unsafe
unsafeDupableInterleaveST :: ST s a -> ST s a
unsafeDupableInterleaveST :: ST s a -> ST s a
unsafeDupableInterleaveST (ST STRep (Any ~~ s) a
m) = STRep (Any ~~ s) a -> ST s a
forall s a. STRep (Any ~~ s) a -> ST s a
ST ( \ State# (Any ~~ s)
s ->
    let
        r :: a
r = case STRep (Any ~~ s) a
m State# (Any ~~ s)
s of (# State# (Any ~~ s)
_, a
res #) -> a
res
    in
    (# State# (Any ~~ s)
s, a
r #)
  )

-- | Embed a strict state transformer in an 'IO'
-- action.  The 'RealWorld' parameter indicates that the internal state
-- used by the 'ST' computation is a special one supplied by the 'IO'
-- monad, and thus distinct from those used by invocations of 'runST'.
stToIO        :: ST RealWorld a -> IO a
stToIO :: ST RealWorld a -> IO a
stToIO (ST STRep (Any ~~ RealWorld) a
m) = (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO (STRep (Any ~~ RealWorld) a
-> State# RealWorld -> (# State# RealWorld, a #)
forall a b. a -> b
unsafeCoerce STRep (Any ~~ RealWorld) a
m)

-- | Convert an 'IO' action into an 'ST' action. The type of the result
-- is constrained to use a 'RealWorld' state, and therefore the result cannot
-- be passed to 'runST'.
ioToST        :: IO a -> ST RealWorld a
ioToST :: IO a -> ST RealWorld a
ioToST (IO State# RealWorld -> (# State# RealWorld, a #)
m) = STRep (Any ~~ RealWorld) a -> ST RealWorld a
forall s a. STRep (Any ~~ s) a -> ST s a
ST ((State# RealWorld -> (# State# RealWorld, a #))
-> STRep (Any ~~ RealWorld) a
forall a b. a -> b
unsafeCoerce State# RealWorld -> (# State# RealWorld, a #)
m)

-- | Convert an 'IO' action to an 'ST' action.
-- This relies on 'IO' and 'ST' having the same representation modulo the
-- constraint on the type of the state.
unsafeIOToST        :: IO a -> ST s a
unsafeIOToST :: IO a -> ST s a
unsafeIOToST (IO State# RealWorld -> (# State# RealWorld, a #)
io) = STRep (Any ~~ s) a -> ST s a
forall s a. STRep (Any ~~ s) a -> ST s a
ST (STRep (Any ~~ s) a -> ST s a) -> STRep (Any ~~ s) a -> ST s a
forall a b. (a -> b) -> a -> b
$ \ State# (Any ~~ s)
s -> ((State# RealWorld -> (# State# RealWorld, a #))
-> STRep (Any ~~ s) a
unsafeCoerce# State# RealWorld -> (# State# RealWorld, a #)
io) State# (Any ~~ s)
s

-- | Convert an 'ST' action to an 'IO' action.
-- This relies on 'IO' and 'ST' having the same representation modulo the
-- constraint on the type of the state.
--
-- For an example demonstrating why this is unsafe, see
-- https://mail.haskell.org/pipermail/haskell-cafe/2009-April/060719.html
unsafeSTToIO :: ST s a -> IO a
unsafeSTToIO :: ST s a -> IO a
unsafeSTToIO (ST STRep (Any ~~ s) a
m) = (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO (STRep (Any ~~ s) a -> State# RealWorld -> (# State# RealWorld, a #)
unsafeCoerce# STRep (Any ~~ s) a
m)

-- | Convert an 'ST' action to a 'PrimMonad'.
stToPrim :: PrimMonad m => ST (PrimState m) a -> m a
{-# INLINE stToPrim #-}
stToPrim :: ST (PrimState m) a -> m a
stToPrim = ST (PrimState m) a -> m a
forall (m1 :: * -> *) (m2 :: * -> *) a.
(PrimBase m1, PrimMonad m2, PrimState m1 ~ PrimState m2) =>
m1 a -> m2 a
primToPrim

-- | Convert any 'PrimBase' to 'ST' with an arbitrary state token. This operation is highly unsafe!
unsafePrimToST :: PrimBase m => m a -> ST s a
{-# INLINE unsafePrimToST #-}
unsafePrimToST :: m a -> ST s a
unsafePrimToST = m a -> ST s a
forall (m1 :: * -> *) (m2 :: * -> *) a.
(PrimBase m1, PrimMonad m2) =>
m1 a -> m2 a
unsafePrimToPrim

-- | Convert an 'ST' action with an arbitrary state token to any 'PrimMonad'. This operation is highly unsafe!
unsafeSTToPrim :: PrimBase m => ST s a -> m a
{-# INLINE unsafeSTToPrim #-}
unsafeSTToPrim :: ST s a -> m a
unsafeSTToPrim = ST s a -> m a
forall (m1 :: * -> *) (m2 :: * -> *) a.
(PrimBase m1, PrimMonad m2) =>
m1 a -> m2 a
unsafePrimToPrim

-- | Extract the value out of the 'ST' computation. Compare this to 'runST'; in this case, the rest of the program
--   is permitted to reference the state thread 's'. This operation is highly unsafe!
unsafeInlineST :: ST s a -> a
{-# INLINE unsafeInlineST #-}
unsafeInlineST :: ST s a -> a
unsafeInlineST = ST s a -> a
forall (m :: * -> *) a. PrimBase m => m a -> a
unsafeInlinePrim

-- | A value of type @STRef s a@ is a mutable variable in state thread @s@,
--   containing a value of type @a@
data STRef s a = STRef (MutVar# s a)

-- |Build a new 'STRef' in the current state thread
newSTRef :: a -> ST s (STRef s a)
newSTRef :: a -> ST s (STRef s a)
newSTRef a
init = STRep (Any ~~ s) (STRef s a) -> ST s (STRef s a)
forall s a. STRep (Any ~~ s) a -> ST s a
ST (STRep (Any ~~ s) (STRef s a) -> ST s (STRef s a))
-> STRep (Any ~~ s) (STRef s a) -> ST s (STRef s a)
forall a b. (a -> b) -> a -> b
$ \State# (Any ~~ s)
s1# ->
    case a -> State# s -> (# State# s, MutVar# s a #)
forall k1 d. k1 -> State# d -> (# State# d, MutVar# d k1 #)
newMutVar# a
init (State# (Any ~~ s) -> State# s
forall k (s :: k) s'. State# (Any ~~ s) -> State# s'
rwFromAny# State# (Any ~~ s)
s1#) of { (# State# s
s2#, MutVar# s a
var# #) ->
      (# (State# s -> State# (Any ~~ s)
unsafeCoerce# State# s
s2#), MutVar# s a -> STRef s a
forall s a. MutVar# s a -> STRef s a
STRef MutVar# s a
var# #) }

-- |Read the value of an 'STRef'
readSTRef :: STRef s a -> ST s a
readSTRef :: STRef s a -> ST s a
readSTRef (STRef MutVar# s a
var#) = STRep (Any ~~ s) a -> ST s a
forall s a. STRep (Any ~~ s) a -> ST s a
ST (STRep (Any ~~ s) a -> ST s a) -> STRep (Any ~~ s) a -> ST s a
forall a b. (a -> b) -> a -> b
$ \State# (Any ~~ s)
s1# -> (# State# s, a #) -> (# State# (Any ~~ s), a #)
forall s a. (# State# s, a #) -> (# State# (Any ~~ s), a #)
rwTupleToAny# (MutVar# s a -> State# s -> (# State# s, a #)
forall d k1. MutVar# d k1 -> State# d -> (# State# d, k1 #)
readMutVar# MutVar# s a
var# (State# (Any ~~ s) -> State# s
forall k (s :: k) s'. State# (Any ~~ s) -> State# s'
rwFromAny# State# (Any ~~ s)
s1#))

-- | Write a new value into an 'STRef'
writeSTRef :: STRef s a -> a -> ST s ()
writeSTRef :: STRef s a -> a -> ST s ()
writeSTRef (STRef MutVar# s a
var#) a
val = STRep (Any ~~ s) () -> ST s ()
forall s a. STRep (Any ~~ s) a -> ST s a
ST (STRep (Any ~~ s) () -> ST s ()) -> STRep (Any ~~ s) () -> ST s ()
forall a b. (a -> b) -> a -> b
$ \State# (Any ~~ s)
s1# ->
  case MutVar# s a -> a -> State# s -> State# s
forall d k1. MutVar# d k1 -> k1 -> State# d -> State# d
writeMutVar# MutVar# s a
var# a
val (State# (Any ~~ s) -> State# s
forall k (s :: k) s'. State# (Any ~~ s) -> State# s'
rwFromAny# State# (Any ~~ s)
s1#) of
    State# s
s2# -> (# (State# s -> State# (Any ~~ s)
forall k (s :: k) s'. State# s' -> State# (Any ~~ s)
rwToAny# State# s
s2#), () #)

-- Just pointer equality on mutable references:
instance Eq (STRef s a) where
  STRef MutVar# s a
v1# == :: STRef s a -> STRef s a -> Bool
== STRef MutVar# s a
v2# = Int# -> Bool
isTrue# (MutVar# s a -> MutVar# s a -> Int#
forall d k1. MutVar# d k1 -> MutVar# d k1 -> Int#
sameMutVar# MutVar# s a
v1# MutVar# s a
v2#)

instance Functor (ST s) where
  fmap :: (a -> b) -> ST s a -> ST s b
fmap a -> b
f (ST STRep (Any ~~ s) a
m) = STRep (Any ~~ s) b -> ST s b
forall s a. STRep (Any ~~ s) a -> ST s a
ST (STRep (Any ~~ s) b -> ST s b) -> STRep (Any ~~ s) b -> ST s b
forall a b. (a -> b) -> a -> b
$ \ State# (Any ~~ s)
s ->
    case (STRep (Any ~~ s) a
m State# (Any ~~ s)
s) of { (# State# (Any ~~ s)
new_s, a
r #) ->
      (# State# (Any ~~ s)
new_s, a -> b
f a
r #) }

instance Applicative (ST s) where
  {-# INLINE pure #-}
  {-# INLINE (*>) #-}
  pure :: a -> ST s a
pure a
x = STRep (Any ~~ s) a -> ST s a
forall s a. STRep (Any ~~ s) a -> ST s a
ST (\ State# (Any ~~ s)
s -> (# State# (Any ~~ s)
s, a
x #))
  ST s a
m *> :: ST s a -> ST s b -> ST s b
*> ST s b
k = ST s a
m ST s a -> (a -> ST s b) -> ST s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ a
_ -> ST s b
k
  <*> :: ST s (a -> b) -> ST s a -> ST s b
(<*>) = ST s (a -> b) -> ST s a -> ST s b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
  liftA2 :: (a -> b -> c) -> ST s a -> ST s b -> ST s c
liftA2 = (a -> b -> c) -> ST s a -> ST s b -> ST s c
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2

instance Monad (ST s) where
    {-# INLINE (>>=)  #-}
    >> :: ST s a -> ST s b -> ST s b
(>>) = ST s a -> ST s b -> ST s b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
(*>)
    (ST STRep (Any ~~ s) a
m) >>= :: ST s a -> (a -> ST s b) -> ST s b
>>= a -> ST s b
k
      = STRep (Any ~~ s) b -> ST s b
forall s a. STRep (Any ~~ s) a -> ST s a
ST (\ State# (Any ~~ s)
s ->
        case (STRep (Any ~~ s) a
m State# (Any ~~ s)
s) of { (# State# (Any ~~ s)
new_s, a
r #) ->
        case (a -> ST s b
k a
r) of { ST STRep (Any ~~ s) b
k2 ->
        (STRep (Any ~~ s) b
k2 State# (Any ~~ s)
new_s) }})

instance Semigroup a => Semigroup (ST s a) where
  <> :: ST s a -> ST s a -> ST s a
(<>) = (a -> a -> a) -> ST s a -> ST s a -> ST s a
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
(<>)

instance Monoid a => Monoid (ST s a) where
  mempty :: ST s a
mempty = a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
forall a. Monoid a => a
mempty
#if !(MIN_VERSION_base(4,11,0))
  mappend = liftA2 mappend
#endif

instance Show (ST s a) where
  showsPrec :: Int -> ST s a -> ShowS
showsPrec Int
_ ST s a
_ = String -> ShowS
showString String
"<<ST action>>"
  showList :: [ST s a] -> ShowS
showList      = (ST s a -> ShowS) -> [ST s a] -> ShowS
forall a. (a -> ShowS) -> [a] -> ShowS
showList__ (Int -> ST s a -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
0)

-- | A pretty type alias for 'Common'.
type s ∩ s' = Common s s'

-- | A type that shows that the state threads s and s' refer to a heap
--   region that overlaps in some way such that s and s' can both access
--   the overlap, while maintaining privacy in their own heap regions.
data Common s s'

-- | Move a variable that you own into a region with
--   common overlap.
share :: STRef s a -> ST s (STRef (Common s s') a)
{-# INLINE share #-}
share :: STRef s a -> ST s (STRef (Common s s') a)
share = STRef (Common s s') a -> ST s (STRef (Common s s') a)
forall (m :: * -> *) a. Monad m => a -> m a
return (STRef (Common s s') a -> ST s (STRef (Common s s') a))
-> (STRef s a -> STRef (Common s s') a)
-> STRef s a
-> ST s (STRef (Common s s') a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STRef s a -> STRef (Common s s') a
forall a b. a -> b
unsafeCoerce

-- | Lift an 'ST' computation into a context with another heap region
liftL :: ST s a -> ST (Common s s') a
{-# INLINE liftL #-}
liftL :: ST s a -> ST (Common s s') a
liftL = ST s a -> ST (Common s s') a
forall a b. a -> b
unsafeCoerce

-- | Lift an 'ST' computation into a context with another heap region
liftR :: ST s' a -> ST (Common s s') a
{-# INLINE liftR #-}
liftR :: ST s' a -> ST (Common s s') a
liftR = ST s' a -> ST (Common s s') a
forall a b. a -> b
unsafeCoerce

-- | Given proof that one has access to the heap regions s and s',
--   yield an STRef to the region s.
use :: STRef (Common s s') a -> STRef s a
{-# INLINE use #-}
use :: STRef (Common s s') a -> STRef s a
use = STRef (Common s s') a -> STRef s a
forall a b. a -> b
unsafeCoerce

-- | Given proof that one has access to the heap regions s and s',
--   yield an 'STRef' that swaps the order of the regions.
symm :: STRef (Common s s') a -> STRef (Common s' s) a
{-# INLINE symm #-}
symm :: STRef (Common s s') a -> STRef (Common s' s) a
symm = STRef (Common s s') a -> STRef (Common s' s) a
forall a b. a -> b
unsafeCoerce

-- | Return the value computed by a state transformer computation
--   over a shared heap. The @forall@ ensures that the internal state(s)
--   used by the 'ST' computation is inaccessible to the rest of the program.
runST2 :: (forall s s'. ST (Common s s') a) -> a
{-# INLINE runST2 #-}
runST2 :: (forall (s :: k) (s' :: k). ST (Common s s') a) -> a
runST2 (ST st_rep) = case (State# (Any ~~ Common Any Any)
 -> (# State# (Any ~~ Common Any Any), a #))
-> (# State# (Any ~~ Common Any Any), a #)
forall k o (s :: k). (State# (Any ~~ s) -> o) -> o
runRegion# State# (Any ~~ Common Any Any)
-> (# State# (Any ~~ Common Any Any), a #)
st_rep of (# State# (Any ~~ Common Any Any)
_, a
a #) -> a
a

-- | Return the value computed by a state transformer computation.
--   The @forall@ ensures that the internal state used by the 'ST'
--   computation is inaccessible to the rest of the program.
runST :: (forall s. ST s a) -> a
{-# INLINE runST #-}
runST :: (forall s. ST s a) -> a
runST (ST st_rep) = case (State# (Any ~~ Any) -> (# State# (Any ~~ Any), a #))
-> (# State# (Any ~~ Any), a #)
forall k o (s :: k). (State# (Any ~~ s) -> o) -> o
runRegion# State# (Any ~~ Any) -> (# State# (Any ~~ Any), a #)
st_rep of (# State# (Any ~~ Any)
_, a
a #) -> a
a

-- | Allow the result of a state transformer computation to be used (lazily)
-- inside the computation.
--
-- Note that if @f@ is strict, @'fixST' f = _|_@.
fixST :: (a -> ST s a) -> ST s a
-- See Note [fixST]
fixST :: (a -> ST s a) -> ST s a
fixST a -> ST s a
k = IO a -> ST s a
forall a s. IO a -> ST s a
unsafeIOToST (IO a -> ST s a) -> IO a -> ST s a
forall a b. (a -> b) -> a -> b
$ do
    MVar a
m <- IO (MVar a)
forall a. IO (MVar a)
newEmptyMVar
    a
ans <- IO a -> IO a
forall a. IO a -> IO a
unsafeDupableInterleaveIO
             (MVar a -> IO a
forall a. MVar a -> IO a
readMVar MVar a
m IO a -> (BlockedIndefinitelyOnMVar -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \BlockedIndefinitelyOnMVar
BlockedIndefinitelyOnMVar ->
                                    NonTermination -> IO a
forall e a. Exception e => e -> IO a
throwIO NonTermination
NonTermination)
    a
result <- ST s a -> IO a
forall s a. ST s a -> IO a
unsafeSTToIO (a -> ST s a
k a
ans)
    MVar a -> a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar a
m a
result
    a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
result

{- Note [fixST]
   ~~~~~~~~~~~~
For many years, we implemented fixST much like a pure fixpoint,
using liftST:
  fixST :: (a -> ST s a) -> ST s a
  fixST k = ST $ \ s ->
      let ans       = liftST (k r) s
          STret _ r = ans
      in
      case ans of STret s' x -> (# s', x #)
We knew that lazy blackholing could cause the computation to be re-run if the
result was demanded strictly, but we thought that would be okay in the case of
ST. However, that is not the case (see Trac #15349). Notably, the first time
the computation is executed, it may mutate variables that cause it to behave
*differently* the second time it's run. That may allow it to terminate when it
should not. More frighteningly, Arseniy Alekseyev produced a somewhat contrived
example ( https://mail.haskell.org/pipermail/libraries/2018-July/028889.html )
demonstrating that it can break reasonable assumptions in "trustworthy" code,
causing a memory safety violation. So now we implement fixST much like we do
fixIO. See also the implementation notes for fixIO. Simon Marlow wondered
whether we could get away with an IORef instead of an MVar. I believe we
cannot. The function passed to fixST may spark a parallel computation that
demands the final result. Such a computation should block until the final
result is available.
-}

runRegion# :: forall (r :: RuntimeRep) (o :: TYPE r) s.
           (State# (Any ~~ s) -> o) -> o
runRegion# :: (State# (Any ~~ s) -> o) -> o
runRegion# State# (Any ~~ s) -> o
m = (State# RealWorld -> o) -> o
forall o. (State# RealWorld -> o) -> o
GHCExts.runRW# ((State# (Any ~~ s) -> o) -> State# RealWorld -> o
unsafeCoerce# State# (Any ~~ s) -> o
m) -- m = m (rwToAny# realWorld#)
{-# INLINE runRegion# #-}

{- Note [runRegion#]
   ~~~~~~~~~~~~~~~~~
Originally, `runRegion#` was defined quite similarly to runRW#:
  runRegion# :: forall (r :: RuntimeRep) (o :: TYPE r) s.
    (State# (Any ~~ s) -> o) -> o
  runRegion# m = m (rwToAny# realWorld#)

But this definition is extremely brittle under optimisations! You should never
define a function that performs as `runRW#` does without defining it in _terms_
of `runRW#`. You can get semantically undesirable floating - runRW# is treated
specially by Core and inlined only very late in compilation, after floating is
complete. Below, I will inline "Note [runRW magic]" which is written in ghc's
compiler/coreSyn/CorePrep.hs:

Some definitions, for instance @runST@, must have careful control over float out
of the bindings in their body. Consider this use of @runST@,

    f x = runST ( \ s -> let (a, s')  = newArray# 100 [] s
                             (_, s'') = fill_in_array_or_something a x s'
                         in freezeArray# a s'' )

If we inline @runST@, we'll get:

    f x = let (a, s')  = newArray# 100 [] realWorld#{-NB-}
              (_, s'') = fill_in_array_or_something a x s'
          in freezeArray# a s''

And now if we allow the @newArray#@ binding to float out to become a CAF,
we end up with a result that is totally and utterly wrong:

    f = let (a, s')  = newArray# 100 [] realWorld#{-NB-} -- YIKES!!!
        in \ x ->
            let (_, s'') = fill_in_array_or_something a x s'
            in freezeArray# a s''

All calls to @f@ will share a {\em single} array! Clearly this is nonsense and
must be prevented.

This is what @runRW#@ gives us: by being inlined extremely late in the
optimization (right before lowering to STG, in CorePrep), we can ensure that
no further floating will occur. This allows us to safely inline things like
@runST@, which are otherwise needlessly expensive (see #10678 and #5916).

'runRW' is defined (for historical reasons) in GHC.Magic, with a NOINLINE
pragma.  It is levity-polymorphic.

    runRW# :: forall (r1 :: RuntimeRep). (o :: TYPE r)
           => (State# RealWorld -> (# State# RealWorld, o #))
                              -> (# State# RealWorld, o #)

It needs no special treatment in GHC except this special inlining
in CorePrep (and in ByteCodeGen).

-}

rwToAny# :: forall s s'. State# s' -> State# (Any ~~ s)
rwToAny# :: State# s' -> State# (Any ~~ s)
rwToAny# State# s'
x# = State# s' -> State# (Any ~~ s)
unsafeCoerce# State# s'
x#
{-# INLINE rwToAny# #-}

rwFromAny# :: forall s s'. State# (Any ~~ s) -> State# s'
rwFromAny# :: State# (Any ~~ s) -> State# s'
rwFromAny# State# (Any ~~ s)
x# = State# (Any ~~ s) -> State# s'
unsafeCoerce# State# (Any ~~ s)
x#
{-# INLINE rwFromAny# #-}

--rwTupleFromAny# :: forall s a. (# State# (Any ~~ s), a #) -> (# State# s, a #)
--rwTupleFromAny# (# x, a #) = (# unsafeCoerce# x, a #)

rwTupleToAny# :: forall s a. (# State# s, a #) -> (# State# (Any ~~ s), a #)
rwTupleToAny# :: (# State# s, a #) -> (# State# (Any ~~ s), a #)
rwTupleToAny# (# State# s
x, a
a #) = (# State# s -> State# (Any ~~ s)
unsafeCoerce# State# s
x, a
a #)
{-# INLINE rwTupleToAny# #-}

repToAny# :: (State# s -> (# State# s, a #)) -> STRep (Any ~~ s) a
repToAny# :: (State# s -> (# State# s, a #)) -> STRep (Any ~~ s) a
repToAny# = (State# s -> (# State# s, a #)) -> STRep (Any ~~ s) a
unsafeCoerce#
{-# INLINE repToAny# #-}

repFromAny# :: STRep (Any ~~ s) a -> (State# s -> (# State# s, a #))
repFromAny# :: STRep (Any ~~ s) a -> State# s -> (# State# s, a #)
repFromAny# = STRep (Any ~~ s) a -> State# s -> (# State# s, a #)
unsafeCoerce#
{-# INLINE repFromAny# #-}