{-# LANGUAGE GHCForeignImportPrim #-}
{-# LANGUAGE MagicHash            #-}
{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE UnboxedTuples        #-}
{-# LANGUAGE UnliftedFFITypes     #-}

-----------------------------------------------------------------------------
-- |
--   This module is an adaptation of `Control.Concurrent.MVar` to an
--   interprocess communication (IPC).
--   The IPC setting implies a few changes to the interface.
--
--   1. `StoredMVar` resides in a shared memory region.
--
--   2. We use `Storable` instance to serialize and deserialize a value.
--
--   3. Point (2) implies the value is always fully evaluated before being stored.
--
--   4. Scheduling is done by OS, thus the module does not guarantee FIFO order.
--
--   5. Using `StoredMVar` is only safe if `Storable` instance for its content
--      is correct and `peek` does not throw exceptions.
--      If `peek` throws an exception inside `takeMVar` or `swapMVar`,
--      the original content of `StoredMVar` is not restored
--
-----------------------------------------------------------------------------
module Control.Concurrent.Process.StoredMVar
  ( StoredMVar (), mVarName
  , newEmptyMVar, newMVar, lookupMVar
  , takeMVar, putMVar, readMVar, swapMVar
  , tryTakeMVar, tryPutMVar, tryReadMVar, trySwapMVar
  , isEmptyMVar
  , withMVar, withMVarMasked
  , modifyMVar, modifyMVar_, modifyMVarMasked, modifyMVarMasked_
  ) where

import Control.Exception
import Control.Monad                     (when)
import Data.Data                         (Typeable)
import Data.Maybe                        (fromMaybe)
import Foreign.C
import Foreign.ForeignPtr
import Foreign.Marshal.Alloc             (alloca)
import Foreign.Marshal.Array             (advancePtr, allocaArray)
import Foreign.Ptr
import Foreign.SharedObjectName.Internal
import Foreign.Storable
import System.Environment                (lookupEnv)
import Text.Read                         (readMaybe)

import GHC.Exts (Int(I#), Addr#, Int#, RealWorld, State#)
import GHC.IO   (IO (..))
import GHC.Ptr  (Ptr (..))


-- | Opaque implementation-dependent StoredMVar
data StoredMVarT

-- | An 'StoredMVar' is a synchronising variable, used
--   for communication between concurrent processes or threads.
--   It can be thought of as a a box, which may be empty or full.
--
--   @StoredMVar@ tries to mimic vanilla `MVar`, though it behaves quite differently.
--   It uses `Storable` instance to make the value accessible in different memory spaces.
--   Thus, the content of @StoredMVar@ is forced to be fully evaluated and serialized.
data StoredMVar a
  = StoredMVar !(SOName (StoredMVar a)) !(ForeignPtr StoredMVarT)
  deriving (StoredMVar a -> StoredMVar a -> Bool
(StoredMVar a -> StoredMVar a -> Bool)
-> (StoredMVar a -> StoredMVar a -> Bool) -> Eq (StoredMVar a)
forall a. StoredMVar a -> StoredMVar a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StoredMVar a -> StoredMVar a -> Bool
$c/= :: forall a. StoredMVar a -> StoredMVar a -> Bool
== :: StoredMVar a -> StoredMVar a -> Bool
$c== :: forall a. StoredMVar a -> StoredMVar a -> Bool
Eq, Typeable)


-- | Create a 'StoredMVar' which is initially empty.
newEmptyMVar :: forall a . Storable a => IO (StoredMVar a)
newEmptyMVar :: IO (StoredMVar a)
newEmptyMVar = IO (StoredMVar a) -> IO (StoredMVar a)
forall a. IO a -> IO a
mask_ (IO (StoredMVar a) -> IO (StoredMVar a))
-> IO (StoredMVar a) -> IO (StoredMVar a)
forall a b. (a -> b) -> a -> b
$ do
    CInt
t <- CInt -> Maybe CInt -> CInt
forall a. a -> Maybe a -> a
fromMaybe CInt
100 (Maybe CInt -> CInt)
-> (Maybe String -> Maybe CInt) -> Maybe String -> CInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe String -> (String -> Maybe CInt) -> Maybe CInt
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Maybe CInt
forall a. Read a => String -> Maybe a
readMaybe) (Maybe String -> CInt) -> IO (Maybe String) -> IO CInt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
"INTEPROCESS_MAX_ERR_WAIT_MS"
    Ptr StoredMVarT
mvar <- String -> IO (Ptr StoredMVarT) -> IO (Ptr StoredMVarT)
forall a. String -> IO (Ptr a) -> IO (Ptr a)
checkNullPointer String
"newEmptyMVar" (IO (Ptr StoredMVarT) -> IO (Ptr StoredMVarT))
-> IO (Ptr StoredMVarT) -> IO (Ptr StoredMVarT)
forall a b. (a -> b) -> a -> b
$ CSize -> CInt -> IO (Ptr StoredMVarT)
c'mvar_new (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a -> Int
forall a. Storable a => a -> Int
sizeOf (a
forall a. HasCallStack => a
undefined :: a))) CInt
t
    SOName (StoredMVar a)
n <- IO (SOName (StoredMVar a))
forall a. IO (SOName a)
newEmptySOName
    SOName (StoredMVar a) -> (CString -> IO ()) -> IO ()
forall a b. SOName a -> (CString -> IO b) -> IO b
unsafeWithSOName SOName (StoredMVar a)
n ((CString -> IO ()) -> IO ()) -> (CString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Ptr StoredMVarT -> CString -> IO ()
c'mvar_name Ptr StoredMVarT
mvar
    SOName (StoredMVar a) -> ForeignPtr StoredMVarT -> StoredMVar a
forall a.
SOName (StoredMVar a) -> ForeignPtr StoredMVarT -> StoredMVar a
StoredMVar SOName (StoredMVar a)
n (ForeignPtr StoredMVarT -> StoredMVar a)
-> IO (ForeignPtr StoredMVarT) -> IO (StoredMVar a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FinalizerPtr StoredMVarT
-> Ptr StoredMVarT -> IO (ForeignPtr StoredMVarT)
forall a. FinalizerPtr a -> Ptr a -> IO (ForeignPtr a)
newForeignPtr FinalizerPtr StoredMVarT
p'mvar_destroy Ptr StoredMVarT
mvar

-- | Create a 'StoredMVar' which is initially empty.
newMVar :: Storable a => a -> IO (StoredMVar a)
newMVar :: a -> IO (StoredMVar a)
newMVar a
value = do
    StoredMVar a
x <- IO (StoredMVar a)
forall a. Storable a => IO (StoredMVar a)
newEmptyMVar
    StoredMVar a -> a -> IO ()
forall a. Storable a => StoredMVar a -> a -> IO ()
putMVar StoredMVar a
x a
value
    StoredMVar a -> IO (StoredMVar a)
forall (m :: * -> *) a. Monad m => a -> m a
return StoredMVar a
x


-- | Find a `StoredMVar` created in another process ot thread by its reference.
lookupMVar :: Storable a => SOName (StoredMVar a) ->  IO (StoredMVar a)
lookupMVar :: SOName (StoredMVar a) -> IO (StoredMVar a)
lookupMVar SOName (StoredMVar a)
n = IO (StoredMVar a) -> IO (StoredMVar a)
forall a. IO a -> IO a
mask_ (IO (StoredMVar a) -> IO (StoredMVar a))
-> IO (StoredMVar a) -> IO (StoredMVar a)
forall a b. (a -> b) -> a -> b
$ do
    Ptr StoredMVarT
mvar <- SOName (StoredMVar a)
-> (CString -> IO (Ptr StoredMVarT)) -> IO (Ptr StoredMVarT)
forall a b. SOName a -> (CString -> IO b) -> IO b
unsafeWithSOName SOName (StoredMVar a)
n ((CString -> IO (Ptr StoredMVarT)) -> IO (Ptr StoredMVarT))
-> (CString -> IO (Ptr StoredMVarT)) -> IO (Ptr StoredMVarT)
forall a b. (a -> b) -> a -> b
$ String -> IO (Ptr StoredMVarT) -> IO (Ptr StoredMVarT)
forall a. String -> IO (Ptr a) -> IO (Ptr a)
checkNullPointer String
"lookupMVar"(IO (Ptr StoredMVarT) -> IO (Ptr StoredMVarT))
-> (CString -> IO (Ptr StoredMVarT))
-> CString
-> IO (Ptr StoredMVarT)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CString -> IO (Ptr StoredMVarT)
c'mvar_lookup
    SOName (StoredMVar a) -> ForeignPtr StoredMVarT -> StoredMVar a
forall a.
SOName (StoredMVar a) -> ForeignPtr StoredMVarT -> StoredMVar a
StoredMVar SOName (StoredMVar a)
n (ForeignPtr StoredMVarT -> StoredMVar a)
-> IO (ForeignPtr StoredMVarT) -> IO (StoredMVar a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FinalizerPtr StoredMVarT
-> Ptr StoredMVarT -> IO (ForeignPtr StoredMVarT)
forall a. FinalizerPtr a -> Ptr a -> IO (ForeignPtr a)
newForeignPtr FinalizerPtr StoredMVarT
p'mvar_destroy Ptr StoredMVarT
mvar

-- | Get a global reference to the `StoredMVar`.
--   Send this reference to another process to lookup this `StoredMVar` and
--   start interprocess communication.
mVarName :: StoredMVar a -> SOName (StoredMVar a)
mVarName :: StoredMVar a -> SOName (StoredMVar a)
mVarName (StoredMVar SOName (StoredMVar a)
r ForeignPtr StoredMVarT
_) = SOName (StoredMVar a)
r
{-# INLINE mVarName #-}

-- | Check whether a given 'StoredMVar' is empty.
--
--   Notice that the boolean value returned  is just a snapshot of
--   the state of the MVar. By the time you get to react on its result,
--   the MVar may have been filled (or emptied) - so be extremely
--   careful when using this operation.  Use 'tryTakeMVar' instead if possible.
isEmptyMVar :: StoredMVar a -> IO Bool
isEmptyMVar :: StoredMVar a -> IO Bool
isEmptyMVar (StoredMVar SOName (StoredMVar a)
_ ForeignPtr StoredMVarT
fp) = ForeignPtr StoredMVarT -> (Ptr StoredMVarT -> IO Bool) -> IO Bool
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr StoredMVarT
fp ((Ptr StoredMVarT -> IO Bool) -> IO Bool)
-> (Ptr StoredMVarT -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ (CInt -> Bool) -> IO CInt -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (CInt
0 CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/=) (IO CInt -> IO Bool)
-> (Ptr StoredMVarT -> IO CInt) -> Ptr StoredMVarT -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr StoredMVarT -> IO CInt
c'mvar_isempty
{-# INLINE isEmptyMVar #-}


-- | Return the contents of the 'StoredMVar'.  If the 'StoredMVar' is currently
--   empty, 'takeMVar' will wait until it is full.  After a 'takeMVar',
--   the 'StoredMVar' is left empty.
--
--
--   * 'takeMVar' is single-wakeup.  That is, if there are multiple
--     processes blocked in 'takeMVar', and the 'StoredMVar' becomes full,
--     only one thread will be woken up.
--
--   * The library makes no guarantees about the order in which processes
--     are woken up. This is all up to implementation-dependent OS scheduling.
--
takeMVar :: Storable a => StoredMVar a -> IO a
takeMVar :: StoredMVar a -> IO a
takeMVar (StoredMVar SOName (StoredMVar a)
_ ForeignPtr StoredMVarT
fp) = IO a -> IO a
forall a. IO a -> IO a
mask_ (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ ForeignPtr StoredMVarT -> (Ptr StoredMVarT -> IO a) -> IO a
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr StoredMVarT
fp ((Ptr StoredMVarT -> IO a) -> IO a)
-> (Ptr StoredMVarT -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Ptr StoredMVarT
p -> (Ptr a -> IO a) -> IO a
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr a -> IO a) -> IO a) -> (Ptr a -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Ptr a
lp -> do
    String -> IO CInt -> IO ()
checkErrorCode String
"takeMVar" (IO CInt -> IO ()) -> IO CInt -> IO ()
forall a b. (a -> b) -> a -> b
$ (State# RealWorld -> (# State# RealWorld, Int# #)) -> IO CInt
cmmOp (Addr# -> Addr# -> State# RealWorld -> (# State# RealWorld, Int# #)
cmm'mvar_take (Ptr StoredMVarT -> Addr#
forall a. Ptr a -> Addr#
unptr Ptr StoredMVarT
p) (Ptr a -> Addr#
forall a. Ptr a -> Addr#
unptr Ptr a
lp))
    Ptr a -> IO a
forall a. Storable a => Ptr a -> IO a
peek Ptr a
lp
{-# INLINE takeMVar #-}


-- | Atomically read the contents of an 'StoredMVar'.  If the 'StoredMVar' is
--   currently empty, 'readMVar' will wait until its full.
--   'readMVar' is guaranteed to receive the next 'putMVar'.
--
--  'readMVar' is multiple-wakeup, so when multiple readers are
--    blocked on an 'StoredMVar', all of them are woken up at the same time.
--
readMVar :: Storable a => StoredMVar a -> IO a
readMVar :: StoredMVar a -> IO a
readMVar (StoredMVar SOName (StoredMVar a)
_ ForeignPtr StoredMVarT
fp) = IO a -> IO a
forall a. IO a -> IO a
mask_ (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ ForeignPtr StoredMVarT -> (Ptr StoredMVarT -> IO a) -> IO a
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr StoredMVarT
fp ((Ptr StoredMVarT -> IO a) -> IO a)
-> (Ptr StoredMVarT -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Ptr StoredMVarT
p -> (Ptr a -> IO a) -> IO a
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr a -> IO a) -> IO a) -> (Ptr a -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Ptr a
lp -> do
    String -> IO CInt -> IO ()
checkErrorCode String
"readMVar" (IO CInt -> IO ()) -> IO CInt -> IO ()
forall a b. (a -> b) -> a -> b
$ (State# RealWorld -> (# State# RealWorld, Int# #)) -> IO CInt
cmmOp (Addr# -> Addr# -> State# RealWorld -> (# State# RealWorld, Int# #)
cmm'mvar_read (Ptr StoredMVarT -> Addr#
forall a. Ptr a -> Addr#
unptr Ptr StoredMVarT
p) (Ptr a -> Addr#
forall a. Ptr a -> Addr#
unptr Ptr a
lp))
    Ptr a -> IO a
forall a. Storable a => Ptr a -> IO a
peek Ptr a
lp
{-# INLINE readMVar #-}


-- | Atomically take a value from an 'StoredMVar', put a new value into the 'StoredMVar' and
--   return the value taken.
swapMVar :: Storable a => StoredMVar a -> a -> IO a
swapMVar :: StoredMVar a -> a -> IO a
swapMVar (StoredMVar SOName (StoredMVar a)
_ ForeignPtr StoredMVarT
fp) a
x
  = IO a -> IO a
forall a. IO a -> IO a
mask_ (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ ForeignPtr StoredMVarT -> (Ptr StoredMVarT -> IO a) -> IO a
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr StoredMVarT
fp ((Ptr StoredMVarT -> IO a) -> IO a)
-> (Ptr StoredMVarT -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Ptr StoredMVarT
p -> Int -> (Ptr a -> IO a) -> IO a
forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b
allocaArray Int
2 ((Ptr a -> IO a) -> IO a) -> (Ptr a -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Ptr a
inp -> do
    let outp :: Ptr a
outp = Ptr a -> Int -> Ptr a
forall a. Storable a => Ptr a -> Int -> Ptr a
advancePtr Ptr a
inp Int
1
    Ptr a -> a -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr a
inp a
x
    String -> IO CInt -> IO ()
checkErrorCode String
"swapMVar" (IO CInt -> IO ()) -> IO CInt -> IO ()
forall a b. (a -> b) -> a -> b
$ (State# RealWorld -> (# State# RealWorld, Int# #)) -> IO CInt
cmmOp (Addr#
-> Addr#
-> Addr#
-> State# RealWorld
-> (# State# RealWorld, Int# #)
cmm'mvar_swap (Ptr StoredMVarT -> Addr#
forall a. Ptr a -> Addr#
unptr Ptr StoredMVarT
p) (Ptr a -> Addr#
forall a. Ptr a -> Addr#
unptr Ptr a
inp) (Ptr a -> Addr#
forall a. Ptr a -> Addr#
unptr Ptr a
outp))
    Ptr a -> IO a
forall a. Storable a => Ptr a -> IO a
peek Ptr a
outp
{-# INLINE swapMVar #-}


-- | Put a value into an 'StoredMVar'.  If the 'StoredMVar' is currently full,
--   'putMVar' will wait until it becomes empty.
--
--
--   * 'putMVar' is single-wakeup.  That is, if there are multiple threads
--     or processes blocked in 'putMVar', and the 'StoredMVar' becomes empty,
--     only one thread will be woken up.
--
--   * The library makes no guarantees about the order in which processes
--     are woken up. This is all up to implementation-dependent OS scheduling.
--
putMVar :: Storable a => StoredMVar a -> a -> IO ()
putMVar :: StoredMVar a -> a -> IO ()
putMVar (StoredMVar SOName (StoredMVar a)
_ ForeignPtr StoredMVarT
fp) a
x = IO () -> IO ()
forall a. IO a -> IO a
mask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ForeignPtr StoredMVarT -> (Ptr StoredMVarT -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr StoredMVarT
fp ((Ptr StoredMVarT -> IO ()) -> IO ())
-> (Ptr StoredMVarT -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr StoredMVarT
p -> (Ptr a -> IO ()) -> IO ()
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr a -> IO ()) -> IO ()) -> (Ptr a -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr a
lp -> do
    Ptr a -> a -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr a
lp a
x
    String -> IO CInt -> IO ()
checkErrorCode String
"putMVar" (IO CInt -> IO ()) -> IO CInt -> IO ()
forall a b. (a -> b) -> a -> b
$ (State# RealWorld -> (# State# RealWorld, Int# #)) -> IO CInt
cmmOp (Addr# -> Addr# -> State# RealWorld -> (# State# RealWorld, Int# #)
cmm'mvar_put (Ptr StoredMVarT -> Addr#
forall a. Ptr a -> Addr#
unptr Ptr StoredMVarT
p) (Ptr a -> Addr#
forall a. Ptr a -> Addr#
unptr Ptr a
lp))
{-# NOINLINE putMVar #-}

-- | A non-blocking version of 'takeMVar'.  The 'tryTakeMVar' function
--   returns immediately, with 'Nothing' if the 'StoredMVar' was empty, or
--   @'Just' a@ if the 'StoredMVar' was full with contents @a@.
--   After 'tryTakeMVar', the 'StoredMVar' is left empty.
tryTakeMVar :: Storable a => StoredMVar a -> IO (Maybe a)
tryTakeMVar :: StoredMVar a -> IO (Maybe a)
tryTakeMVar (StoredMVar SOName (StoredMVar a)
_ ForeignPtr StoredMVarT
fp) = IO (Maybe a) -> IO (Maybe a)
forall a. IO a -> IO a
mask_ (IO (Maybe a) -> IO (Maybe a)) -> IO (Maybe a) -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ ForeignPtr StoredMVarT
-> (Ptr StoredMVarT -> IO (Maybe a)) -> IO (Maybe a)
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr StoredMVarT
fp ((Ptr StoredMVarT -> IO (Maybe a)) -> IO (Maybe a))
-> (Ptr StoredMVarT -> IO (Maybe a)) -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ \Ptr StoredMVarT
p -> (Ptr a -> IO (Maybe a)) -> IO (Maybe a)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr a -> IO (Maybe a)) -> IO (Maybe a))
-> (Ptr a -> IO (Maybe a)) -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ \Ptr a
lp -> do
    CInt
r <- Ptr StoredMVarT -> Ptr a -> IO CInt
forall a. Ptr StoredMVarT -> Ptr a -> IO CInt
c'mvar_trytake Ptr StoredMVarT
p Ptr a
lp
    if CInt
r CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
0 then a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> IO a -> IO (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr a -> IO a
forall a. Storable a => Ptr a -> IO a
peek Ptr a
lp
              else Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
{-# INLINE tryTakeMVar #-}

-- | A non-blocking version of 'readMVar'.
--   The 'tryReadMVar' function
--   returns immediately, with 'Nothing' if the 'StoredMVar' was empty, or
--   @'Just' a@ if the 'StoredMVar' was full with contents @a@.
--
tryReadMVar :: Storable a => StoredMVar a -> IO (Maybe a)
tryReadMVar :: StoredMVar a -> IO (Maybe a)
tryReadMVar (StoredMVar SOName (StoredMVar a)
_ ForeignPtr StoredMVarT
fp) = IO (Maybe a) -> IO (Maybe a)
forall a. IO a -> IO a
mask_ (IO (Maybe a) -> IO (Maybe a)) -> IO (Maybe a) -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ ForeignPtr StoredMVarT
-> (Ptr StoredMVarT -> IO (Maybe a)) -> IO (Maybe a)
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr StoredMVarT
fp ((Ptr StoredMVarT -> IO (Maybe a)) -> IO (Maybe a))
-> (Ptr StoredMVarT -> IO (Maybe a)) -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ \Ptr StoredMVarT
p -> (Ptr a -> IO (Maybe a)) -> IO (Maybe a)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr a -> IO (Maybe a)) -> IO (Maybe a))
-> (Ptr a -> IO (Maybe a)) -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ \Ptr a
lp -> do
    CInt
r <- Ptr StoredMVarT -> Ptr a -> IO CInt
forall a. Ptr StoredMVarT -> Ptr a -> IO CInt
c'mvar_tryread Ptr StoredMVarT
p Ptr a
lp
    if CInt
r CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
0 then a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> IO a -> IO (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr a -> IO a
forall a. Storable a => Ptr a -> IO a
peek Ptr a
lp
              else Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
{-# INLINE tryReadMVar #-}

-- | A non-blocking version of 'putMVar'.
--   The 'tryPutMVar' function
--   attempts to put the value @a@ into the 'StoredMVar', returning 'True' if
--   it was successful, or 'False' otherwise.
tryPutMVar  :: Storable a => StoredMVar a -> a -> IO Bool
tryPutMVar :: StoredMVar a -> a -> IO Bool
tryPutMVar (StoredMVar SOName (StoredMVar a)
_ ForeignPtr StoredMVarT
fp) a
x = IO Bool -> IO Bool
forall a. IO a -> IO a
mask_ (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ ForeignPtr StoredMVarT -> (Ptr StoredMVarT -> IO Bool) -> IO Bool
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr StoredMVarT
fp ((Ptr StoredMVarT -> IO Bool) -> IO Bool)
-> (Ptr StoredMVarT -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \Ptr StoredMVarT
p -> (Ptr a -> IO Bool) -> IO Bool
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr a -> IO Bool) -> IO Bool) -> (Ptr a -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \Ptr a
lp -> do
    Ptr a -> a -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr a
lp a
x
    CInt
r <- Ptr StoredMVarT -> Ptr a -> IO CInt
forall a. Ptr StoredMVarT -> Ptr a -> IO CInt
c'mvar_tryput Ptr StoredMVarT
p Ptr a
lp
    Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ CInt
r CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
0
{-# INLINE tryPutMVar #-}

-- | A non-blocking version of 'swapMVar'.
--   Atomically attempt take a value from an 'StoredMVar', put a new value into the 'StoredMVar' and
--   return the value taken (thus, leave the `StoredMVar` full).
--   Return @Nothing@ if the `StoredMVar` was empty (and leave it empty).
trySwapMVar :: Storable a => StoredMVar a -> a -> IO (Maybe a)
trySwapMVar :: StoredMVar a -> a -> IO (Maybe a)
trySwapMVar (StoredMVar SOName (StoredMVar a)
_ ForeignPtr StoredMVarT
fp) a
x
  = IO (Maybe a) -> IO (Maybe a)
forall a. IO a -> IO a
mask_ (IO (Maybe a) -> IO (Maybe a)) -> IO (Maybe a) -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ ForeignPtr StoredMVarT
-> (Ptr StoredMVarT -> IO (Maybe a)) -> IO (Maybe a)
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr StoredMVarT
fp ((Ptr StoredMVarT -> IO (Maybe a)) -> IO (Maybe a))
-> (Ptr StoredMVarT -> IO (Maybe a)) -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ \Ptr StoredMVarT
p -> Int -> (Ptr a -> IO (Maybe a)) -> IO (Maybe a)
forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b
allocaArray Int
2 ((Ptr a -> IO (Maybe a)) -> IO (Maybe a))
-> (Ptr a -> IO (Maybe a)) -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ \Ptr a
inp -> do
    let outp :: Ptr a
outp = Ptr a -> Int -> Ptr a
forall a. Storable a => Ptr a -> Int -> Ptr a
advancePtr Ptr a
inp Int
1
    Ptr a -> a -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr a
inp a
x
    CInt
r <- Ptr StoredMVarT -> Ptr a -> Ptr a -> IO CInt
forall a. Ptr StoredMVarT -> Ptr a -> Ptr a -> IO CInt
c'mvar_tryswap Ptr StoredMVarT
p Ptr a
inp Ptr a
outp
    if CInt
r CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
0
    then a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> IO a -> IO (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr a -> IO a
forall a. Storable a => Ptr a -> IO a
peek Ptr a
outp
    else Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
{-# INLINE trySwapMVar #-}

checkNullPointer :: String -> IO (Ptr a) -> IO (Ptr a)
checkNullPointer :: String -> IO (Ptr a) -> IO (Ptr a)
checkNullPointer String
s IO (Ptr a)
k = do
  Ptr a
p <- IO (Ptr a)
k
  if Ptr a
p Ptr a -> Ptr a -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr a
forall a. Ptr a
nullPtr
  then IOError -> IO (Ptr a)
forall a. IOError -> IO a
ioError (IOError -> IO (Ptr a)) -> IOError -> IO (Ptr a)
forall a b. (a -> b) -> a -> b
$ String -> Errno -> Maybe Handle -> Maybe String -> IOError
errnoToIOError (String
"StoredMVar." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": FFI returned NULL pointer.") Errno
eINVAL Maybe Handle
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing
  else Ptr a -> IO (Ptr a)
forall (m :: * -> *) a. Monad m => a -> m a
return Ptr a
p
{-# INLINE checkNullPointer #-}

checkErrorCode :: String -> IO CInt -> IO ()
checkErrorCode :: String -> IO CInt -> IO ()
checkErrorCode String
s IO CInt
k = do
  CInt
e <- IO CInt
k
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
e CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= CInt
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    IOError -> IO ()
forall a. IOError -> IO a
ioError (IOError -> IO ()) -> IOError -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Errno -> Maybe Handle -> Maybe String -> IOError
errnoToIOError (String
"StoredMVar." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": FFI failed with code " String -> String -> String
forall a. [a] -> [a] -> [a]
++ CInt -> String
forall a. Show a => a -> String
show CInt
e) (CInt -> Errno
Errno CInt
e) Maybe Handle
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing
{-# INLINE checkErrorCode #-}


foreign import ccall unsafe "mvar_new"
  c'mvar_new :: CSize -> CInt -> IO (Ptr StoredMVarT)

foreign import ccall unsafe "mvar_lookup"
  c'mvar_lookup :: CString -> IO (Ptr StoredMVarT)

foreign import ccall unsafe "&mvar_destroy"
  p'mvar_destroy :: FunPtr (Ptr StoredMVarT -> IO ())

foreign import ccall unsafe "mvar_name"
  c'mvar_name :: Ptr StoredMVarT -> CString -> IO ()

-- These wait a bit and thus may be unsafe
foreign import ccall unsafe "mvar_trytake"
  c'mvar_trytake :: Ptr StoredMVarT -> Ptr a -> IO CInt
foreign import ccall unsafe "mvar_tryput"
  c'mvar_tryput :: Ptr StoredMVarT -> Ptr a -> IO CInt
foreign import ccall unsafe "mvar_tryread"
  c'mvar_tryread :: Ptr StoredMVarT -> Ptr a -> IO CInt
foreign import ccall unsafe "mvar_tryswap"
  c'mvar_tryswap :: Ptr StoredMVarT -> Ptr a -> Ptr a -> IO CInt
foreign import ccall unsafe "mvar_isempty"
  c'mvar_isempty :: Ptr StoredMVarT -> IO CInt


-- These wait a lot and should be interruptible.
-- I need the thread state inside these on the C side, so there are C-- helpers.
foreign import prim "cmm_mvar_take"
  cmm'mvar_take :: Addr# -> Addr# -> State# RealWorld -> (# State# RealWorld, Int# #)
foreign import prim "cmm_mvar_put"
  cmm'mvar_put :: Addr# -> Addr# -> State# RealWorld -> (# State# RealWorld, Int# #)
foreign import prim "cmm_mvar_read"
  cmm'mvar_read :: Addr# -> Addr# -> State# RealWorld -> (# State# RealWorld, Int# #)
foreign import prim "cmm_mvar_swap"
  cmm'mvar_swap :: Addr# -> Addr# -> Addr# -> State# RealWorld -> (# State# RealWorld, Int# #)

cmmOp :: (State# RealWorld -> (# State# RealWorld, Int# #)) -> IO CInt
cmmOp :: (State# RealWorld -> (# State# RealWorld, Int# #)) -> IO CInt
cmmOp State# RealWorld -> (# State# RealWorld, Int# #)
op = (State# RealWorld -> (# State# RealWorld, CInt #)) -> IO CInt
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO (\State# RealWorld
s0 -> case State# RealWorld -> (# State# RealWorld, Int# #)
op State# RealWorld
s0 of (# State# RealWorld
s1, Int#
code #) -> (# State# RealWorld
s1, Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int# -> Int
I# Int#
code) #))

unptr :: Ptr a -> Addr#
unptr :: Ptr a -> Addr#
unptr (Ptr Addr#
p) = Addr#
p

-- | 'withMVar' is an exception-safe wrapper for operating on the contents
--   of an 'StoredMVar'.  This operation is exception-safe: it will replace the
--   original contents of the 'StoredMVar' if an exception is raised (see
--   "Control.Exception").  However, it is only atomic if there are no
--  other producers for this 'StoredMVar'.
withMVar :: Storable a => StoredMVar a -> (a -> IO b) -> IO b
withMVar :: StoredMVar a -> (a -> IO b) -> IO b
withMVar StoredMVar a
m a -> IO b
io = ((forall a. IO a -> IO a) -> IO b) -> IO b
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask (((forall a. IO a -> IO a) -> IO b) -> IO b)
-> ((forall a. IO a -> IO a) -> IO b) -> IO b
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
    a
a <- StoredMVar a -> IO a
forall a. Storable a => StoredMVar a -> IO a
takeMVar StoredMVar a
m
    b
b <- IO b -> IO b
forall a. IO a -> IO a
restore (a -> IO b
io a
a) IO b -> IO () -> IO b
forall a b. IO a -> IO b -> IO a
`onException` StoredMVar a -> a -> IO ()
forall a. Storable a => StoredMVar a -> a -> IO ()
putMVar StoredMVar a
m a
a
    StoredMVar a -> a -> IO ()
forall a. Storable a => StoredMVar a -> a -> IO ()
putMVar StoredMVar a
m a
a
    b -> IO b
forall (m :: * -> *) a. Monad m => a -> m a
return b
b
{-# INLINE withMVar #-}


-- | Like 'withMVar', but the @IO@ action in the second argument is executed
--   with asynchronous exceptions masked.
withMVarMasked :: Storable a => StoredMVar a -> (a -> IO b) -> IO b
withMVarMasked :: StoredMVar a -> (a -> IO b) -> IO b
withMVarMasked StoredMVar a
m a -> IO b
io = IO b -> IO b
forall a. IO a -> IO a
mask_ (IO b -> IO b) -> IO b -> IO b
forall a b. (a -> b) -> a -> b
$ do
    a
a <- StoredMVar a -> IO a
forall a. Storable a => StoredMVar a -> IO a
takeMVar StoredMVar a
m
    b
b <- a -> IO b
io a
a IO b -> IO () -> IO b
forall a b. IO a -> IO b -> IO a
`onException` StoredMVar a -> a -> IO ()
forall a. Storable a => StoredMVar a -> a -> IO ()
putMVar StoredMVar a
m a
a
    StoredMVar a -> a -> IO ()
forall a. Storable a => StoredMVar a -> a -> IO ()
putMVar StoredMVar a
m a
a
    b -> IO b
forall (m :: * -> *) a. Monad m => a -> m a
return b
b
{-# INLINE withMVarMasked #-}


-- | An exception-safe wrapper for modifying the contents of an 'StoredMVar'.
--   Like 'withMVar', 'modifyMVar' will replace the original contents of
--   the 'StoredMVar' if an exception is raised during the operation.  This
--   function is only atomic if there are no other producers for this
--   'StoredMVar'.
modifyMVar_ :: Storable a => StoredMVar a -> (a -> IO a) -> IO ()
modifyMVar_ :: StoredMVar a -> (a -> IO a) -> IO ()
modifyMVar_ StoredMVar a
m a -> IO a
io = ((forall a. IO a -> IO a) -> IO ()) -> IO ()
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask (((forall a. IO a -> IO a) -> IO ()) -> IO ())
-> ((forall a. IO a -> IO a) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
    a
a  <- StoredMVar a -> IO a
forall a. Storable a => StoredMVar a -> IO a
takeMVar StoredMVar a
m
    a
a' <- IO a -> IO a
forall a. IO a -> IO a
restore (a -> IO a
io a
a) IO a -> IO () -> IO a
forall a b. IO a -> IO b -> IO a
`onException` StoredMVar a -> a -> IO ()
forall a. Storable a => StoredMVar a -> a -> IO ()
putMVar StoredMVar a
m a
a
    StoredMVar a -> a -> IO ()
forall a. Storable a => StoredMVar a -> a -> IO ()
putMVar StoredMVar a
m a
a'
{-# INLINE modifyMVar_ #-}


-- | A slight variation on 'modifyMVar_' that allows a value to be
--   returned (@b@) in addition to the modified value of the 'StoredMVar'.
modifyMVar :: Storable a => StoredMVar a -> (a -> IO (a,b)) -> IO b
modifyMVar :: StoredMVar a -> (a -> IO (a, b)) -> IO b
modifyMVar StoredMVar a
m a -> IO (a, b)
io = ((forall a. IO a -> IO a) -> IO b) -> IO b
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask (((forall a. IO a -> IO a) -> IO b) -> IO b)
-> ((forall a. IO a -> IO a) -> IO b) -> IO b
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
    a
a      <- StoredMVar a -> IO a
forall a. Storable a => StoredMVar a -> IO a
takeMVar StoredMVar a
m
    (a
a',b
b) <- IO (a, b) -> IO (a, b)
forall a. IO a -> IO a
restore (a -> IO (a, b)
io a
a IO (a, b) -> ((a, b) -> IO (a, b)) -> IO (a, b)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (a, b) -> IO (a, b)
forall a. a -> IO a
evaluate) IO (a, b) -> IO () -> IO (a, b)
forall a b. IO a -> IO b -> IO a
`onException` StoredMVar a -> a -> IO ()
forall a. Storable a => StoredMVar a -> a -> IO ()
putMVar StoredMVar a
m a
a
    StoredMVar a -> a -> IO ()
forall a. Storable a => StoredMVar a -> a -> IO ()
putMVar StoredMVar a
m a
a'
    b -> IO b
forall (m :: * -> *) a. Monad m => a -> m a
return b
b
{-# INLINE modifyMVar #-}


-- | Like 'modifyMVar_', but the @IO@ action in the second argument is executed with
--   asynchronous exceptions masked.
modifyMVarMasked_ :: Storable a => StoredMVar a -> (a -> IO a) -> IO ()
modifyMVarMasked_ :: StoredMVar a -> (a -> IO a) -> IO ()
modifyMVarMasked_ StoredMVar a
m a -> IO a
io = IO () -> IO ()
forall a. IO a -> IO a
mask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    a
a  <- StoredMVar a -> IO a
forall a. Storable a => StoredMVar a -> IO a
takeMVar StoredMVar a
m
    a
a' <- a -> IO a
io a
a IO a -> IO () -> IO a
forall a b. IO a -> IO b -> IO a
`onException` StoredMVar a -> a -> IO ()
forall a. Storable a => StoredMVar a -> a -> IO ()
putMVar StoredMVar a
m a
a
    StoredMVar a -> a -> IO ()
forall a. Storable a => StoredMVar a -> a -> IO ()
putMVar StoredMVar a
m a
a'
{-# INLINE modifyMVarMasked_ #-}


-- | Like 'modifyMVar', but the @IO@ action in the second argument is executed with
--   asynchronous exceptions masked.
modifyMVarMasked :: Storable a => StoredMVar a -> (a -> IO (a,b)) -> IO b
modifyMVarMasked :: StoredMVar a -> (a -> IO (a, b)) -> IO b
modifyMVarMasked StoredMVar a
m a -> IO (a, b)
io = IO b -> IO b
forall a. IO a -> IO a
mask_ (IO b -> IO b) -> IO b -> IO b
forall a b. (a -> b) -> a -> b
$ do
    a
a      <- StoredMVar a -> IO a
forall a. Storable a => StoredMVar a -> IO a
takeMVar StoredMVar a
m
    (a
a',b
b) <- (a -> IO (a, b)
io a
a IO (a, b) -> ((a, b) -> IO (a, b)) -> IO (a, b)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (a, b) -> IO (a, b)
forall a. a -> IO a
evaluate) IO (a, b) -> IO () -> IO (a, b)
forall a b. IO a -> IO b -> IO a
`onException` StoredMVar a -> a -> IO ()
forall a. Storable a => StoredMVar a -> a -> IO ()
putMVar StoredMVar a
m a
a
    StoredMVar a -> a -> IO ()
forall a. Storable a => StoredMVar a -> a -> IO ()
putMVar StoredMVar a
m a
a'
    b -> IO b
forall (m :: * -> *) a. Monad m => a -> m a
return b
b
{-# INLINE modifyMVarMasked #-}