{-# LINE 1 "src/Gpu/Vulkan/Buffer/Middle/Internal.hsc" #-} {-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE BlockArguments #-} {-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE FlexibleContexts, UndecidableInstances #-} {-# LANGUAGE PatternSynonyms, ViewPatterns #-} {-# LANGUAGE StandaloneDeriving, GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -Wall -fno-warn-tabs #-} module Gpu.Vulkan.Buffer.Middle.Internal ( B(..), CreateInfo(..), create, destroy, bindMemory, getMemoryRequirements, ImageCopy(..), imageCopyToCore, MemoryBarrier(..), memoryBarrierToCore', C.Copy, pattern C.Copy, C.copySrcOffset, C.copyDstOffset, C.copySize ) where import Foreign.Ptr import Foreign.Marshal.Alloc import Foreign.Marshal.Array import Foreign.Storable import Foreign.Storable.PeekPoke (WithPoked, withPoked, withPoked', withPtrS) import Control.Arrow import Control.Monad.Trans import Control.Monad.Cont import Data.Kind import Data.TypeLevel.Maybe qualified as TMaybe import Data.TypeLevel.ParMaybe qualified as TPMaybe import Data.Word import Data.IORef import Gpu.Vulkan.Core import Gpu.Vulkan.Enum import Gpu.Vulkan.Exception.Middle.Internal import Gpu.Vulkan.Exception.Enum import Gpu.Vulkan.Buffer.Enum import Gpu.Vulkan.AllocationCallbacks.Middle.Internal qualified as AllocationCallbacks (A, mToCore) import qualified Gpu.Vulkan.Device.Middle.Internal as Device import qualified Gpu.Vulkan.Buffer.Core as C import qualified Gpu.Vulkan.Memory.Middle.Internal as Memory import qualified Gpu.Vulkan.QueueFamily.EnumManual as QueueFamily import qualified Gpu.Vulkan.Image.Middle.Internal as Image data CreateInfo (mn :: Maybe Type) = CreateInfo { forall (mn :: Maybe (*)). CreateInfo mn -> M mn createInfoNext :: TMaybe.M mn, forall (mn :: Maybe (*)). CreateInfo mn -> CreateFlags createInfoFlags :: CreateFlags, forall (mn :: Maybe (*)). CreateInfo mn -> Size createInfoSize :: Device.Size, forall (mn :: Maybe (*)). CreateInfo mn -> UsageFlags createInfoUsage :: UsageFlags, forall (mn :: Maybe (*)). CreateInfo mn -> SharingMode createInfoSharingMode :: SharingMode, forall (mn :: Maybe (*)). CreateInfo mn -> [Index] createInfoQueueFamilyIndices :: [QueueFamily.Index] } deriving instance Show (TMaybe.M mn) => Show (CreateInfo mn) createInfoToCore :: WithPoked (TMaybe.M mn) => CreateInfo mn -> (Ptr C.CreateInfo -> IO a) -> IO () createInfoToCore :: forall (mn :: Maybe (*)) a. WithPoked (M mn) => CreateInfo mn -> (Ptr CreateInfo -> IO a) -> IO () createInfoToCore CreateInfo { createInfoNext :: forall (mn :: Maybe (*)). CreateInfo mn -> M mn createInfoNext = M mn mnxt, createInfoFlags :: forall (mn :: Maybe (*)). CreateInfo mn -> CreateFlags createInfoFlags = CreateFlagBits Word32 flgs, createInfoSize :: forall (mn :: Maybe (*)). CreateInfo mn -> Size createInfoSize = Device.Size Word64 sz, createInfoUsage :: forall (mn :: Maybe (*)). CreateInfo mn -> UsageFlags createInfoUsage = UsageFlagBits Word32 usg, createInfoSharingMode :: forall (mn :: Maybe (*)). CreateInfo mn -> SharingMode createInfoSharingMode = SharingMode Word32 sm, createInfoQueueFamilyIndices :: forall (mn :: Maybe (*)). CreateInfo mn -> [Index] createInfoQueueFamilyIndices = [Index] -> Int forall a. [a] -> Int forall (t :: * -> *) a. Foldable t => t a -> Int length ([Index] -> Int) -> ([Index] -> [Word32]) -> [Index] -> (Int, [Word32]) forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c') forall (a :: * -> * -> *) b c c'. Arrow a => a b c -> a b c' -> a b (c, c') &&& (Index -> Word32 QueueFamily.unIndex (Index -> Word32) -> [Index] -> [Word32] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$>) -> (Int qfic, [Word32] qfis) } Ptr CreateInfo -> IO a f = Int -> (Ptr Word32 -> IO ()) -> IO () forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b allocaArray Int qfic \Ptr Word32 pqfis -> do Ptr Word32 -> [Word32] -> IO () forall a. Storable a => Ptr a -> [a] -> IO () pokeArray Ptr Word32 pqfis [Word32] qfis M mn -> (forall s. PtrS s (M mn) -> IO ()) -> IO () forall a b. WithPoked a => a -> (forall s. PtrS s a -> IO b) -> IO b forall b. M mn -> (forall s. PtrS s (M mn) -> IO b) -> IO b withPoked' M mn mnxt \PtrS s (M mn) pnxt -> PtrS s (M mn) -> (Ptr (M mn) -> IO a) -> IO () forall s a b. PtrS s a -> (Ptr a -> IO b) -> IO () withPtrS PtrS s (M mn) pnxt \(Ptr (M mn) -> Ptr () forall a b. Ptr a -> Ptr b castPtr -> Ptr () pnxt') -> do CreateInfo -> (Ptr CreateInfo -> IO a) -> IO a forall a b. Pokable a => a -> (Ptr a -> IO b) -> IO b withPoked C.CreateInfo { createInfoSType :: () C.createInfoSType = (), createInfoPNext :: Ptr () C.createInfoPNext = Ptr () pnxt', createInfoFlags :: Word32 C.createInfoFlags = Word32 flgs, createInfoSize :: Word64 C.createInfoSize = Word64 sz, createInfoUsage :: Word32 C.createInfoUsage = Word32 usg, createInfoSharingMode :: Word32 C.createInfoSharingMode = Word32 sm, createInfoQueueFamilyIndexCount :: Word32 C.createInfoQueueFamilyIndexCount = Int -> Word32 forall a b. (Integral a, Num b) => a -> b fromIntegral Int qfic, createInfoPQueueFamilyIndices :: Ptr Word32 C.createInfoPQueueFamilyIndices = Ptr Word32 pqfis } Ptr CreateInfo -> IO a f newtype B = B C.B deriving (Int -> B -> ShowS [B] -> ShowS B -> String (Int -> B -> ShowS) -> (B -> String) -> ([B] -> ShowS) -> Show B forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a $cshowsPrec :: Int -> B -> ShowS showsPrec :: Int -> B -> ShowS $cshow :: B -> String show :: B -> String $cshowList :: [B] -> ShowS showList :: [B] -> ShowS Show, B -> B -> Bool (B -> B -> Bool) -> (B -> B -> Bool) -> Eq B forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a $c== :: B -> B -> Bool == :: B -> B -> Bool $c/= :: B -> B -> Bool /= :: B -> B -> Bool Eq, Ptr B -> IO B Ptr B -> Int -> IO B Ptr B -> Int -> B -> IO () Ptr B -> B -> IO () B -> Int (B -> Int) -> (B -> Int) -> (Ptr B -> Int -> IO B) -> (Ptr B -> Int -> B -> IO ()) -> (forall b. Ptr b -> Int -> IO B) -> (forall b. Ptr b -> Int -> B -> IO ()) -> (Ptr B -> IO B) -> (Ptr B -> B -> IO ()) -> Storable B forall b. Ptr b -> Int -> IO B forall b. Ptr b -> Int -> B -> IO () forall a. (a -> Int) -> (a -> Int) -> (Ptr a -> Int -> IO a) -> (Ptr a -> Int -> a -> IO ()) -> (forall b. Ptr b -> Int -> IO a) -> (forall b. Ptr b -> Int -> a -> IO ()) -> (Ptr a -> IO a) -> (Ptr a -> a -> IO ()) -> Storable a $csizeOf :: B -> Int sizeOf :: B -> Int $calignment :: B -> Int alignment :: B -> Int $cpeekElemOff :: Ptr B -> Int -> IO B peekElemOff :: Ptr B -> Int -> IO B $cpokeElemOff :: Ptr B -> Int -> B -> IO () pokeElemOff :: Ptr B -> Int -> B -> IO () $cpeekByteOff :: forall b. Ptr b -> Int -> IO B peekByteOff :: forall b. Ptr b -> Int -> IO B $cpokeByteOff :: forall b. Ptr b -> Int -> B -> IO () pokeByteOff :: forall b. Ptr b -> Int -> B -> IO () $cpeek :: Ptr B -> IO B peek :: Ptr B -> IO B $cpoke :: Ptr B -> B -> IO () poke :: Ptr B -> B -> IO () Storable) create :: WithPoked (TMaybe.M mn) => Device.D -> CreateInfo mn -> TPMaybe.M AllocationCallbacks.A mc -> IO B create :: forall (mn :: Maybe (*)) (mc :: Maybe (*)). WithPoked (M mn) => D -> CreateInfo mn -> M A mc -> IO B create (Device.D D dvc) CreateInfo mn ci M A mc mac = B -> B B (B -> B) -> IO B -> IO B forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> (Ptr B -> IO B) -> IO B forall a b. Storable a => (Ptr a -> IO b) -> IO b alloca \Ptr B pb -> do CreateInfo mn -> (Ptr CreateInfo -> IO ()) -> IO () forall (mn :: Maybe (*)) a. WithPoked (M mn) => CreateInfo mn -> (Ptr CreateInfo -> IO a) -> IO () createInfoToCore CreateInfo mn ci \Ptr CreateInfo pci -> M A mc -> (Ptr A -> IO ()) -> IO () forall (ma :: Maybe (*)) b. M A ma -> (Ptr A -> IO b) -> IO () AllocationCallbacks.mToCore M A mc mac \Ptr A pac -> Result -> IO () throwUnlessSuccess (Result -> IO ()) -> (Int32 -> Result) -> Int32 -> IO () forall b c a. (b -> c) -> (a -> b) -> a -> c . Int32 -> Result Result (Int32 -> IO ()) -> IO Int32 -> IO () forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< D -> Ptr CreateInfo -> Ptr A -> Ptr B -> IO Int32 C.create D dvc Ptr CreateInfo pci Ptr A pac Ptr B pb Ptr B -> IO B forall a. Storable a => Ptr a -> IO a peek Ptr B pb destroy :: Device.D -> B -> TPMaybe.M AllocationCallbacks.A md -> IO () destroy :: forall (md :: Maybe (*)). D -> B -> M A md -> IO () destroy (Device.D D dvc) (B B b) M A md mac = M A md -> (Ptr A -> IO ()) -> IO () forall (ma :: Maybe (*)) b. M A ma -> (Ptr A -> IO b) -> IO () AllocationCallbacks.mToCore M A md mac ((Ptr A -> IO ()) -> IO ()) -> (Ptr A -> IO ()) -> IO () forall a b. (a -> b) -> a -> b $ D -> B -> Ptr A -> IO () C.destroy D dvc B b getMemoryRequirements :: Device.D -> B -> IO Memory.Requirements getMemoryRequirements :: D -> B -> IO Requirements getMemoryRequirements (Device.D D dvc) (B B b) = (Requirements -> Requirements Memory.requirementsFromCore (Requirements -> Requirements) -> IO Requirements -> IO Requirements forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$>) (IO Requirements -> IO Requirements) -> (((Requirements -> IO Requirements) -> IO Requirements) -> IO Requirements) -> ((Requirements -> IO Requirements) -> IO Requirements) -> IO Requirements forall b c a. (b -> c) -> (a -> b) -> a -> c . (((Requirements -> IO Requirements) -> IO Requirements) -> (Requirements -> IO Requirements) -> IO Requirements forall a b. (a -> b) -> a -> b $ Requirements -> IO Requirements forall a. a -> IO a forall (f :: * -> *) a. Applicative f => a -> f a pure) (((Requirements -> IO Requirements) -> IO Requirements) -> IO Requirements) -> ((Requirements -> IO Requirements) -> IO Requirements) -> IO Requirements forall a b. (a -> b) -> a -> b $ ContT Requirements IO Requirements -> (Requirements -> IO Requirements) -> IO Requirements forall {k} (r :: k) (m :: k -> *) a. ContT r m a -> (a -> m r) -> m r runContT do Ptr Requirements pr <- ((Ptr Requirements -> IO Requirements) -> IO Requirements) -> ContT Requirements IO (Ptr Requirements) forall {k} (r :: k) (m :: k -> *) a. ((a -> m r) -> m r) -> ContT r m a ContT (Ptr Requirements -> IO Requirements) -> IO Requirements forall a b. Storable a => (Ptr a -> IO b) -> IO b alloca IO Requirements -> ContT Requirements IO Requirements forall (m :: * -> *) a. Monad m => m a -> ContT Requirements m a forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a lift do D -> B -> Ptr Requirements -> IO () C.getMemoryRequirements D dvc B b Ptr Requirements pr Ptr Requirements -> IO Requirements forall a. Storable a => Ptr a -> IO a peek Ptr Requirements pr bindMemory :: Device.D -> B -> Memory.M -> Device.Size -> IO () bindMemory :: D -> B -> M -> Size -> IO () bindMemory (Device.D D dvc) (B B b) (Memory.M IORef M mem) (Device.Size Word64 sz) = do M m <- IORef M -> IO M forall a. IORef a -> IO a readIORef IORef M mem Result -> IO () throwUnlessSuccess (Result -> IO ()) -> (Int32 -> Result) -> Int32 -> IO () forall b c a. (b -> c) -> (a -> b) -> a -> c . Int32 -> Result Result (Int32 -> IO ()) -> IO Int32 -> IO () forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< D -> B -> M -> Word64 -> IO Int32 C.bindMemory D dvc B b M m Word64 sz data MemoryBarrier mn = MemoryBarrier { forall (mn :: Maybe (*)). MemoryBarrier mn -> M mn memoryBarrierNext :: TMaybe.M mn, forall (mn :: Maybe (*)). MemoryBarrier mn -> AccessFlags memoryBarrierSrcAccessMask :: AccessFlags, forall (mn :: Maybe (*)). MemoryBarrier mn -> AccessFlags memoryBarrierDstAccessMask :: AccessFlags, forall (mn :: Maybe (*)). MemoryBarrier mn -> Index memoryBarrierSrcQueueFamilyIndex :: QueueFamily.Index, forall (mn :: Maybe (*)). MemoryBarrier mn -> Index memoryBarrierDstQueueFamilyIndex :: QueueFamily.Index, forall (mn :: Maybe (*)). MemoryBarrier mn -> B memoryBarrierBuffer :: B, forall (mn :: Maybe (*)). MemoryBarrier mn -> Size memoryBarrierOffset :: Device.Size, forall (mn :: Maybe (*)). MemoryBarrier mn -> Size memoryBarrierSize :: Device.Size } deriving instance Show (TMaybe.M mn) => Show (MemoryBarrier mn) memoryBarrierToCore' :: WithPoked (TMaybe.M mn) => MemoryBarrier mn -> (C.MemoryBarrier -> IO a) -> IO () memoryBarrierToCore' :: forall (mn :: Maybe (*)) a. WithPoked (M mn) => MemoryBarrier mn -> (MemoryBarrier -> IO a) -> IO () memoryBarrierToCore' MemoryBarrier { memoryBarrierNext :: forall (mn :: Maybe (*)). MemoryBarrier mn -> M mn memoryBarrierNext = M mn mnxt, memoryBarrierSrcAccessMask :: forall (mn :: Maybe (*)). MemoryBarrier mn -> AccessFlags memoryBarrierSrcAccessMask = AccessFlagBits Word32 sam, memoryBarrierDstAccessMask :: forall (mn :: Maybe (*)). MemoryBarrier mn -> AccessFlags memoryBarrierDstAccessMask = AccessFlagBits Word32 dam, memoryBarrierSrcQueueFamilyIndex :: forall (mn :: Maybe (*)). MemoryBarrier mn -> Index memoryBarrierSrcQueueFamilyIndex = QueueFamily.Index Word32 sqfi, memoryBarrierDstQueueFamilyIndex :: forall (mn :: Maybe (*)). MemoryBarrier mn -> Index memoryBarrierDstQueueFamilyIndex = QueueFamily.Index Word32 dqfi, memoryBarrierBuffer :: forall (mn :: Maybe (*)). MemoryBarrier mn -> B memoryBarrierBuffer = B B b, memoryBarrierOffset :: forall (mn :: Maybe (*)). MemoryBarrier mn -> Size memoryBarrierOffset = Device.Size Word64 ofst, memoryBarrierSize :: forall (mn :: Maybe (*)). MemoryBarrier mn -> Size memoryBarrierSize = Device.Size Word64 sz } MemoryBarrier -> IO a f = M mn -> (forall s. PtrS s (M mn) -> IO ()) -> IO () forall a b. WithPoked a => a -> (forall s. PtrS s a -> IO b) -> IO b forall b. M mn -> (forall s. PtrS s (M mn) -> IO b) -> IO b withPoked' M mn mnxt \PtrS s (M mn) pnxt -> PtrS s (M mn) -> (Ptr (M mn) -> IO a) -> IO () forall s a b. PtrS s a -> (Ptr a -> IO b) -> IO () withPtrS PtrS s (M mn) pnxt \(Ptr (M mn) -> Ptr () forall a b. Ptr a -> Ptr b castPtr -> Ptr () pnxt') -> MemoryBarrier -> IO a f C.MemoryBarrier { memoryBarrierSType :: () C.memoryBarrierSType = (), memoryBarrierPNext :: Ptr () C.memoryBarrierPNext = Ptr () pnxt', memoryBarrierSrcAccessMask :: Word32 C.memoryBarrierSrcAccessMask = Word32 sam, memoryBarrierDstAccessMask :: Word32 C.memoryBarrierDstAccessMask = Word32 dam, memoryBarrierSrcQueueFamilyIndex :: Word32 C.memoryBarrierSrcQueueFamilyIndex = Word32 sqfi, memoryBarrierDstQueueFamilyIndex :: Word32 C.memoryBarrierDstQueueFamilyIndex = Word32 dqfi, memoryBarrierBuffer :: B C.memoryBarrierBuffer = B b, memoryBarrierOffset :: Word64 C.memoryBarrierOffset = Word64 ofst, memoryBarrierSize :: Word64 C.memoryBarrierSize = Word64 sz } data ImageCopy = ImageCopy { ImageCopy -> Size imageCopyBufferOffset :: Device.Size, ImageCopy -> Word32 imageCopyBufferRowLength :: Word32, ImageCopy -> Word32 imageCopyBufferImageHeight :: Word32, ImageCopy -> SubresourceLayers imageCopyImageSubresource :: Image.SubresourceLayers, ImageCopy -> Offset3d imageCopyImageOffset :: Offset3d, ImageCopy -> Extent3d imageCopyImageExtent :: Extent3d } deriving Int -> ImageCopy -> ShowS [ImageCopy] -> ShowS ImageCopy -> String (Int -> ImageCopy -> ShowS) -> (ImageCopy -> String) -> ([ImageCopy] -> ShowS) -> Show ImageCopy forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a $cshowsPrec :: Int -> ImageCopy -> ShowS showsPrec :: Int -> ImageCopy -> ShowS $cshow :: ImageCopy -> String show :: ImageCopy -> String $cshowList :: [ImageCopy] -> ShowS showList :: [ImageCopy] -> ShowS Show imageCopyToCore :: ImageCopy -> C.ImageCopy imageCopyToCore :: ImageCopy -> ImageCopy imageCopyToCore ImageCopy { imageCopyBufferOffset :: ImageCopy -> Size imageCopyBufferOffset = Device.Size Word64 bo, imageCopyBufferRowLength :: ImageCopy -> Word32 imageCopyBufferRowLength = Word32 brl, imageCopyBufferImageHeight :: ImageCopy -> Word32 imageCopyBufferImageHeight = Word32 bih, imageCopyImageSubresource :: ImageCopy -> SubresourceLayers imageCopyImageSubresource = SubresourceLayers isr, imageCopyImageOffset :: ImageCopy -> Offset3d imageCopyImageOffset = Offset3d io, imageCopyImageExtent :: ImageCopy -> Extent3d imageCopyImageExtent = Extent3d ie } = C.ImageCopy { imageCopyBufferOffset :: Word64 C.imageCopyBufferOffset = Word64 bo, imageCopyBufferRowLength :: Word32 C.imageCopyBufferRowLength = Word32 brl, imageCopyBufferImageHeight :: Word32 C.imageCopyBufferImageHeight = Word32 bih, imageCopyImageSubresource :: SubresourceLayers C.imageCopyImageSubresource = SubresourceLayers -> SubresourceLayers Image.subresourceLayersToCore SubresourceLayers isr, imageCopyImageOffset :: Offset3d C.imageCopyImageOffset = Offset3d io, imageCopyImageExtent :: Extent3d C.imageCopyImageExtent = Extent3d ie }