diff --git a/gpu-vulkan.cabal b/gpu-vulkan.cabal --- a/gpu-vulkan.cabal +++ b/gpu-vulkan.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: gpu-vulkan -version: 0.1.0.161 +version: 0.1.0.162 synopsis: Vulkan library description: Please see the README on GitHub at category: GPU @@ -110,6 +110,7 @@ Gpu.Vulkan.BufferView.Internal Gpu.Vulkan.ColorComponent.Enum Gpu.Vulkan.CommandBuffer.Enum + Gpu.Vulkan.CommandBuffer.Internal Gpu.Vulkan.CommandBuffer.Type Gpu.Vulkan.CommandPool.Enum Gpu.Vulkan.CommandPool.Type diff --git a/src/Gpu/Vulkan.hs b/src/Gpu/Vulkan.hs --- a/src/Gpu/Vulkan.hs +++ b/src/Gpu/Vulkan.hs @@ -23,6 +23,8 @@ SubmitInfo(..), SubmitInfoListToMiddle, SemaphorePipelineStageFlags(..), + SubmitInfo2(..), SubmitInfo2ListToMiddle, + -- * PROPERTIES LayerProperties(..), diff --git a/src/Gpu/Vulkan/CommandBuffer.hs b/src/Gpu/Vulkan/CommandBuffer.hs --- a/src/Gpu/Vulkan/CommandBuffer.hs +++ b/src/Gpu/Vulkan/CommandBuffer.hs @@ -1,12 +1,3 @@ -{-# LANGUAGE ImportQualifiedPost #-} -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE ScopedTypeVariables, RankNTypes, TypeApplications #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE FlexibleContexts, UndecidableInstances #-} -{-# LANGUAGE PatternSynonyms, ViewPatterns #-} -{-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -Wall -fno-warn-tabs #-} module Gpu.Vulkan.CommandBuffer ( @@ -25,85 +16,17 @@ -- * BEGIN AND RESET - begin, reset, M.BeginInfo(..), M.InheritanceInfo(..), + begin, reset, BeginInfo(..), InheritanceInfo(..), + -- * SUBMIT INFO + + SubmitInfo(..), SubmitInfoListToMiddle, + -- * ENUM module Gpu.Vulkan.CommandBuffer.Enum ) where -import Foreign.Storable.PeekPoke -import Control.Exception -import Data.TypeLevel.Maybe qualified as TMaybe -import Data.TypeLevel.List qualified as TLength -import Data.HeteroParList qualified as HeteroParList -import Data.Word - -import Gpu.Vulkan.CommandBuffer.Type +import Gpu.Vulkan.CommandBuffer.Internal import Gpu.Vulkan.CommandBuffer.Enum - -import qualified Gpu.Vulkan.Device.Type as Device -import qualified Gpu.Vulkan.CommandPool.Type as CommandPool -import qualified Gpu.Vulkan.CommandBuffer.Middle as M - -allocateCs :: ( - WithPoked (TMaybe.M mn), TLength.Length c, HeteroParList.FromList c ) => - Device.D sd -> AllocateInfo mn scp c -> - (forall scb . HeteroParList.LL (C scb) c -> IO a) -> IO a -allocateCs (Device.D dvc) ai f = bracket - (M.allocateCs dvc $ allocateInfoToMiddle ai) - (M.freeCs dvc - . (\(CommandPool.C cp) -> cp) $ allocateInfoCommandPool ai) - (f . HeteroParList.fromList (HeteroParList.Dummy . C)) - -allocateList :: WithPoked (TMaybe.M mn) => - Device.D sd -> AllocateInfoList mn scp -> - (forall scb . [C scb] -> IO a) -> IO a -allocateList (Device.D dvc) ai f = bracket - (M.allocateCs dvc $ allocateInfoToMiddleList ai) - (M.freeCs dvc - . (\(CommandPool.C cp) -> cp) $ allocateInfoCommandPoolList ai) - (f . (C <$>)) - -data AllocateInfo mn scp (c :: [()]) = AllocateInfo { - allocateInfoNext :: TMaybe.M mn, - allocateInfoCommandPool :: CommandPool.C scp, - allocateInfoLevel :: Level } - -data AllocateInfoList mn scp = AllocateInfoList { - allocateInfoNextList :: TMaybe.M mn, - allocateInfoCommandPoolList :: CommandPool.C scp, - allocateInfoLevelList :: Level, - allocateInfoCommandBufferCountList :: Word32 } - -deriving instance Show (TMaybe.M mn) => Show (AllocateInfo mn s c) - -allocateInfoToMiddle :: forall n s c . TLength.Length c => - AllocateInfo n s c -> M.AllocateInfo n -allocateInfoToMiddle AllocateInfo { - allocateInfoNext = mnxt, - allocateInfoCommandPool = CommandPool.C cp, - allocateInfoLevel = lvl } = M.AllocateInfo { - M.allocateInfoNext = mnxt, - M.allocateInfoCommandPool = cp, - M.allocateInfoLevel = lvl, - M.allocateInfoCommandBufferCount = TLength.length @_ @c } - -allocateInfoToMiddleList :: AllocateInfoList n s -> M.AllocateInfo n -allocateInfoToMiddleList AllocateInfoList { - allocateInfoNextList = mnxt, - allocateInfoCommandPoolList = CommandPool.C cp, - allocateInfoLevelList = lvl, - allocateInfoCommandBufferCountList = c } = M.AllocateInfo { - M.allocateInfoNext = mnxt, - M.allocateInfoCommandPool = cp, - M.allocateInfoLevel = lvl, - M.allocateInfoCommandBufferCount = c } - -begin :: (WithPoked (TMaybe.M mn), WithPoked (TMaybe.M ii)) => - C s -> M.BeginInfo mn ii -> IO a -> IO a -begin (C cb) bi act = bracket_ (M.begin cb bi) (M.end cb) act - -reset :: C sc -> ResetFlags -> IO () -reset (C cb) rfs = M.reset cb rfs diff --git a/src/Gpu/Vulkan/CommandBuffer/Internal.hs b/src/Gpu/Vulkan/CommandBuffer/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/CommandBuffer/Internal.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE ScopedTypeVariables, RankNTypes, TypeApplications #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures, TypeOperators #-} +{-# LANGUAGE FlexibleContexts, UndecidableInstances #-} +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.CommandBuffer.Internal ( + + -- * ALLOCATE + + C, GBinded, CBinded, + + -- ** Type Level List + + allocateCs, AllocateInfo(..), + + -- ** Value Level List + + allocateList, AllocateInfoList(..), + + -- * BEGIN AND RESET + + begin, reset, M.BeginInfo(..), M.InheritanceInfo(..), + + -- * SUBMIT INFO + + SubmitInfo(..), SubmitInfoListToMiddle(..) + + ) where + +import Foreign.Storable.PeekPoke +import Control.Exception +import Data.TypeLevel.Tuple.Uncurry +import Data.TypeLevel.Tuple.MapIndex qualified as TMapIndex +import Data.TypeLevel.Maybe qualified as TMaybe +import Data.TypeLevel.List qualified as TLength +import Data.HeteroParList (pattern (:**)) +import Data.HeteroParList qualified as HPList +import Data.HeteroParList qualified as HeteroParList +import Data.Word + +import Gpu.Vulkan.CommandBuffer.Type +import Gpu.Vulkan.CommandBuffer.Enum + +import qualified Gpu.Vulkan.Device.Type as Device +import qualified Gpu.Vulkan.CommandPool.Type as CommandPool +import qualified Gpu.Vulkan.CommandBuffer.Middle as M + +allocateCs :: ( + WithPoked (TMaybe.M mn), TLength.Length c, HeteroParList.FromList c ) => + Device.D sd -> AllocateInfo mn scp c -> + (forall scb . HeteroParList.LL (C scb) c -> IO a) -> IO a +allocateCs (Device.D dvc) ai f = bracket + (M.allocateCs dvc $ allocateInfoToMiddle ai) + (M.freeCs dvc + . (\(CommandPool.C cp) -> cp) $ allocateInfoCommandPool ai) + (f . HeteroParList.fromList (HeteroParList.Dummy . C)) + +allocateList :: WithPoked (TMaybe.M mn) => + Device.D sd -> AllocateInfoList mn scp -> + (forall scb . [C scb] -> IO a) -> IO a +allocateList (Device.D dvc) ai f = bracket + (M.allocateCs dvc $ allocateInfoToMiddleList ai) + (M.freeCs dvc + . (\(CommandPool.C cp) -> cp) $ allocateInfoCommandPoolList ai) + (f . (C <$>)) + +data AllocateInfo mn scp (c :: [()]) = AllocateInfo { + allocateInfoNext :: TMaybe.M mn, + allocateInfoCommandPool :: CommandPool.C scp, + allocateInfoLevel :: Level } + +data AllocateInfoList mn scp = AllocateInfoList { + allocateInfoNextList :: TMaybe.M mn, + allocateInfoCommandPoolList :: CommandPool.C scp, + allocateInfoLevelList :: Level, + allocateInfoCommandBufferCountList :: Word32 } + +deriving instance Show (TMaybe.M mn) => Show (AllocateInfo mn s c) + +allocateInfoToMiddle :: forall n s c . TLength.Length c => + AllocateInfo n s c -> M.AllocateInfo n +allocateInfoToMiddle AllocateInfo { + allocateInfoNext = mnxt, + allocateInfoCommandPool = CommandPool.C cp, + allocateInfoLevel = lvl } = M.AllocateInfo { + M.allocateInfoNext = mnxt, + M.allocateInfoCommandPool = cp, + M.allocateInfoLevel = lvl, + M.allocateInfoCommandBufferCount = TLength.length @_ @c } + +allocateInfoToMiddleList :: AllocateInfoList n s -> M.AllocateInfo n +allocateInfoToMiddleList AllocateInfoList { + allocateInfoNextList = mnxt, + allocateInfoCommandPoolList = CommandPool.C cp, + allocateInfoLevelList = lvl, + allocateInfoCommandBufferCountList = c } = M.AllocateInfo { + M.allocateInfoNext = mnxt, + M.allocateInfoCommandPool = cp, + M.allocateInfoLevel = lvl, + M.allocateInfoCommandBufferCount = c } + +begin :: (WithPoked (TMaybe.M mn), WithPoked (TMaybe.M ii)) => + C s -> M.BeginInfo mn ii -> IO a -> IO a +begin (C cb) bi act = bracket_ (M.begin cb bi) (M.end cb) act + +reset :: C sc -> ResetFlags -> IO () +reset (C cb) rfs = M.reset cb rfs + +data SubmitInfo mn sc = SubmitInfo { + submitInfoNext :: TMaybe.M mn, + submitInfoCommandBuffer :: C sc, + submitInfoDeviceMask :: Word32 } + +class SubmitInfoListToMiddle mnscs where + submitInfoListToMiddle :: + HPList.PL (U2 SubmitInfo) mnscs -> + HPList.PL M.SubmitInfo (TMapIndex.M0_2 mnscs) + +instance SubmitInfoListToMiddle '[] where + submitInfoListToMiddle HPList.Nil = HPList.Nil + +instance SubmitInfoListToMiddle mnscs => + SubmitInfoListToMiddle (mnsc ': mnscs) where + submitInfoListToMiddle (U2 si :** sis) = + submitInfoToMiddle si :** submitInfoListToMiddle sis + +submitInfoToMiddle :: SubmitInfo mn sc -> M.SubmitInfo mn +submitInfoToMiddle SubmitInfo { + submitInfoNext = mnxt, + submitInfoCommandBuffer = C c, + submitInfoDeviceMask = dm } = M.SubmitInfo { + M.submitInfoNext = mnxt, + M.submitInfoCommandBuffer = c, M.submitInfoDeviceMask = dm } diff --git a/src/Gpu/Vulkan/Internal.hs b/src/Gpu/Vulkan/Internal.hs --- a/src/Gpu/Vulkan/Internal.hs +++ b/src/Gpu/Vulkan/Internal.hs @@ -12,7 +12,7 @@ -- * INFO - -- ** ApplicationINfo + -- ** ApplicationInfo M.ApplicationInfo(..), M.ApiVersion, M.makeApiVersion, @@ -23,6 +23,8 @@ SubmitInfo(..), SubmitInfoListToMiddle(..), SemaphorePipelineStageFlags(..), + SubmitInfo2(..), SubmitInfo2ListToMiddle(..), + -- * PROPERTIES LayerProperties(..), layerPropertiesFromMiddle, @@ -90,9 +92,10 @@ import Foreign.Storable.PeekPoke import Data.Kind -import Data.TypeLevel.Maybe qualified as TMaybe import Data.TypeLevel.Tuple.Uncurry import Data.TypeLevel.Tuple.MapIndex qualified as TMapIndex +import Data.TypeLevel.Maybe qualified as TMaybe +import Data.TypeLevel.List qualified as TList import Data.HeteroParList qualified as HeteroParList import Data.HeteroParList qualified as HPList import Data.HeteroParList (pattern (:**)) @@ -101,6 +104,7 @@ import qualified Gpu.Vulkan.Middle as M import Gpu.Vulkan.Enum import qualified Gpu.Vulkan.Semaphore.Type as Semaphore +import qualified Gpu.Vulkan.Semaphore.Internal as Semaphore import qualified Gpu.Vulkan.Semaphore.Middle as Semaphore.M import qualified Gpu.Vulkan.CommandBuffer.Type as CommandBuffer import qualified Gpu.Vulkan.Pipeline.Enum as Pipeline @@ -109,6 +113,8 @@ import {-# SOURCE #-} Gpu.Vulkan.Buffer.Internal qualified as Buffer import Gpu.Vulkan.Image.Internal qualified as Image +import Gpu.Vulkan.CommandBuffer.Internal qualified as CommandBuffer + data SubmitInfo n sss ss ssss = SubmitInfo { submitInfoNext :: TMaybe.M n, submitInfoWaitSemaphoreDstStageMasks :: @@ -155,6 +161,79 @@ data SemaphorePipelineStageFlags ss = SemaphorePipelineStageFlags (Semaphore.S ss) Pipeline.StageFlags deriving Show + +data SubmitInfo2 mn wsas cbas ssas = SubmitInfo2 { + submitInfo2Next :: TMaybe.M mn, + submitInfo2Flags :: SubmitFlags, + submitInfo2WaitSemaphoreInfos :: + HPList.PL (U2 Semaphore.SubmitInfo) wsas, + submitInfo2CommandBufferInfos :: + HPList.PL (U2 CommandBuffer.SubmitInfo) cbas, + submitInfo2SignalSemaphoreInfos :: + HPList.PL (U2 Semaphore.SubmitInfo) ssas } + +class M.SubmitInfo2ListToCore (SubmitInfo2ArgsListToMiddle sias) => SubmitInfo2ListToMiddle sias where + type family SubmitInfo2ArgsListToMiddle sias :: + [(Maybe Type, [Maybe Type], [Maybe Type], [Maybe Type])] + submitInfo2ListToMiddle :: + HPList.PL (U4 SubmitInfo2) sias -> + HPList.PL (U4 M.SubmitInfo2) (SubmitInfo2ArgsListToMiddle sias) + +instance SubmitInfo2ListToMiddle '[] where + type SubmitInfo2ArgsListToMiddle '[] = '[] + submitInfo2ListToMiddle HPList.Nil = HPList.Nil + +instance ( + WithPoked (TMaybe.M mn), + TList.Length (TMapIndex.M0_2 wsas), + TList.Length (TMapIndex.M0_2 cbas), + TList.Length (TMapIndex.M0_2 ssas), + HPList.ToListWithCCpsM' WithPoked TMaybe.M (TMapIndex.M0_2 wsas), + HPList.ToListWithCCpsM' WithPoked TMaybe.M (TMapIndex.M0_2 cbas), + HPList.ToListWithCCpsM' WithPoked TMaybe.M (TMapIndex.M0_2 ssas), + Semaphore.SubmitInfoListToMiddle wsas, + CommandBuffer.SubmitInfoListToMiddle cbas, + Semaphore.SubmitInfoListToMiddle ssas, + SubmitInfo2ListToMiddle sias ) => + SubmitInfo2ListToMiddle ('(mn, wsas, cbas, ssas) ': sias) where + type SubmitInfo2ArgsListToMiddle ('(mn, wsas, cbas, ssas) ': sias) = + '(mn, TMapIndex.M0_2 wsas, + TMapIndex.M0_2 cbas, + TMapIndex.M0_2 ssas) ': SubmitInfo2ArgsListToMiddle sias + submitInfo2ListToMiddle (U4 si :** sis) = + U4 (submitInfo2ToMiddle si) :** submitInfo2ListToMiddle sis + +{- +type family SubmitInfo2ArgsListToMiddle sias where + SubmitInfo2ArgsListToMiddle '[] = '[] + SubmitInfo2ArgsListToMiddle ('(mn, wsas, cbas, ssas) ': sias) = + '(mn, TMapIndex.M0_2 wsas, + TMapIndex.M0_2 cbas, + TMapIndex.M0_2 ssas) ': SubmitInfo2ArgsListToMiddle sias + -} + +submitInfo2ToMiddle :: ( + Semaphore.SubmitInfoListToMiddle wsas, + CommandBuffer.SubmitInfoListToMiddle cbas, + Semaphore.SubmitInfoListToMiddle ssas ) => + SubmitInfo2 mn wsas cbas ssas -> + M.SubmitInfo2 mn (TMapIndex.M0_2 wsas) + (TMapIndex.M0_2 cbas) (TMapIndex.M0_2 ssas) +submitInfo2ToMiddle SubmitInfo2 { + submitInfo2Next = mnxt, + submitInfo2Flags = fs, + submitInfo2WaitSemaphoreInfos = wss, + submitInfo2CommandBufferInfos = cbs, + submitInfo2SignalSemaphoreInfos = sss + } = M.SubmitInfo2 { + M.submitInfo2Next = mnxt, + M.submitInfo2Flags = fs, + M.submitInfo2WaitSemaphoreInfos = + Semaphore.submitInfoListToMiddle wss, + M.submitInfo2CommandBufferInfos = + CommandBuffer.submitInfoListToMiddle cbs, + M.submitInfo2SignalSemaphoreInfos = + Semaphore.submitInfoListToMiddle sss } -- deriving instance (Show n, Show (HeteroParList SemaphorePipelineStageFlags sss)) => -- Show (SubmitInfo n sss s vs) diff --git a/src/Gpu/Vulkan/Queue.hs b/src/Gpu/Vulkan/Queue.hs --- a/src/Gpu/Vulkan/Queue.hs +++ b/src/Gpu/Vulkan/Queue.hs @@ -10,7 +10,7 @@ -- * SUBMIT AND WAIT IDLE - submit, M.waitIdle, M.Q, + submit, submit2, M.waitIdle, M.Q, -- * TYPE SYNONYM @@ -55,6 +55,11 @@ HeteroParList.PL (U4 SubmitInfo) sias -> Maybe (Fence.F sf) -> IO () submit q sis mf = M.submit q (submitInfoListToMiddle sis) $ (\(Fence.F f) -> f) <$> mf + +submit2 :: SubmitInfo2ListToMiddle sias => M.Q -> + HeteroParList.PL (U4 SubmitInfo2) sias -> Maybe (Fence.F sf) -> IO () +submit2 q sis mf = + M.submit2 q (submitInfo2ListToMiddle sis) $ (\(Fence.F f) -> f) <$> mf type Index = Word32 diff --git a/src/Gpu/Vulkan/Semaphore.hs b/src/Gpu/Vulkan/Semaphore.hs --- a/src/Gpu/Vulkan/Semaphore.hs +++ b/src/Gpu/Vulkan/Semaphore.hs @@ -10,6 +10,10 @@ group, Group, create', unsafeDestroy, lookup, + -- * SUBMIT INFO + + SubmitInfo(..), SubmitInfoListToMiddle + ) where import Prelude hiding (lookup) diff --git a/src/Gpu/Vulkan/Semaphore/Internal.hs b/src/Gpu/Vulkan/Semaphore/Internal.hs --- a/src/Gpu/Vulkan/Semaphore/Internal.hs +++ b/src/Gpu/Vulkan/Semaphore/Internal.hs @@ -2,7 +2,10 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wall -fno-warn-tabs #-} @@ -16,6 +19,10 @@ group, Group, create', unsafeDestroy, lookup, + -- * SUBMIT INFO + + SubmitInfo(..), SubmitInfoListToMiddle(..), + ) where import Prelude hiding (lookup) @@ -23,9 +30,12 @@ import Control.Concurrent.STM import Control.Concurrent.STM.TSem import Control.Exception +import Data.TypeLevel.Tuple.MapIndex qualified as TMapIndex import Data.TypeLevel.Maybe qualified as TMaybe import Data.TypeLevel.ParMaybe qualified as TPMaybe import Data.TypeLevel.Tuple.Uncurry +import Data.HeteroParList (pattern (:**)) +import Data.HeteroParList qualified as HPList import Data.Map qualified as Map import Data.Word @@ -36,6 +46,8 @@ import Gpu.Vulkan.Semaphore.Type +import qualified Gpu.Vulkan.Pipeline as Pipeline + create :: (WithPoked (TMaybe.M mn), AllocationCallbacks.ToMiddle mac) => Device.D sd -> M.CreateInfo mn -> TPMaybe.M (U2 AllocationCallbacks.A) mac -> @@ -95,3 +107,32 @@ lookup :: Ord k => Group sd ma ss k -> k -> IO (Maybe (S ss)) lookup (Group _ _ _sem ss) k = atomically $ Map.lookup k <$> readTVar ss + +data SubmitInfo mn ss = SubmitInfo { + submitInfoNext :: TMaybe.M mn, + submitInfoSemaphore :: S ss, submitInfoValue :: Word64, + submitInfoStageMask :: Pipeline.StageFlags2, + submitInfoDeviceIndex :: Word32 } + +class SubmitInfoListToMiddle mnsss where + submitInfoListToMiddle :: + HPList.PL (U2 SubmitInfo) mnsss -> + HPList.PL M.SubmitInfo (TMapIndex.M0_2 mnsss) + +instance SubmitInfoListToMiddle '[] where + submitInfoListToMiddle HPList.Nil = HPList.Nil + +instance SubmitInfoListToMiddle mnsss => + SubmitInfoListToMiddle (mnss ': mnsss) where + submitInfoListToMiddle (U2 si :** sis) = + submitInfoToMiddle si :** submitInfoListToMiddle sis + +submitInfoToMiddle :: SubmitInfo mn ss -> M.SubmitInfo mn +submitInfoToMiddle SubmitInfo { + submitInfoNext = mnxt, + submitInfoSemaphore = S s, submitInfoValue = v, + submitInfoStageMask = sm, submitInfoDeviceIndex = di + } = M.SubmitInfo { + M.submitInfoNext = mnxt, + M.submitInfoSemaphore = s, M.submitInfoValue = v, + M.submitInfoStageMask = sm, M.submitInfoDeviceIndex = di }