{-# LANGUAGE CPP #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE RoleAnnotations #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE Unsafe #-}
module Data.Primitive.PrimRef
(
PrimRef(..)
, newPrimRef
, newPinnedPrimRef
, newAlignedPinnedPrimRef
, readPrimRef
, writePrimRef
, primRefContents
, FrozenPrimRef(..)
, newFrozenPrimRef
, unsafeFreezePrimRef
, unsafeThawPrimRef
, indexFrozenPrimRef
, frozenPrimRefContents
, casInt
, fetchAddInt
, fetchSubInt
, fetchAndInt
, fetchNandInt
, fetchOrInt
, fetchXorInt
, atomicReadInt
, atomicWriteInt
) where
import Control.Monad.Primitive
import Control.Monad.ST
import Data.Data
import Data.Primitive
import GHC.Prim
import GHC.Types (Int(I#))
newtype PrimRef s a = PrimRef (MutableByteArray s)
#ifndef HLINT
type role PrimRef nominal nominal
#endif
newPrimRef :: (PrimMonad m, Prim a) => a -> m (PrimRef (PrimState m) a)
newPrimRef a = do
m <- newByteArray (sizeOf a)
writeByteArray m 0 a
return (PrimRef m)
{-# INLINE newPrimRef #-}
newPinnedPrimRef :: (PrimMonad m, Prim a) => a -> m (PrimRef (PrimState m) a)
newPinnedPrimRef a = do
m <- newPinnedByteArray (sizeOf a)
writeByteArray m 0 a
return (PrimRef m)
{-# INLINE newPinnedPrimRef #-}
newAlignedPinnedPrimRef :: (PrimMonad m, Prim a) => a -> m (PrimRef (PrimState m) a)
newAlignedPinnedPrimRef a = do
m <- newAlignedPinnedByteArray (sizeOf a) (alignment a)
writeByteArray m 0 a
return (PrimRef m)
{-# INLINE newAlignedPinnedPrimRef #-}
readPrimRef :: (PrimMonad m, Prim a) => PrimRef (PrimState m) a -> m a
readPrimRef (PrimRef m) = readByteArray m 0
{-# INLINE readPrimRef #-}
writePrimRef :: (PrimMonad m, Prim a) => PrimRef (PrimState m) a -> a -> m ()
writePrimRef (PrimRef m) a = writeByteArray m 0 a
{-# INLINE writePrimRef #-}
instance Eq (PrimRef s a) where
PrimRef m == PrimRef n = sameMutableByteArray m n
{-# INLINE (==) #-}
primRefContents :: PrimRef s a -> Addr
primRefContents (PrimRef m) = mutableByteArrayContents m
{-# INLINE primRefContents #-}
unsafeFreezePrimRef :: PrimMonad m => PrimRef (PrimState m) a -> m (FrozenPrimRef a)
unsafeFreezePrimRef (PrimRef m) = FrozenPrimRef <$> unsafeFreezeByteArray m
{-# INLINE unsafeFreezePrimRef #-}
newtype FrozenPrimRef a = FrozenPrimRef ByteArray
#ifndef HLINT
type role FrozenPrimRef nominal
#endif
newFrozenPrimRef :: Prim a => a -> FrozenPrimRef a
newFrozenPrimRef a = runST $ newPrimRef a >>= unsafeFreezePrimRef
indexFrozenPrimRef :: Prim a => FrozenPrimRef a -> a
indexFrozenPrimRef (FrozenPrimRef ba) = indexByteArray ba 0
{-# INLINE indexFrozenPrimRef #-}
unsafeThawPrimRef :: PrimMonad m => FrozenPrimRef a -> m (PrimRef (PrimState m) a)
unsafeThawPrimRef (FrozenPrimRef m) = PrimRef <$> unsafeThawByteArray m
{-# INLINE unsafeThawPrimRef #-}
frozenPrimRefContents :: FrozenPrimRef a -> Addr
frozenPrimRefContents (FrozenPrimRef m) = byteArrayContents m
{-# INLINE frozenPrimRefContents #-}
casInt :: PrimMonad m => PrimRef (PrimState m) Int -> Int -> Int -> m Int
casInt (PrimRef (MutableByteArray m)) (I# old) (I# new) = primitive $ \s -> case casIntArray# m 0# old new s of
(# s', result #) -> (# s', I# result #)
fetchAddInt :: PrimMonad m => PrimRef (PrimState m) Int -> Int -> m Int
fetchAddInt (PrimRef (MutableByteArray m)) (I# x) = primitive $ \s -> case fetchAddIntArray# m 0# x s of
(# s', result #) -> (# s', I# result #)
fetchSubInt :: PrimMonad m => PrimRef (PrimState m) Int -> Int -> m Int
fetchSubInt (PrimRef (MutableByteArray m)) (I# x) = primitive $ \s -> case fetchSubIntArray# m 0# x s of
(# s', result #) -> (# s', I# result #)
fetchAndInt :: PrimMonad m => PrimRef (PrimState m) Int -> Int -> m Int
fetchAndInt (PrimRef (MutableByteArray m)) (I# x) = primitive $ \s -> case fetchAndIntArray# m 0# x s of
(# s', result #) -> (# s', I# result #)
fetchNandInt :: PrimMonad m => PrimRef (PrimState m) Int -> Int -> m Int
fetchNandInt (PrimRef (MutableByteArray m)) (I# x) = primitive $ \s -> case fetchNandIntArray# m 0# x s of
(# s', result #) -> (# s', I# result #)
fetchOrInt :: PrimMonad m => PrimRef (PrimState m) Int -> Int -> m Int
fetchOrInt (PrimRef (MutableByteArray m)) (I# x) = primitive $ \s -> case fetchOrIntArray# m 0# x s of
(# s', result #) -> (# s', I# result #)
fetchXorInt :: PrimMonad m => PrimRef (PrimState m) Int -> Int -> m Int
fetchXorInt (PrimRef (MutableByteArray m)) (I# x) = primitive $ \s -> case fetchXorIntArray# m 0# x s of
(# s', result #) -> (# s', I# result #)
atomicReadInt :: PrimMonad m => PrimRef (PrimState m) Int -> m Int
atomicReadInt (PrimRef (MutableByteArray m)) = primitive $ \s -> case atomicReadIntArray# m 0# s of
(# s', result #) -> (# s', I# result #)
atomicWriteInt :: PrimMonad m => PrimRef (PrimState m) Int -> Int -> m ()
atomicWriteInt (PrimRef (MutableByteArray m)) (I# x) = primitive_ $ \s -> atomicWriteIntArray# m 0# x s
instance (Prim a, Data a) => Data (FrozenPrimRef a) where
gfoldl f z m = z newFrozenPrimRef `f` indexFrozenPrimRef m
toConstr _ = newFrozenPrimRefConstr
gunfold k z c = case constrIndex c of
1 -> k (z newFrozenPrimRef)
_ -> error "gunfold"
dataTypeOf _ = frozenPrimRefDataType
newFrozenPrimRefConstr :: Constr
newFrozenPrimRefConstr = mkConstr frozenPrimRefDataType "newFrozenPrimRef" [] Prefix
frozenPrimRefDataType :: DataType
frozenPrimRefDataType = mkDataType "Data.Transient.Primitive.FrozenPrimRef" [newFrozenPrimRefConstr]