{-# 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 addr PlainForeignPtr{})
| I# n <- sizeOf (undefined :: a)
, I# a <- alignment (undefined :: a)
= IO
(\s0 -> case newAlignedPinnedByteArray# n a s0 of
(# s1, mba #) -> case copyAddrToByteArray# addr mba 0# n s1 of
s2 -> case unsafeFreezeByteArray# mba s2 of
(# s3, ba #) -> (# s3, unsafeFromByteArrayOffset 0# ba #)
)
fromForeignPtr# (ForeignPtr addr (MallocPtr mba _))
= IO
(\s0 -> case unsafeFreezeByteArray# mba s0 of
(# s1, ba #) -> (# s1, unsafeFromByteArrayOffset
(minusAddr# addr (byteArrayContents# ba)) ba #)
)
fromForeignPtr# (ForeignPtr addr (PlainPtr mba))
= IO
(\s0 -> case unsafeFreezeByteArray# mba s0 of
(# s1, ba #) -> (# s1, unsafeFromByteArrayOffset
(minusAddr# addr (byteArrayContents# ba)) ba #)
)
{-# INLINE fromForeignPtr# #-}
toForeignPtr# :: VulkanMarshalPrim a => a -> IO (ForeignPtr a)
toForeignPtr# x
| a <- unsafeAddr x
, b <- unsafeByteArray x = do
ForeignPtr _ (PlainForeignPtr r)
<- newForeignPtr_ (Ptr a)
IO (\s -> (# s, ForeignPtr a (MallocPtr (unsafeCoerce# b) r) #))
{-# INLINE toForeignPtr# #-}
toPlainForeignPtr# :: VulkanMarshalPrim a => a -> IO (ForeignPtr a)
toPlainForeignPtr# x
| a <- unsafeAddr x
, b <- unsafeByteArray x = IO
(\s -> (# s, ForeignPtr a (PlainPtr (unsafeCoerce# b)) #))
{-# INLINE toPlainForeignPtr# #-}
touchVkData# :: VulkanMarshalPrim a => a -> IO ()
touchVkData# a = IO (\s -> (# touch# (unsafeByteArray a) s, () #))
{-# INLINE touchVkData# #-}
newVkData# :: forall a
. (Storable a, VulkanMarshalPrim a)
=> (Ptr a -> IO ()) -> IO a
newVkData# f
| I# n <- sizeOf (undefined :: a)
, I# a <- alignment (undefined :: a)
= IO
(\s0 -> case newAlignedPinnedByteArray# n a s0 of
(# s1, mba #) -> case unsafeFreezeByteArray# mba s1 of
(# s2, ba #) -> case f (Ptr (byteArrayContents# ba)) of
IO k -> case k s2 of
(# s3, () #) -> (# s3, unsafeFromByteArrayOffset 0# ba #)
)
{-# INLINE newVkData# #-}
mallocVkData# :: forall a
. (Storable a, VulkanMarshalPrim a)
=> IO a
mallocVkData#
| I# n <- sizeOf (undefined :: a)
, I# a <- alignment (undefined :: a)
= IO
(\s0 -> case newAlignedPinnedByteArray# n a s0 of
(# s1, mba #) -> case unsafeFreezeByteArray# mba s1 of
(# s2, ba #) -> (# s2, unsafeFromByteArrayOffset 0# ba #)
)
{-# INLINE mallocVkData# #-}
mallocVkDataArray# :: forall a
. (Storable a, VulkanMarshalPrim a)
=> Int -> IO (Ptr a, [a])
mallocVkDataArray# (I# m)
| I# n <- sizeOf (undefined :: a)
, I# a <- alignment (undefined :: a)
, nm <- n *# m
= IO
(\s0 -> case newAlignedPinnedByteArray# nm a s0 of
(# s1, mba #) -> case unsafeFreezeByteArray# mba s1 of
(# s2, ba #) ->
(# s2
, ( Ptr (byteArrayContents# ba)
, let go k | isTrue# (k >=# nm) = []
| otherwise = unsafeFromByteArrayOffset k ba
: go (k +# n)
in go 0#
)
#)
)
{-# INLINE mallocVkDataArray# #-}
peekVkData# :: forall a
. (Storable a, VulkanMarshalPrim a)
=> Ptr a -> IO a
peekVkData# (Ptr addr)
| I# n <- sizeOf (undefined :: a)
, I# a <- alignment (undefined :: a)
= IO
(\s -> case newAlignedPinnedByteArray# n a s of
(# s1, mba #) -> case copyAddrToByteArray# addr mba 0# n s1 of
s2 -> case unsafeFreezeByteArray# mba s2 of
(# s3, ba #) -> (# s3, unsafeFromByteArrayOffset 0# ba #)
)
{-# INLINE peekVkData# #-}
pokeVkData# :: forall a
. (Storable a, VulkanMarshalPrim a)
=> Ptr a -> a -> IO ()
pokeVkData# (Ptr addr) x
= c_memcpy addr (unsafeAddr x) (fromIntegral $ sizeOf x)
{-# INLINE pokeVkData# #-}
cmpBytes# :: Int -> Addr# -> Addr# -> Ordering
cmpBytes# n a b
| isTrue# (eqAddr# a b) = EQ
| otherwise = c_memcmp a b (fromIntegral n) `compare` 0
foreign import ccall unsafe "memcmp"
c_memcmp :: Addr# -> Addr# -> CSize -> CInt
foreign import ccall unsafe "memcpy"
c_memcpy :: Addr# -> Addr# -> CSize -> IO ()