{-# language UnboxedTuples #-}
{-# language UnboxedSums #-}
{-# language RoleAnnotations #-}
{-# language ScopedTypeVariables #-}
{-# language TypeFamilies #-}
{-# language MagicHash #-}
{-# language RankNTypes #-}
{-# language PatternSynonyms #-}
{-# language ViewPatterns #-}
{-# language BangPatterns #-}
{- options_ghc -ddump-simpl #-}

-- | This module includes all the features of "Control.Concurrent.MVar", except
-- that the functions in "Data.Primitive.Unlifted.Weak" subsume the functionality
-- of @mkWeakMV@ and @addMVarFinalizer@, so we do not include analogues of those
-- functions.
module Data.Primitive.Unlifted.MVar.ST
  ( UnliftedMVar_ (..)
  , UnliftedMVar
  , newUnliftedMVar
  , newEmptyUnliftedMVar
  , takeUnliftedMVar
  , tryTakeUnliftedMVar
  , putUnliftedMVar
  , tryPutUnliftedMVar
  , readUnliftedMVar
  , tryReadUnliftedMVar
  , isEmptyUnliftedMVar
  , swapUnliftedMVar
  , withUnliftedMVar
  , withUnliftedMVarMasked
  , modifyUnliftedMVar
  , modifyUnliftedMVar_
  , modifyUnliftedMVarMasked
  , modifyUnliftedMVarMasked_
  ) where
import Data.Primitive.Unlifted.Class (PrimUnlifted (..))
import Data.Primitive.Unlifted.MVar.Primops
import Data.Primitive.Unlifted.Box
import GHC.Exts (isTrue#, State#, RealWorld)
import GHC.ST (ST (..))
import GHC.IO (IO (..))
import qualified Control.Exception as E -- (mask, mask_, onException)
import Control.Monad.Primitive (primToST, stToPrim)
import Data.Coerce (coerce)

mask :: ((forall a. ST RealWorld a -> ST RealWorld a) -> ST RealWorld b) -> ST RealWorld b
{-# INLINE mask #-}
mask :: ((forall a. ST RealWorld a -> ST RealWorld a) -> ST RealWorld b)
-> ST RealWorld b
mask (forall a. ST RealWorld a -> ST RealWorld a) -> ST RealWorld b
f = IO b -> ST (PrimState IO) b
forall (m :: * -> *) a. PrimBase m => m a -> ST (PrimState m) a
primToST (IO b -> ST (PrimState IO) b) -> IO b -> ST (PrimState IO) b
forall a b. (a -> b) -> a -> b
$ ((forall a. IO a -> IO a) -> IO b) -> IO b
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
E.mask (\forall a. IO a -> IO a
restore -> ST (PrimState IO) b -> IO b
forall (m :: * -> *) a. PrimMonad m => ST (PrimState m) a -> m a
stToPrim (ST (PrimState IO) b -> IO b) -> ST (PrimState IO) b -> IO b
forall a b. (a -> b) -> a -> b
$ (forall a. ST RealWorld a -> ST RealWorld a) -> ST RealWorld b
f (IO a -> ST RealWorld a
forall (m :: * -> *) a. PrimBase m => m a -> ST (PrimState m) a
primToST (IO a -> ST RealWorld a)
-> (ST RealWorld a -> IO a) -> ST RealWorld a -> ST RealWorld a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> IO a
forall a. IO a -> IO a
restore (IO a -> IO a)
-> (ST RealWorld a -> IO a) -> ST RealWorld a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ST RealWorld a -> IO a
forall (m :: * -> *) a. PrimMonad m => ST (PrimState m) a -> m a
stToPrim))

mask_ :: ST RealWorld a -> ST RealWorld a
{-# INLINE mask_ #-}
mask_ :: ST RealWorld a -> ST RealWorld a
mask_ ST RealWorld a
f = ((forall a. ST RealWorld a -> ST RealWorld a) -> ST RealWorld a)
-> ST RealWorld a
forall b.
((forall a. ST RealWorld a -> ST RealWorld a) -> ST RealWorld b)
-> ST RealWorld b
mask (((forall a. ST RealWorld a -> ST RealWorld a) -> ST RealWorld a)
 -> ST RealWorld a)
-> ((forall a. ST RealWorld a -> ST RealWorld a) -> ST RealWorld a)
-> ST RealWorld a
forall a b. (a -> b) -> a -> b
$ \forall a. ST RealWorld a -> ST RealWorld a
_ -> ST RealWorld a
f

primitive_ :: (State# s -> State# s) -> ST s ()
{-# INLINE primitive_ #-}
primitive_ :: (State# s -> State# s) -> ST s ()
primitive_ State# s -> State# s
f = STRep s () -> ST s ()
forall s a. STRep s a -> ST s a
ST (\State# s
s -> (# State# s -> State# s
f State# s
s, () #))

onException :: forall a b. ST RealWorld a -> ST RealWorld b -> ST RealWorld a
{-# INLINE onException #-}
onException :: ST RealWorld a -> ST RealWorld b -> ST RealWorld a
onException = (IO a -> IO b -> IO a)
-> ST RealWorld a -> ST RealWorld b -> ST RealWorld a
coerce (IO a -> IO b -> IO a
forall a b. IO a -> IO b -> IO a
E.onException :: IO a -> IO b -> IO a)

data UnliftedMVar_ s a unlifted_a
  = UnliftedMVar (UnliftedMVar# s unlifted_a)
type role UnliftedMVar_ nominal phantom representational

type UnliftedMVar s a = UnliftedMVar_ s a (Unlifted a)

instance unlifted_a ~ Unlifted a => PrimUnlifted (UnliftedMVar_ s a unlifted_a) where
  {-# INLINE toUnlifted# #-}
  {-# INLINE fromUnlifted# #-}
  type Unlifted (UnliftedMVar_ s _ unlifted_a) = UnliftedMVar# s unlifted_a
  toUnlifted# :: UnliftedMVar_ s a unlifted_a
-> Unlifted (UnliftedMVar_ s a unlifted_a)
toUnlifted# (UnliftedMVar UnliftedMVar# s unlifted_a
mv) = Unlifted (UnliftedMVar_ s a unlifted_a)
UnliftedMVar# s unlifted_a
mv
  fromUnlifted# :: Unlifted (UnliftedMVar_ s a unlifted_a)
-> UnliftedMVar_ s a unlifted_a
fromUnlifted# Unlifted (UnliftedMVar_ s a unlifted_a)
mv = UnliftedMVar# s unlifted_a -> UnliftedMVar_ s a unlifted_a
forall s a (unlifted_a :: TYPE 'UnliftedRep).
UnliftedMVar# s unlifted_a -> UnliftedMVar_ s a unlifted_a
UnliftedMVar Unlifted (UnliftedMVar_ s a unlifted_a)
UnliftedMVar# s unlifted_a
mv

instance unlifted_a ~ Unlifted a => Eq (UnliftedMVar_ s a unlifted_a) where
  {-# INLINE (==) #-}
  UnliftedMVar UnliftedMVar# s unlifted_a
mv1 == :: UnliftedMVar_ s a unlifted_a
-> UnliftedMVar_ s a unlifted_a -> Bool
== UnliftedMVar UnliftedMVar# s unlifted_a
mv2
    = Int# -> Bool
isTrue# (UnliftedMVar# s unlifted_a -> UnliftedMVar# s unlifted_a -> Int#
forall s (a :: TYPE 'UnliftedRep).
UnliftedMVar# s a -> UnliftedMVar# s a -> Int#
sameUnliftedMVar# UnliftedMVar# s unlifted_a
mv1 UnliftedMVar# s unlifted_a
mv2)

newUnliftedMVar
  :: PrimUnlifted a
  => a -> ST s (UnliftedMVar s a)
newUnliftedMVar :: a -> ST s (UnliftedMVar s a)
newUnliftedMVar a
a = do
  UnliftedMVar s a
mv <- ST s (UnliftedMVar s a)
forall s a. ST s (UnliftedMVar s a)
newEmptyUnliftedMVar
  UnliftedMVar s a -> a -> ST s ()
forall a s. PrimUnlifted a => UnliftedMVar s a -> a -> ST s ()
putUnliftedMVar UnliftedMVar s a
mv a
a
  UnliftedMVar s a -> ST s (UnliftedMVar s a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure UnliftedMVar s a
mv

newEmptyUnliftedMVar :: ST s (UnliftedMVar s a)
{-# INLINE newEmptyUnliftedMVar #-}
newEmptyUnliftedMVar :: ST s (UnliftedMVar s a)
newEmptyUnliftedMVar = STRep s (UnliftedMVar s a) -> ST s (UnliftedMVar s a)
forall s a. STRep s a -> ST s a
ST (STRep s (UnliftedMVar s a) -> ST s (UnliftedMVar s a))
-> STRep s (UnliftedMVar s a) -> ST s (UnliftedMVar s a)
forall a b. (a -> b) -> a -> b
$ \State# s
s -> case State# s -> (# State# s, UnliftedMVar# s (Unlifted a) #)
forall s (a :: TYPE 'UnliftedRep).
State# s -> (# State# s, UnliftedMVar# s a #)
newUnliftedMVar# State# s
s of
  (# State# s
s', UnliftedMVar# s (Unlifted a)
mv #) -> (# State# s
s', UnliftedMVar# s (Unlifted a) -> UnliftedMVar s a
forall s a (unlifted_a :: TYPE 'UnliftedRep).
UnliftedMVar# s unlifted_a -> UnliftedMVar_ s a unlifted_a
UnliftedMVar UnliftedMVar# s (Unlifted a)
mv #)

takeUnliftedMVar
  :: PrimUnlifted a
  => UnliftedMVar s a -> ST s a
{-# INLINE takeUnliftedMVar #-}
takeUnliftedMVar :: UnliftedMVar s a -> ST s a
takeUnliftedMVar = UnliftedMVar s a -> ST s a
forall a s x.
PrimUnlifted a =>
UnliftedMVar_ s x (Unlifted a) -> ST s a
takeUnliftedMVar_

takeUnliftedMVarBox
  :: UnliftedMVar_ s x unlifted_a -> ST s (Box unlifted_a)
{-# INLINE takeUnliftedMVarBox #-}
takeUnliftedMVarBox :: UnliftedMVar_ s x unlifted_a -> ST s (Box unlifted_a)
takeUnliftedMVarBox = UnliftedMVar_ s x unlifted_a -> ST s (Box unlifted_a)
forall a s x.
PrimUnlifted a =>
UnliftedMVar_ s x (Unlifted a) -> ST s a
takeUnliftedMVar_

-- A version of takeUnliftedMVar that doesn't care about the
-- lifted type. We use this to specialize to Box so things can
-- get simplified more aggressively. This also avoids any
-- risk of exceptions happening in unexpected places in case
-- @toUnlifted#@ or @fromUnlifted#@ should fail.
takeUnliftedMVar_
  :: PrimUnlifted a
  => UnliftedMVar_ s x (Unlifted a) -> ST s a
{-# INLINE takeUnliftedMVar_ #-}
takeUnliftedMVar_ :: UnliftedMVar_ s x (Unlifted a) -> ST s a
takeUnliftedMVar_ (UnliftedMVar UnliftedMVar# s (Unlifted a)
mv) = STRep s a -> ST s a
forall s a. STRep s a -> ST s a
ST (STRep s a -> ST s a) -> STRep s a -> ST s a
forall a b. (a -> b) -> a -> b
$ \State# s
s ->
  case UnliftedMVar# s (Unlifted a)
-> State# s -> (# State# s, Unlifted a #)
forall s (a :: TYPE 'UnliftedRep).
UnliftedMVar# s a -> State# s -> (# State# s, a #)
takeUnliftedMVar# UnliftedMVar# s (Unlifted a)
mv State# s
s of
    (# State# s
s', Unlifted a
a #) -> (# State# s
s', Unlifted a -> a
forall a. PrimUnlifted a => Unlifted a -> a
fromUnlifted# Unlifted a
a #)

tryTakeUnliftedMVar
  :: PrimUnlifted a
  => UnliftedMVar s a -> ST s (Maybe a)
{-# INLINE tryTakeUnliftedMVar #-}
tryTakeUnliftedMVar :: UnliftedMVar s a -> ST s (Maybe a)
tryTakeUnliftedMVar (UnliftedMVar UnliftedMVar# s (Unlifted a)
mv) = STRep s (Maybe a) -> ST s (Maybe a)
forall s a. STRep s a -> ST s a
ST (STRep s (Maybe a) -> ST s (Maybe a))
-> STRep s (Maybe a) -> ST s (Maybe a)
forall a b. (a -> b) -> a -> b
$ \State# s
s ->
  case UnliftedMVar# s (Unlifted a)
-> State# s -> (# State# s, (# (# #) | Unlifted a #) #)
forall s (a :: TYPE 'UnliftedRep).
UnliftedMVar# s a -> State# s -> (# State# s, (# (# #) | a #) #)
tryTakeUnliftedMVar# UnliftedMVar# s (Unlifted a)
mv State# s
s of
    (# State# s
s', (# | Unlifted a
a #) #) -> (# State# s
s', a -> Maybe a
forall a. a -> Maybe a
Just (Unlifted a -> a
forall a. PrimUnlifted a => Unlifted a -> a
fromUnlifted# Unlifted a
a) #)
    (# State# s
s', (# (##) | #) #) -> (# State# s
s', Maybe a
forall a. Maybe a
Nothing #)

putUnliftedMVar
  :: PrimUnlifted a
  => UnliftedMVar s a -> a -> ST s ()
{-# INLINE putUnliftedMVar #-}
putUnliftedMVar :: UnliftedMVar s a -> a -> ST s ()
putUnliftedMVar = UnliftedMVar s a -> a -> ST s ()
forall a s x.
PrimUnlifted a =>
UnliftedMVar_ s x (Unlifted a) -> a -> ST s ()
putUnliftedMVar_

putUnliftedMVarBox
  :: UnliftedMVar_ s x unlifted_a -> Box unlifted_a -> ST s ()
{-# INLINE putUnliftedMVarBox #-}
putUnliftedMVarBox :: UnliftedMVar_ s x unlifted_a -> Box unlifted_a -> ST s ()
putUnliftedMVarBox = UnliftedMVar_ s x unlifted_a -> Box unlifted_a -> ST s ()
forall a s x.
PrimUnlifted a =>
UnliftedMVar_ s x (Unlifted a) -> a -> ST s ()
putUnliftedMVar_

-- A version of putUnliftedMVar that doesn't care about the
-- lifted type. We use this to specialize to Box so things can
-- get simplified more aggressively. This also avoids any
-- risk of exceptions happening in unexpected places in case
-- @toUnlifted#@ or @fromUnlifted#@ should fail.
putUnliftedMVar_
  :: PrimUnlifted a
  => UnliftedMVar_ s x (Unlifted a) -> a -> ST s ()
{-# INLINE putUnliftedMVar_ #-}
putUnliftedMVar_ :: UnliftedMVar_ s x (Unlifted a) -> a -> ST s ()
putUnliftedMVar_ (UnliftedMVar UnliftedMVar# s (Unlifted a)
mv) a
a = (State# s -> State# s) -> ST s ()
forall s. (State# s -> State# s) -> ST s ()
primitive_ ((State# s -> State# s) -> ST s ())
-> (State# s -> State# s) -> ST s ()
forall a b. (a -> b) -> a -> b
$
  UnliftedMVar# s (Unlifted a) -> Unlifted a -> State# s -> State# s
forall s (a :: TYPE 'UnliftedRep).
UnliftedMVar# s a -> a -> State# s -> State# s
putUnliftedMVar# UnliftedMVar# s (Unlifted a)
mv (a -> Unlifted a
forall a. PrimUnlifted a => a -> Unlifted a
toUnlifted# a
a)

tryPutUnliftedMVar
  :: PrimUnlifted a
  => UnliftedMVar s a -> a -> ST s Bool
{-# INLINE tryPutUnliftedMVar #-}
tryPutUnliftedMVar :: UnliftedMVar s a -> a -> ST s Bool
tryPutUnliftedMVar (UnliftedMVar UnliftedMVar# s (Unlifted a)
mv) a
a = STRep s Bool -> ST s Bool
forall s a. STRep s a -> ST s a
ST (STRep s Bool -> ST s Bool) -> STRep s Bool -> ST s Bool
forall a b. (a -> b) -> a -> b
$ \State# s
s ->
  case UnliftedMVar# s (Unlifted a)
-> Unlifted a -> State# s -> (# State# s, Int# #)
forall s (a :: TYPE 'UnliftedRep).
UnliftedMVar# s a -> a -> State# s -> (# State# s, Int# #)
tryPutUnliftedMVar# UnliftedMVar# s (Unlifted a)
mv (a -> Unlifted a
forall a. PrimUnlifted a => a -> Unlifted a
toUnlifted# a
a) State# s
s of
    (# State# s
s', Int#
0# #) -> (# State# s
s', Bool
False #)
    (# State# s
s', Int#
_ #) -> (# State# s
s', Bool
True #)

readUnliftedMVar
  :: PrimUnlifted a
  => UnliftedMVar s a -> ST s a
{-# INLINE readUnliftedMVar #-}
readUnliftedMVar :: UnliftedMVar s a -> ST s a
readUnliftedMVar (UnliftedMVar UnliftedMVar# s (Unlifted a)
mv) = STRep s a -> ST s a
forall s a. STRep s a -> ST s a
ST (STRep s a -> ST s a) -> STRep s a -> ST s a
forall a b. (a -> b) -> a -> b
$ \State# s
s ->
  case UnliftedMVar# s (Unlifted a)
-> State# s -> (# State# s, Unlifted a #)
forall s (a :: TYPE 'UnliftedRep).
UnliftedMVar# s a -> State# s -> (# State# s, a #)
readUnliftedMVar# UnliftedMVar# s (Unlifted a)
mv State# s
s of
    (# State# s
s', Unlifted a
a #) -> (# State# s
s', Unlifted a -> a
forall a. PrimUnlifted a => Unlifted a -> a
fromUnlifted# Unlifted a
a #)

tryReadUnliftedMVar
  :: PrimUnlifted a
  => UnliftedMVar s a -> ST s (Maybe a)
{-# INLINE tryReadUnliftedMVar #-}
tryReadUnliftedMVar :: UnliftedMVar s a -> ST s (Maybe a)
tryReadUnliftedMVar (UnliftedMVar UnliftedMVar# s (Unlifted a)
mv) = STRep s (Maybe a) -> ST s (Maybe a)
forall s a. STRep s a -> ST s a
ST (STRep s (Maybe a) -> ST s (Maybe a))
-> STRep s (Maybe a) -> ST s (Maybe a)
forall a b. (a -> b) -> a -> b
$ \State# s
s ->
  case UnliftedMVar# s (Unlifted a)
-> State# s -> (# State# s, (# (# #) | Unlifted a #) #)
forall s (a :: TYPE 'UnliftedRep).
UnliftedMVar# s a -> State# s -> (# State# s, (# (# #) | a #) #)
tryReadUnliftedMVar# UnliftedMVar# s (Unlifted a)
mv State# s
s of
    (# State# s
s', (# (##) | #) #) -> (# State# s
s', Maybe a
forall a. Maybe a
Nothing #)
    (# State# s
s', (# | Unlifted a
a #) #) -> (# State# s
s', a -> Maybe a
forall a. a -> Maybe a
Just (Unlifted a -> a
forall a. PrimUnlifted a => Unlifted a -> a
fromUnlifted# Unlifted a
a) #)

isEmptyUnliftedMVar
  :: UnliftedMVar s a -> ST s Bool
{-# INLINE isEmptyUnliftedMVar #-}
isEmptyUnliftedMVar :: UnliftedMVar s a -> ST s Bool
isEmptyUnliftedMVar (UnliftedMVar UnliftedMVar# s (Unlifted a)
mv) = STRep s Bool -> ST s Bool
forall s a. STRep s a -> ST s a
ST (STRep s Bool -> ST s Bool) -> STRep s Bool -> ST s Bool
forall a b. (a -> b) -> a -> b
$ \State# s
s ->
  case UnliftedMVar# s (Unlifted a) -> State# s -> (# State# s, Int# #)
forall s (a :: TYPE 'UnliftedRep).
UnliftedMVar# s a -> State# s -> (# State# s, Int# #)
isEmptyUnliftedMVar# UnliftedMVar# s (Unlifted a)
mv State# s
s of
    (# State# s
s', Int#
0# #) -> (# State# s
s', Bool
False #)
    (# State# s
s', Int#
_ #) -> (# State# s
s', Bool
True #)

swapUnliftedMVar
  :: PrimUnlifted a
  => UnliftedMVar RealWorld a -> a -> ST RealWorld a
{-# INLINE swapUnliftedMVar #-}
swapUnliftedMVar :: UnliftedMVar RealWorld a -> a -> ST RealWorld a
swapUnliftedMVar UnliftedMVar RealWorld a
mvar a
new =
  Box (Unlifted a) -> a
forall a. PrimUnlifted a => Box (Unlifted a) -> a
fromBox (Box (Unlifted a) -> a)
-> ST RealWorld (Box (Unlifted a)) -> ST RealWorld a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ST RealWorld (Box (Unlifted a)) -> ST RealWorld (Box (Unlifted a))
forall a. ST RealWorld a -> ST RealWorld a
mask_ (ST RealWorld (Box (Unlifted a))
 -> ST RealWorld (Box (Unlifted a)))
-> ST RealWorld (Box (Unlifted a))
-> ST RealWorld (Box (Unlifted a))
forall a b. (a -> b) -> a -> b
$ do
     Box (Unlifted a)
old <- UnliftedMVar RealWorld a -> ST RealWorld (Box (Unlifted a))
forall s x (unlifted_a :: TYPE 'UnliftedRep).
UnliftedMVar_ s x unlifted_a -> ST s (Box unlifted_a)
takeUnliftedMVarBox UnliftedMVar RealWorld a
mvar
     UnliftedMVar RealWorld a -> Box (Unlifted a) -> ST RealWorld ()
forall s x (unlifted_a :: TYPE 'UnliftedRep).
UnliftedMVar_ s x unlifted_a -> Box unlifted_a -> ST s ()
putUnliftedMVarBox UnliftedMVar RealWorld a
mvar Box (Unlifted a)
new_box
     Box (Unlifted a) -> ST RealWorld (Box (Unlifted a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Box (Unlifted a)
old)
  where !new_box :: Box (Unlifted a)
new_box = a -> Box (Unlifted a)
forall a. PrimUnlifted a => a -> Box (Unlifted a)
toBox a
new

withUnliftedMVar
  :: PrimUnlifted a
  => UnliftedMVar RealWorld a -> (a -> ST RealWorld b) -> ST RealWorld b
{-# INLINE withUnliftedMVar #-}
withUnliftedMVar :: UnliftedMVar RealWorld a -> (a -> ST RealWorld b) -> ST RealWorld b
withUnliftedMVar UnliftedMVar RealWorld a
m a -> ST RealWorld b
f =
  ((forall a. ST RealWorld a -> ST RealWorld a) -> ST RealWorld b)
-> ST RealWorld b
forall b.
((forall a. ST RealWorld a -> ST RealWorld a) -> ST RealWorld b)
-> ST RealWorld b
mask (((forall a. ST RealWorld a -> ST RealWorld a) -> ST RealWorld b)
 -> ST RealWorld b)
-> ((forall a. ST RealWorld a -> ST RealWorld a) -> ST RealWorld b)
-> ST RealWorld b
forall a b. (a -> b) -> a -> b
$ \forall a. ST RealWorld a -> ST RealWorld a
restore -> do
    Box (Unlifted a)
a <- UnliftedMVar RealWorld a -> ST RealWorld (Box (Unlifted a))
forall s x (unlifted_a :: TYPE 'UnliftedRep).
UnliftedMVar_ s x unlifted_a -> ST s (Box unlifted_a)
takeUnliftedMVarBox UnliftedMVar RealWorld a
m
    b
b <- ST RealWorld b -> ST RealWorld b
forall a. ST RealWorld a -> ST RealWorld a
restore (a -> ST RealWorld b
f (Box (Unlifted a) -> a
forall a. PrimUnlifted a => Box (Unlifted a) -> a
fromBox Box (Unlifted a)
a)) ST RealWorld b -> ST RealWorld () -> ST RealWorld b
forall a b. ST RealWorld a -> ST RealWorld b -> ST RealWorld a
`onException` UnliftedMVar RealWorld a -> Box (Unlifted a) -> ST RealWorld ()
forall s x (unlifted_a :: TYPE 'UnliftedRep).
UnliftedMVar_ s x unlifted_a -> Box unlifted_a -> ST s ()
putUnliftedMVarBox UnliftedMVar RealWorld a
m Box (Unlifted a)
a
    UnliftedMVar RealWorld a -> Box (Unlifted a) -> ST RealWorld ()
forall s x (unlifted_a :: TYPE 'UnliftedRep).
UnliftedMVar_ s x unlifted_a -> Box unlifted_a -> ST s ()
putUnliftedMVarBox UnliftedMVar RealWorld a
m Box (Unlifted a)
a
    b -> ST RealWorld b
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
b

withUnliftedMVarMasked
  :: PrimUnlifted a
  => UnliftedMVar RealWorld a -> (a -> ST RealWorld b) -> ST RealWorld b
{-# INLINE withUnliftedMVarMasked #-}
withUnliftedMVarMasked :: UnliftedMVar RealWorld a -> (a -> ST RealWorld b) -> ST RealWorld b
withUnliftedMVarMasked UnliftedMVar RealWorld a
m a -> ST RealWorld b
st =
  ST RealWorld b -> ST RealWorld b
forall a. ST RealWorld a -> ST RealWorld a
mask_ (ST RealWorld b -> ST RealWorld b)
-> ST RealWorld b -> ST RealWorld b
forall a b. (a -> b) -> a -> b
$ do
    Box (Unlifted a)
a <- UnliftedMVar RealWorld a -> ST RealWorld (Box (Unlifted a))
forall s x (unlifted_a :: TYPE 'UnliftedRep).
UnliftedMVar_ s x unlifted_a -> ST s (Box unlifted_a)
takeUnliftedMVarBox UnliftedMVar RealWorld a
m
    b
b <- a -> ST RealWorld b
st (Box (Unlifted a) -> a
forall a. PrimUnlifted a => Box (Unlifted a) -> a
fromBox Box (Unlifted a)
a) ST RealWorld b -> ST RealWorld () -> ST RealWorld b
forall a b. ST RealWorld a -> ST RealWorld b -> ST RealWorld a
`onException` UnliftedMVar RealWorld a -> Box (Unlifted a) -> ST RealWorld ()
forall s x (unlifted_a :: TYPE 'UnliftedRep).
UnliftedMVar_ s x unlifted_a -> Box unlifted_a -> ST s ()
putUnliftedMVarBox UnliftedMVar RealWorld a
m Box (Unlifted a)
a
    UnliftedMVar RealWorld a -> Box (Unlifted a) -> ST RealWorld ()
forall s x (unlifted_a :: TYPE 'UnliftedRep).
UnliftedMVar_ s x unlifted_a -> Box unlifted_a -> ST s ()
putUnliftedMVarBox UnliftedMVar RealWorld a
m Box (Unlifted a)
a
    b -> ST RealWorld b
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
b

data HalfUnlifted a b = HalfUnlifted !(Box (Unlifted a)) b

-- Note:
-- Except in the "masked" functions, we are careful not to use
-- toUnlifted# or fromUnlifted# with exceptions masked. In theory, those
-- operations could be slow.
--
-- mask, mask_, and onException deal in lifted values, which is a bit
-- annoying. The underlying primops do too. I wonder if that's essential.
-- Could we unsafeCoerce# our way to glory and let these functions return
-- unlifted pointers and even actions producing unboxed tuples?

modifyUnliftedMVar
  :: forall a b. PrimUnlifted a
  => UnliftedMVar RealWorld a -> (a -> ST RealWorld (a, b)) -> ST RealWorld b
{-# INLINE modifyUnliftedMVar #-}
modifyUnliftedMVar :: UnliftedMVar RealWorld a
-> (a -> ST RealWorld (a, b)) -> ST RealWorld b
modifyUnliftedMVar UnliftedMVar RealWorld a
m a -> ST RealWorld (a, b)
st =
  ((forall a. ST RealWorld a -> ST RealWorld a) -> ST RealWorld b)
-> ST RealWorld b
forall b.
((forall a. ST RealWorld a -> ST RealWorld a) -> ST RealWorld b)
-> ST RealWorld b
mask (((forall a. ST RealWorld a -> ST RealWorld a) -> ST RealWorld b)
 -> ST RealWorld b)
-> ((forall a. ST RealWorld a -> ST RealWorld a) -> ST RealWorld b)
-> ST RealWorld b
forall a b. (a -> b) -> a -> b
$ \forall a. ST RealWorld a -> ST RealWorld a
restore -> do
    Box (Unlifted a)
a <- UnliftedMVar RealWorld a -> ST RealWorld (Box (Unlifted a))
forall s x (unlifted_a :: TYPE 'UnliftedRep).
UnliftedMVar_ s x unlifted_a -> ST s (Box unlifted_a)
takeUnliftedMVarBox UnliftedMVar RealWorld a
m
    HalfUnlifted Box (Unlifted a)
a' b
b :: HalfUnlifted a b <- ST RealWorld (HalfUnlifted a b) -> ST RealWorld (HalfUnlifted a b)
forall a. ST RealWorld a -> ST RealWorld a
restore
      (do
         (a
a', b
b) <- a -> ST RealWorld (a, b)
st (Box (Unlifted a) -> a
forall a. PrimUnlifted a => Box (Unlifted a) -> a
fromBox Box (Unlifted a)
a)
         HalfUnlifted a b -> ST RealWorld (HalfUnlifted a b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HalfUnlifted a b -> ST RealWorld (HalfUnlifted a b))
-> HalfUnlifted a b -> ST RealWorld (HalfUnlifted a b)
forall a b. (a -> b) -> a -> b
$! Box (Unlifted a) -> b -> HalfUnlifted a b
forall a b. Box (Unlifted a) -> b -> HalfUnlifted a b
HalfUnlifted (a -> Box (Unlifted a)
forall a. PrimUnlifted a => a -> Box (Unlifted a)
toBox a
a') b
b) ST RealWorld (HalfUnlifted a b)
-> ST RealWorld () -> ST RealWorld (HalfUnlifted a b)
forall a b. ST RealWorld a -> ST RealWorld b -> ST RealWorld a
`onException` UnliftedMVar RealWorld a -> Box (Unlifted a) -> ST RealWorld ()
forall s x (unlifted_a :: TYPE 'UnliftedRep).
UnliftedMVar_ s x unlifted_a -> Box unlifted_a -> ST s ()
putUnliftedMVarBox UnliftedMVar RealWorld a
m Box (Unlifted a)
a
    UnliftedMVar RealWorld a -> Box (Unlifted a) -> ST RealWorld ()
forall s x (unlifted_a :: TYPE 'UnliftedRep).
UnliftedMVar_ s x unlifted_a -> Box unlifted_a -> ST s ()
putUnliftedMVarBox UnliftedMVar RealWorld a
m Box (Unlifted a)
a'
    b -> ST RealWorld b
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
b

modifyUnliftedMVar_
  :: PrimUnlifted a
  => UnliftedMVar RealWorld a -> (a -> ST RealWorld a) -> ST RealWorld ()
{-# INLINE modifyUnliftedMVar_ #-}
modifyUnliftedMVar_ :: UnliftedMVar RealWorld a
-> (a -> ST RealWorld a) -> ST RealWorld ()
modifyUnliftedMVar_ UnliftedMVar RealWorld a
m a -> ST RealWorld a
st =
  ((forall a. ST RealWorld a -> ST RealWorld a) -> ST RealWorld ())
-> ST RealWorld ()
forall b.
((forall a. ST RealWorld a -> ST RealWorld a) -> ST RealWorld b)
-> ST RealWorld b
mask (((forall a. ST RealWorld a -> ST RealWorld a) -> ST RealWorld ())
 -> ST RealWorld ())
-> ((forall a. ST RealWorld a -> ST RealWorld a)
    -> ST RealWorld ())
-> ST RealWorld ()
forall a b. (a -> b) -> a -> b
$ \forall a. ST RealWorld a -> ST RealWorld a
restore -> do
    Box (Unlifted a)
a  <- UnliftedMVar RealWorld a -> ST RealWorld (Box (Unlifted a))
forall s x (unlifted_a :: TYPE 'UnliftedRep).
UnliftedMVar_ s x unlifted_a -> ST s (Box unlifted_a)
takeUnliftedMVarBox UnliftedMVar RealWorld a
m
    Box (Unlifted a)
a' <- ST RealWorld (Box (Unlifted a)) -> ST RealWorld (Box (Unlifted a))
forall a. ST RealWorld a -> ST RealWorld a
restore (a -> Box (Unlifted a)
forall a. PrimUnlifted a => a -> Box (Unlifted a)
toBox (a -> Box (Unlifted a))
-> ST RealWorld a -> ST RealWorld (Box (Unlifted a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> ST RealWorld a
st (Box (Unlifted a) -> a
forall a. PrimUnlifted a => Box (Unlifted a) -> a
fromBox Box (Unlifted a)
a)) ST RealWorld (Box (Unlifted a))
-> ST RealWorld () -> ST RealWorld (Box (Unlifted a))
forall a b. ST RealWorld a -> ST RealWorld b -> ST RealWorld a
`onException` UnliftedMVar RealWorld a -> Box (Unlifted a) -> ST RealWorld ()
forall s x (unlifted_a :: TYPE 'UnliftedRep).
UnliftedMVar_ s x unlifted_a -> Box unlifted_a -> ST s ()
putUnliftedMVarBox UnliftedMVar RealWorld a
m Box (Unlifted a)
a
    UnliftedMVar RealWorld a -> Box (Unlifted a) -> ST RealWorld ()
forall s x (unlifted_a :: TYPE 'UnliftedRep).
UnliftedMVar_ s x unlifted_a -> Box unlifted_a -> ST s ()
putUnliftedMVarBox UnliftedMVar RealWorld a
m Box (Unlifted a)
a'

modifyUnliftedMVarMasked
  :: forall a b. PrimUnlifted a
  => UnliftedMVar RealWorld a -> (a -> ST RealWorld (a, b)) -> ST RealWorld b
{-# INLINE modifyUnliftedMVarMasked #-}
modifyUnliftedMVarMasked :: UnliftedMVar RealWorld a
-> (a -> ST RealWorld (a, b)) -> ST RealWorld b
modifyUnliftedMVarMasked UnliftedMVar RealWorld a
m a -> ST RealWorld (a, b)
st =
  ST RealWorld b -> ST RealWorld b
forall a. ST RealWorld a -> ST RealWorld a
mask_ (ST RealWorld b -> ST RealWorld b)
-> ST RealWorld b -> ST RealWorld b
forall a b. (a -> b) -> a -> b
$ do
    Box (Unlifted a)
a <- UnliftedMVar RealWorld a -> ST RealWorld (Box (Unlifted a))
forall s x (unlifted_a :: TYPE 'UnliftedRep).
UnliftedMVar_ s x unlifted_a -> ST s (Box unlifted_a)
takeUnliftedMVarBox UnliftedMVar RealWorld a
m
    HalfUnlifted Box (Unlifted a)
a' b
b :: HalfUnlifted a b <-
      (do
         (a
a', b
b) <- a -> ST RealWorld (a, b)
st (Box (Unlifted a) -> a
forall a. PrimUnlifted a => Box (Unlifted a) -> a
fromBox Box (Unlifted a)
a)
         HalfUnlifted a b -> ST RealWorld (HalfUnlifted a b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HalfUnlifted a b -> ST RealWorld (HalfUnlifted a b))
-> HalfUnlifted a b -> ST RealWorld (HalfUnlifted a b)
forall a b. (a -> b) -> a -> b
$! Box (Unlifted a) -> b -> HalfUnlifted a b
forall a b. Box (Unlifted a) -> b -> HalfUnlifted a b
HalfUnlifted (a -> Box (Unlifted a)
forall a. PrimUnlifted a => a -> Box (Unlifted a)
toBox a
a') b
b) ST RealWorld (HalfUnlifted a b)
-> ST RealWorld () -> ST RealWorld (HalfUnlifted a b)
forall a b. ST RealWorld a -> ST RealWorld b -> ST RealWorld a
`onException` UnliftedMVar RealWorld a -> Box (Unlifted a) -> ST RealWorld ()
forall s x (unlifted_a :: TYPE 'UnliftedRep).
UnliftedMVar_ s x unlifted_a -> Box unlifted_a -> ST s ()
putUnliftedMVarBox UnliftedMVar RealWorld a
m Box (Unlifted a)
a
    UnliftedMVar RealWorld a -> Box (Unlifted a) -> ST RealWorld ()
forall s x (unlifted_a :: TYPE 'UnliftedRep).
UnliftedMVar_ s x unlifted_a -> Box unlifted_a -> ST s ()
putUnliftedMVarBox UnliftedMVar RealWorld a
m Box (Unlifted a)
a'
    b -> ST RealWorld b
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
b

modifyUnliftedMVarMasked_
  :: PrimUnlifted a
  => UnliftedMVar RealWorld a -> (a -> ST RealWorld a) -> ST RealWorld ()
{-# INLINE modifyUnliftedMVarMasked_ #-}
modifyUnliftedMVarMasked_ :: UnliftedMVar RealWorld a
-> (a -> ST RealWorld a) -> ST RealWorld ()
modifyUnliftedMVarMasked_ UnliftedMVar RealWorld a
m a -> ST RealWorld a
st =
  ST RealWorld () -> ST RealWorld ()
forall a. ST RealWorld a -> ST RealWorld a
mask_ (ST RealWorld () -> ST RealWorld ())
-> ST RealWorld () -> ST RealWorld ()
forall a b. (a -> b) -> a -> b
$ do
    Box (Unlifted a)
a  <- UnliftedMVar RealWorld a -> ST RealWorld (Box (Unlifted a))
forall s x (unlifted_a :: TYPE 'UnliftedRep).
UnliftedMVar_ s x unlifted_a -> ST s (Box unlifted_a)
takeUnliftedMVarBox UnliftedMVar RealWorld a
m
    Box (Unlifted a)
a' <- (a -> Box (Unlifted a)
forall a. PrimUnlifted a => a -> Box (Unlifted a)
toBox (a -> Box (Unlifted a))
-> ST RealWorld a -> ST RealWorld (Box (Unlifted a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> ST RealWorld a
st (Box (Unlifted a) -> a
forall a. PrimUnlifted a => Box (Unlifted a) -> a
fromBox Box (Unlifted a)
a)) ST RealWorld (Box (Unlifted a))
-> ST RealWorld () -> ST RealWorld (Box (Unlifted a))
forall a b. ST RealWorld a -> ST RealWorld b -> ST RealWorld a
`onException` UnliftedMVar RealWorld a -> Box (Unlifted a) -> ST RealWorld ()
forall s x (unlifted_a :: TYPE 'UnliftedRep).
UnliftedMVar_ s x unlifted_a -> Box unlifted_a -> ST s ()
putUnliftedMVarBox UnliftedMVar RealWorld a
m Box (Unlifted a)
a
    UnliftedMVar RealWorld a -> Box (Unlifted a) -> ST RealWorld ()
forall s x (unlifted_a :: TYPE 'UnliftedRep).
UnliftedMVar_ s x unlifted_a -> Box unlifted_a -> ST s ()
putUnliftedMVarBox UnliftedMVar RealWorld a
m Box (Unlifted a)
a'