{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE Strict #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE UnliftedFFITypes #-}
module Graphics.Vulkan.Marshal.Internal
( VulkanMarshalPrim (..)
, fromForeignPtr#
, toForeignPtr#, toPlainForeignPtr#
, touchVkData#
, cmpBytes#
, newVkData#
, mallocVkData#, mallocVkDataArray#
, peekVkData#, pokeVkData#
) where
import Foreign.C.Types (CInt (..), CSize (..))
import Foreign.ForeignPtr (ForeignPtr, newForeignPtr_)
import Foreign.Storable (Storable (..))
import GHC.Base (Addr#, ByteArray#, IO (..), Int (..), Int#,
byteArrayContents#, copyAddrToByteArray#,
eqAddr#, isTrue#, minusAddr#,
newAlignedPinnedByteArray#, touch#,
unsafeCoerce#, unsafeFreezeByteArray#,
(*#), (+#), (>=#))
import GHC.Ptr (Ptr (..))
import GHC.ForeignPtr (ForeignPtr (..), ForeignPtrContents (..))
class VulkanMarshalPrim a where
unsafeAddr :: a -> Addr#
unsafeByteArray :: a -> ByteArray#
unsafeFromByteArrayOffset :: Int# -> ByteArray# -> a
fromForeignPtr# :: forall a . (Storable a, VulkanMarshalPrim a)
=> ForeignPtr a -> IO a
fromForeignPtr# :: ForeignPtr a -> IO a
fromForeignPtr# (ForeignPtr Addr#
addr PlainForeignPtr{})
| I# Int#
n <- a -> Int
forall a. Storable a => a -> Int
sizeOf (a
forall a. HasCallStack => a
undefined :: a)
, I# Int#
a <- a -> Int
forall a. Storable a => a -> Int
alignment (a
forall a. HasCallStack => a
undefined :: a)
= (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO
(\State# RealWorld
s0 -> case Int#
-> Int#
-> State# RealWorld
-> (# State# RealWorld, MutableByteArray# RealWorld #)
forall d.
Int# -> Int# -> State# d -> (# State# d, MutableByteArray# d #)
newAlignedPinnedByteArray# Int#
n Int#
a State# RealWorld
s0 of
(# State# RealWorld
s1, MutableByteArray# RealWorld
mba #) -> case Addr#
-> MutableByteArray# RealWorld
-> Int#
-> Int#
-> State# RealWorld
-> State# RealWorld
forall d.
Addr#
-> MutableByteArray# d -> Int# -> Int# -> State# d -> State# d
copyAddrToByteArray# Addr#
addr MutableByteArray# RealWorld
mba Int#
0# Int#
n State# RealWorld
s1 of
State# RealWorld
s2 -> case MutableByteArray# RealWorld
-> State# RealWorld -> (# State# RealWorld, ByteArray# #)
forall d.
MutableByteArray# d -> State# d -> (# State# d, ByteArray# #)
unsafeFreezeByteArray# MutableByteArray# RealWorld
mba State# RealWorld
s2 of
(# State# RealWorld
s3, ByteArray#
ba #) -> (# State# RealWorld
s3, Int# -> ByteArray# -> a
forall a. VulkanMarshalPrim a => Int# -> ByteArray# -> a
unsafeFromByteArrayOffset Int#
0# ByteArray#
ba #)
)
fromForeignPtr# (ForeignPtr Addr#
addr (MallocPtr MutableByteArray# RealWorld
mba IORef Finalizers
_))
= (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO
(\State# RealWorld
s0 -> case MutableByteArray# RealWorld
-> State# RealWorld -> (# State# RealWorld, ByteArray# #)
forall d.
MutableByteArray# d -> State# d -> (# State# d, ByteArray# #)
unsafeFreezeByteArray# MutableByteArray# RealWorld
mba State# RealWorld
s0 of
(# State# RealWorld
s1, ByteArray#
ba #) -> (# State# RealWorld
s1, Int# -> ByteArray# -> a
forall a. VulkanMarshalPrim a => Int# -> ByteArray# -> a
unsafeFromByteArrayOffset
(Addr# -> Addr# -> Int#
minusAddr# Addr#
addr (ByteArray# -> Addr#
byteArrayContents# ByteArray#
ba)) ByteArray#
ba #)
)
fromForeignPtr# (ForeignPtr Addr#
addr (PlainPtr MutableByteArray# RealWorld
mba))
= (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO
(\State# RealWorld
s0 -> case MutableByteArray# RealWorld
-> State# RealWorld -> (# State# RealWorld, ByteArray# #)
forall d.
MutableByteArray# d -> State# d -> (# State# d, ByteArray# #)
unsafeFreezeByteArray# MutableByteArray# RealWorld
mba State# RealWorld
s0 of
(# State# RealWorld
s1, ByteArray#
ba #) -> (# State# RealWorld
s1, Int# -> ByteArray# -> a
forall a. VulkanMarshalPrim a => Int# -> ByteArray# -> a
unsafeFromByteArrayOffset
(Addr# -> Addr# -> Int#
minusAddr# Addr#
addr (ByteArray# -> Addr#
byteArrayContents# ByteArray#
ba)) ByteArray#
ba #)
)
{-# INLINE fromForeignPtr# #-}
toForeignPtr# :: VulkanMarshalPrim a => a -> IO (ForeignPtr a)
toForeignPtr# :: a -> IO (ForeignPtr a)
toForeignPtr# a
x
| Addr#
a <- a -> Addr#
forall a. VulkanMarshalPrim a => a -> Addr#
unsafeAddr a
x
, ByteArray#
b <- a -> ByteArray#
forall a. VulkanMarshalPrim a => a -> ByteArray#
unsafeByteArray a
x = do
ForeignPtr Addr#
_ (PlainForeignPtr IORef Finalizers
r)
<- Ptr Any -> IO (ForeignPtr Any)
forall a. Ptr a -> IO (ForeignPtr a)
newForeignPtr_ (Addr# -> Ptr Any
forall a. Addr# -> Ptr a
Ptr Addr#
a)
(State# RealWorld -> (# State# RealWorld, ForeignPtr a #))
-> IO (ForeignPtr a)
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO (\State# RealWorld
s -> (# State# RealWorld
s, Addr# -> ForeignPtrContents -> ForeignPtr a
forall a. Addr# -> ForeignPtrContents -> ForeignPtr a
ForeignPtr Addr#
a (MutableByteArray# RealWorld
-> IORef Finalizers -> ForeignPtrContents
MallocPtr (ByteArray# -> MutableByteArray# RealWorld
unsafeCoerce# ByteArray#
b) IORef Finalizers
r) #))
{-# INLINE toForeignPtr# #-}
toPlainForeignPtr# :: VulkanMarshalPrim a => a -> IO (ForeignPtr a)
toPlainForeignPtr# :: a -> IO (ForeignPtr a)
toPlainForeignPtr# a
x
| Addr#
a <- a -> Addr#
forall a. VulkanMarshalPrim a => a -> Addr#
unsafeAddr a
x
, ByteArray#
b <- a -> ByteArray#
forall a. VulkanMarshalPrim a => a -> ByteArray#
unsafeByteArray a
x = (State# RealWorld -> (# State# RealWorld, ForeignPtr a #))
-> IO (ForeignPtr a)
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO
(\State# RealWorld
s -> (# State# RealWorld
s, Addr# -> ForeignPtrContents -> ForeignPtr a
forall a. Addr# -> ForeignPtrContents -> ForeignPtr a
ForeignPtr Addr#
a (MutableByteArray# RealWorld -> ForeignPtrContents
PlainPtr (ByteArray# -> MutableByteArray# RealWorld
unsafeCoerce# ByteArray#
b)) #))
{-# INLINE toPlainForeignPtr# #-}
touchVkData# :: VulkanMarshalPrim a => a -> IO ()
touchVkData# :: a -> IO ()
touchVkData# a
a = (State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO (\State# RealWorld
s -> (# ByteArray# -> State# RealWorld -> State# RealWorld
forall k1. k1 -> State# RealWorld -> State# RealWorld
touch# (a -> ByteArray#
forall a. VulkanMarshalPrim a => a -> ByteArray#
unsafeByteArray a
a) State# RealWorld
s, () #))
{-# INLINE touchVkData# #-}
newVkData# :: forall a
. (Storable a, VulkanMarshalPrim a)
=> (Ptr a -> IO ()) -> IO a
newVkData# :: (Ptr a -> IO ()) -> IO a
newVkData# Ptr a -> IO ()
f
| I# Int#
n <- a -> Int
forall a. Storable a => a -> Int
sizeOf (a
forall a. HasCallStack => a
undefined :: a)
, I# Int#
a <- a -> Int
forall a. Storable a => a -> Int
alignment (a
forall a. HasCallStack => a
undefined :: a)
= (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO
(\State# RealWorld
s0 -> case Int#
-> Int#
-> State# RealWorld
-> (# State# RealWorld, MutableByteArray# RealWorld #)
forall d.
Int# -> Int# -> State# d -> (# State# d, MutableByteArray# d #)
newAlignedPinnedByteArray# Int#
n Int#
a State# RealWorld
s0 of
(# State# RealWorld
s1, MutableByteArray# RealWorld
mba #) -> case MutableByteArray# RealWorld
-> State# RealWorld -> (# State# RealWorld, ByteArray# #)
forall d.
MutableByteArray# d -> State# d -> (# State# d, ByteArray# #)
unsafeFreezeByteArray# MutableByteArray# RealWorld
mba State# RealWorld
s1 of
(# State# RealWorld
s2, ByteArray#
ba #) -> case Ptr a -> IO ()
f (Addr# -> Ptr a
forall a. Addr# -> Ptr a
Ptr (ByteArray# -> Addr#
byteArrayContents# ByteArray#
ba)) of
IO State# RealWorld -> (# State# RealWorld, () #)
k -> case State# RealWorld -> (# State# RealWorld, () #)
k State# RealWorld
s2 of
(# State# RealWorld
s3, () #) -> (# State# RealWorld
s3, Int# -> ByteArray# -> a
forall a. VulkanMarshalPrim a => Int# -> ByteArray# -> a
unsafeFromByteArrayOffset Int#
0# ByteArray#
ba #)
)
{-# INLINE newVkData# #-}
mallocVkData# :: forall a
. (Storable a, VulkanMarshalPrim a)
=> IO a
mallocVkData# :: IO a
mallocVkData#
| I# Int#
n <- a -> Int
forall a. Storable a => a -> Int
sizeOf (a
forall a. HasCallStack => a
undefined :: a)
, I# Int#
a <- a -> Int
forall a. Storable a => a -> Int
alignment (a
forall a. HasCallStack => a
undefined :: a)
= (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO
(\State# RealWorld
s0 -> case Int#
-> Int#
-> State# RealWorld
-> (# State# RealWorld, MutableByteArray# RealWorld #)
forall d.
Int# -> Int# -> State# d -> (# State# d, MutableByteArray# d #)
newAlignedPinnedByteArray# Int#
n Int#
a State# RealWorld
s0 of
(# State# RealWorld
s1, MutableByteArray# RealWorld
mba #) -> case MutableByteArray# RealWorld
-> State# RealWorld -> (# State# RealWorld, ByteArray# #)
forall d.
MutableByteArray# d -> State# d -> (# State# d, ByteArray# #)
unsafeFreezeByteArray# MutableByteArray# RealWorld
mba State# RealWorld
s1 of
(# State# RealWorld
s2, ByteArray#
ba #) -> (# State# RealWorld
s2, Int# -> ByteArray# -> a
forall a. VulkanMarshalPrim a => Int# -> ByteArray# -> a
unsafeFromByteArrayOffset Int#
0# ByteArray#
ba #)
)
{-# INLINE mallocVkData# #-}
mallocVkDataArray# :: forall a
. (Storable a, VulkanMarshalPrim a)
=> Int -> IO (Ptr a, [a])
mallocVkDataArray# :: Int -> IO (Ptr a, [a])
mallocVkDataArray# (I# Int#
m)
| I# Int#
n <- a -> Int
forall a. Storable a => a -> Int
sizeOf (a
forall a. HasCallStack => a
undefined :: a)
, I# Int#
a <- a -> Int
forall a. Storable a => a -> Int
alignment (a
forall a. HasCallStack => a
undefined :: a)
, Int#
nm <- Int#
n Int# -> Int# -> Int#
*# Int#
m
= (State# RealWorld -> (# State# RealWorld, (Ptr a, [a]) #))
-> IO (Ptr a, [a])
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO
(\State# RealWorld
s0 -> case Int#
-> Int#
-> State# RealWorld
-> (# State# RealWorld, MutableByteArray# RealWorld #)
forall d.
Int# -> Int# -> State# d -> (# State# d, MutableByteArray# d #)
newAlignedPinnedByteArray# Int#
nm Int#
a State# RealWorld
s0 of
(# State# RealWorld
s1, MutableByteArray# RealWorld
mba #) -> case MutableByteArray# RealWorld
-> State# RealWorld -> (# State# RealWorld, ByteArray# #)
forall d.
MutableByteArray# d -> State# d -> (# State# d, ByteArray# #)
unsafeFreezeByteArray# MutableByteArray# RealWorld
mba State# RealWorld
s1 of
(# State# RealWorld
s2, ByteArray#
ba #) ->
(# State# RealWorld
s2
, ( Addr# -> Ptr a
forall a. Addr# -> Ptr a
Ptr (ByteArray# -> Addr#
byteArrayContents# ByteArray#
ba)
, let go :: Int# -> [a]
go Int#
k | Int# -> Bool
isTrue# (Int#
k Int# -> Int# -> Int#
>=# Int#
nm) = []
| Bool
otherwise = Int# -> ByteArray# -> a
forall a. VulkanMarshalPrim a => Int# -> ByteArray# -> a
unsafeFromByteArrayOffset Int#
k ByteArray#
ba
a -> [a] -> [a]
forall k1. k1 -> [k1] -> [k1]
: Int# -> [a]
go (Int#
k Int# -> Int# -> Int#
+# Int#
n)
in Int# -> [a]
forall a. VulkanMarshalPrim a => Int# -> [a]
go Int#
0#
)
#)
)
{-# INLINE mallocVkDataArray# #-}
peekVkData# :: forall a
. (Storable a, VulkanMarshalPrim a)
=> Ptr a -> IO a
peekVkData# :: Ptr a -> IO a
peekVkData# (Ptr Addr#
addr)
| I# Int#
n <- a -> Int
forall a. Storable a => a -> Int
sizeOf (a
forall a. HasCallStack => a
undefined :: a)
, I# Int#
a <- a -> Int
forall a. Storable a => a -> Int
alignment (a
forall a. HasCallStack => a
undefined :: a)
= (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO
(\State# RealWorld
s -> case Int#
-> Int#
-> State# RealWorld
-> (# State# RealWorld, MutableByteArray# RealWorld #)
forall d.
Int# -> Int# -> State# d -> (# State# d, MutableByteArray# d #)
newAlignedPinnedByteArray# Int#
n Int#
a State# RealWorld
s of
(# State# RealWorld
s1, MutableByteArray# RealWorld
mba #) -> case Addr#
-> MutableByteArray# RealWorld
-> Int#
-> Int#
-> State# RealWorld
-> State# RealWorld
forall d.
Addr#
-> MutableByteArray# d -> Int# -> Int# -> State# d -> State# d
copyAddrToByteArray# Addr#
addr MutableByteArray# RealWorld
mba Int#
0# Int#
n State# RealWorld
s1 of
State# RealWorld
s2 -> case MutableByteArray# RealWorld
-> State# RealWorld -> (# State# RealWorld, ByteArray# #)
forall d.
MutableByteArray# d -> State# d -> (# State# d, ByteArray# #)
unsafeFreezeByteArray# MutableByteArray# RealWorld
mba State# RealWorld
s2 of
(# State# RealWorld
s3, ByteArray#
ba #) -> (# State# RealWorld
s3, Int# -> ByteArray# -> a
forall a. VulkanMarshalPrim a => Int# -> ByteArray# -> a
unsafeFromByteArrayOffset Int#
0# ByteArray#
ba #)
)
{-# INLINE peekVkData# #-}
pokeVkData# :: forall a
. (Storable a, VulkanMarshalPrim a)
=> Ptr a -> a -> IO ()
pokeVkData# :: Ptr a -> a -> IO ()
pokeVkData# (Ptr Addr#
addr) a
x
= Addr# -> Addr# -> CSize -> IO ()
c_memcpy Addr#
addr (a -> Addr#
forall a. VulkanMarshalPrim a => a -> Addr#
unsafeAddr a
x) (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> CSize) -> Int -> CSize
forall a b. (a -> b) -> a -> b
$ a -> Int
forall a. Storable a => a -> Int
sizeOf a
x)
{-# INLINE pokeVkData# #-}
cmpBytes# :: Int -> Addr# -> Addr# -> Ordering
cmpBytes# :: Int -> Addr# -> Addr# -> Ordering
cmpBytes# Int
n Addr#
a Addr#
b
| Int# -> Bool
isTrue# (Addr# -> Addr# -> Int#
eqAddr# Addr#
a Addr#
b) = Ordering
EQ
| Bool
otherwise = Addr# -> Addr# -> CSize -> CInt
c_memcmp Addr#
a Addr#
b (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n) CInt -> CInt -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` CInt
0
foreign import ccall unsafe "memcmp"
c_memcmp :: Addr# -> Addr# -> CSize -> CInt
foreign import ccall unsafe "memcpy"
c_memcpy :: Addr# -> Addr# -> CSize -> IO ()