module Z.Foreign.CPtr (
CPtr, newCPtr', newCPtrUnsafe, newCPtr
, withCPtr, withCPtrsUnsafe, withCPtrForever, withCPtrs
, addCPtrDep
, Ptr
, nullPtr
, FunPtr
) where
import Control.Monad
import Control.Monad.Primitive
import Data.Primitive.PrimArray
import qualified Z.Data.Text as T
import GHC.Ptr
import GHC.Exts
import GHC.IO
import Z.Data.Array hiding (newPinnedPrimArray)
import Z.Foreign
newtype CPtr a = CPtr (PrimArray (Ptr a))
instance Eq (CPtr a) where
{-# INLINE (==) #-}
CPtr PrimArray (Ptr a)
a == :: CPtr a -> CPtr a -> Bool
== CPtr PrimArray (Ptr a)
b = forall a. Prim a => PrimArray a -> Int -> a
indexPrimArray PrimArray (Ptr a)
a Int
0 forall a. Eq a => a -> a -> Bool
== forall a. Prim a => PrimArray a -> Int -> a
indexPrimArray PrimArray (Ptr a)
b Int
0
instance Ord (CPtr a) where
{-# INLINE compare #-}
CPtr PrimArray (Ptr a)
a compare :: CPtr a -> CPtr a -> Ordering
`compare` CPtr PrimArray (Ptr a)
b = forall a. Prim a => PrimArray a -> Int -> a
indexPrimArray PrimArray (Ptr a)
a Int
0 forall a. Ord a => a -> a -> Ordering
`compare` forall a. Prim a => PrimArray a -> Int -> a
indexPrimArray PrimArray (Ptr a)
b Int
0
instance Show (CPtr a) where
show :: CPtr a -> String
show = forall a. Print a => a -> String
T.toString
instance T.Print (CPtr a) where
{-# INLINE toUTF8BuilderP #-}
toUTF8BuilderP :: Int -> CPtr a -> Builder ()
toUTF8BuilderP Int
_ (CPtr PrimArray (Ptr a)
mpa) = forall a. Print a => Int -> a -> Builder ()
T.toUTF8BuilderP Int
0 (forall a. Prim a => PrimArray a -> Int -> a
indexPrimArray PrimArray (Ptr a)
mpa Int
0)
newCPtr' :: IO (Ptr a)
-> FunPtr (Ptr a -> IO b)
-> IO (CPtr a)
{-# INLINABLE newCPtr' #-}
newCPtr' :: forall a b. IO (Ptr a) -> FunPtr (Ptr a -> IO b) -> IO (CPtr a)
newCPtr' IO (Ptr a)
ini (FunPtr Addr#
fin#) = forall a. IO a -> IO a
mask_ forall a b. (a -> b) -> a -> b
$ do
MutablePrimArray RealWorld (Ptr a)
mpa <- forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
Int -> m (MutablePrimArray (PrimState m) a)
newPrimArray Int
1
p :: Ptr a
p@(Ptr Addr#
addr#) <- IO (Ptr a)
ini
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> a -> m ()
writePrimArray MutablePrimArray RealWorld (Ptr a)
mpa Int
0 Ptr a
p
pa :: PrimArray (Ptr a)
pa@(PrimArray ByteArray#
ba#) <- forall (m :: * -> *) a.
PrimMonad m =>
MutablePrimArray (PrimState m) a -> m (PrimArray a)
unsafeFreezePrimArray MutablePrimArray RealWorld (Ptr a)
mpa
forall (m :: * -> *).
PrimMonad m =>
(State# (PrimState m) -> State# (PrimState m)) -> m ()
primitive_ forall a b. (a -> b) -> a -> b
$ \ State# (PrimState IO)
s0# ->
let !(# State# RealWorld
s1#, Weak# ()
w# #) = mkWeakNoFinalizer# :: forall a b.
a -> b -> State# RealWorld -> (# State# RealWorld, Weak# b #)
mkWeakNoFinalizer# ByteArray#
ba# () State# (PrimState IO)
s0#
!(# State# RealWorld
s2#, Int#
_ #) = forall b.
Addr#
-> Addr#
-> Int#
-> Addr#
-> Weak# b
-> State# RealWorld
-> (# State# RealWorld, Int# #)
addCFinalizerToWeak# Addr#
fin# Addr#
addr# Int#
0# Addr#
addr# Weak# ()
w# State# RealWorld
s1#
in State# RealWorld
s2#
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. PrimArray (Ptr a) -> CPtr a
CPtr PrimArray (Ptr a)
pa)
newCPtrUnsafe :: (MutableByteArray# RealWorld -> IO r)
-> FunPtr (Ptr a -> IO b)
-> IO (CPtr a, r)
{-# INLINABLE newCPtrUnsafe #-}
newCPtrUnsafe :: forall r a b.
(MutableByteArray# RealWorld -> IO r)
-> FunPtr (Ptr a -> IO b) -> IO (CPtr a, r)
newCPtrUnsafe MutableByteArray# RealWorld -> IO r
ini (FunPtr Addr#
fin#) = forall a. IO a -> IO a
mask_ forall a b. (a -> b) -> a -> b
$ do
mpa :: MutablePrimArray RealWorld (Ptr a)
mpa@(MutablePrimArray MutableByteArray# RealWorld
mba#) <- forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
Int -> m (MutablePrimArray (PrimState m) a)
newPrimArray Int
1
r
r <- MutableByteArray# RealWorld -> IO r
ini MutableByteArray# RealWorld
mba#
(Ptr Addr#
addr#) <- forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> m a
readPrimArray MutablePrimArray RealWorld (Ptr a)
mpa Int
0
pa :: PrimArray (Ptr a)
pa@(PrimArray ByteArray#
ba#) <- forall (m :: * -> *) a.
PrimMonad m =>
MutablePrimArray (PrimState m) a -> m (PrimArray a)
unsafeFreezePrimArray MutablePrimArray RealWorld (Ptr a)
mpa
forall (m :: * -> *).
PrimMonad m =>
(State# (PrimState m) -> State# (PrimState m)) -> m ()
primitive_ forall a b. (a -> b) -> a -> b
$ \ State# (PrimState IO)
s0# ->
let !(# State# RealWorld
s1#, Weak# ()
w# #) = mkWeakNoFinalizer# :: forall a b.
a -> b -> State# RealWorld -> (# State# RealWorld, Weak# b #)
mkWeakNoFinalizer# ByteArray#
ba# () State# (PrimState IO)
s0#
!(# State# RealWorld
s2#, Int#
_ #) = forall b.
Addr#
-> Addr#
-> Int#
-> Addr#
-> Weak# b
-> State# RealWorld
-> (# State# RealWorld, Int# #)
addCFinalizerToWeak# Addr#
fin# Addr#
addr# Int#
0# Addr#
addr# Weak# ()
w# State# RealWorld
s1#
in State# RealWorld
s2#
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. PrimArray (Ptr a) -> CPtr a
CPtr PrimArray (Ptr a)
pa, r
r)
newCPtr :: (Ptr (Ptr a) -> IO r)
-> FunPtr (Ptr a -> IO b)
-> IO (CPtr a, r)
{-# INLINABLE newCPtr #-}
newCPtr :: forall a r b.
(Ptr (Ptr a) -> IO r) -> FunPtr (Ptr a -> IO b) -> IO (CPtr a, r)
newCPtr Ptr (Ptr a) -> IO r
ini (FunPtr Addr#
fin#) = forall a. IO a -> IO a
mask_ forall a b. (a -> b) -> a -> b
$ do
MutablePrimArray RealWorld (Ptr a)
mpa <- forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
Int -> m (MutablePrimArray (PrimState m) a)
newPinnedPrimArray Int
1
r
r <- Ptr (Ptr a) -> IO r
ini (forall s a. MutablePrimArray s a -> Ptr a
mutablePrimArrayContents MutablePrimArray RealWorld (Ptr a)
mpa)
(Ptr Addr#
addr#) <- forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> m a
readPrimArray MutablePrimArray RealWorld (Ptr a)
mpa Int
0
pa :: PrimArray (Ptr a)
pa@(PrimArray ByteArray#
ba#) <- forall (m :: * -> *) a.
PrimMonad m =>
MutablePrimArray (PrimState m) a -> m (PrimArray a)
unsafeFreezePrimArray MutablePrimArray RealWorld (Ptr a)
mpa
forall (m :: * -> *).
PrimMonad m =>
(State# (PrimState m) -> State# (PrimState m)) -> m ()
primitive_ forall a b. (a -> b) -> a -> b
$ \ State# (PrimState IO)
s0# ->
let !(# State# RealWorld
s1#, Weak# ()
w# #) = mkWeakNoFinalizer# :: forall a b.
a -> b -> State# RealWorld -> (# State# RealWorld, Weak# b #)
mkWeakNoFinalizer# ByteArray#
ba# () State# (PrimState IO)
s0#
!(# State# RealWorld
s2#, Int#
_ #) = forall b.
Addr#
-> Addr#
-> Int#
-> Addr#
-> Weak# b
-> State# RealWorld
-> (# State# RealWorld, Int# #)
addCFinalizerToWeak# Addr#
fin# Addr#
addr# Int#
0# Addr#
addr# Weak# ()
w# State# RealWorld
s1#
in State# RealWorld
s2#
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. PrimArray (Ptr a) -> CPtr a
CPtr PrimArray (Ptr a)
pa, r
r)
withCPtr :: CPtr a -> (Ptr a -> IO b) -> IO b
{-# INLINABLE withCPtr #-}
withCPtr :: forall a b. CPtr a -> (Ptr a -> IO b) -> IO b
withCPtr (CPtr pa :: PrimArray (Ptr a)
pa@(PrimArray ByteArray#
ba#)) Ptr a -> IO b
f = do
b
r <- Ptr a -> IO b
f (forall a. Prim a => PrimArray a -> Int -> a
indexPrimArray PrimArray (Ptr a)
pa Int
0)
forall (m :: * -> *).
PrimMonad m =>
(State# (PrimState m) -> State# (PrimState m)) -> m ()
primitive_ (touch# :: forall a. a -> State# RealWorld -> State# RealWorld
touch# ByteArray#
ba#)
forall (m :: * -> *) a. Monad m => a -> m a
return b
r
withCPtrForever :: CPtr a -> (Ptr a -> IO b) -> IO b
{-# INLINABLE withCPtrForever #-}
withCPtrForever :: forall a b. CPtr a -> (Ptr a -> IO b) -> IO b
withCPtrForever (CPtr pa :: PrimArray (Ptr a)
pa@(PrimArray ByteArray#
ba#)) Ptr a -> IO b
f = forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO forall a b. (a -> b) -> a -> b
$ \ State# RealWorld
s ->
case Ptr a -> IO b
f (forall a. Prim a => PrimArray a -> Int -> a
indexPrimArray PrimArray (Ptr a)
pa Int
0) of
IO State# RealWorld -> (# State# RealWorld, b #)
action# -> keepAlive# :: forall a b. a -> State# RealWorld -> (State# RealWorld -> b) -> b
keepAlive# ByteArray#
ba# State# RealWorld
s State# RealWorld -> (# State# RealWorld, b #)
action#
withCPtrsUnsafe :: forall a b. [CPtr a] -> (BA# (Ptr a) -> Int -> IO b) -> IO b
{-# INLINABLE withCPtrsUnsafe #-}
withCPtrsUnsafe :: forall a b. [CPtr a] -> (ByteArray# -> Int -> IO b) -> IO b
withCPtrsUnsafe [CPtr a]
cptrs ByteArray# -> Int -> IO b
f = do
MutablePrimArray RealWorld (Ptr a)
mpa <- forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
Int -> m (MutablePrimArray (PrimState m) a)
newPrimArray @IO @(Ptr a) Int
len
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m ()
foldM_ (\ !Int
i (CPtr PrimArray (Ptr a)
pa) ->
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> a -> m ()
writePrimArray MutablePrimArray RealWorld (Ptr a)
mpa Int
i (forall a. Prim a => PrimArray a -> Int -> a
indexPrimArray PrimArray (Ptr a)
pa Int
0) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return (Int
iforall a. Num a => a -> a -> a
+Int
1)) Int
0 [CPtr a]
cptrs
(PrimArray ByteArray#
ba#) <- forall (m :: * -> *) a.
PrimMonad m =>
MutablePrimArray (PrimState m) a -> m (PrimArray a)
unsafeFreezePrimArray MutablePrimArray RealWorld (Ptr a)
mpa
b
r <- ByteArray# -> Int -> IO b
f ByteArray#
ba# Int
len
forall (m :: * -> *).
PrimMonad m =>
(State# (PrimState m) -> State# (PrimState m)) -> m ()
primitive_ (touch# :: forall a. a -> State# RealWorld -> State# RealWorld
touch# [CPtr a]
cptrs)
forall (m :: * -> *) a. Monad m => a -> m a
return b
r
where len :: Int
len = forall (t :: * -> *) a. Foldable t => t a -> Int
length [CPtr a]
cptrs
withCPtrs :: forall a b. [CPtr a] -> (Ptr (Ptr a) -> Int -> IO b) -> IO b
{-# INLINABLE withCPtrs #-}
withCPtrs :: forall a b. [CPtr a] -> (Ptr (Ptr a) -> Int -> IO b) -> IO b
withCPtrs [CPtr a]
cptrs Ptr (Ptr a) -> Int -> IO b
f = do
MutablePrimArray RealWorld (Ptr a)
mpa <- forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
Int -> m (MutablePrimArray (PrimState m) a)
newPinnedPrimArray @IO @(Ptr a) Int
len
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m ()
foldM_ (\ !Int
i (CPtr PrimArray (Ptr a)
pa) ->
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> a -> m ()
writePrimArray MutablePrimArray RealWorld (Ptr a)
mpa Int
i (forall a. Prim a => PrimArray a -> Int -> a
indexPrimArray PrimArray (Ptr a)
pa Int
0) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return (Int
iforall a. Num a => a -> a -> a
+Int
1)) Int
0 [CPtr a]
cptrs
b
r <- forall a b. MutablePrimArray RealWorld a -> (Ptr a -> IO b) -> IO b
withMutablePrimArrayContents MutablePrimArray RealWorld (Ptr a)
mpa forall a b. (a -> b) -> a -> b
$ \ Ptr (Ptr a)
p -> Ptr (Ptr a) -> Int -> IO b
f Ptr (Ptr a)
p Int
len
forall (m :: * -> *).
PrimMonad m =>
(State# (PrimState m) -> State# (PrimState m)) -> m ()
primitive_ (touch# :: forall a. a -> State# RealWorld -> State# RealWorld
touch# [CPtr a]
cptrs)
forall (m :: * -> *) a. Monad m => a -> m a
return b
r
where len :: Int
len = forall (t :: * -> *) a. Foldable t => t a -> Int
length [CPtr a]
cptrs
addCPtrDep :: CPtr a -> b -> IO ()
{-# INLINABLE addCPtrDep #-}
addCPtrDep :: forall a b. CPtr a -> b -> IO ()
addCPtrDep (CPtr (PrimArray ByteArray#
ba#)) b
b =
forall (m :: * -> *).
PrimMonad m =>
(State# (PrimState m) -> State# (PrimState m)) -> m ()
primitive_ forall a b. (a -> b) -> a -> b
$ \ State# (PrimState IO)
s0# ->
let !(# State# RealWorld
s1#, Weak# b
_ #) = mkWeakNoFinalizer# :: forall a b.
a -> b -> State# RealWorld -> (# State# RealWorld, Weak# b #)
mkWeakNoFinalizer# ByteArray#
ba# b
b State# (PrimState IO)
s0#
in State# RealWorld
s1#