diff --git a/gpu-vulkan-middle.cabal b/gpu-vulkan-middle.cabal --- a/gpu-vulkan-middle.cabal +++ b/gpu-vulkan-middle.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: gpu-vulkan-middle -version: 0.1.0.66 +version: 0.1.0.67 synopsis: Medium wrapper for Vulkan API description: Please see the README on GitHub at category: GPU diff --git a/src/Gpu/Vulkan/CommandBuffer/Middle.hs b/src/Gpu/Vulkan/CommandBuffer/Middle.hs --- a/src/Gpu/Vulkan/CommandBuffer/Middle.hs +++ b/src/Gpu/Vulkan/CommandBuffer/Middle.hs @@ -10,6 +10,10 @@ begin, end, reset, BeginInfo(..), InheritanceInfo(..), + -- * SUBMIT INFO + + SubmitInfo(..) + ) where import Gpu.Vulkan.CommandBuffer.Middle.Internal diff --git a/src/Gpu/Vulkan/CommandBuffer/Middle/Internal.hs b/src/Gpu/Vulkan/CommandBuffer/Middle/Internal.hs --- a/src/Gpu/Vulkan/CommandBuffer/Middle/Internal.hs +++ b/src/Gpu/Vulkan/CommandBuffer/Middle/Internal.hs @@ -10,10 +10,14 @@ {-# OPTIONS_GHC -Wall -fno-warn-tabs #-} module Gpu.Vulkan.CommandBuffer.Middle.Internal ( + C(..), AllocateInfo(..), allocateCs, freeCs, - BeginInfo(..), InheritanceInfo(..), begin, end, reset + BeginInfo(..), InheritanceInfo(..), begin, end, reset, + + SubmitInfo(..), submitInfoToCore + ) where import Foreign.Ptr @@ -151,3 +155,18 @@ (length &&& ((\(C _ cb) -> cb) <$>) -> (cc, cs)) = allocaArray cc \pcs -> do pokeArray pcs cs C.freeCs dvc cp (fromIntegral cc) pcs + +data SubmitInfo mn = SubmitInfo { + submitInfoNext :: TMaybe.M mn, + submitInfoCommandBuffer :: C, + submitInfoDeviceMask :: Word32 } + +submitInfoToCore :: WithPoked (TMaybe.M mn) => + SubmitInfo mn -> (C.SubmitInfo -> IO r) -> IO () +submitInfoToCore SubmitInfo { + submitInfoNext = mnxt, + submitInfoCommandBuffer = C _ c, submitInfoDeviceMask = dm } f = + withPoked' mnxt \pnxt -> withPtrS pnxt \(castPtr -> pnxt') -> + f C.SubmitInfo { + C.submitInfoSType = (), C.submitInfoPNext = pnxt', + C.submitInfoCommandBuffer = c, C.submitInfoDeviceMask = dm } diff --git a/src/Gpu/Vulkan/CommandBuffer/Middle/Internal.hs-boot b/src/Gpu/Vulkan/CommandBuffer/Middle/Internal.hs-boot --- a/src/Gpu/Vulkan/CommandBuffer/Middle/Internal.hs-boot +++ b/src/Gpu/Vulkan/CommandBuffer/Middle/Internal.hs-boot @@ -1,11 +1,17 @@ -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE DataKinds, PolyKinds #-} {-# LANGUAGE KindSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RoleAnnotations #-} {-# OPTIONS_GHC -Wall -fno-warn-tabs #-} module Gpu.Vulkan.CommandBuffer.Middle.Internal ( - C(..) + C(..), SubmitInfo, submitInfoToCore ) where +import Foreign.Storable.PeekPoke +import Data.Kind +import Data.TypeLevel.Maybe qualified as TMaybe import Data.IORef import qualified Gpu.Vulkan.CommandBuffer.Core as C @@ -14,3 +20,9 @@ data C = C { cPipeline :: IORef Pipeline.C.P, unC :: C.C } + +type role SubmitInfo nominal +data SubmitInfo (s :: Maybe Type) + +submitInfoToCore :: WithPoked (TMaybe.M mn) => + SubmitInfo mn -> (C.SubmitInfo -> IO r) -> IO () diff --git a/src/Gpu/Vulkan/Enum.hsc b/src/Gpu/Vulkan/Enum.hsc --- a/src/Gpu/Vulkan/Enum.hsc +++ b/src/Gpu/Vulkan/Enum.hsc @@ -3290,6 +3290,12 @@ ("FormatR16g16S105Nv", #{const VK_FORMAT_R16G16_S10_5_NV}), ("FormatMaxEnum", #{const VK_FORMAT_MAX_ENUM}) ] +enum "SubmitFlagBits" ''#{type VkSubmitFlagBits} + [''Show, ''Eq, ''Storable, ''Bits] [ + ("SubmitProtectedBit", #{const VK_SUBMIT_PROTECTED_BIT}), + ("SubmitProtectedBitKhr", #{const VK_SUBMIT_PROTECTED_BIT_KHR}), + ("SubmitFlagBitsMaxEnum", #{const VK_SUBMIT_FLAG_BITS_MAX_ENUM}) ] + enum "AccessFlagBits" ''#{type VkAccessFlagBits} [''Show, ''Eq, ''Storable, ''Bits] [ ("AccessFlagsZero", 0), @@ -3555,3 +3561,4 @@ type CullModeFlags = CullModeFlagBits type ShaderStageFlags = ShaderStageFlagBits type FormatFeatureFlags = FormatFeatureFlagBits +type SubmitFlags = SubmitFlagBits diff --git a/src/Gpu/Vulkan/Middle.hs b/src/Gpu/Vulkan/Middle.hs --- a/src/Gpu/Vulkan/Middle.hs +++ b/src/Gpu/Vulkan/Middle.hs @@ -13,7 +13,8 @@ -- ** SubmitInfo - SubmitInfo(..), SubmitInfoListToCore(..), + SubmitInfo(..), SubmitInfoListToCore, + SubmitInfo2(..), SubmitInfo2ListToCore, -- * PROPERTIES diff --git a/src/Gpu/Vulkan/Middle/Internal.hsc b/src/Gpu/Vulkan/Middle/Internal.hsc --- a/src/Gpu/Vulkan/Middle/Internal.hsc +++ b/src/Gpu/Vulkan/Middle/Internal.hsc @@ -5,7 +5,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE KindSignatures, TypeOperators #-} {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE FlexibleContexts, UndecidableInstances #-} +{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-} {-# LANGUAGE PatternSynonyms, ViewPatterns #-} {-# LANGUAGE StandaloneDeriving, GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -Wall -fno-warn-tabs #-} @@ -25,7 +25,8 @@ C.ClearDepthStencilValue, pattern C.ClearDepthStencilValue, C.clearDepthStencilValueDepth, C.clearDepthStencilValueStencil, - SubmitInfo(..), SubmitInfoListToCore(..), submitInfoToCore, + SubmitInfo(..), SubmitInfoListToCore(..), + SubmitInfo2(..), SubmitInfo2ListToCore(..), FormatProperties(..), formatPropertiesFromCore, @@ -58,6 +59,7 @@ import Control.Monad import Data.Kind import Data.Default +import Data.TypeLevel.Tuple.Uncurry import Data.TypeLevel.Maybe qualified as TMaybe import Data.TypeLevel.List qualified as TL import Data.HeteroParList qualified as HPList @@ -339,6 +341,71 @@ C.submitInfoPCommandBuffers = pcbs, C.submitInfoSignalSemaphoreCount = fromIntegral ssc, C.submitInfoPSignalSemaphores = psss } + +data SubmitInfo2 mn wsas cbas ssas = SubmitInfo2 { + submitInfo2Next :: TMaybe.M mn, + submitInfo2Flags :: SubmitFlags, + submitInfo2WaitSemaphoreInfos :: HPList.PL Semaphore.SubmitInfo wsas, + submitInfo2CommandBufferInfos :: + HPList.PL CommandBuffer.SubmitInfo cbas, + submitInfo2SignalSemaphoreInfos :: HPList.PL Semaphore.SubmitInfo ssas } + +class SubmitInfo2ListToCore si2as where + submitInfo2ListToCore :: + HeteroParList.PL (U4 SubmitInfo2) si2as -> + ([C.SubmitInfo2] -> IO a) -> IO () + +instance SubmitInfo2ListToCore '[] where + submitInfo2ListToCore HPList.Nil f = void $ f [] + +instance ( + WithPoked (TMaybe.M mn), + HPList.ToListWithCCpsM' WithPoked TMaybe.M wsas, TL.Length wsas, + HPList.ToListWithCCpsM' WithPoked TMaybe.M cbas, TL.Length cbas, + HPList.ToListWithCCpsM' WithPoked TMaybe.M ssas, TL.Length ssas, + SubmitInfo2ListToCore si2as ) => + SubmitInfo2ListToCore ('(mn, wsas, cbas, ssas) ': si2as) where + submitInfo2ListToCore (U4 si :** sis) f = + submitInfo2ToCore si \csi -> + submitInfo2ListToCore sis \csis -> f $ csi : csis + +submitInfo2ToCore :: forall mn wsas cbas ssas r . ( + WithPoked (TMaybe.M mn), + HPList.ToListWithCCpsM' WithPoked TMaybe.M wsas, TL.Length wsas, + HPList.ToListWithCCpsM' WithPoked TMaybe.M cbas, TL.Length cbas, + HPList.ToListWithCCpsM' WithPoked TMaybe.M ssas, TL.Length ssas + ) => + SubmitInfo2 mn wsas cbas ssas -> (C.SubmitInfo2 -> IO r) -> IO () +submitInfo2ToCore SubmitInfo2 { + submitInfo2Next = mnxt, + submitInfo2Flags = SubmitFlagBits fs, + submitInfo2WaitSemaphoreInfos = wss, + submitInfo2CommandBufferInfos = cbs, + submitInfo2SignalSemaphoreInfos = sss } f = + withPoked' mnxt \pnxt -> withPtrS pnxt \(castPtr -> pnxt') -> + allocaArray wsc \pwss -> allocaArray cbc \pcbs -> + allocaArray ssc \psss -> do + HPList.withListWithCCpsM' @_ @WithPoked @TMaybe.M + wss Semaphore.submitInfoToCore \cwss -> pokeArray pwss cwss + HPList.withListWithCCpsM' @_ @WithPoked @TMaybe.M + cbs CommandBuffer.submitInfoToCore \ccbs -> pokeArray pcbs ccbs + HPList.withListWithCCpsM' @_ @WithPoked @TMaybe.M + sss Semaphore.submitInfoToCore \csss -> pokeArray psss csss + f C.SubmitInfo2 { + C.submitInfo2SType = (), + C.submitInfo2PNext = pnxt', + C.submitInfo2Flags = fs, + C.submitInfo2WaitSemaphoreInfoCount = wsc, + C.submitInfo2PWaitSemaphoreInfos = pwss, + C.submitInfo2CommandBufferInfoCount = cbc, + C.submitInfo2PCommandBufferInfos = pcbs, + C.submitInfo2SignalSemaphoreInfoCount = ssc, + C.submitInfo2PSignalSemaphoreInfos = psss } + where + wsc, cbc, ssc :: Integral n => n + wsc = TL.length @_ @wsas + cbc = TL.length @_ @cbas + ssc = TL.length @_ @ssas data FormatProperties = FormatProperties { formatPropertiesLinearTilingFeatures :: FormatFeatureFlags, diff --git a/src/Gpu/Vulkan/Queue/Middle.hs b/src/Gpu/Vulkan/Queue/Middle.hs --- a/src/Gpu/Vulkan/Queue/Middle.hs +++ b/src/Gpu/Vulkan/Queue/Middle.hs @@ -4,7 +4,7 @@ -- * SUBMIT AND WAIT IDLE - submit, waitIdle, Q, + submit, submit2, waitIdle, Q, -- * SPARSE RESOURCES diff --git a/src/Gpu/Vulkan/Queue/Middle/Internal.hs b/src/Gpu/Vulkan/Queue/Middle/Internal.hs --- a/src/Gpu/Vulkan/Queue/Middle/Internal.hs +++ b/src/Gpu/Vulkan/Queue/Middle/Internal.hs @@ -13,7 +13,7 @@ -- * SUBMIT AND WAIT IDLE - submit, waitIdle, Q(..), + submit, submit2, waitIdle, Q(..), -- * SPARSE RESOURCES @@ -26,10 +26,11 @@ import Foreign.Storable.PeekPoke import Control.Arrow import Control.Monad.Cont.MiscYj +import Data.TypeLevel.Tuple.Uncurry import Data.HeteroParList qualified as HeteroParList import Gpu.Vulkan.Base.Middle -import Gpu.Vulkan.Middle +import Gpu.Vulkan.Middle.Internal import Gpu.Vulkan.Exception.Middle.Internal import Gpu.Vulkan.Exception.Enum import Gpu.Vulkan.Fence.Middle.Internal qualified as Fence.M @@ -56,6 +57,16 @@ r <- C.submit q (fromIntegral sic) psis $ Fence.M.maybeFToCore mf throwUnlessSuccess $ Result r + +submit2 :: SubmitInfo2ListToCore sias => + Q -> HeteroParList.PL (U4 SubmitInfo2) sias -> Maybe Fence.M.F -> IO () +submit2 (Q q) sis mf = + submitInfo2ListToCore sis \csis -> let sic = length csis in + allocaArray sic \psis -> do + pokeArray psis csis + r <- C.submit2 q (fromIntegral sic) psis + $ Fence.M.maybeFToCore mf + throwUnlessSuccess $ Result r waitIdle :: Q -> IO () waitIdle (Q q) = throwUnlessSuccess . Result =<< C.waitIdle q diff --git a/src/Gpu/Vulkan/Semaphore/Middle.hs b/src/Gpu/Vulkan/Semaphore/Middle.hs --- a/src/Gpu/Vulkan/Semaphore/Middle.hs +++ b/src/Gpu/Vulkan/Semaphore/Middle.hs @@ -6,6 +6,10 @@ create, destroy, S, CreateInfo(..), CreateFlags, + -- * SUBMIT INFO + + SubmitInfo(..) + ) where import Gpu.Vulkan.Semaphore.Middle.Internal diff --git a/src/Gpu/Vulkan/Semaphore/Middle/Internal.hsc b/src/Gpu/Vulkan/Semaphore/Middle/Internal.hsc --- a/src/Gpu/Vulkan/Semaphore/Middle/Internal.hsc +++ b/src/Gpu/Vulkan/Semaphore/Middle/Internal.hsc @@ -14,6 +14,10 @@ create, destroy, S(..), CreateInfo(..), CreateFlags, + -- * SUBMIT INFO + + SubmitInfo(..), submitInfoToCore + ) where import Foreign.Ptr @@ -34,6 +38,7 @@ import qualified Gpu.Vulkan.Semaphore.Core as C import qualified Gpu.Vulkan.Device.Middle.Types as Device +import qualified Gpu.Vulkan.Pipeline.Enum as Pipeline #include @@ -72,3 +77,24 @@ destroy :: Device.D -> S -> TPMaybe.M AllocationCallbacks.A md -> IO () destroy (Device.D dvc) (S s) mac = AllocationCallbacks.mToCore mac $ C.destroy dvc s + +data SubmitInfo mn = SubmitInfo { + submitInfoNext :: TMaybe.M mn, + submitInfoSemaphore :: S, + submitInfoValue :: Word64, + submitInfoStageMask :: Pipeline.StageFlags2, + submitInfoDeviceIndex :: Word32 } + +submitInfoToCore :: WithPoked (TMaybe.M mn) => + SubmitInfo mn -> (C.SubmitInfo -> IO r) -> IO () +submitInfoToCore SubmitInfo { + submitInfoNext = mnxt, + submitInfoSemaphore = S s, submitInfoValue = v, + submitInfoStageMask = Pipeline.StageFlagBits2 sm, + submitInfoDeviceIndex = di + } f = + withPoked' mnxt \pnxt -> withPtrS pnxt \(castPtr -> pnxt') -> + f C.SubmitInfo { + C.submitInfoSType = (), C.submitInfoPNext = pnxt', + C.submitInfoSemaphore = s, C.submitInfoValue = v, + C.submitInfoStageMask = sm, C.submitInfoDeviceIndex = di }