{-# LANGUAGE GHCForeignImportPrim #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE UnliftedFFITypes #-}
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 (..))
data StoredMVarT
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)
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
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
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
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 #-}
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 #-}
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 #-}
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 #-}
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 #-}
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 #-}
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 #-}
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 #-}
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 #-}
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 ()
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
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 :: 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 #-}
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 #-}
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_ #-}
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 #-}
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_ #-}
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 #-}