{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Data.Prim.Memory.ForeignPtr
( PtrAccess(..)
, ForeignPtr(..)
, castForeignPtr
, unsafeForeignPtrToPtr
, ForeignPtrContents(..)
, plusOffForeignPtr
, plusByteOffForeignPtr
, minusOffForeignPtr
, minusOffRemForeignPtr
, minusByteOffForeignPtr
, withForeignPtr
, withNoHaltForeignPtr
, mallocPlainForeignPtr
, mallocCountPlainForeignPtr
, mallocCountPlainForeignPtrAligned
, mallocByteCountPlainForeignPtr
, mallocByteCountPlainForeignPtrAligned
, finalizeForeignPtr
, FinalizerPtr
, newForeignPtr
, newForeignPtr_
, touchForeignPtr
, mallocForeignPtr
, mallocCountForeignPtr
, mallocCountForeignPtrAligned
, mallocByteCountForeignPtr
, mallocByteCountForeignPtrAligned
, addForeignPtrFinalizer
, FinalizerEnvPtr
, newForeignPtrEnv
, addForeignPtrFinalizerEnv
, newConcForeignPtr
, addForeignPtrConcFinalizer
, toForeignPtrBytes
, toForeignPtrMBytes
) where
import Control.Prim.Monad
import Data.Prim
import Data.Prim.Class
import Data.Prim.Memory.ByteString
import Data.Prim.Memory.Bytes.Internal
( Bytes
, MBytes(..)
, Pinned(..)
, toForeignPtrBytes
, toForeignPtrMBytes
, withNoHaltPtrBytes
, withNoHaltPtrMBytes
, withPtrBytes
, withPtrMBytes
)
import Foreign.Prim
import GHC.ForeignPtr
( FinalizerEnvPtr
, FinalizerPtr
, ForeignPtr(..)
, ForeignPtrContents(..)
, castForeignPtr
, unsafeForeignPtrToPtr
)
import qualified Foreign.ForeignPtr as GHC
import qualified GHC.ForeignPtr as GHC
class PtrAccess s p where
toForeignPtr :: MonadPrim s m => p -> m (ForeignPtr a)
withPtrAccess :: MonadPrim s m => p -> (Ptr a -> m b) -> m b
withPtrAccess p action = toForeignPtr p >>= (`withForeignPtr` action)
{-# INLINE withPtrAccess #-}
withNoHaltPtrAccess :: (MonadUnliftPrim s m) => p -> (Ptr a -> m b) -> m b
withNoHaltPtrAccess p f = do
ForeignPtr addr# ptrContents <- toForeignPtr p
withAliveUnliftPrim ptrContents $ f (Ptr addr#)
{-# INLINE withNoHaltPtrAccess #-}
instance PtrAccess s (ForeignPtr a) where
toForeignPtr = pure . coerce
{-# INLINE toForeignPtr #-}
instance PtrAccess s ByteString where
toForeignPtr (PS ps s _) = pure (coerce ps `plusByteOffForeignPtr` Off s)
{-# INLINE toForeignPtr #-}
withPtrAccess = withPtrByteString
{-# INLINE withPtrAccess #-}
withNoHaltPtrAccess = withNoHaltPtrByteString
{-# INLINE withNoHaltPtrAccess #-}
instance PtrAccess s (MByteString s) where
toForeignPtr mbs = toForeignPtr (coerce mbs :: ByteString)
{-# INLINE toForeignPtr #-}
withPtrAccess mbs = withPtrByteString (coerce mbs)
{-# INLINE withPtrAccess #-}
withNoHaltPtrAccess mbs = withNoHaltPtrByteString (coerce mbs)
{-# INLINE withNoHaltPtrAccess #-}
instance PtrAccess s (Bytes 'Pin) where
toForeignPtr = pure . toForeignPtrBytes
{-# INLINE toForeignPtr #-}
withPtrAccess = withPtrBytes
{-# INLINE withPtrAccess #-}
withNoHaltPtrAccess = withNoHaltPtrBytes
{-# INLINE withNoHaltPtrAccess #-}
instance PtrAccess s (MBytes 'Pin s) where
toForeignPtr = pure . toForeignPtrMBytes
{-# INLINE toForeignPtr #-}
withPtrAccess = withPtrMBytes
{-# INLINE withPtrAccess #-}
withNoHaltPtrAccess = withNoHaltPtrMBytes
{-# INLINE withNoHaltPtrAccess #-}
withForeignPtr :: MonadPrim s m => ForeignPtr e -> (Ptr e -> m b) -> m b
withForeignPtr (ForeignPtr addr# ptrContents) f = do
r <- f (Ptr addr#)
r <$ touch ptrContents
{-# INLINE withForeignPtr #-}
withNoHaltForeignPtr ::
MonadUnliftPrim s m => ForeignPtr e -> (Ptr e -> m b) -> m b
withNoHaltForeignPtr (ForeignPtr addr# ptrContents) f =
withAliveUnliftPrim ptrContents $ f (Ptr addr#)
{-# INLINE withNoHaltForeignPtr #-}
touchForeignPtr :: MonadPrim s m => ForeignPtr e -> m ()
touchForeignPtr (ForeignPtr _ contents) = touch contents
newForeignPtr :: MonadPrim RW m => FinalizerPtr e -> Ptr e -> m (ForeignPtr e)
newForeignPtr fin = liftPrimBase . GHC.newForeignPtr fin
newForeignPtrEnv :: MonadPrim RW m => FinalizerEnvPtr env e -> Ptr env -> Ptr e -> m (ForeignPtr e)
newForeignPtrEnv finEnv envPtr = liftPrimBase . GHC.newForeignPtrEnv finEnv envPtr
newForeignPtr_ :: MonadPrim RW m => Ptr e -> m (ForeignPtr e)
newForeignPtr_ = liftPrimBase . GHC.newForeignPtr_
mallocForeignPtr :: forall e m . (MonadPrim RW m, Prim e) => m (ForeignPtr e)
mallocForeignPtr = mallocCountForeignPtrAligned (1 :: Count e)
mallocCountForeignPtr :: (MonadPrim RW m, Prim e) => Count e -> m (ForeignPtr e)
mallocCountForeignPtr = liftPrimBase . GHC.mallocForeignPtrBytes . fromCount
mallocCountForeignPtrAligned :: (MonadPrim RW m, Prim e) => Count e -> m (ForeignPtr e)
mallocCountForeignPtrAligned count =
liftPrimBase $ GHC.mallocForeignPtrAlignedBytes (coerce count) (alignmentProxy count)
mallocByteCountForeignPtr :: MonadPrim RW m => Count Word8 -> m (ForeignPtr e)
mallocByteCountForeignPtr = liftPrimBase . GHC.mallocForeignPtrBytes . coerce
mallocByteCountForeignPtrAligned ::
MonadPrim RW m
=> Count Word8
-> Int
-> m (ForeignPtr e)
mallocByteCountForeignPtrAligned count =
liftPrimBase . GHC.mallocForeignPtrAlignedBytes (coerce count)
addForeignPtrFinalizer :: MonadPrim RW m => FinalizerPtr e -> ForeignPtr e -> m ()
addForeignPtrFinalizer fin = liftPrimBase . GHC.addForeignPtrFinalizer fin
addForeignPtrFinalizerEnv ::
MonadPrim RW m => FinalizerEnvPtr env e -> Ptr env -> ForeignPtr e -> m ()
addForeignPtrFinalizerEnv fin envPtr = liftPrimBase . GHC.addForeignPtrFinalizerEnv fin envPtr
mallocPlainForeignPtr ::
forall e m s. (MonadPrim s m, Prim e)
=> m (ForeignPtr e)
mallocPlainForeignPtr = mallocCountPlainForeignPtr (1 :: Count e)
{-# INLINE mallocPlainForeignPtr #-}
mallocCountPlainForeignPtr :: (MonadPrim s m, Prim e) => Count e -> m (ForeignPtr e)
mallocCountPlainForeignPtr = mallocByteCountPlainForeignPtr . toByteCount
{-# INLINE mallocCountPlainForeignPtr #-}
mallocCountPlainForeignPtrAligned ::
forall e m s. (MonadPrim s m, Prim e)
=> Count e
-> m (ForeignPtr e)
mallocCountPlainForeignPtrAligned c =
prim $ \s ->
let a# = alignment# (proxy# :: Proxy# e)
in case newAlignedPinnedByteArray# (fromCount# c) a# s of
(# s', mba# #) ->
let addr# = mutableByteArrayContents# mba#
in (# s', ForeignPtr addr# (PlainPtr (unsafeCoerce# mba#)) #)
{-# INLINE mallocCountPlainForeignPtrAligned #-}
mallocByteCountPlainForeignPtr :: MonadPrim s m => Count Word8 -> m (ForeignPtr e)
mallocByteCountPlainForeignPtr (Count (I# c#)) =
prim $ \s ->
case newPinnedByteArray# c# s of
(# s', mba# #) ->
(# s', ForeignPtr (mutableByteArrayContents# mba#) (PlainPtr (unsafeCoerce# mba#)) #)
{-# INLINE mallocByteCountPlainForeignPtr #-}
mallocByteCountPlainForeignPtrAligned ::
MonadPrim s m
=> Count Word8
-> Int
-> m (ForeignPtr e)
mallocByteCountPlainForeignPtrAligned (Count (I# c#)) (I# a#) =
prim $ \s ->
case newAlignedPinnedByteArray# c# a# s of
(# s', mba# #) ->
(# s', ForeignPtr (mutableByteArrayContents# mba#) (PlainPtr (unsafeCoerce# mba#)) #)
{-# INLINE mallocByteCountPlainForeignPtrAligned #-}
newConcForeignPtr :: MonadUnliftPrim RW m => Ptr e -> m () -> m (ForeignPtr e)
newConcForeignPtr ptr fin =
withRunInPrimBase $ \run -> liftPrimBase (GHC.newConcForeignPtr ptr (run fin))
addForeignPtrConcFinalizer :: MonadUnliftPrim RW m => ForeignPtr a -> m () -> m ()
addForeignPtrConcFinalizer fp fin =
withRunInPrimBase $ \run -> liftPrimBase (GHC.addForeignPtrConcFinalizer fp (run fin))
finalizeForeignPtr :: MonadPrim RW m => ForeignPtr e -> m ()
finalizeForeignPtr = liftPrimBase . GHC.finalizeForeignPtr
plusOffForeignPtr :: Prim e => ForeignPtr e -> Off e -> ForeignPtr e
plusOffForeignPtr (ForeignPtr addr# content) off =
ForeignPtr (addr# `plusAddr#` fromOff# off) content
{-# INLINE plusOffForeignPtr #-}
plusByteOffForeignPtr :: ForeignPtr e -> Off Word8 -> ForeignPtr e
plusByteOffForeignPtr (ForeignPtr addr# content) (Off (I# c#)) =
ForeignPtr (addr# `plusAddr#` c#) content
{-# INLINE plusByteOffForeignPtr #-}
minusByteOffForeignPtr :: ForeignPtr e -> ForeignPtr e -> Off Word8
minusByteOffForeignPtr (ForeignPtr xaddr# _) (ForeignPtr yaddr# _) =
Off (I# (xaddr# `minusAddr#` yaddr#))
{-# INLINE minusByteOffForeignPtr #-}
minusOffForeignPtr :: Prim e => ForeignPtr e -> ForeignPtr e -> Off e
minusOffForeignPtr (ForeignPtr xaddr# _) (ForeignPtr yaddr# _) =
fromByteOff (Off (I# (xaddr# `minusAddr#` yaddr#)))
{-# INLINE minusOffForeignPtr #-}
minusOffRemForeignPtr :: Prim e => ForeignPtr e -> ForeignPtr e -> (Off e, Off Word8)
minusOffRemForeignPtr (ForeignPtr xaddr# _) (ForeignPtr yaddr# _) =
fromByteOffRem (Off (I# (xaddr# `minusAddr#` yaddr#)))
{-# INLINE minusOffRemForeignPtr #-}