{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE MagicHash                 #-}
{-# LANGUAGE ScopedTypeVariables       #-}
{-# LANGUAGE Strict                    #-}
{-# LANGUAGE UnboxedTuples             #-}
{-# LANGUAGE UnliftedFFITypes          #-}
-- | This module is not part of auto-generated code based on vk.xml.
--   Instead, it is hand-written to provide common types and classes.
--
--   DANGER!
--   This is an internal module; it can change a lot between package versions;
--   it provides low-level functions, most of which have user-friendly analogues.
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 (..))


-- | This class gives low-level access to memory location occupied by Vulkan data.
--
--   Meant for internal use only.
class VulkanMarshalPrim a where
  -- | Get address of vulkan structure.
  --   Note, the address is only valid as long as a given vulkan structure exists.
  --   Structures created with newVkData are stored in pinned byte arrays,
  --   so their memory is maintained by Haskell GC.
  unsafeAddr :: a -> Addr#
  -- | Get a @ByteArray#@ that keeps the data.
  --
  --   Note, the data structure does not necessarily starts at zero offset.
  unsafeByteArray :: a -> ByteArray#
  -- | Combine a vulkan structure from ByteArray and an offset in this array.
  unsafeFromByteArrayOffset :: Int# -> ByteArray# -> a




-- | Create a `ByteArray#`-based type from `ForeignPtr`.
--   Try to not copy data, but do it if necessary.
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# #-}


-- | Create a `ForeignPtr` referencing the structure without copying data.
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# #-}

-- | Create a `ForeignPtr` referencing the structure without copying data.
--   This version of a pointer carries no finalizers.
--
-- It is not possible to add a finalizer to a ForeignPtr created with
-- @toPlainForeignPtr@.
-- Attempts to add a finalizer to a ForeignPtr created this way, or to
-- finalize such a pointer, will throw an exception.
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# #-}

-- | Make sure the region of memory is not collected at this moment in time.
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# #-}


-- | Internal function used to implement Eq and Ord instances for Vulkan structs.
--   Compares first n bytes of two memory areas.
--
--   Uses lexicographic ordering (c memcmp inside).
--
--   This is a helper that should be used in VulkanMarshal instances only.
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 ()