{-# LANGUAGE MagicHash #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__ >= 800
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
#endif
module Data.Primitive.PVar
(
PVar
, RW
, newPVar
, withPVarST
, readPVar
, writePVar
, modifyPVar
, modifyPVar_
, fetchModifyPVar
, modifyFetchPVar
, modifyPVarM
, modifyPVarM_
, fetchModifyPVarM
, modifyFetchPVarM
, swapPVars_
, swapPVars
, copyPVar
, sizeOfPVar
, alignmentPVar
, newPinnedPVar
, newAlignedPinnedPVar
, withPtrPVar
, withStorablePVar
, withAlignedStorablePVar
, copyPVarToPtr
, toForeignPtrPVar
, isPinnedPVar
, peekPrim
, pokePrim
, atomicModifyIntPVar
, atomicModifyIntPVar_
, atomicFetchModifyIntPVar
, atomicModifyFetchIntPVar
, atomicReadIntPVar
, atomicWriteIntPVar
, casIntPVar
, atomicAddIntPVar
, atomicSubIntPVar
, atomicAndIntPVar
, atomicNandIntPVar
, atomicOrIntPVar
, atomicXorIntPVar
, atomicNotIntPVar
, Prim
, MonadPrim
, PrimMonad(PrimState)
, RealWorld
, sizeOf
, alignment
, ST
, runST
, S.Storable(peek, poke)
) where
import Control.Monad (void)
import Control.Monad.Primitive (MonadPrim, PrimMonad(primitive), PrimState, primitive_,
touch)
import Control.Monad.ST (ST, runST)
import Data.Primitive.PVar.Internal
import Data.Primitive.PVar.Unsafe
import Data.Primitive.Types
import qualified Foreign.Storable as S
import GHC.Exts
import GHC.ForeignPtr
type RW = RealWorld
withPVarST ::
Prim p
=> p
-> (forall s. PVar p s -> ST s a)
-> a
withPVarST x st = runST (newPVar x >>= st)
{-# INLINE withPVarST #-}
withPtrPVar :: (MonadPrim s m, Prim a) => PVar a n -> (Ptr a -> m b) -> m (Maybe b)
withPtrPVar pvar f =
case toPtrPVar pvar of
Nothing -> return Nothing
Just ptr -> do
r <- f ptr
touch pvar
return $ Just r
{-# INLINE withPtrPVar #-}
toForeignPtrPVar :: PVar a s -> Maybe (ForeignPtr a)
toForeignPtrPVar pvar
| isPinnedPVar pvar = Just $ unsafeToForeignPtrPVar pvar
| otherwise = Nothing
{-# INLINE toForeignPtrPVar #-}
copyPVar ::
(MonadPrim s m, Prim a)
=> PVar a s
-> PVar a s
-> m ()
copyPVar pvar@(PVar mbas#) (PVar mbad#) =
primitive_ (copyMutableByteArray# mbas# 0# mbad# 0# (sizeOfPVar# pvar))
{-# INLINE copyPVar #-}
copyPVarToPtr :: (MonadPrim s m, Prim a) => PVar a s -> Ptr a -> m ()
copyPVarToPtr pvar@(PVar mbas#) (Ptr addr#) =
primitive_ (copyMutableByteArrayToAddr# mbas# 0# addr# (sizeOfPVar# pvar))
{-# INLINE copyPVarToPtr #-}
modifyPVar :: (MonadPrim s m, Prim a) => PVar a s -> (a -> (a, b)) -> m b
modifyPVar pvar f = modifyPVarM pvar (return . f)
{-# INLINE modifyPVar #-}
modifyPVar_ :: (MonadPrim s m, Prim a) => PVar a s -> (a -> a) -> m ()
modifyPVar_ pvar f = modifyPVarM_ pvar (return . f)
{-# INLINE modifyPVar_ #-}
fetchModifyPVar :: (MonadPrim s m, Prim a) => PVar a s -> (a -> a) -> m a
fetchModifyPVar pvar f = fetchModifyPVarM pvar (return . f)
{-# INLINE fetchModifyPVar #-}
modifyFetchPVar :: (MonadPrim s m, Prim a) => PVar a s -> (a -> a) -> m a
modifyFetchPVar pvar f = modifyFetchPVarM pvar (return . f)
{-# INLINE modifyFetchPVar #-}
modifyPVarM :: (MonadPrim s m, Prim a) => PVar a s -> (a -> m (a, b)) -> m b
modifyPVarM pvar f = do
a <- readPVar pvar
(a', b) <- f a
b <$ writePVar pvar a'
{-# INLINE modifyPVarM #-}
fetchModifyPVarM :: (MonadPrim s m, Prim a) => PVar a s -> (a -> m a) -> m a
fetchModifyPVarM pvar f = do
a <- readPVar pvar
a <$ (writePVar pvar =<< f a)
{-# INLINE fetchModifyPVarM #-}
modifyFetchPVarM :: (MonadPrim s m, Prim a) => PVar a s -> (a -> m a) -> m a
modifyFetchPVarM pvar f = do
a <- readPVar pvar
a' <- f a
a' <$ writePVar pvar a'
{-# INLINE modifyFetchPVarM #-}
modifyPVarM_ :: (MonadPrim s m, Prim a) => PVar a s -> (a -> m a) -> m ()
modifyPVarM_ pvar f = readPVar pvar >>= f >>= writePVar pvar
{-# INLINE modifyPVarM_ #-}
swapPVars :: (MonadPrim s m, Prim a) => PVar a s -> PVar a s -> m (a, a)
swapPVars pvar1 pvar2 = do
a1 <- readPVar pvar1
a2 <- fetchModifyPVar pvar2 (const a1)
(a1, a2) <$ writePVar pvar1 a2
{-# INLINE swapPVars #-}
swapPVars_ :: (MonadPrim s m, Prim a) => PVar a s -> PVar a s -> m ()
swapPVars_ pvar1 pvar2 = void $ swapPVars pvar1 pvar2
{-# INLINE swapPVars_ #-}
withStorablePVar ::
(MonadPrim s m, S.Storable a)
=> a
-> (PVar a s -> Ptr a -> m b)
-> m b
withStorablePVar a f = do
pvar <- rawStorablePVar
runWithPokedPtr pvar a f
{-# INLINE withStorablePVar #-}
withAlignedStorablePVar ::
(MonadPrim s m, S.Storable a)
=> a
-> (PVar a s -> Ptr a -> m b)
-> m b
withAlignedStorablePVar a f = do
pvar <- rawAlignedStorablePVar
runWithPokedPtr pvar a f
{-# INLINE withAlignedStorablePVar #-}
atomicReadIntPVar :: MonadPrim s m => PVar Int s -> m Int
atomicReadIntPVar (PVar mba#) =
primitive $ \s# ->
case atomicReadIntArray# mba# 0# s# of
(# s'#, i# #) -> (# s'#, I# i# #)
{-# INLINE atomicReadIntPVar #-}
atomicWriteIntPVar :: MonadPrim s m => PVar Int s -> Int -> m ()
atomicWriteIntPVar (PVar mba#) a = primitive_ (atomicWriteIntArray# mba# 0# (unI# a))
{-# INLINE atomicWriteIntPVar #-}
atomicFetchModifyIntPVar ::
MonadPrim s m => PVar Int s -> (Int -> Int) -> m Int
atomicFetchModifyIntPVar pvar f =
atomicModifyIntPVar pvar $ \a ->
let a' = f a
in a' `seq` (a', a)
{-# INLINE atomicFetchModifyIntPVar #-}
atomicModifyFetchIntPVar ::
MonadPrim s m => PVar Int s -> (Int -> Int) -> m Int
atomicModifyFetchIntPVar pvar f =
atomicModifyIntPVar pvar $ \a ->
let a' = f a
in a' `seq` (a', a')
{-# INLINE atomicModifyFetchIntPVar #-}
casIntPVar ::
MonadPrim s m
=> PVar Int s
-> Int
-> Int
-> m Int
casIntPVar (PVar mba#) old new =
primitive $ \s# ->
case casIntArray# mba# 0# (unI# old) (unI# new) s# of
(# s'#, i'# #) -> (# s'#, I# i'# #)
{-# INLINE casIntPVar #-}
atomicAddIntPVar :: MonadPrim s m => PVar Int s -> Int -> m Int
atomicAddIntPVar (PVar mba#) a =
primitive $ \s# ->
case fetchAddIntArray# mba# 0# (unI# a) s# of
(# s'#, p# #) -> (# s'#, I# p# #)
{-# INLINE atomicAddIntPVar #-}
atomicSubIntPVar :: MonadPrim s m => PVar Int s -> Int -> m Int
atomicSubIntPVar (PVar mba#) a =
primitive $ \s# ->
case fetchSubIntArray# mba# 0# (unI# a) s# of
(# s'#, p# #) -> (# s'#, I# p# #)
{-# INLINE atomicSubIntPVar #-}
atomicAndIntPVar :: MonadPrim s m => PVar Int s -> Int -> m Int
atomicAndIntPVar (PVar mba#) a =
primitive $ \s# ->
case fetchAndIntArray# mba# 0# (unI# a) s# of
(# s'#, p# #) -> (# s'#, I# p# #)
{-# INLINE atomicAndIntPVar #-}
atomicNandIntPVar :: MonadPrim s m => PVar Int s -> Int -> m Int
atomicNandIntPVar (PVar mba#) a =
primitive $ \s# ->
case fetchNandIntArray# mba# 0# (unI# a) s# of
(# s'#, p# #) -> (# s'#, I# p# #)
{-# INLINE atomicNandIntPVar #-}
atomicOrIntPVar :: MonadPrim s m => PVar Int s -> Int -> m Int
atomicOrIntPVar (PVar mba#) a =
primitive $ \s# ->
case fetchOrIntArray# mba# 0# (unI# a) s# of
(# s'#, p# #) -> (# s'#, I# p# #)
{-# INLINE atomicOrIntPVar #-}
atomicXorIntPVar :: MonadPrim s m => PVar Int s -> Int -> m Int
atomicXorIntPVar (PVar mba#) a =
primitive $ \s# ->
case fetchXorIntArray# mba# 0# (unI# a) s# of
(# s'#, p# #) -> (# s'#, I# p# #)
{-# INLINE atomicXorIntPVar #-}
atomicNotIntPVar :: MonadPrim s m => PVar Int s -> m Int
atomicNotIntPVar (PVar mba#) =
primitive $ \s# ->
case fetchXorIntArray# mba# 0# fullInt# s# of
(# s'#, p# #) -> (# s'#, I# p# #)
where
fullInt# =
case maxBound :: Word of
W# w# -> word2Int# w#
{-# INLINE atomicNotIntPVar #-}