{-# LANGUAGE InterruptibleFFI #-}
{-# LANGUAGE ScopedTypeVariables #-}
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 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
data StoredMVarT
data StoredMVar a
= StoredMVar !(SOName (StoredMVar a)) !(ForeignPtr StoredMVarT)
deriving (Eq, Typeable)
newEmptyMVar :: forall a . Storable a => IO (StoredMVar a)
newEmptyMVar = mask_ $ do
mvar <- checkNullPointer "newEmptyMVar"
. c'mvar_new . fromIntegral $ sizeOf (undefined :: a)
n <- newEmptySOName
unsafeWithSOName n $ c'mvar_name mvar
StoredMVar n <$> newForeignPtr p'mvar_destroy mvar
newMVar :: Storable a => a -> IO (StoredMVar a)
newMVar value = do
x <- newEmptyMVar
putMVar x value
return x
lookupMVar :: Storable a => SOName (StoredMVar a) -> IO (StoredMVar a)
lookupMVar n = mask_ $ do
mvar <- unsafeWithSOName n $ checkNullPointer "lookupMVar". c'mvar_lookup
StoredMVar n <$> newForeignPtr p'mvar_destroy mvar
mVarName :: StoredMVar a -> SOName (StoredMVar a)
mVarName (StoredMVar r _) = r
{-# INLINE mVarName #-}
isEmptyMVar :: StoredMVar a -> IO Bool
isEmptyMVar (StoredMVar _ fp) = withForeignPtr fp $ fmap (0 /=) . c'mvar_isempty
{-# INLINE isEmptyMVar #-}
takeMVar :: Storable a => StoredMVar a -> IO a
takeMVar (StoredMVar _ fp) = mask_ $ withForeignPtr fp $ \p -> alloca $ \lp -> do
r <- c'mvar_take p lp
if r == 0
then peek lp
else throwErrno $ "takeMVar failed with code " ++ show r
{-# INLINE takeMVar #-}
readMVar :: Storable a => StoredMVar a -> IO a
readMVar (StoredMVar _ fp) = mask_ $ withForeignPtr fp $ \p -> alloca $ \lp -> do
r <- c'mvar_read p lp
if r == 0
then peek lp
else throwErrno $ "readMVar failed with code " ++ show r
{-# INLINE readMVar #-}
swapMVar :: Storable a => StoredMVar a -> a -> IO a
swapMVar (StoredMVar _ fp) x
= mask_ $ withForeignPtr fp $ \p -> allocaArray 2 $ \inp -> do
let outp = advancePtr inp 1
poke inp x
r <- c'mvar_swap p inp outp
if r == 0
then peek outp
else throwErrno $ "swapMVar failed with code " ++ show r
{-# INLINE swapMVar #-}
putMVar :: Storable a => StoredMVar a -> a -> IO ()
putMVar (StoredMVar _ fp) x = mask_ $ withForeignPtr fp $ \p -> alloca $ \lp -> do
poke lp x
r <- c'mvar_put p lp
when (r /= 0) $ throwErrno $ "putMVar failed with code " ++ show r
{-# NOINLINE putMVar #-}
tryTakeMVar :: Storable a => StoredMVar a -> IO (Maybe a)
tryTakeMVar (StoredMVar _ fp) = mask_ $ withForeignPtr fp $ \p -> alloca $ \lp -> do
r <- c'mvar_trytake p lp
if r == 0 then Just <$> peek lp
else return Nothing
{-# INLINE tryTakeMVar #-}
tryReadMVar :: Storable a => StoredMVar a -> IO (Maybe a)
tryReadMVar (StoredMVar _ fp) = mask_ $ withForeignPtr fp $ \p -> alloca $ \lp -> do
r <- c'mvar_tryread p lp
if r == 0 then Just <$> peek lp
else return Nothing
{-# INLINE tryReadMVar #-}
tryPutMVar :: Storable a => StoredMVar a -> a -> IO Bool
tryPutMVar (StoredMVar _ fp) x = mask_ $ withForeignPtr fp $ \p -> alloca $ \lp -> do
poke lp x
r <- c'mvar_tryput p lp
return $ r == 0
{-# INLINE tryPutMVar #-}
trySwapMVar :: Storable a => StoredMVar a -> a -> IO (Maybe a)
trySwapMVar (StoredMVar _ fp) x
= mask_ $ withForeignPtr fp $ \p -> allocaArray 2 $ \inp -> do
let outp = advancePtr inp 1
poke inp x
r <- c'mvar_tryswap p inp outp
if r == 0
then Just <$> peek outp
else return Nothing
{-# INLINE trySwapMVar #-}
checkNullPointer :: String -> IO (Ptr a) -> IO (Ptr a)
checkNullPointer s k = do
p <- k
if p == nullPtr
then throwErrno ("StoredMVar." ++ s ++ ": FFI returned NULL pointer.")
else return p
{-# INLINE checkNullPointer #-}
foreign import ccall unsafe "mvar_new"
c'mvar_new :: CSize -> 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 interruptible "mvar_take"
c'mvar_take :: Ptr StoredMVarT -> Ptr a -> IO CInt
foreign import ccall unsafe "mvar_trytake"
c'mvar_trytake :: Ptr StoredMVarT -> Ptr a -> IO CInt
foreign import ccall interruptible "mvar_put"
c'mvar_put :: Ptr StoredMVarT -> Ptr a -> IO CInt
foreign import ccall unsafe "mvar_tryput"
c'mvar_tryput :: Ptr StoredMVarT -> Ptr a -> IO CInt
foreign import ccall interruptible "mvar_read"
c'mvar_read :: Ptr StoredMVarT -> Ptr a -> IO CInt
foreign import ccall unsafe "mvar_tryread"
c'mvar_tryread :: Ptr StoredMVarT -> Ptr a -> IO CInt
foreign import ccall interruptible "mvar_swap"
c'mvar_swap :: Ptr StoredMVarT -> Ptr a -> 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
withMVar :: Storable a => StoredMVar a -> (a -> IO b) -> IO b
withMVar m io = mask $ \restore -> do
a <- takeMVar m
b <- restore (io a) `onException` putMVar m a
putMVar m a
return b
{-# INLINE withMVar #-}
withMVarMasked :: Storable a => StoredMVar a -> (a -> IO b) -> IO b
withMVarMasked m io = mask_ $ do
a <- takeMVar m
b <- io a `onException` putMVar m a
putMVar m a
return b
{-# INLINE withMVarMasked #-}
modifyMVar_ :: Storable a => StoredMVar a -> (a -> IO a) -> IO ()
modifyMVar_ m io = mask $ \restore -> do
a <- takeMVar m
a' <- restore (io a) `onException` putMVar m a
putMVar m a'
{-# INLINE modifyMVar_ #-}
modifyMVar :: Storable a => StoredMVar a -> (a -> IO (a,b)) -> IO b
modifyMVar m io = mask $ \restore -> do
a <- takeMVar m
(a',b) <- restore (io a >>= evaluate) `onException` putMVar m a
putMVar m a'
return b
{-# INLINE modifyMVar #-}
modifyMVarMasked_ :: Storable a => StoredMVar a -> (a -> IO a) -> IO ()
modifyMVarMasked_ m io = mask_ $ do
a <- takeMVar m
a' <- io a `onException` putMVar m a
putMVar m a'
{-# INLINE modifyMVarMasked_ #-}
modifyMVarMasked :: Storable a => StoredMVar a -> (a -> IO (a,b)) -> IO b
modifyMVarMasked m io = mask_ $ do
a <- takeMVar m
(a',b) <- (io a >>= evaluate) `onException` putMVar m a
putMVar m a'
return b
{-# INLINE modifyMVarMasked #-}