{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UnboxedTuples #-}
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.Bytes.Internal (Bytes, MBytes(..), Pinned(..),
toForeignPtrBytes, toForeignPtrMBytes,
withNoHaltPtrBytes, withNoHaltPtrMBytes,
withPtrBytes, withPtrMBytes)
import Data.Prim.Memory.ByteString
import qualified Foreign.ForeignPtr as GHC
import Foreign.Prim
import GHC.ForeignPtr (FinalizerEnvPtr, FinalizerPtr, ForeignPtr(..),
ForeignPtrContents(..), castForeignPtr,
unsafeForeignPtrToPtr)
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 action = toForeignPtr p >>= (`withNoHaltForeignPtr` action)
{-# 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 . unCountBytes
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# (unCountBytes# 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#` unOffBytes# 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 #-}