diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,11 @@ +# Changelog for `try-gpu-vulkan` + +All notable changes to this project will be documented in this file. + +The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), +and this project adheres to the +[Haskell Package Versioning Policy](https://pvp.haskell.org/). + +## Unreleased + +## 0.1.0.0 - YYYY-MM-DD diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Yoshikuni Jujo (c) 2023 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Yoshikuni Jujo nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,1 @@ +# try-gpu-vulkan diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/debug/Debug.hs b/debug/Debug.hs new file mode 100644 --- /dev/null +++ b/debug/Debug.hs @@ -0,0 +1,3 @@ +module Debug where + +debug = True diff --git a/gpu-vulkan.cabal b/gpu-vulkan.cabal new file mode 100644 --- /dev/null +++ b/gpu-vulkan.cabal @@ -0,0 +1,242 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.37.0. +-- +-- see: https://github.com/sol/hpack + +name: gpu-vulkan +version: 0.1.0.137 +synopsis: Vulkan library +description: Please see the README on GitHub at +category: GPU +homepage: https://github.com/YoshikuniJujo/gpu-vulkan#readme +bug-reports: https://github.com/YoshikuniJujo/gpu-vulkan/issues +author: Yoshikuni Jujo +maintainer: yoshikuni.jujo@gmail.com +copyright: 2023 Yoshikuni Jujo +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + CHANGELOG.md +data-files: + th/vkPhysicalDeviceLimits.txt + th/vkPhysicalDeviceFeatures.txt + th/vkFormat.txt + th/vkShaderStageFlagBits.txt + +source-repository head + type: git + location: https://github.com/YoshikuniJujo/gpu-vulkan + +flag debug + manual: True + default: False + +library + exposed-modules: + Gpu.Vulkan + Gpu.Vulkan.AllocationCallbacks + Gpu.Vulkan.AllocationCallbacks.Internal + Gpu.Vulkan.Attachment + Gpu.Vulkan.Buffer + Gpu.Vulkan.BufferView + Gpu.Vulkan.Cmd + Gpu.Vulkan.ColorComponent + Gpu.Vulkan.CommandBuffer + Gpu.Vulkan.CommandPool + Gpu.Vulkan.Component + Gpu.Vulkan.Descriptor + Gpu.Vulkan.DescriptorPool + Gpu.Vulkan.DescriptorSet + Gpu.Vulkan.DescriptorSetLayout + Gpu.Vulkan.DescriptorSetLayout.BindingFlags + Gpu.Vulkan.Device + Gpu.Vulkan.Device.Internal + Gpu.Vulkan.Exception + Gpu.Vulkan.Fence + Gpu.Vulkan.Fence.Internal + Gpu.Vulkan.Framebuffer + Gpu.Vulkan.Image + Gpu.Vulkan.Image.Internal + Gpu.Vulkan.ImageView + Gpu.Vulkan.Instance + Gpu.Vulkan.Instance.Internal + Gpu.Vulkan.Memory + Gpu.Vulkan.Object + Gpu.Vulkan.Object.Base + Gpu.Vulkan.Object.NoAlignment + Gpu.Vulkan.PhysicalDevice + Gpu.Vulkan.Pipeline + Gpu.Vulkan.Pipeline.ColorBlendAttachment + Gpu.Vulkan.Pipeline.ColorBlendState + Gpu.Vulkan.Pipeline.Compute + Gpu.Vulkan.Pipeline.DepthStencilState + Gpu.Vulkan.Pipeline.DynamicState + Gpu.Vulkan.Pipeline.Graphics + Gpu.Vulkan.Pipeline.InputAssemblyState + Gpu.Vulkan.Pipeline.MultisampleState + Gpu.Vulkan.Pipeline.RasterizationState + Gpu.Vulkan.Pipeline.ShaderStage + Gpu.Vulkan.Pipeline.TessellationState + Gpu.Vulkan.Pipeline.VertexInputState + Gpu.Vulkan.Pipeline.ViewportState + Gpu.Vulkan.PipelineCache + Gpu.Vulkan.PipelineLayout + Gpu.Vulkan.PushConstant + Gpu.Vulkan.Query + Gpu.Vulkan.QueryPool + Gpu.Vulkan.Queue + Gpu.Vulkan.QueueFamily + Gpu.Vulkan.RenderPass + Gpu.Vulkan.Sample + Gpu.Vulkan.Sampler + Gpu.Vulkan.Semaphore + Gpu.Vulkan.Semaphore.Internal + Gpu.Vulkan.ShaderModule + Gpu.Vulkan.Subpass + Gpu.Vulkan.TypeEnum + Gpu.Vulkan.VertexInput + other-modules: + Gpu.Vulkan.AllocationCallbacks.Type + Gpu.Vulkan.Attachment.Enum + Gpu.Vulkan.Buffer.Enum + Gpu.Vulkan.Buffer.Internal + Gpu.Vulkan.Buffer.Type + Gpu.Vulkan.BufferView.Internal + Gpu.Vulkan.ColorComponent.Enum + Gpu.Vulkan.CommandBuffer.Enum + Gpu.Vulkan.CommandBuffer.Type + Gpu.Vulkan.CommandPool.Enum + Gpu.Vulkan.CommandPool.Type + Gpu.Vulkan.Component.Enum + Gpu.Vulkan.Descriptor.Enum + Gpu.Vulkan.Descriptor.Internal + Gpu.Vulkan.DescriptorPool.Enum + Gpu.Vulkan.DescriptorPool.Type + Gpu.Vulkan.DescriptorSet.BindingAndArrayElem + Gpu.Vulkan.DescriptorSet.BindingAndArrayElem.Buffer + Gpu.Vulkan.DescriptorSet.Copy + Gpu.Vulkan.DescriptorSet.Type + Gpu.Vulkan.DescriptorSet.Write + Gpu.Vulkan.DescriptorSet.Write.Sources + Gpu.Vulkan.DescriptorSetLayout.Enum + Gpu.Vulkan.DescriptorSetLayout.Type + Gpu.Vulkan.DescriptorSetLayout.UpdateDynamicLengths + Gpu.Vulkan.Device.Enum + Gpu.Vulkan.Device.Type + Gpu.Vulkan.Enum + Gpu.Vulkan.Exception.Enum + Gpu.Vulkan.Fence.Enum + Gpu.Vulkan.Fence.Type + Gpu.Vulkan.Framebuffer.Enum + Gpu.Vulkan.Framebuffer.Type + Gpu.Vulkan.Image.Enum + Gpu.Vulkan.Image.Type + Gpu.Vulkan.ImageView.Enum + Gpu.Vulkan.ImageView.Type + Gpu.Vulkan.Instance.Type + Gpu.Vulkan.Internal + Gpu.Vulkan.Memory.Bind + Gpu.Vulkan.Memory.Enum + Gpu.Vulkan.Memory.ImageBuffer + Gpu.Vulkan.Memory.OffsetSize + Gpu.Vulkan.Memory.Type + Gpu.Vulkan.PhysicalDevice.Enum + Gpu.Vulkan.PhysicalDevice.Struct + Gpu.Vulkan.Pipeline.Enum + Gpu.Vulkan.Pipeline.Graphics.Type + Gpu.Vulkan.Pipeline.ShaderStage.Enum + Gpu.Vulkan.Pipeline.ShaderStage.Internal + Gpu.Vulkan.Pipeline.VertexInputState.BindingOffset + Gpu.Vulkan.Pipeline.VertexInputState.Data.Type.TypeFam + Gpu.Vulkan.Pipeline.VertexInputState.Data.Type.TypeValMap + Gpu.Vulkan.Pipeline.VertexInputState.Formattable + Gpu.Vulkan.Pipeline.VertexInputState.GHC.Generics.TypeFam + Gpu.Vulkan.Pipeline.VertexInputState.Internal + Gpu.Vulkan.Pipeline.VertexInputState.SizeAlignment + Gpu.Vulkan.Pipeline.VertexInputState.SizeAlignment.Internal + Gpu.Vulkan.Pipeline.VertexInputState.SizeAlignment.TH + Gpu.Vulkan.PipelineCache.Type + Gpu.Vulkan.PipelineLayout.Type + Gpu.Vulkan.PushConstant.Internal + Gpu.Vulkan.Query.Enum + Gpu.Vulkan.QueryPool.Type + Gpu.Vulkan.Queue.Enum + Gpu.Vulkan.RenderPass.Enum + Gpu.Vulkan.RenderPass.Internal + Gpu.Vulkan.RenderPass.Type + Gpu.Vulkan.Sample.Enum + Gpu.Vulkan.Sampler.Enum + Gpu.Vulkan.Sampler.Type + Gpu.Vulkan.Semaphore.Type + Gpu.Vulkan.ShaderModule.Internal + Gpu.Vulkan.Subpass.Enum + Gpu.Vulkan.TypeEnum.Th + Gpu.Vulkan.TypeEnum.TypeValues + Gpu.Vulkan.VertexInput.Internal + Paths_gpu_vulkan + hs-source-dirs: + src + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints + build-depends: + base >=4.7 && <5 + , bytestring <1 + , containers <1 + , data-default <1 + , gpu-vulkan-middle <1 + , hetero-parameter-list <1 + , hetero-parameter-list-with-typelevel-tools <1 + , language-spir-v <1 + , mono-traversable <2 + , stm <3 + , storable-hetero-list <1 + , storable-peek-poke <1 + , template-haskell <3 + , temporary <2 + , text <3 + , time <2 + , tools-yj <1 + , typelevel-tools-yj <1 + default-language: Haskell2010 + if flag(debug) + other-modules: + Debug + hs-source-dirs: + debug + else + other-modules: + Debug + hs-source-dirs: + nodebug + +test-suite gpu-vulkan-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_gpu_vulkan + hs-source-dirs: + test + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.7 && <5 + , bytestring <1 + , containers <1 + , data-default <1 + , gpu-vulkan + , gpu-vulkan-middle <1 + , hetero-parameter-list <1 + , hetero-parameter-list-with-typelevel-tools <1 + , language-spir-v <1 + , mono-traversable <2 + , stm <3 + , storable-hetero-list <1 + , storable-peek-poke <1 + , template-haskell <3 + , temporary <2 + , text <3 + , time <2 + , tools-yj <1 + , typelevel-tools-yj <1 + default-language: Haskell2010 diff --git a/nodebug/Debug.hs b/nodebug/Debug.hs new file mode 100644 --- /dev/null +++ b/nodebug/Debug.hs @@ -0,0 +1,3 @@ +module Debug where + +debug = False diff --git a/src/Gpu/Vulkan.hs b/src/Gpu/Vulkan.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-} +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan ( + + -- * INFO + + -- ** ApplicationINfo + + ApplicationInfo(..), + ApiVersion, makeApiVersion, apiVersion_1_0, apiVersion_1_1, + + -- ** SubmitInfo + + SubmitInfo(..), + SubmitInfoListToMiddle, SemaphorePipelineStageFlags(..), + + -- * PROPERTIES + + LayerProperties(..), + FormatProperties(..), + + -- * NAMES + + LayerName(..), layerKhronosValidation, + + -- * PIPELINE VALUES + + -- ** ViewPort + + Viewport, pattern Viewport, + viewportX, viewportY, viewportWidth, viewportHeight, + viewportMinDepth, viewportMaxDepth, + + -- ** StencilOpState + + StencilOpState(..), + + -- ** ClearValue + + ClearValue(..), ClearValueListToCore, + + -- *** ClearType + + ClearType(..), ClearColorType(..), + + -- *** ClearColorValue + + -- *** ClearDepthStencilValue + + ClearDepthStencilValue, pattern ClearDepthStencilValue, + clearDepthStencilValueDepth, clearDepthStencilValueStencil, + + -- * RECT, OFFSET AND EXTENT + + -- ** Rect + + Rect2d, pattern Rect2d, rect2dExtent, rect2dOffset, + + -- ** Offset + + Offset2d, pattern Offset2d, offset2dX, offset2dY, + Offset3d, pattern Offset3d, offset3dX, offset3dY, offset3dZ, + + -- ** Extent + + Extent2d, pattern Extent2d, + extent2dWidth, extent2dHeight, + + Extent3d, pattern Extent3d, + extent3dWidth, extent3dHeight, extent3dDepth, + + -- * OTHERS + + Size(..), + + -- * ENUM + + module Gpu.Vulkan.Enum, + + ) where + +import Gpu.Vulkan.Internal +import Gpu.Vulkan.Enum diff --git a/src/Gpu/Vulkan/AllocationCallbacks.hs b/src/Gpu/Vulkan/AllocationCallbacks.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/AllocationCallbacks.hs @@ -0,0 +1,24 @@ +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.AllocationCallbacks ( + + -- * CREATE + + create, Functions, FunctionsInfo(..), + + -- ** Function Types + + FnAllocationFunction, FnReallocationFunction, FnFreeFunction, + FnInternalAllocationNotification, FnInternalFreeNotification, + + -- *** Size and Alignment + + Size, Alignment, + + -- * APPLY + + apply, A, ToMiddle + + ) where + +import Gpu.Vulkan.AllocationCallbacks.Internal diff --git a/src/Gpu/Vulkan/AllocationCallbacks/Internal.hs b/src/Gpu/Vulkan/AllocationCallbacks/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/AllocationCallbacks/Internal.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE RankNTypes #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.AllocationCallbacks.Internal ( + + -- * CREATE + + create, Functions, M.FunctionsInfo(..), + + -- ** Function Types + + M.FnAllocationFunction, M.FnReallocationFunction, M.FnFreeFunction, + M.FnInternalAllocationNotification, M.FnInternalFreeNotification, + + -- *** Size and Alignment + + M.Size, M.Alignment, + + -- * APPLY + + apply, A, ToMiddle(..) + + ) where + +import Control.Exception +import Gpu.Vulkan.AllocationCallbacks.Type +import Gpu.Vulkan.AllocationCallbacks.Middle qualified as M + +create :: M.FunctionsInfo a -> (forall s . Functions s a -> IO b) -> IO b +create fns f = bracket (M.create fns) M.destroy (f . Functions) diff --git a/src/Gpu/Vulkan/AllocationCallbacks/Type.hs b/src/Gpu/Vulkan/AllocationCallbacks/Type.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/AllocationCallbacks/Type.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.AllocationCallbacks.Type ( + + -- * A + + A(..), ToMiddle(..), + + -- * Functions + + Functions(..), apply + + ) where + +import Foreign.Ptr +import Data.Kind +import Data.TypeLevel.ParMaybe qualified as TPMaybe +import Data.TypeLevel.Tuple.Uncurry + +import Gpu.Vulkan.AllocationCallbacks.Middle qualified as M + +newtype A s a = A (M.A a) deriving Show + +class ToMiddle msa where + type Snd msa :: Maybe Type + toMiddle :: TPMaybe.M (U2 A) msa -> TPMaybe.M M.A (Snd msa) + +instance ToMiddle 'Nothing where + type Snd 'Nothing = 'Nothing + toMiddle TPMaybe.N = TPMaybe.N + +instance ToMiddle ('Just '(s, a)) where + type Snd ('Just '(s, a)) = 'Just a + toMiddle (TPMaybe.J (U2 (A a))) = TPMaybe.J a + +newtype Functions s a = Functions { toMiddleFunctions :: M.Functions a } + deriving Show + +apply :: Functions s a -> Ptr a -> A s a +Functions f `apply` p = A $ f `M.apply` p diff --git a/src/Gpu/Vulkan/Attachment.hs b/src/Gpu/Vulkan/Attachment.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Attachment.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE ScopedTypeVariables, TypeApplications #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures, TypeOperators #-} +{-# LANGUAGE PatternSynonyms #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Attachment ( + + -- * DESCRIPTION + + Description(..), DescriptionListToMiddle(..), + + -- * REFERENCE + + M.Reference(..), M.A, + + -- * ENUM + + module Gpu.Vulkan.Attachment.Enum + + ) where + +import qualified Data.HeteroParList as HeteroParList +import Data.HeteroParList (pattern (:**)) + +import Gpu.Vulkan.Attachment.Enum + +import qualified Gpu.Vulkan.TypeEnum as T +import qualified Gpu.Vulkan.Sample.Enum as Sample +import qualified Gpu.Vulkan.Image.Enum as Image + +import Gpu.Vulkan.Attachment.Middle qualified as M + +data Description (fmt :: T.Format) = Description { + descriptionFlags :: DescriptionFlags, + descriptionSamples :: Sample.CountFlagBits, + descriptionLoadOp :: LoadOp, + descriptionStoreOp :: StoreOp, + descriptionStencilLoadOp :: LoadOp, + descriptionStencilStoreOp :: StoreOp, + descriptionInitialLayout :: Image.Layout, + descriptionFinalLayout :: Image.Layout } + deriving Show + +class DescriptionListToMiddle fmts where + descriptionListToMiddle :: + HeteroParList.PL Description fmts -> [M.Description] + +instance DescriptionListToMiddle '[] where descriptionListToMiddle HeteroParList.Nil = [] + +instance (T.FormatToValue fmt, DescriptionListToMiddle fmts) => + DescriptionListToMiddle (fmt ': fmts) where + descriptionListToMiddle (d :** ds) = + descriptionToMiddle d : descriptionListToMiddle ds + +descriptionToMiddle :: forall fmt . T.FormatToValue fmt => Description fmt -> M.Description +descriptionToMiddle Description { + descriptionFlags = flgs, + descriptionSamples = smpls, + descriptionLoadOp = lop, + descriptionStoreOp = sop, + descriptionStencilLoadOp = slop, + descriptionStencilStoreOp = ssop, + descriptionInitialLayout = ilyt, + descriptionFinalLayout = flyt + } = M.Description { + M.descriptionFlags = flgs, + M.descriptionFormat = T.formatToValue @fmt, + M.descriptionSamples = smpls, + M.descriptionLoadOp = lop, + M.descriptionStoreOp = sop, + M.descriptionStencilLoadOp = slop, + M.descriptionStencilStoreOp = ssop, + M.descriptionInitialLayout = ilyt, + M.descriptionFinalLayout = flyt } diff --git a/src/Gpu/Vulkan/Attachment/Enum.hs b/src/Gpu/Vulkan/Attachment/Enum.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Attachment/Enum.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE PackageImports #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Attachment.Enum (module Gpu.Vulkan.Attachment.Enum) where + +import "gpu-vulkan-middle" Gpu.Vulkan.Attachment.Enum diff --git a/src/Gpu/Vulkan/Buffer.hs b/src/Gpu/Vulkan/Buffer.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Buffer.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE ScopedTypeVariables, RankNTypes, TypeApplications #-} +{-# LANGUAGE GADTs, TypeFamilies #-} +{-# LANGUAGE DataKinds, PolyKinds #-} +{-# LANGUAGE KindSignatures, TypeOperators #-} +{-# LANGUAGE MultiParamTypeClasses, AllowAmbiguousTypes #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-} +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Buffer ( + + -- * CREATE + + create, B, CreateInfo(..), + + -- ** Buffer Group + + Group, group, create', unsafeDestroy, lookup, + + -- * BINDED + + getMemoryRequirements, Binded, lengthBinded, IndexedForList(..), + + -- * COPY + + MakeCopies, ImageCopy(..), ImageCopyListToMiddle, + + -- * MEMORY BARRIER + + MemoryBarrier(..), MemoryBarrierListToMiddle, + + -- * ENUM + + module Gpu.Vulkan.Buffer.Enum + + ) where + +import Prelude hiding (lookup) +import Gpu.Vulkan.Buffer.Internal +import Gpu.Vulkan.Buffer.Enum diff --git a/src/Gpu/Vulkan/Buffer/Enum.hs b/src/Gpu/Vulkan/Buffer/Enum.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Buffer/Enum.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE PackageImports #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Buffer.Enum (module Gpu.Vulkan.Buffer.Enum) where + +import "gpu-vulkan-middle" Gpu.Vulkan.Buffer.Enum diff --git a/src/Gpu/Vulkan/Buffer/Internal.hs b/src/Gpu/Vulkan/Buffer/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Buffer/Internal.hs @@ -0,0 +1,394 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE ScopedTypeVariables, RankNTypes, TypeApplications #-} +{-# LANGUAGE GADTs, TypeFamilies #-} +{-# LANGUAGE DataKinds, PolyKinds #-} +{-# LANGUAGE KindSignatures, TypeOperators #-} +{-# LANGUAGE MultiParamTypeClasses, AllowAmbiguousTypes #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-} +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Buffer.Internal ( + + -- * CREATE + + create, B, CreateInfo(..), + + -- ** Buffer Group + + Group, group, create', unsafeDestroy, lookup, + + -- * BINDED + + getMemoryRequirements, Binded, lengthBinded, + IndexedForList(..), indexedListToMiddles, indexedListToMiddle, + + -- * COPY + + MakeCopies(..), CopyInfo, + + -- * IMAGE COPY + + ImageCopy(..), ImageCopyListToMiddle(..), + + -- * MEMORY BARRIER + + MemoryBarrier(..), MemoryBarrierListToMiddle(..) + + ) where + +import Prelude hiding (lookup) +import GHC.TypeLits +import Foreign.Storable.PeekPoke +import Control.Exception +import Gpu.Vulkan.Object qualified as VObj +import Data.Kind +import Data.TypeLevel.Tuple.Uncurry +import Data.TypeLevel.Tuple.MapIndex qualified as TMapIndex +import Data.TypeLevel.Maybe qualified as TMaybe +import Data.TypeLevel.ParMaybe qualified as TPMaybe +import Data.HeteroParList qualified as HeteroParList +import Data.HeteroParList (pattern (:**)) +import Data.Word + +import Gpu.Vulkan.Enum hiding (ObjectType) +import Gpu.Vulkan.Buffer.Enum + +import qualified Gpu.Vulkan.Middle as C +import qualified Gpu.Vulkan.AllocationCallbacks as AllocationCallbacks +import qualified Gpu.Vulkan.AllocationCallbacks.Type as AllocationCallbacks +import qualified Gpu.Vulkan.Device.Type as Device +import qualified Gpu.Vulkan.Device.Middle as Device.M +import qualified Gpu.Vulkan.Memory as Memory +import qualified Gpu.Vulkan.Buffer.Middle as M +import qualified Gpu.Vulkan.Buffer.Middle as C +import qualified Gpu.Vulkan.QueueFamily as QueueFamily +import qualified Gpu.Vulkan.Image as Image.M + +import Gpu.Vulkan.Buffer.Type + +import Control.Concurrent.STM +import Control.Concurrent.STM.TSem +import Data.Map qualified as Map + +data CreateInfo mn objs = CreateInfo { + createInfoNext :: TMaybe.M mn, + createInfoFlags :: CreateFlags, + createInfoLengths :: HeteroParList.PL VObj.Length objs, + createInfoUsage :: UsageFlags, + createInfoSharingMode :: SharingMode, + createInfoQueueFamilyIndices :: [QueueFamily.Index] } + +deriving instance + (Show (TMaybe.M n), Show (HeteroParList.PL VObj.Length objs)) => + Show (CreateInfo n objs) + +createInfoToMiddle :: VObj.SizeAlignmentList objs => + CreateInfo n objs -> M.CreateInfo n +createInfoToMiddle CreateInfo { + createInfoNext = mnxt, + createInfoFlags = flgs, + createInfoLengths = lns, + createInfoUsage = usg, + createInfoSharingMode = smd, + createInfoQueueFamilyIndices = qfis } = M.CreateInfo { + M.createInfoNext = mnxt, + M.createInfoFlags = flgs, + M.createInfoSize = VObj.wholeSize lns, + M.createInfoUsage = usg, + M.createInfoSharingMode = smd, + M.createInfoQueueFamilyIndices = qfis } + +create :: ( + WithPoked (TMaybe.M mn), + VObj.SizeAlignmentList objs, AllocationCallbacks.ToMiddle ma ) => + Device.D sd -> CreateInfo mn objs -> + TPMaybe.M (U2 AllocationCallbacks.A) ma -> + (forall sb . B sb nm objs -> IO a) -> IO a +create (Device.D dvc) ci (AllocationCallbacks.toMiddle -> mac) f = bracket + (M.create dvc (createInfoToMiddle ci) mac) (\b -> M.destroy dvc b mac) + (f . B (createInfoLengths ci)) + +data Group sd ma s k nm objs = Group (Device.D sd) + (TPMaybe.M (U2 AllocationCallbacks.A) ma) + TSem (TVar (Map.Map k (B s nm objs))) + +group :: AllocationCallbacks.ToMiddle md => + Device.D sd -> TPMaybe.M (U2 AllocationCallbacks.A) md -> + (forall s . Group sd md s k nm objs -> IO a) -> IO a +group dvc@(Device.D mdvc) mac@(AllocationCallbacks.toMiddle -> mmac) f = do + (sem, m) <- atomically $ (,) <$> newTSem 1 <*> newTVar Map.empty + rtn <- f $ Group dvc mac sem m + ((\(B _ mb) -> M.destroy mdvc mb mmac) `mapM_`) + =<< atomically (readTVar m) + pure rtn + +create' :: ( + Ord k, WithPoked (TMaybe.M mn), + VObj.SizeAlignmentList objs, AllocationCallbacks.ToMiddle ma ) => + Group sd ma sg k nm objs -> k -> CreateInfo mn objs -> + IO (Either String (B sg nm objs)) +create' (Group (Device.D dvc) + (AllocationCallbacks.toMiddle -> mac) sem bs) k ci = do + ok <- atomically do + mx <- (Map.lookup k) <$> readTVar bs + case mx of + Nothing -> waitTSem sem >> pure True + Just _ -> pure False + if ok + then do b <- M.create dvc (createInfoToMiddle ci) mac + let b' = B (createInfoLengths ci) b + atomically $ modifyTVar bs (Map.insert k b') >> signalTSem sem + pure $ Right b' + else pure . Left $ "Gpu.Vulkan.Buffer.create': The key already exist" + +unsafeDestroy :: (Ord k, AllocationCallbacks.ToMiddle ma) => + Group sd ma sg k nm objs -> k -> IO (Either String ()) +unsafeDestroy (Group (Device.D mdvc) + (AllocationCallbacks.toMiddle -> ma) sem bs) k = do + mb <- atomically do + mx <- Map.lookup k <$> readTVar bs + case mx of + Nothing -> pure Nothing + Just _ -> waitTSem sem >> pure mx + case mb of + Nothing -> pure $ Left "Gpu.Vulkan.Buffer.unsafeDestroy: No such key" + Just (B _ b) -> do + M.destroy mdvc b ma + atomically do + modifyTVar bs (Map.delete k) + signalTSem sem + pure $ Right () + +lookup :: Ord k => Group sd md sg k nm objs -> k -> IO (Maybe (B sg nm objs)) +lookup (Group _ _ _sem bs) k = atomically $ Map.lookup k <$> readTVar bs + +getMemoryRequirements :: Device.D sd -> B sb nm objs -> IO Memory.Requirements +getMemoryRequirements (Device.D dvc) (B _ b) = M.getMemoryRequirements dvc b + +data IndexedForList sm sb nm t onm = forall objs . + VObj.OffsetOfList t onm objs => IndexedForList (Binded sm sb nm objs) + +indexedListToOffset :: forall sm sb nm v onm a . IndexedForList sm sb nm v onm -> + (forall vs . (Binded sm sb nm vs, Device.M.Size) -> a) -> a +indexedListToOffset (IndexedForList b@(Binded lns _)) f = + f (b, fst $ VObj.offsetOfList @v @onm lns) + +indexedListToMiddle :: IndexedForList sm sb nm v onm -> (M.B, Device.M.Size) +indexedListToMiddle il = indexedListToOffset il \(Binded _ b, sz) -> (b, sz) + +indexedListToMiddles :: + HeteroParList.PL (U5 IndexedForList) smsbvs -> [(M.B, Device.M.Size)] +indexedListToMiddles HeteroParList.Nil = [] +indexedListToMiddles (U5 il :** ils) = + indexedListToMiddle il : indexedListToMiddles ils + +class CopyPrefix (area :: [VObj.O]) (src :: [VObj.O]) (dst :: [VObj.O]) where + copyCheckLengthPrefix :: + HeteroParList.PL VObj.Length src -> + HeteroParList.PL VObj.Length dst -> Bool + copySizePrefix :: Word64 -> HeteroParList.PL VObj.Length src -> Word64 + +instance CopyPrefix '[] src dst where + copyCheckLengthPrefix _ _ = True + copySizePrefix sz _ = sz + +instance ( + VObj.SizeAlignment a, + CopyPrefix as ss ds ) => + CopyPrefix (a ': as) (a ': ss) (a ': ds) where + copyCheckLengthPrefix (s :** ss) (d :** ds) = + s == d && copyCheckLengthPrefix @as ss ds + copySizePrefix sz (ln :** lns) = copySizePrefix @as @ss @ds + (((sz - 1) `div` algn + 1) * algn + fromIntegral (VObj.size ln)) + lns + where algn = fromIntegral $ VObj.alignment @a + +class CopyInfo (area :: [VObj.O]) (is :: Nat) (id :: Nat) (src :: [VObj.O]) (dst :: [VObj.O]) where + copyCheckLength :: + HeteroParList.PL VObj.Length src -> + HeteroParList.PL VObj.Length dst -> Bool + copySrcOffset :: Word64 -> HeteroParList.PL VObj.Length src -> Word64 + copyDstOffset :: Word64 -> HeteroParList.PL VObj.Length dst -> Word64 + copySize :: HeteroParList.PL VObj.Length src -> Word64 + +type OT o = VObj.TypeOf o + +instance ( + Sizable (VObj.TypeOf a), + CopyPrefix (a ': as) (a ': ss) (a ': ds) ) => CopyInfo (a ': as) 0 0 (a ': ss) (a ': ds) where + copyCheckLength = copyCheckLengthPrefix @(a ': as) @(a ': ss) @(a ': ds) + copySrcOffset ost _ = ((ost - 1) `div` algn + 1) * algn + where algn = fromIntegral $ alignment' @(OT a) + copyDstOffset ost _ = ((ost - 1) `div` algn + 1) * algn + where algn = fromIntegral $ alignment' @(OT a) + copySize = copySizePrefix @(a ': as) @(a ': ss) @(a ': ds) 0 + +instance {-# OVERLAPPABLE #-} + (VObj.SizeAlignment a, CopyInfo (a ': as) 0 (id - 1) (a ': ss) ds) => + CopyInfo (a ': as) 0 id (a ': ss) (a ': ds) where + copyCheckLength ss (_ :** ds) = + copyCheckLength @(a ': as) @0 @(id - 1) @(a ': ss) @ds ss ds + copySrcOffset ost lns = copySrcOffset @(a ': as) @0 @(id - 1) @(a ': ss) @ds ost lns + copyDstOffset ost (ln :** lns) = copyDstOffset @(a ': as) @0 @(id - 1) @(a ': ss) + (((ost - 1) `div` algn + 1) * algn + fromIntegral (VObj.size ln)) + lns + where algn = fromIntegral $ VObj.alignment @a + copySize = copySize @(a ': as) @0 @(id - 1) @(a ': ss) @ds + +instance {-# OVERLAPPABLE #-} + (VObj.SizeAlignment d, CopyInfo (a ': as) 0 id (a ': ss) ds) => + CopyInfo (a ': as) 0 id (a ': ss) (d ': ds) where + copyCheckLength ss (_ :** ds) = + copyCheckLength @(a ': as) @0 @id @(a ': ss) @ds ss ds + copySrcOffset ost lns = copySrcOffset @(a ': as) @0 @id @(a ': ss) @ds ost lns + copyDstOffset ost (ln :** lns) = copyDstOffset @(a ': as) @0 @id @(a ': ss) + (((ost - 1) `div` algn + 1) * algn + fromIntegral (VObj.size ln)) + lns + where algn = fromIntegral $ VObj.alignment @d + copySize = copySize @(a ': as) @0 @id @(a ': ss) @ds + +instance {-# OVERLAPPABLE #-} + (VObj.SizeAlignment a, CopyInfo (a ': as) (is - 1) id ss ds) => + CopyInfo (a ': as) is id (a ': ss) ds where + copyCheckLength (_ :** ss) ds = copyCheckLength @(a ': as) @(is - 1) @id @ss @ds ss ds + copySrcOffset ost (ln :** lns) = copySrcOffset @(a ': as) @(is - 1) @id @ss @ds + (((ost - 1) `div` algn + 1) * algn + fromIntegral (VObj.size ln)) + lns + where algn = fromIntegral $ VObj.alignment @a + copyDstOffset ost lns = copyDstOffset @(a ': as) @(is - 1) @id @ss ost lns + copySize (_ :** lns) = copySize @(a ': as) @(is - 1) @id @ss @ds lns + +instance {-# OVERLAPPABLE #-} + (VObj.SizeAlignment s, + CopyInfo as is id ss ds) => + CopyInfo as is id (s ': ss) ds where + copyCheckLength (_ :** ss) ds = copyCheckLength @as @is @id ss ds + copySrcOffset ost (ln :** lns) = copySrcOffset @as @is @id @ss @ds + (((ost - 1) `div` algn + 1) * algn + fromIntegral (VObj.size ln)) + lns + where algn = fromIntegral (VObj.alignment @s) + copyDstOffset ost lns = copyDstOffset @as @is @id @ss ost lns + copySize (_ :** lns) = copySize @as @is @id @ss @ds lns + +makeCopy :: forall (as :: [VObj.O]) is id ss ds . CopyInfo as is id ss ds => + HeteroParList.PL VObj.Length ss -> HeteroParList.PL VObj.Length ds -> C.Copy +makeCopy src dst + | copyCheckLength @as @is @id src dst = C.Copy { + C.copySrcOffset = copySrcOffset @as @is @id @ss @ds 0 src, + C.copyDstOffset = copyDstOffset @as @is @id @ss @ds 0 dst, + C.copySize = copySize @as @is @id @ss @ds src } + | otherwise = error "List lengths are different" + +class MakeCopies (cpss :: [([VObj.O], Nat, Nat)]) (ss :: [VObj.O]) (ds :: [VObj.O]) where + makeCopies :: + HeteroParList.PL VObj.Length ss -> + HeteroParList.PL VObj.Length ds -> [C.Copy] + +instance MakeCopies '[] ss ds where makeCopies _ _ = [] + +instance (CopyInfo as is id ss ds, MakeCopies ass ss ds) => + MakeCopies ('(as, is, id) ': ass) ss ds where + makeCopies src dst = makeCopy @as @is @id src dst : makeCopies @ass src dst + +{- +offsetSize :: forall v vs . ( + VObj.OffsetRange v vs, VObj.SizeAlignment v, + VObj.LengthOf v vs ) => + HeteroParList.PL VObj.Length vs -> + Device.M.Size -> (Device.M.Size, Device.M.Size) +offsetSize lns _ = (VObj.offsetNew @v lns, sizeNew @v lns) + +sizeNew :: forall v vs . ( + VObj.SizeAlignment v, VObj.LengthOf v vs ) => + HeteroParList.PL VObj.Length vs -> Device.M.Size +sizeNew = fromIntegral . VObj.size . VObj.objectLengthOf @v +-} + +data MemoryBarrier mn sm sb nm obj = forall objs . ( + VObj.OffsetRange obj objs 0, VObj.LengthOf obj objs ) => + MemoryBarrier { + memoryBarrierNext :: TMaybe.M mn, + memoryBarrierSrcAccessMask :: AccessFlags, + memoryBarrierDstAccessMask :: AccessFlags, + memoryBarrierSrcQueueFamilyIndex :: QueueFamily.Index, + memoryBarrierDstQueueFamilyIndex :: QueueFamily.Index, + memoryBarrierBuffer :: Binded sm sb nm objs } + +memoryBarrierToMiddle :: forall n sm sb nm obj . + MemoryBarrier n sm sb nm obj -> M.MemoryBarrier n +memoryBarrierToMiddle MemoryBarrier { + memoryBarrierNext = mnxt, + memoryBarrierSrcAccessMask = sam, + memoryBarrierDstAccessMask = dam, + memoryBarrierSrcQueueFamilyIndex = sqfi, + memoryBarrierDstQueueFamilyIndex = dqfi, + memoryBarrierBuffer = Binded lns b :: Binded sm sb nm objs } = + M.MemoryBarrier { + M.memoryBarrierNext = mnxt, + M.memoryBarrierSrcAccessMask = sam, + M.memoryBarrierDstAccessMask = dam, + M.memoryBarrierSrcQueueFamilyIndex = sqfi, + M.memoryBarrierDstQueueFamilyIndex = dqfi, + M.memoryBarrierBuffer = b, + M.memoryBarrierOffset = ost, + M.memoryBarrierSize = sz } + where (ost, sz) = VObj.offsetRange @obj @_ @0 0 lns + +class MemoryBarrierListToMiddle nsmsbnmobjs where + memoryBarrierListToMiddle :: + HeteroParList.PL (U5 MemoryBarrier) nsmsbnmobjs -> + HeteroParList.PL M.MemoryBarrier (TMapIndex.M0_5 nsmsbnmobjs) + +instance MemoryBarrierListToMiddle '[] where + memoryBarrierListToMiddle HeteroParList.Nil = HeteroParList.Nil + +instance MemoryBarrierListToMiddle nsmsbnmobjs => + MemoryBarrierListToMiddle ('(mn, sm, sb, nm, obj) ': nsmsbnmobjs) where + memoryBarrierListToMiddle (U5 mb :** mbs) = + memoryBarrierToMiddle mb :** memoryBarrierListToMiddle mbs + +data ImageCopy img inm = ImageCopy { + imageCopyImageSubresource :: Image.M.SubresourceLayers, + imageCopyImageOffset :: C.Offset3d, + imageCopyImageExtent :: C.Extent3d } + deriving Show + +class ImageCopyListToMiddle algn objs (img :: Type) (inms :: [Symbol]) where + imageCopyListToMiddle :: + Binded sm sb nm objs -> + HeteroParList.PL (ImageCopy img) inms -> + [M.ImageCopy] + +instance ImageCopyListToMiddle algn objs img '[] where + imageCopyListToMiddle _ HeteroParList.Nil = [] + +instance ( + VObj.OffsetRange (VObj.Image algn img nm) objs 0, + VObj.LengthOf (VObj.Image algn img nm) objs, + ImageCopyListToMiddle algn objs img nms ) => + ImageCopyListToMiddle algn objs img (nm ': nms) where + imageCopyListToMiddle bf (ic :** ics) = + imageCopyToMiddle @algn @_ @nm bf (ic :: ImageCopy img nm) : + imageCopyListToMiddle @algn bf ics + +imageCopyToMiddle :: forall algn img inm sm sb nm obj objs . ( + obj ~ VObj.Image algn img inm, + VObj.OffsetRange obj objs 0, VObj.LengthOf obj objs ) => + Binded sm sb nm objs -> ImageCopy img inm -> M.ImageCopy +imageCopyToMiddle (Binded lns _) ImageCopy { + imageCopyImageSubresource = isr, + imageCopyImageOffset = iost, + imageCopyImageExtent = iext } = M.ImageCopy { + M.imageCopyBufferOffset = ost, + M.imageCopyBufferRowLength = fromIntegral r, + M.imageCopyBufferImageHeight = fromIntegral h, + M.imageCopyImageSubresource = isr, + M.imageCopyImageOffset = iost, + M.imageCopyImageExtent = iext } + where + (ost, _) = VObj.offsetRange @(VObj.Image algn img inm) @_ @0 0 lns + VObj.LengthImage r _w h _d = VObj.lengthOf @obj lns diff --git a/src/Gpu/Vulkan/Buffer/Type.hs b/src/Gpu/Vulkan/Buffer/Type.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Buffer/Type.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE FlexibleContexts, UndecidableInstances #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Buffer.Type where + +import GHC.TypeLits +import Data.Kind +import Data.HeteroParList qualified as HeteroParList + +import Gpu.Vulkan.Object qualified as VObj +import Gpu.Vulkan.Buffer.Middle qualified as M + +data B s (nm :: Symbol) (objs :: [VObj.O]) = + B (HeteroParList.PL VObj.Length objs) M.B + +deriving instance Show (HeteroParList.PL VObj.Length objs) => + Show (B s nm objs) + +deriving instance Eq (HeteroParList.PL VObj.Length objs) => + Eq (B s nm objs) + +data Binded (sm :: Type) (sb :: Type) (nm :: Symbol) (objs :: [VObj.O]) = + Binded (HeteroParList.PL VObj.Length objs) M.B + +lengthBinded :: Binded sm sb nm objs -> HeteroParList.PL VObj.Length objs +lengthBinded (Binded ln _) = ln + +deriving instance Show (HeteroParList.PL VObj.Length objs) => + Show (Binded sm sb nm objs) + +deriving instance Eq (HeteroParList.PL VObj.Length objs) => + Eq (Binded sm sb nm objs) diff --git a/src/Gpu/Vulkan/BufferView.hs b/src/Gpu/Vulkan/BufferView.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/BufferView.hs @@ -0,0 +1,15 @@ +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.BufferView ( + + -- * CREATE + + create, B, CreateInfo(..), FormatOf, + + -- ** Buffer View Group + Group, group, create', unsafeDestroy, lookup + + ) where + +import Prelude hiding (lookup) +import Gpu.Vulkan.BufferView.Internal diff --git a/src/Gpu/Vulkan/BufferView/Internal.hs b/src/Gpu/Vulkan/BufferView/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/BufferView/Internal.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE ScopedTypeVariables, RankNTypes, TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures, TypeOperators #-} +{-# LANGUAGE MultiParamTypeClasses, AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts, FlexibleInstances #-} +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.BufferView.Internal ( + + -- * CREATE + + create, B(..), CreateInfo(..), FormatOf, + + -- ** Buffer View Group + Group, group, create', unsafeDestroy, lookup + + ) where + +import Prelude hiding (lookup) + +import GHC.TypeLits +import Foreign.Storable.PeekPoke +import Control.Concurrent.STM +import Control.Concurrent.STM.TSem +import Control.Exception +import Data.TypeLevel.Tuple.Uncurry +import Data.TypeLevel.Maybe qualified as TMaybe +import Data.TypeLevel.ParMaybe qualified as TPMaybe +import Data.Map qualified as Map +import Data.HeteroParList qualified as HeteroParList +import Gpu.Vulkan.Object qualified as VObj + +import Gpu.Vulkan.AllocationCallbacks qualified as AllocationCallbacks +import Gpu.Vulkan.AllocationCallbacks.Type qualified as AllocationCallbacks +import Gpu.Vulkan.Device qualified as Device +import Gpu.Vulkan.Device.Type qualified as Device +import Gpu.Vulkan.Device.Middle qualified as Device.M +import Gpu.Vulkan.TypeEnum qualified as TEnum +import Gpu.Vulkan.Buffer.Type qualified as Buffer +import Gpu.Vulkan.BufferView.Middle qualified as M + +newtype B s (nm :: Symbol) t = B M.B deriving Show + +create :: ( + WithPoked (TMaybe.M mn), + TEnum.FormatToValue (FormatOf t), + VObj.OffsetOfList t nm objs, + AllocationCallbacks.ToMiddle mscc ) => + Device.D sd -> CreateInfo mn t nm '(sm, sb, bnm, objs) -> + TPMaybe.M (U2 AllocationCallbacks.A) mscc -> + (forall s . B s nm t -> IO a) -> IO a +create (Device.D dvc) ci + (AllocationCallbacks.toMiddle -> macc) f = bracket + (M.create dvc (createInfoToMiddle ci) macc) + (\b -> M.destroy dvc b macc) (f . B) + +data CreateInfo mn t (nm :: Symbol) snmobjs = CreateInfo { + createInfoNext :: TMaybe.M mn, + createInfoFlags :: M.CreateFlags, + createInfoBuffer :: U4 Buffer.Binded snmobjs } + +createInfoToMiddle :: forall n t nm sm sb bnm objs . ( + TEnum.FormatToValue (FormatOf t), + VObj.OffsetOfList t nm objs ) => + CreateInfo n t nm '(sm, sb, bnm, objs) -> M.CreateInfo n +createInfoToMiddle CreateInfo { + createInfoNext = mnxt, + createInfoFlags = flgs, + createInfoBuffer = U4 (Buffer.Binded lns b) } = M.CreateInfo { + M.createInfoNext = mnxt, + M.createInfoFlags = flgs, + M.createInfoBuffer = b, + M.createInfoFormat = TEnum.formatToValue @(FormatOf t), + M.createInfoOffset = ost, M.createInfoRange = rng } + where + (ost, rng) = offsetRange @t @nm lns + +type family FormatOf t :: TEnum.Format + +offsetRange :: forall t nm objs . + VObj.OffsetOfList t nm objs => + HeteroParList.PL VObj.Length objs -> (Device.M.Size, Device.M.Size) +offsetRange = VObj.offsetOfList @t @nm + +group :: AllocationCallbacks.ToMiddle ma => + Device.D sd -> TPMaybe.M (U2 AllocationCallbacks.A) ma -> + (forall s . Group ma s k nm t -> IO a) -> IO a +group (Device.D mdvc) mac@(AllocationCallbacks.toMiddle -> mmac) f = do + (sem, m) <- atomically $ (,) <$> newTSem 1 <*> newTVar Map.empty + rtn <- f $ Group mac sem m + ((\(B mb) -> M.destroy mdvc mb mmac) `mapM_`) + =<< atomically (readTVar m) + pure rtn + +data Group ma s k nm t = Group + (TPMaybe.M (U2 AllocationCallbacks.A) ma) + TSem (TVar (Map.Map k (B s nm t))) + +create' :: ( + Ord k, + WithPoked (TMaybe.M mn), + TEnum.FormatToValue (FormatOf t), + VObj.OffsetOfList t nm objs, + AllocationCallbacks.ToMiddle mscc ) => + Device.D sd -> Group mscc s k nm t -> k -> + CreateInfo mn t nm '(sm, sb, bnm, objs) -> IO (Either String (B s nm t)) +create' (Device.D dvc) + (Group (AllocationCallbacks.toMiddle -> mac) sem bs) k ci = do + ok <- atomically do + mx <- (Map.lookup k) <$> readTVar bs + case mx of + Nothing -> waitTSem sem >> pure True + Just _ -> pure False + if ok + then do b <- M.create dvc (createInfoToMiddle ci) mac + let b' = B b + atomically $ modifyTVar bs (Map.insert k b') >> signalTSem sem + pure $ Right b' + else pure . Left $ "Gpu.Vulkan.BufferView.create': The key already exist" + +unsafeDestroy :: (Ord k, AllocationCallbacks.ToMiddle ma) => + Device.D sd -> Group ma sg k nm t -> k -> IO (Either String ()) +unsafeDestroy (Device.D mdvc) + (Group (AllocationCallbacks.toMiddle -> ma) sem bs) k = do + mb <- atomically do + mx <- Map.lookup k <$> readTVar bs + case mx of + Nothing -> pure Nothing + Just _ -> waitTSem sem >> pure mx + case mb of + Nothing -> pure $ Left "Gp[u.Vulkan.BufferView.unsafeDestroy: No such key" + Just (B b) -> do + M.destroy mdvc b ma + atomically do + modifyTVar bs (Map.delete k) + signalTSem sem + pure $ Right () + +lookup :: Ord k => Group md sg k nm t -> k -> IO (Maybe (B sg nm t)) +lookup (Group _ _sem bs) k = atomically $ Map.lookup k <$> readTVar bs diff --git a/src/Gpu/Vulkan/Cmd.hs b/src/Gpu/Vulkan/Cmd.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Cmd.hs @@ -0,0 +1,338 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE ScopedTypeVariables, RankNTypes, TypeApplications #-} +{-# LANGUAGE GADTs, TypeFamilies #-} +{-# LANGUAGE DataKinds, PolyKinds #-} +{-# LANGUAGE KindSignatures, TypeOperators #-} +{-# LANGUAGE MultiParamTypeClasses, AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-} +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} +{-# LANGUAGe StandaloneDeriving #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Cmd ( + +-- * BEGIN RENDER PASS + +beginRenderPass, + +-- * DRAW AND DISPATCH + +-- ** Draw + +bindPipelineGraphics, +bindVertexBuffers, bindIndexBuffer, IsIndex, +draw, drawIndexed, +VertexCount, IndexCount, InstanceCount, +FirstVertex, FirstIndex, FirstInstance, +VertexOffset, + +-- ** Dispatch + +bindPipelineCompute, dispatch, GroupCountX, GroupCountY, GroupCountZ, + +-- * PUSH CONSTANTS AND BIND DESCRIPTOR SETS + +pushConstantsGraphics, pushConstantsCompute, +bindDescriptorSetsGraphics, bindDescriptorSetsCompute, +DynamicIndex(..), GetDynamicLength, + +-- * COPY BUFFER AND IMAGES + +copyBuffer, copyBufferToImage, copyImageToBuffer, blitImage, + +-- * MEMORY DEPENDENCY + +pipelineBarrier, + +-- * QUERY + +resetQueryPool, +beginQuery, +writeTimestamp, + +-- * OTHERS + +LayoutArgListOnlyDynamics + +) where + +import GHC.TypeNats +import Foreign.Storable.PeekPoke +import Foreign.Storable.HeteroList +import Control.Exception +import Data.TypeLevel.Maybe qualified as TMaybe +import Data.TypeLevel.List +import Data.TypeLevel.Tuple.Uncurry +import Data.TypeLevel.Tuple.Index qualified as TIndex +import Data.TypeLevel.Tuple.MapIndex qualified as TMapIndex +import qualified Data.HeteroParList as HeteroParList +import Data.HeteroParList (pattern (:**)) +import Data.Word +import Data.Int + +import Gpu.Vulkan +import Gpu.Vulkan.TypeEnum qualified as T + +import qualified Gpu.Vulkan.CommandBuffer as CommandBuffer +import qualified Gpu.Vulkan.CommandBuffer.Type as CommandBuffer.T +import qualified Gpu.Vulkan.Pipeline.Graphics.Type as Pipeline +import qualified Gpu.Vulkan.Pipeline.Compute as Pipeline.Compute +import qualified Gpu.Vulkan.Pipeline.Enum as Pipeline +import qualified Gpu.Vulkan.PipelineLayout.Type as PipelineLayout +import qualified Gpu.Vulkan.DescriptorSet as DescriptorSet +import qualified Gpu.Vulkan.DescriptorSet.Type as DescriptorSet +import qualified Gpu.Vulkan.DescriptorSetLayout.Type as Layout +import qualified Gpu.Vulkan.Buffer.Type as Bffr +import qualified Gpu.Vulkan.Buffer as Bffr +import qualified Gpu.Vulkan.Buffer.Internal as Bffr.I +import qualified Gpu.Vulkan.Image as Image +import qualified Gpu.Vulkan.Image.Internal as Image.I +import qualified Gpu.Vulkan.Image.Type as Image +import qualified Gpu.Vulkan.Image.Middle as Image.M + +import qualified Gpu.Vulkan.RenderPass.Internal as RenderPass +import qualified Gpu.Vulkan.Subpass.Enum as Subpass +import qualified Gpu.Vulkan.Cmd.Middle as M + +import qualified Gpu.Vulkan.Memory as Memory + +import Data.IORef -- for debug + +import Gpu.Vulkan.Query.Enum qualified as Query +import Gpu.Vulkan.QueryPool qualified as QueryPool +import Gpu.Vulkan.QueryPool.Type qualified as QueryPool +import Gpu.Vulkan.Query qualified as Query +import Gpu.Vulkan.Object.Base qualified as KObj + +beginRenderPass :: (WithPoked (TMaybe.M mn), ClearValueListToCore cts) => + CommandBuffer.C scb -> RenderPass.BeginInfo mn sr sf cts -> + Subpass.Contents -> IO a -> IO a +beginRenderPass (CommandBuffer.T.C cb) bi cnt f = bracket_ + (M.beginRenderPass cb (RenderPass.beginInfoToMiddle bi) cnt) + (M.endRenderPass cb) f + +bindPipelineGraphics :: CommandBuffer.C scb -> + Pipeline.BindPoint -> Pipeline.G sg vibs vias slbtss -> + (forall sgb . CommandBuffer.GBinded sgb vibs slbtss -> IO a) -> IO a +bindPipelineGraphics (CommandBuffer.T.C c) bp (Pipeline.G g) f = + M.bindPipelineGraphics c bp g >> f (CommandBuffer.T.GBinded c) + +bindPipelineCompute :: CommandBuffer.C scmdb -> Pipeline.BindPoint -> + Pipeline.Compute.C scp slbtss -> + (forall scbnd . CommandBuffer.CBinded scbnd slbtss -> IO a) -> IO a +bindPipelineCompute (CommandBuffer.T.C cb) bp (Pipeline.Compute.C g) f = + M.bindPipelineCompute cb bp g >> f (CommandBuffer.T.CBinded cb) + +draw :: CommandBuffer.GBinded sc vibs slbtss -> + VertexCount -> InstanceCount -> FirstVertex -> FirstInstance -> IO () +draw (CommandBuffer.T.GBinded cb) vc ic fv fi = M.draw cb vc ic fv fi + +type VertexCount = Word32 +type InstanceCount = Word32 +type FirstVertex = Word32 +type FirstInstance = Word32 + +drawIndexed :: CommandBuffer.GBinded sc vibs slbtss -> + IndexCount -> InstanceCount -> + FirstIndex -> VertexOffset -> FirstInstance -> IO () +drawIndexed (CommandBuffer.T.GBinded cb) idxc istc fidx vo fist = + M.drawIndexed cb idxc istc fidx vo fist + +type IndexCount = Word32 +type FirstIndex = Word32 +type VertexOffset = Int32 + +dispatch :: CommandBuffer.CBinded sc slbtss -> + GroupCountX -> GroupCountY -> GroupCountZ -> IO () +dispatch (CommandBuffer.T.CBinded cb) = M.dispatch cb + +type GroupCountX = Word32 +type GroupCountY = Word32 +type GroupCountZ = Word32 + +bindDescriptorSetsGraphics :: forall sgbnd vibs sl dsls pcs dss dsls' dyns . ( + TMapIndex.M1_2 dss ~ dsls', + LayoutArgListOnlyDynamics dsls' ~ dyns, + InfixIndex dsls' dsls, GetDynamicLength dss, + HeteroParList.ZipListWithC3 KObj.SizeAlignment dyns ) => + CommandBuffer.GBinded sgbnd vibs '(sl, dsls, pcs) -> + Pipeline.BindPoint -> PipelineLayout.P sl dsls pcs -> + HeteroParList.PL (U2 DescriptorSet.D) dss -> + HeteroParList.PL3 DynamicIndex dyns -> IO () +bindDescriptorSetsGraphics + (CommandBuffer.T.GBinded c) bp (PipelineLayout.P l) dss idxs = do + lns <- getDynamicLength dss + let dosts = concat $ concat <$> getOffsetListNew lns idxs + M.bindDescriptorSets c bp l + (fromIntegral $ infixIndex @_ @dsls' @dsls) + (HeteroParList.toList + (\(U2 (DescriptorSet.D _ s)) -> s) + dss) + dosts + +bindDescriptorSetsCompute :: forall scbnd sl dsls pcs dss dsls' dyns . ( + TMapIndex.M1_2 dss ~ dsls', + LayoutArgListOnlyDynamics dsls' ~ dyns, + InfixIndex dsls' dsls, GetDynamicLength dss, + HeteroParList.ZipListWithC3 KObj.SizeAlignment dyns ) => + CommandBuffer.CBinded scbnd '(sl, dsls, pcs) -> + PipelineLayout.P sl dsls pcs -> + HeteroParList.PL (U2 DescriptorSet.D) dss -> + HeteroParList.PL3 DynamicIndex dyns -> IO () +bindDescriptorSetsCompute + (CommandBuffer.T.CBinded c) (PipelineLayout.P l) dss idxs = do + lns <- getDynamicLength dss + let dosts = concat $ concat <$> getOffsetListNew lns idxs + M.bindDescriptorSets c Pipeline.BindPointCompute l + (fromIntegral $ infixIndex @_ @dsls' @dsls) + (HeteroParList.toList (\(U2 (DescriptorSet.D _ s)) -> s) + dss) + dosts + +newtype DynamicIndex (obj :: KObj.O) = DynamicIndex Word32 deriving Show +newtype DynamicOffset (obj :: KObj.O) = DynamicOffset Word32 deriving Show + +getOffset' :: forall obj . KObj.SizeAlignment obj => + KObj.Length obj -> DynamicIndex obj -> Word32 +getOffset' ln (DynamicIndex i) = fromIntegral sz * i + where + sz = ((KObj.size ln - 1) `div` algn + 1) * algn + algn = KObj.alignment @obj + +getOffsetListNew :: HeteroParList.ZipListWithC3 KObj.SizeAlignment osss => + HeteroParList.PL3 KObj.Length osss -> + HeteroParList.PL3 DynamicIndex osss -> [[[Word32]]] +getOffsetListNew = HeteroParList.zipListWithC3 @KObj.SizeAlignment getOffset' + +class GetDynamicLength sspslbtss where + getDynamicLength :: + HeteroParList.PL (U2 DescriptorSet.D) sspslbtss -> + IO (HeteroParList.PL3 KObj.Length + (LayoutArgListOnlyDynamics (TMapIndex.M1_2 sspslbtss))) + +type family LayoutArgListOnlyDynamics las where + LayoutArgListOnlyDynamics '[] = '[] + LayoutArgListOnlyDynamics (la ': las) = + Layout.BindingTypeListBufferOnlyDynamics (TIndex.I1_2 la) ': + LayoutArgListOnlyDynamics las + +instance GetDynamicLength '[] where + getDynamicLength HeteroParList.Nil = pure HeteroParList.Nil + +instance GetDynamicLength spslbtss => + GetDynamicLength (slbts ': spslbtss) where + getDynamicLength (U2 ds :** dss) = + (:**) <$> getDscSetLengthsNew ds <*> getDynamicLength dss + +getDscSetLengthsNew :: DescriptorSet.D s slbts -> + IO (HeteroParList.PL2 KObj.Length + (Layout.BindingTypeListBufferOnlyDynamics (TIndex.I1_2 slbts))) +getDscSetLengthsNew (DescriptorSet.D lns _) = readIORef lns + +bindVertexBuffers :: forall sg vibs slbtss smsbnmts . + InfixIndex (TMapIndex.M3_5 smsbnmts) (TMapIndex.M0_2 vibs) => + CommandBuffer.GBinded sg vibs slbtss -> + HeteroParList.PL (U5 Bffr.IndexedForList) smsbnmts -> IO () +bindVertexBuffers (CommandBuffer.T.GBinded cb) bils = M.bindVertexBuffers + cb (fromIntegral fb) (Bffr.I.indexedListToMiddles bils) + where fb = infixIndex @_ @(TMapIndex.M3_5 smsbnmts) @(TMapIndex.M0_2 vibs) + +bindIndexBuffer :: forall sg vibs slbtss sm sb nm i onm . IsIndex i => + CommandBuffer.GBinded sg vibs slbtss -> + Bffr.IndexedForList sm sb nm i onm -> IO () +bindIndexBuffer (CommandBuffer.T.GBinded cb) ib = + uncurry (M.bindIndexBuffer cb) (Bffr.I.indexedListToMiddle ib) (indexType @i) + +class IsIndex a where indexType :: IndexType +instance IsIndex Word16 where indexType = IndexTypeUint16 +instance IsIndex Word32 where indexType = IndexTypeUint32 + +copyBuffer :: forall cpobjss scb sms sbs nms objss smd sbd nmd objsd . + Bffr.MakeCopies cpobjss objss objsd => CommandBuffer.C scb -> + Bffr.Binded sms sbs nms objss -> Bffr.Binded smd sbd nmd objsd -> IO () +copyBuffer (CommandBuffer.T.C cb) (Bffr.Binded lnss s) (Bffr.Binded lnsd d) = + M.copyBuffer cb s d (Bffr.I.makeCopies @cpobjss lnss lnsd) + +pushConstantsGraphics :: forall sss sc vibs sl sbtss pcs ts . ( + T.ShaderStageFlagBitsListToValue sss, + PokableList ts, InfixOffsetSize ts pcs ) => + CommandBuffer.GBinded sc vibs '(sl, sbtss, pcs) -> + PipelineLayout.P sl sbtss pcs -> HeteroParList.L ts -> IO () +pushConstantsGraphics (CommandBuffer.T.GBinded cb) (PipelineLayout.P lyt) xs = + M.pushConstants + cb lyt (T.shaderStageFlagBitsListToValue @sss) offt xs + where (fromIntegral -> offt, _) = infixOffsetSize @ts @pcs + +pushConstantsCompute :: forall sss sc sl sbtss pcs ts . ( + T.ShaderStageFlagBitsListToValue sss, + PokableList ts, InfixOffsetSize ts pcs ) => + CommandBuffer.CBinded sc '(sl, sbtss, pcs) -> + PipelineLayout.P sl sbtss pcs -> HeteroParList.L ts -> IO () +pushConstantsCompute (CommandBuffer.T.CBinded cb) (PipelineLayout.P lyt) xs = + M.pushConstants + cb lyt (T.shaderStageFlagBitsListToValue @sss) offt xs + where (fromIntegral -> offt, _) = infixOffsetSize @ts @pcs + +pipelineBarrier :: ( + HeteroParList.ToListWithCCpsM' WithPoked TMaybe.M mbargs, + HeteroParList.ToListWithCCpsM' WithPoked TMaybe.M + (TMapIndex.M0_5 bmbargss), + HeteroParList.ToListWithCCpsM' WithPoked TMaybe.M + (TMapIndex.M0_5 imbargss), + Bffr.MemoryBarrierListToMiddle bmbargss, + Image.MemoryBarrierListToMiddle imbargss ) => + CommandBuffer.C scb -> Pipeline.StageFlags -> Pipeline.StageFlags -> + DependencyFlags -> HeteroParList.PL Memory.Barrier mbargs -> + HeteroParList.PL (U5 Bffr.MemoryBarrier) bmbargss -> + HeteroParList.PL (U5 Image.MemoryBarrier) imbargss -> IO () +pipelineBarrier (CommandBuffer.T.C cb) ssm dsm dfs mbs bmbs imbs = + M.pipelineBarrier cb ssm dsm dfs mbs + (Bffr.I.memoryBarrierListToMiddle bmbs) + (Image.I.memoryBarrierListToMiddle imbs) + +copyBufferToImage :: + forall (algn :: Nat) img inms scb smb sbb bnm objs smi si inm . + (Bffr.ImageCopyListToMiddle algn objs img inms) => + CommandBuffer.C scb -> Bffr.Binded smb sbb bnm objs -> + Image.Binded smi si inm (KObj.ImageFormat img) -> Image.Layout -> + HeteroParList.PL (Bffr.ImageCopy img) inms -> IO () +copyBufferToImage (CommandBuffer.T.C cb) + bf@(Bffr.Binded _ mbf) (Image.Binded mim) imlyt ics = + M.copyBufferToImage cb mbf mim imlyt mics + where mics = Bffr.I.imageCopyListToMiddle @algn bf ics + +copyImageToBuffer :: + forall (algn :: Nat) img inms scb smi si inm smb sbb bnm objs . + (Bffr.ImageCopyListToMiddle algn objs img inms) => + CommandBuffer.C scb -> + Image.Binded smi si inm (KObj.ImageFormat img) -> Image.Layout -> + Bffr.Binded smb sbb bnm objs -> + HeteroParList.PL (Bffr.ImageCopy img) inms -> IO () +copyImageToBuffer (CommandBuffer.T.C cb) + (Image.Binded mim) imlyt bf@(Bffr.Binded _ mbf) ics = + M.copyImageToBuffer cb mim imlyt mbf mics + where mics = Bffr.I.imageCopyListToMiddle @algn bf ics + +blitImage :: CommandBuffer.C scb -> + Image.Binded sms sis nms fmts -> Image.Layout -> + Image.Binded smd sid nmd fmtd -> Image.Layout -> + [Image.M.Blit] -> Filter -> IO () +blitImage (CommandBuffer.T.C cb) + (Image.Binded src) slyt (Image.Binded dst) dlyt blts fltr = + M.blitImage cb src slyt dst dlyt blts fltr + +resetQueryPool :: CommandBuffer.C sc -> + QueryPool.Q sq tp -> Query.First -> Query.Count -> IO () +resetQueryPool (CommandBuffer.T.C cb) (QueryPool.Q qp) fq qc = + M.resetQueryPool cb qp fq qc + +beginQuery :: CommandBuffer.C sc -> + QueryPool.Q sq tp -> Query.Q -> Query.ControlFlags -> IO a -> IO () +beginQuery (CommandBuffer.T.C cb) (QueryPool.Q qp) i flgs act = + M.beginQuery cb qp i flgs >> act >> M.endQuery cb qp i + +writeTimestamp :: CommandBuffer.C sc -> Pipeline.StageFlagBits -> + QueryPool.Q sq QueryPool.Timestamp -> Query.Q -> IO () +writeTimestamp (CommandBuffer.T.C cb) sflgs (QueryPool.Q qp) i = + M.writeTimestamp cb sflgs qp i diff --git a/src/Gpu/Vulkan/ColorComponent.hs b/src/Gpu/Vulkan/ColorComponent.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/ColorComponent.hs @@ -0,0 +1,5 @@ +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.ColorComponent (module Gpu.Vulkan.ColorComponent.Enum) where + +import Gpu.Vulkan.ColorComponent.Enum diff --git a/src/Gpu/Vulkan/ColorComponent/Enum.hs b/src/Gpu/Vulkan/ColorComponent/Enum.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/ColorComponent/Enum.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE PackageImports #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.ColorComponent.Enum ( + module Gpu.Vulkan.ColorComponent.Enum ) where + +import "gpu-vulkan-middle" Gpu.Vulkan.ColorComponent.Enum diff --git a/src/Gpu/Vulkan/CommandBuffer.hs b/src/Gpu/Vulkan/CommandBuffer.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/CommandBuffer.hs @@ -0,0 +1,109 @@ +{-# 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 ( + + -- * ALLOCATE + + C, GBinded, CBinded, + + -- ** Type Level List + + allocate, AllocateInfo(..), + + -- ** Value Level List + + allocateList, AllocateInfoList(..), + + -- * BEGIN AND RESET + + begin, reset, M.BeginInfo(..), M.InheritanceInfo(..), + + -- * 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.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 + +allocate :: ( + 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 +allocate (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/Enum.hs b/src/Gpu/Vulkan/CommandBuffer/Enum.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/CommandBuffer/Enum.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE PackageImports #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.CommandBuffer.Enum ( + module Gpu.Vulkan.CommandBuffer.Enum ) where + +import "gpu-vulkan-middle" Gpu.Vulkan.CommandBuffer.Enum diff --git a/src/Gpu/Vulkan/CommandBuffer/Type.hs b/src/Gpu/Vulkan/CommandBuffer/Type.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/CommandBuffer/Type.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.CommandBuffer.Type where + +import Data.Kind + +import Gpu.Vulkan.DescriptorSetLayout.Type qualified as DscStLyt +import Gpu.Vulkan.CommandBuffer.Middle qualified as M + +import Gpu.Vulkan.VertexInput qualified as VertexInput + +newtype C s = C { unC :: M.C } + +newtype GBinded s (vibs :: [(Type, VertexInput.Rate)]) + (largs :: (Type, [(Type, [DscStLyt.BindingType])], [Type])) = + GBinded { unGBinded :: M.C } + +newtype CBinded s + (largs :: (Type, [(Type, [DscStLyt.BindingType])], [Type])) = + CBinded { unCBinded :: M.C } diff --git a/src/Gpu/Vulkan/CommandPool.hs b/src/Gpu/Vulkan/CommandPool.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/CommandPool.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.CommandPool ( + + -- * CREATE + + create, reset, C, M.CreateInfo(..), + + -- * ENUM + + module Gpu.Vulkan.CommandPool.Enum + + ) where + +import Foreign.Storable.PeekPoke +import Control.Exception +import Data.TypeLevel.Maybe qualified as TMaybe +import Data.TypeLevel.ParMaybe qualified as TPMaybe +import Data.TypeLevel.Tuple.Uncurry + +import Gpu.Vulkan.CommandPool.Type + +import qualified Gpu.Vulkan.AllocationCallbacks as AllocationCallbacks +import qualified Gpu.Vulkan.AllocationCallbacks.Type as AllocationCallbacks +import qualified Gpu.Vulkan.Device.Type as Device +import qualified Gpu.Vulkan.CommandPool.Middle as M +import qualified Gpu.Vulkan.CommandPool.Enum as Enum +import Gpu.Vulkan.CommandPool.Enum + +create :: (WithPoked (TMaybe.M mn), AllocationCallbacks.ToMiddle ma) => + Device.D sd -> M.CreateInfo mn -> + TPMaybe.M (U2 AllocationCallbacks.A) ma -> + (forall s . C s -> IO a) -> IO a +create (Device.D dvc) ci + (AllocationCallbacks.toMiddle -> macc) f = + bracket (M.create dvc ci macc) (\c -> M.destroy dvc c macc) (f . C) + +reset :: Device.D sd -> C s -> Enum.ResetFlags -> IO () +reset (Device.D dv) (C c) fs = M.reset dv c fs diff --git a/src/Gpu/Vulkan/CommandPool/Enum.hs b/src/Gpu/Vulkan/CommandPool/Enum.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/CommandPool/Enum.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE PackageImports #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.CommandPool.Enum (module Gpu.Vulkan.CommandPool.Enum) where + +import "gpu-vulkan-middle" Gpu.Vulkan.CommandPool.Enum diff --git a/src/Gpu/Vulkan/CommandPool/Type.hs b/src/Gpu/Vulkan/CommandPool/Type.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/CommandPool/Type.hs @@ -0,0 +1,7 @@ +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.CommandPool.Type where + +import qualified Gpu.Vulkan.CommandPool.Middle as M + +newtype C s = C M.C deriving Show diff --git a/src/Gpu/Vulkan/Component.hs b/src/Gpu/Vulkan/Component.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Component.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Component ( + + -- * MAPPING + + Mapping(..), + + -- * ENUM + + module Gpu.Vulkan.Component.Enum + + ) where + +import Gpu.Vulkan.Component.Middle +import Gpu.Vulkan.Component.Enum diff --git a/src/Gpu/Vulkan/Component/Enum.hs b/src/Gpu/Vulkan/Component/Enum.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Component/Enum.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE PackageImports #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Component.Enum (module Gpu.Vulkan.Component.Enum) where + +import "gpu-vulkan-middle" Gpu.Vulkan.Component.Enum diff --git a/src/Gpu/Vulkan/Descriptor.hs b/src/Gpu/Vulkan/Descriptor.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Descriptor.hs @@ -0,0 +1,24 @@ +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Descriptor ( + + -- * EXTENSION NAME + + indexingExtensionName, + + -- * BUFFER INFO + + BufferInfo(..), + + -- * IMAGE INFO + + ImageInfo(..), ImageInfoNoSampler(..), + + -- * ENUM + + module Gpu.Vulkan.Descriptor.Enum + + ) where + +import Gpu.Vulkan.Descriptor.Internal +import Gpu.Vulkan.Descriptor.Enum diff --git a/src/Gpu/Vulkan/Descriptor/Enum.hs b/src/Gpu/Vulkan/Descriptor/Enum.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Descriptor/Enum.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE PackageImports #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Descriptor.Enum (module Gpu.Vulkan.Descriptor.Enum) where + +import "gpu-vulkan-middle" Gpu.Vulkan.Descriptor.Enum diff --git a/src/Gpu/Vulkan/Descriptor/Internal.hs b/src/Gpu/Vulkan/Descriptor/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Descriptor/Internal.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables, RankNTypes, TypeApplications #-} +{-# LANGUAGE GADTs, TypeFamilies #-} +{-# LANGUAGE DataKinds, PolyKinds #-} +{-# LANGUAGE KindSignatures, TypeOperators #-} +{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Descriptor.Internal ( + + -- * EXTENSION NAME + + indexingExtensionName, + + -- * BUFFER INFO + + BufferInfo(..), bufferInfoToMiddle, + + -- * IMAGE INFO + + ImageInfo(..), imageInfoToMiddle, + ImageInfoNoSampler(..), imageInfoNoSamplerToMiddle + + ) where + +import Gpu.Vulkan.Object qualified as VObj + +import qualified Gpu.Vulkan.Buffer as Buffer +import qualified Gpu.Vulkan.Buffer.Type as Buffer +import qualified Gpu.Vulkan.Descriptor.Middle as M + +import qualified Gpu.Vulkan.Sampler.Type as Sampler +import qualified Gpu.Vulkan.Image.Enum as Image +import qualified Gpu.Vulkan.ImageView as ImageView +import qualified Gpu.Vulkan.ImageView.Type as ImageView + +import Gpu.Vulkan.Sampler.Middle as Sampler.M + +import Gpu.Vulkan.PhysicalDevice qualified as PhysicalDevice + +indexingExtensionName :: PhysicalDevice.ExtensionName +indexingExtensionName = PhysicalDevice.ExtensionName M.indexingExtensionName + +data BufferInfo sm sb nm obj i = forall objs . + (Show (Buffer.Binded sm sb nm objs), VObj.OffsetRange obj objs i) => + BufferInfo (Buffer.Binded sm sb nm objs) + +deriving instance Show (BufferInfo sm sb nm obj i) + +bufferInfoToMiddle :: forall sb sm nm obj i . + BufferInfo sm sb nm obj i -> M.BufferInfo +bufferInfoToMiddle (BufferInfo (Buffer.Binded lns b)) = M.BufferInfo { + M.bufferInfoBuffer = b, + M.bufferInfoOffset = ost, + M.bufferInfoRange = rng } + where (ost, rng) = VObj.offsetRange @obj @_ @i 0 lns + +data ImageInfo ss fmt nm si = ImageInfo { + imageInfoSampler :: Sampler.S ss, + imageInfoImageView :: ImageView.I fmt nm si, + imageInfoImageLayout :: Image.Layout } + deriving Show + +imageInfoToMiddle :: + ImageInfo ss fmt nm si -> M.ImageInfo +imageInfoToMiddle ImageInfo { + imageInfoSampler = s, + imageInfoImageView = ImageView.I iv, + imageInfoImageLayout = lyt } = M.ImageInfo { + M.imageInfoSampler = Sampler.sToMiddle s, + M.imageInfoImageView = iv, + M.imageInfoImageLayout = lyt } + +data ImageInfoNoSampler fmt nm si = ImageInfoNoSampler { + imageInfoNoSamplerImageView :: ImageView.I fmt nm si, + imageInfoNoSamplerImageLayout :: Image.Layout } + deriving Show + +imageInfoNoSamplerToMiddle :: + ImageInfoNoSampler fmt nm si -> M.ImageInfo +imageInfoNoSamplerToMiddle ImageInfoNoSampler { + imageInfoNoSamplerImageView = ImageView.I iv, + imageInfoNoSamplerImageLayout = lyt } = M.ImageInfo { + M.imageInfoSampler = Sampler.M.Null, + M.imageInfoImageView = iv, + M.imageInfoImageLayout = lyt } diff --git a/src/Gpu/Vulkan/DescriptorPool.hs b/src/Gpu/Vulkan/DescriptorPool.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/DescriptorPool.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.DescriptorPool ( + + -- * CREATE + + create, P, M.CreateInfo(..), M.Size(..), + + -- * ENUM + + module Gpu.Vulkan.DescriptorPool.Enum + + ) where + +import Foreign.Storable.PeekPoke +import Control.Exception +import Data.TypeLevel.Maybe qualified as TMaybe +import Data.TypeLevel.ParMaybe qualified as TPMaybe +import Data.TypeLevel.Tuple.Uncurry + +import Gpu.Vulkan.DescriptorPool.Type +import Gpu.Vulkan.DescriptorPool.Enum + +import qualified Gpu.Vulkan.AllocationCallbacks as AllocationCallbacks +import qualified Gpu.Vulkan.AllocationCallbacks.Type as AllocationCallbacks +import qualified Gpu.Vulkan.Device.Type as Device +import qualified Gpu.Vulkan.DescriptorPool.Middle as M + +create :: (WithPoked (TMaybe.M mn), AllocationCallbacks.ToMiddle mac) => + Device.D sd -> M.CreateInfo mn -> + TPMaybe.M (U2 AllocationCallbacks.A) mac -> + (forall s . P s -> IO a) -> IO a +create (Device.D dvc) ci + (AllocationCallbacks.toMiddle -> macc) f = + bracket (M.create dvc ci macc) (\p -> M.destroy dvc p macc) (f . P) diff --git a/src/Gpu/Vulkan/DescriptorPool/Enum.hs b/src/Gpu/Vulkan/DescriptorPool/Enum.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/DescriptorPool/Enum.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE PackageImports #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.DescriptorPool.Enum ( + module Gpu.Vulkan.DescriptorPool.Enum ) where + +import "gpu-vulkan-middle" Gpu.Vulkan.DescriptorPool.Enum diff --git a/src/Gpu/Vulkan/DescriptorPool/Type.hs b/src/Gpu/Vulkan/DescriptorPool/Type.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/DescriptorPool/Type.hs @@ -0,0 +1,5 @@ +module Gpu.Vulkan.DescriptorPool.Type where + +import qualified Gpu.Vulkan.DescriptorPool.Middle as M + +newtype P s = P M.D deriving Show diff --git a/src/Gpu/Vulkan/DescriptorSet.hs b/src/Gpu/Vulkan/DescriptorSet.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/DescriptorSet.hs @@ -0,0 +1,198 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE BlockArguments, LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables, RankNTypes, TypeApplications #-} +{-# LANGUAGE GADTs, TypeFamilies #-} +{-# LANGUAGE DataKinds, ConstraintKinds #-} +{-# LANGUAGE KindSignatures, TypeOperators #-} +{-# LANGUAGE MultiParamTypeClasses, AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-} +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.DescriptorSet ( + + -- * ALLOCATE + + allocateDs, D, AllocateInfo(..), DListFromMiddle, DefaultDynamicLengths, + + -- ** Descriptor Set Group + + Group, group, allocateDs', unsafeFreeDs, lookup, + + -- * UPDATE + + updateDs, + + -- ** Write + + W.Write(..), W.WriteListToMiddle, + W.WriteListUpdateDynamicLengths, W.UpdateDynamicLength, + W.WriteSources(..), W.WriteSourcesArg(..), + W.WriteSourcesToMiddle, + + -- ** Copy + + Copy(..), CopyListToMiddle, + + -- ** BindingAndArrayElem + + BindingAndArrayElem, W.BindingAndArrayElemImage, + W.BindingAndArrayElemImageWithImmutableSampler, + W.BindingAndArrayElemBuffer, W.BindingAndArrayElemBufferView + + ) where + +import Prelude hiding (lookup) + +import Foreign.Storable.PeekPoke +import Data.Default +import Data.TypeLevel.Maybe qualified as TMaybe +import Data.TypeLevel.Tuple.Uncurry +import Data.TypeLevel.Tuple.Index qualified as TIndex +import qualified Data.HeteroParList as HeteroParList +import Data.HeteroParList (pattern (:**)) + +import Gpu.Vulkan.DescriptorSet.Type + +import qualified Gpu.Vulkan.Device.Type as Device +import qualified Gpu.Vulkan.DescriptorPool.Type as Descriptor.Pool +import qualified Gpu.Vulkan.DescriptorSetLayout.Type as Layout +import qualified Gpu.Vulkan.DescriptorSetLayout.Middle as Layout.M +import qualified Gpu.Vulkan.DescriptorSet.Write as W +import qualified Gpu.Vulkan.DescriptorSet.Middle as M + +import Gpu.Vulkan.DescriptorSet.Copy + +import Gpu.Vulkan.Object.Base qualified as KObj + +import Control.Concurrent.STM +import Control.Concurrent.STM.TSem +import Data.Map qualified as Map + +import Data.IORef.ToolsYj + +import Data.TypeLevel.Tuple.MapIndex qualified + +import Control.Monad +import Debug + +layoutToMiddle :: U2 Layout.D slbts -> Layout.M.D +layoutToMiddle (U2 (Layout.D l)) = l + +data AllocateInfo mn sp slbtss = AllocateInfo { + allocateInfoNext :: TMaybe.M mn, + allocateInfoDescriptorPool :: Descriptor.Pool.P sp, + allocateInfoSetLayouts :: HeteroParList.PL (U2 Layout.D) slbtss } + +deriving instance (Show (TMaybe.M n), Show (HeteroParList.PL (U2 Layout.D) slbtss)) => + Show (AllocateInfo n sp slbtss) + +allocateInfoToMiddle :: AllocateInfo n sp slbtss -> M.AllocateInfo n +allocateInfoToMiddle AllocateInfo { + allocateInfoNext = mnxt, + allocateInfoDescriptorPool = Descriptor.Pool.P dp, + allocateInfoSetLayouts = dscsls + } = M.AllocateInfo { + M.allocateInfoNext = mnxt, + M.allocateInfoDescriptorPool = dp, + M.allocateInfoSetLayouts = + HeteroParList.toList layoutToMiddle dscsls } + +class DListFromMiddle slbtss where + dListFromMiddle :: [M.D] -> IO (HeteroParList.PL (D s) slbtss) + +instance DListFromMiddle '[] where + dListFromMiddle = \case [] -> pure HeteroParList.Nil; _ -> error "bad" + +instance ( + DefaultDynamicLengths slbts, + DListFromMiddle slbtss ) => + DListFromMiddle (slbts ': slbtss) where + dListFromMiddle = \case + (d : ds) -> (:**) + <$> ((`D` d) <$> newDefaultIORef) + <*> dListFromMiddle @slbtss ds + _ -> error "bad" + +type DefaultDynamicLengths slbts = Default + (HeteroParList.PL + (HeteroParList.PL KObj.Length) + (Layout.BindingTypeListBufferOnlyDynamics (TIndex.I1_2 slbts))) + +allocateDs :: (WithPoked (TMaybe.M mn), DListFromMiddle slbtss) => + Device.D sd -> AllocateInfo mn sp slbtss -> + (forall s . HeteroParList.PL (D s) slbtss -> IO a) -> IO a +allocateDs (Device.D dvc) ai f = do + dsm <- M.allocateDs dvc (allocateInfoToMiddle ai) + ds <- dListFromMiddle dsm + f ds <* M.freeDs dvc + ((\(Descriptor.Pool.P p) -> p) $ allocateInfoDescriptorPool ai) + dsm + +data Group sd s k sp slbtss = Group (Device.D sd) TSem + (TVar (Map.Map k (Descriptor.Pool.P sp, HeteroParList.PL (D s) slbtss))) + +group :: Device.D sd -> (forall s . Group sd s k sp slbtss -> IO a) -> IO a +group dv@(Device.D mdvc) f = do + (sem, dsss) <- atomically $ (,) <$> newTSem 1 <*> newTVar Map.empty + rtn <- f $ Group dv sem dsss + ((\(Descriptor.Pool.P dsp, dss) -> M.freeDs mdvc dsp $ dListToMiddle dss) `mapM_`) =<< + (Map.elems <$> atomically (readTVar dsss)) + pure rtn + +allocateDs' :: (Ord k, WithPoked (TMaybe.M mn), DListFromMiddle slbtss) => + Group sd sg k sp slbtss -> k -> AllocateInfo mn sp slbtss -> + IO (Either String (HeteroParList.PL (D sg) slbtss)) +allocateDs' (Group (Device.D dvc) sem mp) k ai = do + ok <- atomically do + mx <- (Map.lookup k) <$> readTVar mp + case mx of + Nothing -> waitTSem sem >> pure True + Just _ -> pure False + if ok + then do dsm <- M.allocateDs dvc (allocateInfoToMiddle ai) + ds <- dListFromMiddle dsm + atomically do + modifyTVar mp (Map.insert k (sp, ds)) + signalTSem sem + pure $ Right ds + else pure . Left + $ "Gpu.Vulkan.DescriptorSet.allocateDs': The key already exist" +-- where Descriptor.Pool.P sp = allocateInfoDescriptorPool ai + where sp = allocateInfoDescriptorPool ai + +unsafeFreeDs :: Ord k => Group sd sg k sp slbtss -> k -> IO (Either String ()) +unsafeFreeDs (Group (Device.D mdvc) sem mp) k = do + md <- atomically do + mx <- Map.lookup k <$> readTVar mp + case mx of + Nothing -> pure Nothing + Just _ -> waitTSem sem >> pure mx + case md of + Nothing -> pure $ Left "Gpu.Vulkan.DescriptorSet.unsafeFreeDs" + Just (Descriptor.Pool.P p, ds) -> do + M.freeDs mdvc p (dListToMiddle ds) + atomically do + modifyTVar mp (Map.delete k) + signalTSem sem + pure $ Right () + +lookup :: Ord k => + Group sd s k sp slbtss -> k -> IO (Maybe (HeteroParList.PL (D s) slbtss)) +lookup (Group _ _sem mp) k = atomically $ (snd <$>) . Map.lookup k <$> readTVar mp + +dListToMiddle :: HeteroParList.PL (D s) slbtss -> [M.D] +dListToMiddle = HeteroParList.toList \(D _ md) -> md + +updateDs :: ( + Show (HeteroParList.PL M.Write (Data.TypeLevel.Tuple.MapIndex.M0_5 writeArgs)), + W.WriteListToMiddle writeArgs, + W.WriteListUpdateDynamicLengths writeArgs, + CopyListToMiddle copyArgs) => + Device.D sd -> + HeteroParList.PL (U5 W.Write) writeArgs -> + HeteroParList.PL (U8 Copy) copyArgs -> IO () +updateDs (Device.D dvc) ws cs = when debug (print ws') >> + W.writeListUpdateDynamicLength ws >> M.updateDs dvc ws' cs' + where ws' = W.writeListToMiddle ws; cs' = copyListToMiddle cs diff --git a/src/Gpu/Vulkan/DescriptorSet/BindingAndArrayElem.hs b/src/Gpu/Vulkan/DescriptorSet/BindingAndArrayElem.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/DescriptorSet/BindingAndArrayElem.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE ScopedTypeVariables, TypeApplications #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures, TypeOperators #-} +{-# LANGUAGE MultiParamTypeClasses, AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs -fno-warn-redundant-constraints #-} + +module Gpu.Vulkan.DescriptorSet.BindingAndArrayElem ( + + -- * IMAGE + + BindingAndArrayElemImage(..), + BindingAndArrayElemImageWithImmutableSampler(..), + + -- * BUFFER VIEW + + BindingAndArrayElemBufferView(..) ) where + +import GHC.TypeLits +import Data.Kind +import Data.TypeLevel.List qualified as TList +import Data.TypeLevel.Tuple.MapIndex qualified as TMapIndex + +import Gpu.Vulkan.TypeEnum qualified as T +import Gpu.Vulkan.DescriptorSetLayout.Type qualified as Lyt + +-- * IMAGE + +-- ** Image + +class BindingAndArrayElemImage + (lbts :: [Lyt.BindingType]) + (iargs :: [(Symbol, T.Format)]) (i :: Nat) where + bindingAndArrayElemImage :: Integral n => n -> n -> (n, n) + +instance TList.IsPrefixOf iargs liargs => + BindingAndArrayElemImage + ('Lyt.Image (iarg ': liargs) : lbts) (iarg ': iargs) 0 where + bindingAndArrayElemImage b ae = (b, ae) + +instance {-# OVERLAPPABLE #-} + BindingAndArrayElemImage + ('Lyt.Image liargs ': lbts) (iarg ': iargs) (i - 1) => + BindingAndArrayElemImage + ('Lyt.Image (iarg ': liargs) ': lbts) (iarg ': iargs) i where + bindingAndArrayElemImage b ae = bindingAndArrayElemImage + @('Lyt.Image liargs ': lbts) @(iarg ': iargs) @(i - 1) b (ae + 1) + +instance {-# OVERLAPPABLE #-} + BindingAndArrayElemImage ('Lyt.Image liargs : lbts) iargs i => + BindingAndArrayElemImage + ('Lyt.Image (liarg ': liargs) ': lbts) iargs i where + bindingAndArrayElemImage b a = bindingAndArrayElemImage + @('Lyt.Image liargs : lbts) @iargs @i b (a + 1) + +instance {-# OVERLAPPABLE #-} + BindingAndArrayElemImage lbts iargs i => + BindingAndArrayElemImage (bt ': lbts) iargs i where + bindingAndArrayElemImage b _ = + bindingAndArrayElemImage @lbts @iargs @i (b + 1) 0 + +-- ** Image With Immutable Sampler + +class BindingAndArrayElemImageWithImmutableSampler + (lbts :: [Lyt.BindingType]) + (iargs :: [(Symbol, T.Format)]) (i :: Nat) where + bindingAndArrayElemImageWithImmutableSampler :: Integral n => n -> n -> (n, n) + +instance TList.IsPrefixOf iargs (TMapIndex.M0'1_3 liargs) => + BindingAndArrayElemImageWithImmutableSampler + ('Lyt.ImageSampler ('(nm, fmt, ss) ': liargs) : lbts) ('(nm, fmt) ': iargs) 0 where + bindingAndArrayElemImageWithImmutableSampler b ae = (b, ae) + +instance {-# OVERLAPPABLE #-} + BindingAndArrayElemImageWithImmutableSampler + ('Lyt.ImageSampler liargs ': lbts) ('(nm, fmt) ': iargs) (i - 1) => + BindingAndArrayElemImageWithImmutableSampler + ('Lyt.ImageSampler ('(nm, fmt, ss) ': liargs) ': lbts) ('(nm, fmt) ': iargs) i where + bindingAndArrayElemImageWithImmutableSampler b ae = + bindingAndArrayElemImageWithImmutableSampler + @('Lyt.ImageSampler liargs ': lbts) @('(nm, fmt) ': iargs) + @(i - 1) b (ae + 1) + +instance {-# OVERLAPPABLE #-} + BindingAndArrayElemImageWithImmutableSampler ('Lyt.ImageSampler liargs : lbts) iargs i => + BindingAndArrayElemImageWithImmutableSampler + ('Lyt.ImageSampler (liarg ': liargs) ': lbts) iargs i where + bindingAndArrayElemImageWithImmutableSampler b a = bindingAndArrayElemImageWithImmutableSampler + @('Lyt.ImageSampler liargs : lbts) @iargs @i b (a + 1) + +instance {-# OVERLAPPABLE #-} + BindingAndArrayElemImageWithImmutableSampler lbts iargs i => + BindingAndArrayElemImageWithImmutableSampler (bt ': lbts) iargs i where + bindingAndArrayElemImageWithImmutableSampler b _ = + bindingAndArrayElemImageWithImmutableSampler @lbts @iargs @i (b + 1) 0 + +-- * BUFFER VIEW + +class BindingAndArrayElemBufferView + (bt :: [Lyt.BindingType]) (bvargs :: [(Symbol, Type)]) (i :: Nat) where + bindingAndArrayElemBufferView :: Integral n => n -> n -> (n, n) + +instance TList.IsPrefixOf bvargs lbvargs => BindingAndArrayElemBufferView + ('Lyt.BufferView (bvarg ': lbvargs) ': lbts) + (bvarg ': bvargs) 0 where + bindingAndArrayElemBufferView b a = (b, a) + +instance {-# OVERLAPPABLE #-} + BindingAndArrayElemBufferView + ('Lyt.BufferView lbvargs ': lbts) (bvarg ': bvargs) (i - 1) => + BindingAndArrayElemBufferView + ('Lyt.BufferView (bvarg ': lbvargs) ': lbts) + (bvarg ': bvargs) i where + bindingAndArrayElemBufferView b a = bindingAndArrayElemBufferView + @('Lyt.BufferView lbvargs ': lbts) @(bvarg ': bvargs) @(i - 1) + b a + +instance {-# OVERLAPPABLE #-} BindingAndArrayElemBufferView + ('Lyt.BufferView lbvargs ': lbts) bvargs i => + BindingAndArrayElemBufferView + ('Lyt.BufferView (bvarg ': lbvargs) ': lbts) bvargs i where + bindingAndArrayElemBufferView b a = bindingAndArrayElemBufferView + @('Lyt.BufferView lbvargs ': lbts) @bvargs @i b (a + 1) + +instance {-# OVERLAPPABLE #-} BindingAndArrayElemBufferView lbts bvargs i => + BindingAndArrayElemBufferView + (bt ': lbts) bvargs i where + bindingAndArrayElemBufferView b _a = + bindingAndArrayElemBufferView @lbts @bvargs @i (b + 1) 0 diff --git a/src/Gpu/Vulkan/DescriptorSet/BindingAndArrayElem/Buffer.hs b/src/Gpu/Vulkan/DescriptorSet/BindingAndArrayElem/Buffer.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/DescriptorSet/BindingAndArrayElem/Buffer.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE ScopedTypeVariables, TypeApplications #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures, TypeOperators #-} +{-# LANGUAGE MultiParamTypeClasses, AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs -fno-warn-redundant-constraints #-} + +module Gpu.Vulkan.DescriptorSet.BindingAndArrayElem.Buffer where + +import GHC.TypeLits + +import Gpu.Vulkan.Object qualified as VO +import Gpu.Vulkan.DescriptorSetLayout.Type qualified as Lyt + +-- * BUFFER + +-- ** BindingAndArrayElemBuffer + +class BindingAndArrayElemBuffer + (lbts :: [Lyt.BindingType]) (objs :: [VO.O]) (i :: Nat) where + bindingAndArrayElemBuffer :: Integral n => n -> n -> (n, n) + +instance IsPrefixObject objs lobjs => BindingAndArrayElemBuffer + ('Lyt.Buffer (VO.Static al 'Nothing ot t ': lobjs) ': lbts) + (VO.Static al ('Just _nm) ot t ': objs) 0 where + bindingAndArrayElemBuffer b ae = (b, ae) + +instance IsPrefixObject objs lobjs => BindingAndArrayElemBuffer + ('Lyt.Buffer (VO.Static al ('Just _nm) ot t ': lobjs) ': lbts) + (VO.Static al 'Nothing ot t ': objs) 0 where + bindingAndArrayElemBuffer b ae = (b, ae) + +instance IsPrefixObject objs lobjs => BindingAndArrayElemBuffer + ('Lyt.Buffer (VO.Dynamic n al 'Nothing ot t ': lobjs) ': lbts) + (VO.Dynamic n al ('Just _nm) ot t ': objs) 0 where + bindingAndArrayElemBuffer b ae = (b, ae) + +instance IsPrefixObject objs lobjs => BindingAndArrayElemBuffer + ('Lyt.Buffer (VO.Dynamic n al ('Just _nm) ot t ': lobjs) ': lbts) + (VO.Dynamic n al 'Nothing ot t ': objs) 0 where + bindingAndArrayElemBuffer b ae = (b, ae) + +instance IsPrefixObject objs lobjs => BindingAndArrayElemBuffer + ('Lyt.Buffer (obj ': lobjs) ': lbts) (obj ': objs) 0 where + bindingAndArrayElemBuffer b ae = (b, ae) + +instance {-# OVERLAPPABLE #-} + BindingAndArrayElemBuffer ('Lyt.Buffer lobjs ': lbts) + (VO.Static al ('Just nm) ot t ': objs) (i - 1) => + BindingAndArrayElemBuffer + ('Lyt.Buffer (VO.Static al 'Nothing ot t ': lobjs) ': lbts) + (VO.Static al ('Just nm) ot t ': objs) i where + bindingAndArrayElemBuffer b ae = bindingAndArrayElemBuffer + @('Lyt.Buffer lobjs ': lbts) + @(VO.Static al ('Just nm) ot t ': objs) @(i - 1) b (ae + 1) + +instance {-# OVERLAPPABLE #-} ( + BindingAndArrayElemBuffer ('Lyt.Buffer lobjs ': lbts) + (VO.Static al 'Nothing ot t ': objs) (i - 1) ) => + BindingAndArrayElemBuffer + ('Lyt.Buffer (VO.Static al ('Just _nm) ot t ': lobjs) ': lbts) + (VO.Static al 'Nothing ot t ': objs) i where + bindingAndArrayElemBuffer b ae = bindingAndArrayElemBuffer + @('Lyt.Buffer lobjs ': lbts) + @(VO.Static al 'Nothing ot t ': objs) @(i - 1) b (ae + 1) + +instance {-# OVERLAPPABLE #-} ( + BindingAndArrayElemBuffer ('Lyt.Buffer lobjs ': lbts) + (VO.Dynamic n al ('Just nm) ot t ': objs) (i - 1) ) => + BindingAndArrayElemBuffer + ('Lyt.Buffer (VO.Dynamic n al 'Nothing ot t ': lobjs) ': lbts) + (VO.Dynamic n al ('Just nm) ot t ': objs) i where + bindingAndArrayElemBuffer b ae = + bindingAndArrayElemBuffer + @('Lyt.Buffer lobjs ': lbts) + @(VO.Dynamic n al ('Just nm) ot t ': objs) @(i - 1) + b (ae + 1) + +instance {-# OVERLAPPABLE #-} ( + BindingAndArrayElemBuffer ('Lyt.Buffer lobjs ': lbts) + (VO.Dynamic n al 'Nothing ot t ': objs) (i - 1) ) => + BindingAndArrayElemBuffer + ('Lyt.Buffer (VO.Dynamic n al ('Just _nm) ot t ': lobjs) ': lbts) + (VO.Dynamic n al 'Nothing ot t ': objs) i where + bindingAndArrayElemBuffer b ae = + bindingAndArrayElemBuffer + @('Lyt.Buffer lobjs ': lbts) + @(VO.Dynamic n al 'Nothing ot t ': objs) @(i - 1) + b (ae + 1) + +instance {-# OVERLAPPABLE #-} ( + BindingAndArrayElemBuffer ('Lyt.Buffer lobjs ': lbts) + (obj ': objs) (i - 1) ) => + BindingAndArrayElemBuffer + ('Lyt.Buffer (obj ': lobjs) ': lbts) (obj ': objs) i where + bindingAndArrayElemBuffer b ae = + bindingAndArrayElemBuffer + @('Lyt.Buffer lobjs ': lbts) + @(obj ': objs) @(i - 1) b (ae + 1) + +instance {-# OVERLAPPABLE #-} + BindingAndArrayElemBuffer ('Lyt.Buffer lobjs ': lbts) (obj ': objs) i => + BindingAndArrayElemBuffer + ('Lyt.Buffer (lobj ': lobjs) ': lbts) (obj ': objs) i where + bindingAndArrayElemBuffer b ae = + bindingAndArrayElemBuffer + @('Lyt.Buffer lobjs ': lbts) + @(obj ': objs) @i b (ae + 1) + +instance {-# OVERLAPPABLE #-} + BindingAndArrayElemBuffer lbts (obj ': objs) i => + BindingAndArrayElemBuffer (bt ': lbts) (obj ': objs) i where + bindingAndArrayElemBuffer b _ae = + bindingAndArrayElemBuffer @lbts @(obj ': objs) @i (b + 1) 0 + +-- ** IsPrefixObject + +class IsPrefixObject (objs :: [VO.O]) (objs' :: [VO.O]) + +instance IsPrefixObject '[] objs' + +instance IsPrefixObject objs objs' => IsPrefixObject + (VO.Static al 'Nothing ot t ': objs) + (VO.Static al ('Just _nm) ot t ': objs') + +instance IsPrefixObject objs objs' => IsPrefixObject + (VO.Static al ('Just _nm) ot t ': objs) + (VO.Static al 'Nothing ot t ': objs') + +instance IsPrefixObject objs objs' => IsPrefixObject + (VO.Dynamic n al 'Nothing ot t ': objs) + (VO.Dynamic n al ('Just _nm) ot t ': objs') + +instance IsPrefixObject objs objs' => IsPrefixObject + (VO.Dynamic n al ('Just _nm) ot t ': objs) + (VO.Dynamic n al 'Nothing ot t ': objs') + +instance IsPrefixObject objs objs' => + IsPrefixObject (obj ': objs) (obj ': objs') diff --git a/src/Gpu/Vulkan/DescriptorSet/Copy.hs b/src/Gpu/Vulkan/DescriptorSet/Copy.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/DescriptorSet/Copy.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables, RankNTypes, TypeApplications #-} +{-# LANGUAGE GADTs, TypeFamilies #-} +{-# LANGUAGE DataKinds, ConstraintKinds #-} +{-# LANGUAGE KindSignatures, TypeOperators #-} +{-# LANGUAGE MultiParamTypeClasses, AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-} +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.DescriptorSet.Copy ( + + -- * COPY + + Copy(..), + + -- ** CopyListToMiddle + + CopyListToMiddle(..), + + -- ** BindingAndArrayElem + + BindingAndArrayElem, + + -- ** BindingLength + + BindingLength + + ) where + +import Data.TypeLevel.List qualified as TList +import Gpu.Vulkan.DescriptorSet.BindingAndArrayElem +import Gpu.Vulkan.DescriptorSet.BindingAndArrayElem.Buffer + +import GHC.TypeLits +import Foreign.Storable.PeekPoke +import Data.TypeLevel.Maybe qualified as TMaybe +import Data.TypeLevel.Tuple.Uncurry +import Data.TypeLevel.Tuple.Index qualified as TIndex +import Data.TypeLevel.Tuple.MapIndex qualified as TMapIndex +import qualified Data.HeteroParList as HeteroParList +import Data.HeteroParList (pattern (:**)) + +import Gpu.Vulkan.DescriptorSet.Type + +import qualified Gpu.Vulkan.DescriptorSetLayout.Type as Lyt +import qualified Gpu.Vulkan.DescriptorSet.Middle as M + +-- * COPY + +data Copy mn sdss slbtss (is :: Nat) sdsd slbtsd (id :: Nat) + (lbts :: Lyt.BindingType) = Copy { + copyNext :: TMaybe.M mn, + copySrcSet :: D sdss slbtss, copyDstSet :: D sdsd slbtsd } + +-- ** CopyListToMiddle + +class M.CopyListToCore (TMapIndex.M0_8 cargs) => + CopyListToMiddle cargs where + copyListToMiddle :: + HeteroParList.PL (U8 Copy) cargs -> + HeteroParList.PL M.Copy (TMapIndex.M0_8 cargs) + +instance CopyListToMiddle '[] where + copyListToMiddle HeteroParList.Nil = HeteroParList.Nil + +instance ( + WithPoked (TMaybe.M mn), + BindingAndArrayElem (TIndex.I1_2 slbtss) lbts is, + BindingAndArrayElem (TIndex.I1_2 slbtsd) lbts id, + BindingLength lbts, CopyListToMiddle cargs ) => + CopyListToMiddle ( + '(mn, sdss, slbtss, is, sdsd, slbtsd, id, lbts) ': cargs) where + copyListToMiddle (U8 c :** cs) = copyToMiddle c :** copyListToMiddle cs + +copyToMiddle :: forall mn sdss slbtss is sdsd slbtsd id lbts . ( + BindingAndArrayElem (TIndex.I1_2 slbtss) lbts is, + BindingAndArrayElem (TIndex.I1_2 slbtsd) lbts id, BindingLength lbts ) => + Copy mn sdss slbtss is sdsd slbtsd id lbts -> M.Copy mn +copyToMiddle Copy { + copyNext = mnxt, copySrcSet = D _ ss, copyDstSet = D _ sd } = let + (bs, aes) = bindingAndArrayElem @(TIndex.I1_2 slbtss) @lbts @is + (bd, aed) = bindingAndArrayElem @(TIndex.I1_2 slbtsd) @lbts @id + cnt = bindingLength @lbts in + M.Copy { + M.copyNext = mnxt, + M.copySrcSet = ss, + M.copySrcBinding = bs, M.copySrcArrayElement = aes, + M.copyDstSet = sd, + M.copyDstBinding = bd, M.copyDstArrayElement = aed, + M.copyDescriptorCount = cnt } + +-- ** BindingAndArrayElem + +class BindingAndArrayElem + (lbts :: [Lyt.BindingType]) + (lbt :: Lyt.BindingType) (i :: Nat) where + bindingAndArrayElem :: Integral n => (n, n) + +instance BindingAndArrayElemBuffer lbts objs i => + BindingAndArrayElem lbts (Lyt.Buffer objs) i where + bindingAndArrayElem = bindingAndArrayElemBuffer @lbts @objs @i 0 0 + +instance BindingAndArrayElemImage lbts iargs i => + BindingAndArrayElem lbts (Lyt.Image iargs) i where + bindingAndArrayElem = bindingAndArrayElemImage @lbts @iargs @i 0 0 + +instance BindingAndArrayElemImageWithImmutableSampler lbts (TMapIndex.M0'1_3 iargs) i => + BindingAndArrayElem lbts (Lyt.ImageSampler iargs) i where + bindingAndArrayElem = + bindingAndArrayElemImageWithImmutableSampler @lbts @(TMapIndex.M0'1_3 iargs) @i 0 0 + +instance BindingAndArrayElemBufferView lbts bvargs i => + BindingAndArrayElem lbts (Lyt.BufferView bvargs) i where + bindingAndArrayElem = bindingAndArrayElemBufferView @lbts @bvargs @i 0 0 + +-- ** BindingLength + +class BindingLength (bt :: Lyt.BindingType) where + bindingLength :: Integral n => n + +instance TList.Length objs => BindingLength (Lyt.Buffer objs) where + bindingLength = TList.length @_ @objs + +instance TList.Length iargs => BindingLength (Lyt.Image iargs) where + bindingLength = TList.length @_ @iargs + +instance TList.Length bvargs => BindingLength (Lyt.BufferView bvargs) where + bindingLength = TList.length @_ @bvargs + +instance TList.Length isargs => BindingLength (Lyt.ImageSampler isargs) where + bindingLength = TList.length @_ @isargs diff --git a/src/Gpu/Vulkan/DescriptorSet/Type.hs b/src/Gpu/Vulkan/DescriptorSet/Type.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/DescriptorSet/Type.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.DescriptorSet.Type (D(..)) where + +import Data.Kind +import Data.TypeLevel.Tuple.Index qualified as TIndex +import Data.IORef +import Data.HeteroParList qualified as HeteroParList + +import Gpu.Vulkan.Object.Base qualified as KObj +import Gpu.Vulkan.DescriptorSet.Middle qualified as M +import Gpu.Vulkan.DescriptorSetLayout.Type qualified as Lyt + +data D s (slbts :: (Type, [Lyt.BindingType])) = D + (IORef (HeteroParList.PL2 KObj.Length + (Lyt.BindingTypeListBufferOnlyDynamics (TIndex.I1_2 slbts)))) + M.D diff --git a/src/Gpu/Vulkan/DescriptorSet/Write.hs b/src/Gpu/Vulkan/DescriptorSet/Write.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/DescriptorSet/Write.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables, RankNTypes, TypeApplications #-} +{-# LANGUAGE GADTs, TypeFamilies #-} +{-# LANGUAGE DataKinds, ConstraintKinds #-} +{-# LANGUAGE KindSignatures, TypeOperators #-} +{-# LANGUAGE MultiParamTypeClasses, AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-} +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.DescriptorSet.Write ( + + -- * WRITE + + -- ** Types + + Write(..), WriteSources(..), WriteSourcesArg(..), + + -- ** WriteListToMiddle + + WriteListToMiddle(..), WriteSourcesToMiddle, + BindingAndArrayElemImage, BindingAndArrayElemImageWithImmutableSampler, + BindingAndArrayElemBuffer, BindingAndArrayElemBufferView, + + -- ** WriteListUpdateDynamicLengths + + WriteListUpdateDynamicLengths(..), + WriteSourcesUpdateDynamicLengths, UpdateDynamicLength + + ) where + +import GHC.TypeLits +import Foreign.Storable.PeekPoke +import Data.TypeLevel.Tuple.Index qualified as TIndex +import Data.TypeLevel.Tuple.MapIndex qualified as TMapIndex +import Data.TypeLevel.Maybe qualified as TMaybe +import Data.TypeLevel.Tuple.Uncurry +import qualified Data.HeteroParList as HeteroParList +import Data.HeteroParList (pattern (:**)) + +import Gpu.Vulkan.DescriptorSet.Type + +import qualified Gpu.Vulkan.Descriptor.Enum as Descriptor +import qualified Gpu.Vulkan.DescriptorSet.Middle as M + +import Gpu.Vulkan.DescriptorSet.Write.Sources + +-- * WRITE + +data Write mn sds slbts wsarg (i :: Nat) = Write { + writeNext :: TMaybe.M mn, + writeDstSet :: D sds slbts, + writeDescriptorType :: Descriptor.Type, + writeSources :: WriteSources wsarg } + +-- ** WriteListToMiddle + +class M.WriteListToCore (TMapIndex.M0_5 wargs) => WriteListToMiddle wargs where + writeListToMiddle :: + HeteroParList.PL (U5 Write) wargs -> + HeteroParList.PL M.Write (TMapIndex.M0_5 wargs) + +instance WriteListToMiddle '[] where + writeListToMiddle HeteroParList.Nil = HeteroParList.Nil + +instance ( + WithPoked (TMaybe.M mn), + WriteSourcesToMiddle (TIndex.I1_2 slbts) wsarg i, + WriteListToMiddle wargs ) => + WriteListToMiddle ('(mn, sds, slbts, wsarg, i) ': wargs) where + writeListToMiddle (U5 w :** ws) = + writeToMiddle w :** writeListToMiddle ws + +writeToMiddle :: forall mn s slbts wsa i . + WriteSourcesToMiddle (TIndex.I1_2 slbts) wsa i => + Write mn s slbts wsa i -> M.Write mn +writeToMiddle Write { + writeNext = mnxt, + writeDstSet = D _ ds, + writeDescriptorType = dt, + writeSources = srcs } = M.Write { + M.writeNext = mnxt, + M.writeDstSet = ds, + M.writeDstBinding = bdg, M.writeDstArrayElement = ae, + M.writeDescriptorType = dt, + M.writeSources = srcs' } + where ((bdg, ae), srcs') = + writeSourcesToMiddle @(TIndex.I1_2 slbts) @_ @i srcs + +-- ** WriteListUpdateDynamicLengths + +class WriteListUpdateDynamicLengths wargs where + writeListUpdateDynamicLength :: + HeteroParList.PL (U5 Write) wargs -> IO () + +instance WriteListUpdateDynamicLengths '[] where + writeListUpdateDynamicLength HeteroParList.Nil = pure () + +instance ( + WriteSourcesUpdateDynamicLengths bts wsarg, + WriteListUpdateDynamicLengths wargs ) => + WriteListUpdateDynamicLengths + ('(mn, sds, '(sl, bts), wsarg, i) ': wargs) where + writeListUpdateDynamicLength (U5 w :** ws) = + writeUpdateDynamicLength w >> writeListUpdateDynamicLength ws + +writeUpdateDynamicLength :: + WriteSourcesUpdateDynamicLengths bts wsarg => + Write n s '(sl, bts) wsarg i -> IO () +writeUpdateDynamicLength Write { writeDstSet = ds, writeSources = ws } = + writeSourcesUpdateDynamicLength ds ws diff --git a/src/Gpu/Vulkan/DescriptorSet/Write/Sources.hs b/src/Gpu/Vulkan/DescriptorSet/Write/Sources.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/DescriptorSet/Write/Sources.hs @@ -0,0 +1,176 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE BlockArguments, LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables, TypeApplications #-} +{-# LANGUAGE GADTs, TypeFamilies #-} +{-# LANGUAGE DataKinds, PolyKinds #-} +{-# LANGUAGE KindSignatures, TypeOperators #-} +{-# LANGUAGE MultiParamTypeClasses, AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-} +{-# LANGUAGE PatternSynonyms #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.DescriptorSet.Write.Sources ( + + -- * WRITE SOURCES + + -- ** Types + + WriteSources(..), WriteSourcesArg(..), + DstBinding, DstArrayElement, DescriptorCount, + + -- ** WriteSourcesToMiddle + + WriteSourcesToMiddle(..), + BindingAndArrayElemImage, BindingAndArrayElemImageWithImmutableSampler, + BindingAndArrayElemBuffer, BindingAndArrayElemBufferView, + + -- ** WriteSourcesUpdateDynamicLengths + + WriteSourcesUpdateDynamicLengths(..), UpdateDynamicLength + + ) where + +import GHC.TypeLits +import Data.Kind +import Data.TypeLevel.Tuple.Uncurry +import Data.TypeLevel.Tuple.MapIndex qualified as TMapIndex +import Data.HeteroParList qualified as HeteroParList +import Data.HeteroParList.Tuple qualified as HeteroParList +import Data.Word +import Data.IORef + +import Gpu.Vulkan.Object qualified as VObj + +import Gpu.Vulkan.TypeEnum qualified as T + +import Gpu.Vulkan.Descriptor.Internal qualified as Descriptor +import Gpu.Vulkan.Descriptor.Middle qualified as Descriptor.M + +import Gpu.Vulkan.DescriptorSet.Type +import Gpu.Vulkan.DescriptorSet.BindingAndArrayElem +import Gpu.Vulkan.DescriptorSet.BindingAndArrayElem.Buffer +import Gpu.Vulkan.DescriptorSet.Middle qualified as M +import Gpu.Vulkan.DescriptorSetLayout.Type qualified as Layout +import Gpu.Vulkan.DescriptorSetLayout.UpdateDynamicLengths + +import Gpu.Vulkan.Buffer.Type qualified as Buffer +import Gpu.Vulkan.BufferView.Internal qualified as BufferView +import Gpu.Vulkan.BufferView.Middle qualified as BufferView.M + +-- * WRITE SOURCES + +-- ** Types + +data WriteSources arg where + ImageInfos :: + HeteroParList.PL (U4 Descriptor.ImageInfo) iiargs -> + WriteSources ('WriteSourcesArgImage iiargs) + ImageInfosNoSampler :: + HeteroParList.PL (U3 Descriptor.ImageInfoNoSampler) iiargs -> + WriteSources ('WriteSourcesArgImageNoSampler iiargs) + BufferInfos :: + HeteroParList.PL (U5 Descriptor.BufferInfo) biargs -> + WriteSources ('WriteSourcesArgBuffer biargs) + TexelBufferViews :: + HeteroParList.PL (U3 BufferView.B) tbvargs -> + WriteSources ('WriteSourcesArgBufferView tbvargs) + WriteSourcesInNext :: DstBinding -> DstArrayElement -> + DescriptorCount -> WriteSources 'WriteSourcesArgInNext + +data WriteSourcesArg + = WriteSourcesArgImage [(Type, Symbol, T.Format, Type)] + | WriteSourcesArgImageNoSampler [(Symbol, T.Format, Type)] + | WriteSourcesArgBuffer [(Type, Type, Symbol, VObj.O, Nat)] + | WriteSourcesArgBufferView [(Type, Symbol, Type)] + | WriteSourcesArgInNext + +type DstBinding = Word32 +type DstArrayElement = Word32 +type DescriptorCount = Word32 + +-- ** WriteSourcesToMiddle + +class WriteSourcesToMiddle (lbts :: [Layout.BindingType]) wsarg (i :: Nat) where + writeSourcesToMiddle :: + WriteSources wsarg -> ((Word32, Word32), M.WriteSources) + +instance (BindingAndArrayElemBuffer lbts (TMapIndex.M3_5 barg) i) => + WriteSourcesToMiddle lbts ('WriteSourcesArgBuffer barg) i where + writeSourcesToMiddle (BufferInfos bis) = ( + bindingAndArrayElemBuffer @lbts @(TMapIndex.M3_5 barg) @i 0 0, + M.WriteSourcesBufferInfo $ bufferInfoListToMiddle bis ) + where + bufferInfoListToMiddle :: + HeteroParList.PL (U5 Descriptor.BufferInfo) biargs -> + [Descriptor.M.BufferInfo] + bufferInfoListToMiddle = HeteroParList.toList \(U5 bi) -> + Descriptor.bufferInfoToMiddle bi + +instance BindingAndArrayElemImage lbts (TMapIndex.M1'2_4 iarg) i => + WriteSourcesToMiddle lbts ('WriteSourcesArgImage iarg) i where + writeSourcesToMiddle (ImageInfos iis) = ( + bindingAndArrayElemImage @lbts @(TMapIndex.M1'2_4 iarg) @i 0 0, + M.WriteSourcesImageInfo $ imageInfosToMiddle iis ) + where + imageInfosToMiddle :: + HeteroParList.PL (U4 Descriptor.ImageInfo) iiargs -> + [Descriptor.M.ImageInfo] + imageInfosToMiddle = HeteroParList.toList \(U4 ii) -> + Descriptor.imageInfoToMiddle ii + +instance BindingAndArrayElemImageWithImmutableSampler + lbts (TMapIndex.M0'1_3 iarg) i => + WriteSourcesToMiddle lbts ('WriteSourcesArgImageNoSampler iarg) i where + writeSourcesToMiddle (ImageInfosNoSampler iis) = ( + bindingAndArrayElemImageWithImmutableSampler + @lbts @(TMapIndex.M0'1_3 iarg) @i 0 0, + M.WriteSourcesImageInfo $ imageInfosToMiddle iis ) + where + imageInfosToMiddle :: + HeteroParList.PL + (U3 Descriptor.ImageInfoNoSampler) iiargs -> + [Descriptor.M.ImageInfo] + imageInfosToMiddle = HeteroParList.toList \(U3 ii) -> + Descriptor.imageInfoNoSamplerToMiddle ii + +instance BindingAndArrayElemBufferView lbts (TMapIndex.M1'2_3 bvarg) i => + WriteSourcesToMiddle lbts ('WriteSourcesArgBufferView bvarg) i where + writeSourcesToMiddle (TexelBufferViews bvarg) = ( + bindingAndArrayElemBufferView + @lbts @(TMapIndex.M1'2_3 bvarg) @i 0 0, + M.WriteSourcesBufferView $ bvsToMiddle bvarg ) + where + bvsToMiddle :: HeteroParList.PL (U3 BufferView.B) bvs -> + [BufferView.M.B] + bvsToMiddle = + HeteroParList.toList \(U3 (BufferView.B mbv)) -> mbv + +instance WriteSourcesToMiddle lbts 'WriteSourcesArgInNext i where + writeSourcesToMiddle (WriteSourcesInNext bdg ae cnt) = + ((bdg, ae), M.WriteSourcesInNext cnt) + +-- ** WriteSourcesUpdateDynamicLengths + +class WriteSourcesUpdateDynamicLengths lbts wsarg where + writeSourcesUpdateDynamicLength :: + D sds '(sl, lbts) -> WriteSources wsarg -> IO () + +instance ( + TMapIndex.M3_5 bargs ~ objs, UpdateDynamicLength lbts objs, + HeteroParList.Map3_5 bargs ) => + WriteSourcesUpdateDynamicLengths + lbts (WriteSourcesArgBuffer bargs) where + writeSourcesUpdateDynamicLength (D rlns _) (BufferInfos bis) = do + lns <- readIORef rlns + writeIORef rlns + . updateDynamicLength @lbts @objs lns + . VObj.onlyDynamicLength @objs + $ HeteroParList.map3_5 (toLength . unU5) bis + where + toLength :: Descriptor.BufferInfo sm sb nm obj i -> + VObj.Length obj + toLength (Descriptor.BufferInfo (Buffer.Binded lns _)) = + HeteroParList.typeIndex lns + +instance {-# OVERLAPPABLE #-} WriteSourcesUpdateDynamicLengths lbts wsarg where + writeSourcesUpdateDynamicLength _ _ = pure () diff --git a/src/Gpu/Vulkan/DescriptorSetLayout.hs b/src/Gpu/Vulkan/DescriptorSetLayout.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/DescriptorSetLayout.hs @@ -0,0 +1,158 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE ScopedTypeVariables, TypeApplications, RankNTypes #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures, TypeOperators #-} +{-# LANGUAGE FlexibleContexts, UndecidableInstances #-} +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.DescriptorSetLayout ( + + -- * CREATE + + create, D, CreateInfo(..), + + -- ** Binding + + Binding(..), BindingListToMiddle, + + -- ** BindingType + + BindingType(..), BindingTypeListBufferOnlyDynamics, + + -- * ENUM + + module Gpu.Vulkan.DescriptorSetLayout.Enum + + ) where + +import Prelude hiding (length) + +import Foreign.Storable.PeekPoke +import Control.Exception +import Data.TypeLevel.Maybe qualified as TMaybe +import Data.TypeLevel.ParMaybe qualified as TPMaybe +import Data.TypeLevel.List +import Data.TypeLevel.Tuple.Uncurry +import Data.TypeLevel.Tuple.MapIndex qualified as TMapIndex +import Data.HeteroParList qualified as HeteroParList +import Data.HeteroParList (pattern (:**)) +import Data.Word + +import Gpu.Vulkan.Enum +import Gpu.Vulkan.DescriptorSetLayout.Type +import Gpu.Vulkan.DescriptorSetLayout.Enum + +import qualified Gpu.Vulkan.AllocationCallbacks as AllocationCallbacks +import qualified Gpu.Vulkan.AllocationCallbacks.Type as AllocationCallbacks +import qualified Gpu.Vulkan.Device.Type as Device +import qualified Gpu.Vulkan.Descriptor.Enum as Descriptor +import qualified Gpu.Vulkan.DescriptorSetLayout.Middle as M +import qualified Gpu.Vulkan.Sampler.Type as Sampler + +create :: ( + WithPoked (TMaybe.M mn), BindingListToMiddle bts, + AllocationCallbacks.ToMiddle mac ) => + Device.D sd -> CreateInfo mn bts -> + TPMaybe.M (U2 AllocationCallbacks.A) mac -> + (forall s . D s bts -> IO a) -> IO a +create (Device.D dvc) ci (AllocationCallbacks.toMiddle -> mac) f = + bracket (M.create dvc (createInfoToMiddle ci) mac) + (\l -> M.destroy dvc l mac) (f . D) + +data CreateInfo mn bts = CreateInfo { + createInfoNext :: TMaybe.M mn, + createInfoFlags :: CreateFlags, + createInfoBindings :: HeteroParList.PL Binding bts } + +-- deriving instance (Show (TMaybe.M mn), Show (HeteroParList.PL Binding bts)) => +-- Show (CreateInfo mn bts) + +createInfoToMiddle :: + BindingListToMiddle bts => CreateInfo mn bts -> M.CreateInfo mn +createInfoToMiddle CreateInfo { + createInfoNext = mnxt, + createInfoFlags = flgs, + createInfoBindings = bds } = M.CreateInfo { + M.createInfoNext = mnxt, + M.createInfoFlags = flgs, + M.createInfoBindings = bindingListToMiddle bds 0 } + +data Binding (bt :: BindingType) where + BindingBuffer :: { + bindingBufferDescriptorType :: Descriptor.Type, + bindingBufferStageFlags :: ShaderStageFlags + } -> Binding ('Buffer objs) + BindingBufferView :: { + bindingBufferViewDescriptorType :: Descriptor.Type, + bindingBufferViewStageFlags :: ShaderStageFlags + } -> Binding ('BufferView bvargs) + BindingImage :: { + bindingImageDescriptorType :: Descriptor.Type, + bindingImageStageFlags :: ShaderStageFlags + } -> Binding ('Image iargs) + BindingImageSampler :: { + bindingImageSamplerDescriptorType :: Descriptor.Type, + bindingImageSamplerStageFlags :: ShaderStageFlags, + bindingImageSamplerImmutableSamplers :: + HeteroParList.PL Sampler.S (TMapIndex.M2_3 iargs) + } -> Binding ('ImageSampler iargs) + +class BindingListToMiddle bts where + bindingListToMiddle :: + HeteroParList.PL Binding bts -> Word32 -> [M.Binding] + +instance BindingListToMiddle '[] where + bindingListToMiddle HeteroParList.Nil _ = [] + +instance (BindingToMiddle bt, BindingListToMiddle bts) => + BindingListToMiddle (bt ': bts) where + bindingListToMiddle (bd :** bds) bb = + bindingToMiddle bd bb : bindingListToMiddle bds (bb + 1) + +class BindingToMiddle bt where + bindingToMiddle :: Binding bt -> Word32 -> M.Binding + +instance Length objs => BindingToMiddle ('Buffer objs) where + bindingToMiddle BindingBuffer { + bindingBufferDescriptorType = dt, + bindingBufferStageFlags = sfs } bb = M.Binding { + M.bindingBinding = bb, + M.bindingDescriptorType = dt, + M.bindingDescriptorCountOrImmutableSamplers = + Left (length @_ @objs), + M.bindingStageFlags = sfs } + +instance Length bvargs => BindingToMiddle ('BufferView bvargs) where + bindingToMiddle BindingBufferView { + bindingBufferViewDescriptorType = dt, + bindingBufferViewStageFlags = sfs } bb = M.Binding { + M.bindingBinding = bb, + M.bindingDescriptorType = dt, + M.bindingDescriptorCountOrImmutableSamplers = + Left (length @_ @bvargs), + M.bindingStageFlags = sfs } + +instance Length iargs => BindingToMiddle ('Image iargs) where + bindingToMiddle BindingImage { + bindingImageDescriptorType = dt, + bindingImageStageFlags = sfs } bb = M.Binding { + M.bindingBinding = bb, + M.bindingDescriptorType = dt, + M.bindingDescriptorCountOrImmutableSamplers = + Left (length @_ @iargs), + M.bindingStageFlags = sfs } + +instance BindingToMiddle ('ImageSampler iargs) where + bindingToMiddle BindingImageSampler { + bindingImageSamplerDescriptorType = dt, + bindingImageSamplerStageFlags = sfs, + bindingImageSamplerImmutableSamplers = iss } bb = M.Binding { + M.bindingBinding = bb, + M.bindingDescriptorType = dt, + M.bindingDescriptorCountOrImmutableSamplers = Right + $ HeteroParList.toList Sampler.sToMiddle iss, + M.bindingStageFlags = sfs } diff --git a/src/Gpu/Vulkan/DescriptorSetLayout/BindingFlags.hs b/src/Gpu/Vulkan/DescriptorSetLayout/BindingFlags.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/DescriptorSetLayout/BindingFlags.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.DescriptorSetLayout.BindingFlags (M.CreateInfo(..)) where + +import Gpu.Vulkan.DescriptorSetLayout.BindingFlags.Middle qualified as M diff --git a/src/Gpu/Vulkan/DescriptorSetLayout/Enum.hs b/src/Gpu/Vulkan/DescriptorSetLayout/Enum.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/DescriptorSetLayout/Enum.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE PackageImports #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.DescriptorSetLayout.Enum ( + module Gpu.Vulkan.DescriptorSetLayout.Enum ) where + +import "gpu-vulkan-middle" Gpu.Vulkan.DescriptorSetLayout.Enum diff --git a/src/Gpu/Vulkan/DescriptorSetLayout/Type.hs b/src/Gpu/Vulkan/DescriptorSetLayout/Type.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/DescriptorSetLayout/Type.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds, PolyKinds #-} +{-# LANGUAGE KindSignatures, TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.DescriptorSetLayout.Type where + +import GHC.TypeLits +import Data.Kind +import Gpu.Vulkan.Object qualified as VObj + +import qualified Gpu.Vulkan.TypeEnum as T +import qualified Gpu.Vulkan.DescriptorSetLayout.Middle as M + +newtype D s (bts :: [BindingType]) = D { unL :: M.D } deriving Show + +data BindingType + = Image [(Symbol, T.Format)] | ImageSampler [(Symbol, T.Format, Type)] + | Buffer [VObj.O] | BufferView [(Symbol, Type)] + +type family BindingTypeListBufferOnlyDynamics bts where + BindingTypeListBufferOnlyDynamics '[] = '[] + BindingTypeListBufferOnlyDynamics (bt ': bts) = + BindingTypeBufferOnlyDynamics bt ': + BindingTypeListBufferOnlyDynamics bts + +type family BindingTypeBufferOnlyDynamics bt where + BindingTypeBufferOnlyDynamics bt = + VObj.OnlyDynamics (BindingTypeBufferObjects bt) + +type family BindingTypeBufferObjects bt where + BindingTypeBufferObjects (Buffer os) = os + BindingTypeBufferObjects _ = '[] diff --git a/src/Gpu/Vulkan/DescriptorSetLayout/UpdateDynamicLengths.hs b/src/Gpu/Vulkan/DescriptorSetLayout/UpdateDynamicLengths.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/DescriptorSetLayout/UpdateDynamicLengths.hs @@ -0,0 +1,150 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE ScopedTypeVariables, TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE MultiParamTypeClasses, AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-} +{-# LANGUAGE PatternSynonyms #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.DescriptorSetLayout.UpdateDynamicLengths ( + + -- * UPDATE DYNAMIC LENGTHS + + UpdateDynamicLength(..) ) where + +import Gpu.Vulkan.Object qualified as VObj +import Gpu.Vulkan.Object.Base qualified as KObj +import Data.HeteroParList qualified as HeteroParList +import Data.HeteroParList (pattern (:**)) + +import qualified Gpu.Vulkan.DescriptorSetLayout.Type as Layout + +class VObj.OnlyDynamicLengths objs => UpdateDynamicLength bts objs where + updateDynamicLength :: + HeteroParList.PL + (HeteroParList.PL KObj.Length) + (Layout.BindingTypeListBufferOnlyDynamics bts) -> + HeteroParList.PL KObj.Length + (VObj.OnlyDynamics objs) -> + HeteroParList.PL + (HeteroParList.PL KObj.Length) + (Layout.BindingTypeListBufferOnlyDynamics bts) + +instance UpdateDynamicLength _bts '[] where updateDynamicLength x _ = x + +instance UpdateDynamicLength bts (o ': os) => + UpdateDynamicLength ('Layout.Buffer '[] ': bts) (o ': os) where + updateDynamicLength (HeteroParList.Nil :** lnss) lns = + HeteroParList.Nil :** updateDynamicLength @bts @(o ': os) lnss lns + +instance (UpdateDynamicLengthPrefix os os', VObj.OnlyDynamicLengths os) => + UpdateDynamicLength + ('Layout.Buffer (VObj.Static algn 'Nothing ot t ': os') ': bts) + (VObj.Static algn ('Just _nm) ot t ': os) where + updateDynamicLength (lns' :** lnss) lns = + updateDynamicLengthPrefix @os @os' lns' lns :** lnss + +instance (UpdateDynamicLengthPrefix os os', VObj.OnlyDynamicLengths os) => + UpdateDynamicLength + ('Layout.Buffer (VObj.Static algn ('Just _nm) ot t ': os') ': bts) + (VObj.Static algn 'Nothing ot t ': os) where + updateDynamicLength (lns' :** lnss) lns = + updateDynamicLengthPrefix @os @os' lns' lns :** lnss + +instance (UpdateDynamicLengthPrefix os os', VObj.OnlyDynamicLengths os) => + UpdateDynamicLength + ('Layout.Buffer (VObj.Dynamic n algn 'Nothing ot t ': os') ': bts) + (VObj.Dynamic n algn ('Just _nm) ot t ': os) where + updateDynamicLength ((_ln :** lns') :** lnss) (ln :** lns) = + (KObj.renameLength ln :** updateDynamicLengthPrefix @os @os' lns' lns) :** lnss + +instance (UpdateDynamicLengthPrefix os os', VObj.OnlyDynamicLengths os) => + UpdateDynamicLength + ('Layout.Buffer (VObj.Dynamic n algn ('Just _nm) ot t ': os') ': bts) + (VObj.Dynamic n algn 'Nothing ot t ': os) where + updateDynamicLength ((_ln :** lns') :** lnss) (ln :** lns) = + (KObj.renameLength ln :** updateDynamicLengthPrefix @os @os' lns' lns) :** lnss + +instance (UpdateDynamicLengthPrefix os os', VObj.OnlyDynamicLengths os) => + UpdateDynamicLength + ('Layout.Buffer (VObj.Static_ o ': os') ': bts) + (VObj.Static_ o ': os) where + updateDynamicLength (lns' :** lnss) lns = + updateDynamicLengthPrefix @os @os' lns' lns :** lnss + +instance (UpdateDynamicLengthPrefix os os', VObj.OnlyDynamicLengths os) => + UpdateDynamicLength + ('Layout.Buffer ('VObj.Dynamic n o ': os') ': bts) + ('VObj.Dynamic n o ': os) where + updateDynamicLength ((_ln :** lns') :** lnss) (ln :** lns) = + (ln :** updateDynamicLengthPrefix @os @os' lns' lns) :** lnss + +instance {-# OVERLAPPABLE #-} + UpdateDynamicLength + ('Layout.Buffer os' ': bts) (oo ': os) => + UpdateDynamicLength + ('Layout.Buffer (VObj.Static_ o ': os') ': bts) (oo ': os) where + updateDynamicLength lnss lns = + updateDynamicLength + @('Layout.Buffer os' ': bts) @(oo ': os) lnss lns + +instance {-# OVERLAPPABLE #-} + UpdateDynamicLength + ('Layout.Buffer os' ': bts) (oo ': os) => + UpdateDynamicLength + ('Layout.Buffer ('VObj.Dynamic n o ': os') ': bts) (oo ': os) where + updateDynamicLength ((ln :** lns') :** lnss) lns = let + ls' :** lss = updateDynamicLength + @('Layout.Buffer os' ': bts) @(oo ': os) (lns' :** lnss) lns in + (ln :** ls') :** lss + +class UpdateDynamicLengthPrefix (objs :: [VObj.O]) (objs' :: [VObj.O]) where + updateDynamicLengthPrefix :: + HeteroParList.PL KObj.Length (VObj.OnlyDynamics objs') -> + HeteroParList.PL KObj.Length (VObj.OnlyDynamics objs) -> + HeteroParList.PL KObj.Length (VObj.OnlyDynamics objs') + +instance UpdateDynamicLengthPrefix '[] objs where + updateDynamicLengthPrefix lns _ = lns + +instance UpdateDynamicLengthPrefix os os' => + UpdateDynamicLengthPrefix + (VObj.Static algn 'Nothing ot t ': os) + (VObj.Static algn ('Just _nm) ot t ': os') where + updateDynamicLengthPrefix lns' lns = + updateDynamicLengthPrefix @os @os' lns' lns + +instance UpdateDynamicLengthPrefix os os' => + UpdateDynamicLengthPrefix + (VObj.Static algn ('Just _nm) ot t ': os) + (VObj.Static algn 'Nothing ot t ': os') where + updateDynamicLengthPrefix lns' lns = + updateDynamicLengthPrefix @os @os' lns' lns + +instance UpdateDynamicLengthPrefix os os' => + UpdateDynamicLengthPrefix + (VObj.Dynamic n algn 'Nothing ot t ': os) + (VObj.Dynamic n algn ('Just _nm) ot t ': os') where + updateDynamicLengthPrefix (_ln :** lns') (ln :** lns) = + KObj.renameLength ln :** updateDynamicLengthPrefix @os @os' lns' lns + +instance UpdateDynamicLengthPrefix os os' => + UpdateDynamicLengthPrefix + (VObj.Dynamic n algn ('Just _nm) ot t ': os) + (VObj.Dynamic n algn 'Nothing ot t ': os') where + updateDynamicLengthPrefix (_ln :** lns') (ln :** lns) = + KObj.renameLength ln :** updateDynamicLengthPrefix @os @os' lns' lns + +instance UpdateDynamicLengthPrefix os os' => + UpdateDynamicLengthPrefix + (VObj.Static_ o : os) (VObj.Static_ o : os') where + updateDynamicLengthPrefix lns' lns = + updateDynamicLengthPrefix @os @os' lns' lns + +instance UpdateDynamicLengthPrefix os os' => + UpdateDynamicLengthPrefix + ('VObj.Dynamic n o : os) ('VObj.Dynamic n o : os') where + updateDynamicLengthPrefix (_ln :** lns') (ln :** lns) = + ln :** updateDynamicLengthPrefix @os @os' lns' lns diff --git a/src/Gpu/Vulkan/Device.hs b/src/Gpu/Vulkan/Device.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Device.hs @@ -0,0 +1,30 @@ +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Device ( + + -- * CREATE + + create, D, CreateInfo(..), + CreateFlags, QueueCreateInfo(..), + + -- ** Group + + group, Group, create', unsafeDestroy, lookup, + + -- * GET QUEUE AND WAIT IDLE + + getQueue, waitIdle, + + -- * SIZE + + Size, + + -- * ENUM + + module Gpu.Vulkan.Device.Enum + + ) where + +import Prelude hiding (lookup) +import Gpu.Vulkan.Device.Internal +import Gpu.Vulkan.Device.Enum diff --git a/src/Gpu/Vulkan/Device/Enum.hs b/src/Gpu/Vulkan/Device/Enum.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Device/Enum.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE PackageImports #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Device.Enum (module Gpu.Vulkan.Device.Enum) where + +import "gpu-vulkan-middle" Gpu.Vulkan.Device.Enum diff --git a/src/Gpu/Vulkan/Device/Internal.hs b/src/Gpu/Vulkan/Device/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Device/Internal.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE FlexibleContexts, UndecidableInstances #-} +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Device.Internal ( + + -- * CREATE + + create, D(..), CreateInfo(..), + M.CreateFlags, M.QueueCreateInfo(..), + + -- ** Group + + group, Group, create', unsafeDestroy, lookup, + + -- * GET QUEUE AND WAIT IDLE + + getQueue, waitIdle, + + -- * SIZE + + M.Size + + ) where + +import Prelude hiding (lookup) +import Foreign.Storable.PeekPoke +import Control.Concurrent.STM +import Control.Concurrent.STM.TSem +import Control.Exception +import Data.TypeLevel.Maybe qualified as TMaybe +import Data.TypeLevel.ParMaybe qualified as TPMaybe +import Data.TypeLevel.Tuple.Uncurry +import Data.Map qualified as Map + +import Gpu.Vulkan +import Gpu.Vulkan.Device.Type + +import qualified Gpu.Vulkan.AllocationCallbacks as AllocationCallbacks +import qualified Gpu.Vulkan.AllocationCallbacks.Type as AllocationCallbacks +import qualified Gpu.Vulkan.PhysicalDevice as PhysicalDevice +import qualified Gpu.Vulkan.Device.Middle as M +import qualified Gpu.Vulkan.QueueFamily.Middle as QueueFamily +import qualified Gpu.Vulkan.Queue as Queue + +import Data.HeteroParList qualified as HeteroParList + +create :: ( + WithPoked (TMaybe.M mn), + HeteroParList.ToListWithCM' WithPoked TMaybe.M qcis, + AllocationCallbacks.ToMiddle mac ) => + PhysicalDevice.P -> CreateInfo mn qcis -> + TPMaybe.M (U2 AllocationCallbacks.A) mac -> + (forall s . D s -> IO a) -> IO a +create pd (createInfoToMiddle -> ci) (AllocationCallbacks.toMiddle -> mac) f = + bracket (M.create pd ci mac) (`M.destroy` mac) (f . D) + +getQueue :: D sd -> QueueFamily.Index -> Queue.Index -> IO Queue.Q +getQueue (D d) (QueueFamily.Index qfi) qi = M.getQueue d qfi qi + +waitIdle :: D s -> IO () +waitIdle (D d) = M.waitIdle d + +data CreateInfo mn qcis = CreateInfo { + createInfoNext :: TMaybe.M mn, + createInfoFlags :: M.CreateFlags, + createInfoQueueCreateInfos :: HeteroParList.PL M.QueueCreateInfo qcis, + createInfoEnabledLayerNames :: [LayerName], + createInfoEnabledExtensionNames :: [PhysicalDevice.ExtensionName], + createInfoEnabledFeatures :: Maybe PhysicalDevice.Features } + +deriving instance ( + Show (TMaybe.M mn), Show (HeteroParList.PL M.QueueCreateInfo qcis) ) => + Show (CreateInfo mn qcis) + +createInfoToMiddle :: CreateInfo mn qcis -> M.CreateInfo mn qcis +createInfoToMiddle CreateInfo { + createInfoNext = nxt, + createInfoFlags = flgs, + createInfoQueueCreateInfos = qcis, + createInfoEnabledLayerNames = ((\(LayerName ln) -> ln) <$>) -> elnms, + createInfoEnabledExtensionNames = + ((\(PhysicalDevice.ExtensionName en) -> en) <$>) ->eenms, + createInfoEnabledFeatures = mef } = M.CreateInfo { + M.createInfoNext = nxt, + M.createInfoFlags = flgs, + M.createInfoQueueCreateInfos = qcis, + M.createInfoEnabledLayerNames = elnms, + M.createInfoEnabledExtensionNames = eenms, + M.createInfoEnabledFeatures = mef } + +data Group ma sd k = Group + (TPMaybe.M (U2 AllocationCallbacks.A) ma) TSem (TVar (Map.Map k (D sd))) + +group :: AllocationCallbacks.ToMiddle ma => + TPMaybe.M (U2 AllocationCallbacks.A) ma -> + (forall sd . Group ma sd k -> IO a) -> IO a +group mac@(AllocationCallbacks.toMiddle -> mmac) f = do + (sem, m) <- atomically $ (,) <$> newTSem 1 <*> newTVar Map.empty + rtn <- f $ Group mac sem m + ((\(D d) -> M.destroy d mmac) `mapM_`) =<< atomically (readTVar m) + pure rtn + +create' :: ( + Ord k, WithPoked (TMaybe.M mn), + HeteroParList.ToListWithCM' WithPoked TMaybe.M qcis, + AllocationCallbacks.ToMiddle ma ) => PhysicalDevice.P -> + Group ma sd k -> k -> CreateInfo mn qcis -> IO (Either String (D sd)) +create' phd (Group + (AllocationCallbacks.toMiddle -> mmac) sem ds) k + (createInfoToMiddle -> ci) = do + ok <- atomically do + mx <- Map.lookup k <$> readTVar ds + case mx of + Nothing -> waitTSem sem >> pure True + Just _ -> pure False + if ok + then do d <- M.create phd ci mmac + let d' = D d + atomically $ modifyTVar ds (Map.insert k d') >> signalTSem sem + pure $ Right d' + else pure . Left $ "Gpu.Vulkan.Device.create': The key already exist" + +unsafeDestroy :: (Ord k, AllocationCallbacks.ToMiddle ma) => + Group ma sd k -> k -> IO (Either String ()) +unsafeDestroy (Group + (AllocationCallbacks.toMiddle -> ma) sem ds) k = do + md <- atomically do + mx <- Map.lookup k <$> readTVar ds + case mx of + Nothing -> pure Nothing + Just _ -> waitTSem sem >> pure mx + case md of + Nothing -> pure $ Left "Gpu.Vulkan.Device.unsafaDestroy: No such key" + Just (D d) -> do + M.destroy d ma + atomically do + modifyTVar ds $ Map.delete k + signalTSem sem + pure $ Right () + +lookup :: Ord k => Group ma sd k -> k -> IO (Maybe (D sd)) +lookup (Group _ _sem ds) k = atomically $ Map.lookup k <$> readTVar ds diff --git a/src/Gpu/Vulkan/Device/Type.hs b/src/Gpu/Vulkan/Device/Type.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Device/Type.hs @@ -0,0 +1,7 @@ +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Device.Type where + +import qualified Gpu.Vulkan.Device.Middle as M + +newtype D s = D M.D deriving Show diff --git a/src/Gpu/Vulkan/Enum.hs b/src/Gpu/Vulkan/Enum.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Enum.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE PackageImports #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Enum (module Gpu.Vulkan.Enum) where + +import "gpu-vulkan-middle" Gpu.Vulkan.Enum diff --git a/src/Gpu/Vulkan/Exception.hs b/src/Gpu/Vulkan/Exception.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Exception.hs @@ -0,0 +1,12 @@ +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Exception ( + + MultiResult(..), + + module Gpu.Vulkan.Exception.Enum + + ) where + +import Gpu.Vulkan.Exception.Middle +import Gpu.Vulkan.Exception.Enum diff --git a/src/Gpu/Vulkan/Exception/Enum.hs b/src/Gpu/Vulkan/Exception/Enum.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Exception/Enum.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE PackageImports #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Exception.Enum (module Gpu.Vulkan.Exception.Enum) where + +import "gpu-vulkan-middle" Gpu.Vulkan.Exception.Enum diff --git a/src/Gpu/Vulkan/Fence.hs b/src/Gpu/Vulkan/Fence.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Fence.hs @@ -0,0 +1,25 @@ +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Fence ( + + -- * CREATE + + create, F, CreateInfo(..), + + -- ** Group + + group, Group, create', unsafeDestroy, lookup, + + -- * WAIT FOR FENCES AND RESET FENCES + + waitForFs, resetFs, + + -- * ENUM + + module Gpu.Vulkan.Fence.Enum + + ) where + +import Prelude hiding (lookup) +import Gpu.Vulkan.Fence.Internal +import Gpu.Vulkan.Fence.Enum diff --git a/src/Gpu/Vulkan/Fence/Enum.hs b/src/Gpu/Vulkan/Fence/Enum.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Fence/Enum.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE PackageImports #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Fence.Enum (module Gpu.Vulkan.Fence.Enum) where + +import "gpu-vulkan-middle" Gpu.Vulkan.Fence.Enum diff --git a/src/Gpu/Vulkan/Fence/Internal.hs b/src/Gpu/Vulkan/Fence/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Fence/Internal.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Fence.Internal ( + + -- * CREATE + + create, F(..), M.CreateInfo(..), + + -- ** Group + + group, Group, create', unsafeDestroy, lookup, + + -- * WAIT FOR FENCES AND RESET FENCES + + waitForFs, resetFs + + ) where + +import Prelude hiding (lookup) +import Foreign.Storable.PeekPoke +import Control.Concurrent.STM +import Control.Concurrent.STM.TSem +import Control.Exception +import Data.TypeLevel.Maybe qualified as TMaybe +import Data.TypeLevel.ParMaybe qualified as TPMaybe +import Data.TypeLevel.Tuple.Uncurry +import Data.HeteroParList qualified as HeteroParList +import Data.Map qualified as Map +import Data.Word +import Data.Time + +import Gpu.Vulkan.Fence.Type + +import qualified Gpu.Vulkan.Device.Type as Device +import qualified Gpu.Vulkan.AllocationCallbacks as AllocationCallbacks +import qualified Gpu.Vulkan.AllocationCallbacks.Type as AllocationCallbacks +import qualified Gpu.Vulkan.Fence.Middle as M + +create :: (WithPoked (TMaybe.M mn), AllocationCallbacks.ToMiddle mac) => + Device.D sd -> M.CreateInfo mn -> + TPMaybe.M (U2 AllocationCallbacks.A) mac -> + (forall s . F s -> IO a) -> IO a +create (Device.D dvc) ci (AllocationCallbacks.toMiddle -> mac) f = + bracket (M.create dvc ci mac) (\fnc -> M.destroy dvc fnc mac) (f . F) + +waitForFs :: Device.D sd -> HeteroParList.PL F sfs -> Bool -> Maybe DiffTime -> IO () +waitForFs (Device.D dvc) fs wa (maybe maxBound diffTimeToNanoseconds -> to) = + M.waitForFs dvc (HeteroParList.toList (\(F f) -> f) fs) wa to + +resetFs :: Device.D sd -> HeteroParList.PL F sfs -> IO () +resetFs (Device.D dvc) = M.resetFs dvc . HeteroParList.toList \(F f) -> f + +diffTimeToNanoseconds :: DiffTime -> Word64 +diffTimeToNanoseconds = fromInteger . (`div` 1000) . diffTimeToPicoseconds + +data Group sd ma sf k = Group (Device.D sd) + (TPMaybe.M (U2 AllocationCallbacks.A) ma) TSem (TVar (Map.Map k (F sf))) + +group :: AllocationCallbacks.ToMiddle ma => + Device.D sd -> TPMaybe.M (U2 AllocationCallbacks.A) ma -> + (forall sf . Group sd ma sf k -> IO a) -> IO a +group dvc@(Device.D mdvc) mac@(AllocationCallbacks.toMiddle -> mmac) f = do + (sem, m) <- atomically $ (,) <$> newTSem 1 <*> newTVar Map.empty + rtn <- f $ Group dvc mac sem m + ((\(F s) -> M.destroy mdvc s mmac) `mapM_`) =<< atomically (readTVar m) + pure rtn + +create' :: ( + Ord k, WithPoked (TMaybe.M mn), AllocationCallbacks.ToMiddle ma) => + Group sd ma sf k -> k -> M.CreateInfo mn -> IO (Either String (F sf)) +create' (Group (Device.D mdvc) + (AllocationCallbacks.toMiddle -> mmac) sem sf) k ci = do + ok <- atomically do + mx <- Map.lookup k <$> readTVar sf + case mx of + Nothing -> waitTSem sem >> pure True + Just _ -> pure False + if ok + then do f <- M.create mdvc ci mmac + let f' = F f + atomically $ modifyTVar sf (Map.insert k f') >> signalTSem sem + pure $ Right f' + else pure . Left $ + "Gpu.Vulkan.Fence.Internal.create': The key already exist" + +unsafeDestroy :: ( + Ord k, AllocationCallbacks.ToMiddle ma) => + Group sd ma sf k -> k -> IO (Either String ()) +unsafeDestroy (Group (Device.D mdvc) + (AllocationCallbacks.toMiddle -> ma) sem fs) k = do + mf <- atomically do + mx <- Map.lookup k <$> readTVar fs + case mx of + Nothing -> pure Nothing + Just _ -> waitTSem sem >> pure mx + case mf of + Nothing -> pure $ Left + "Gpu.Vulkan.Fence.unsafeDestroy: No such key" + Just (F f) -> do + M.destroy mdvc f ma + atomically do + modifyTVar fs $ Map.delete k + signalTSem sem + pure $ Right () + +lookup :: Ord k => Group sd ma sf k -> k -> IO (Maybe (F sf)) +lookup (Group _ _ _sem fs) k = atomically $ Map.lookup k <$> readTVar fs diff --git a/src/Gpu/Vulkan/Fence/Type.hs b/src/Gpu/Vulkan/Fence/Type.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Fence/Type.hs @@ -0,0 +1,7 @@ +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Fence.Type where + +import qualified Gpu.Vulkan.Fence.Middle as M + +newtype F sf = F M.F deriving Show diff --git a/src/Gpu/Vulkan/Framebuffer.hs b/src/Gpu/Vulkan/Framebuffer.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Framebuffer.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds, PolyKinds #-} +{-# LANGUAGE KindSignatures, TypeOperators #-} +{-# LANGUAGE FlexibleContexts, UndecidableInstances #-} +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Framebuffer ( + + -- * CREATE + + create, unsafeRecreate, F, CreateInfo(..), + + -- ** Group + + group, Group, create', unsafeDestroy, lookup, + + -- * ENUM + + module Gpu.Vulkan.Framebuffer.Enum + + ) where + +import Prelude hiding (lookup) +import Foreign.Storable.PeekPoke +import Control.Concurrent.STM +import Control.Concurrent.STM.TSem +import Control.Exception +import Data.TypeLevel.Tuple.Uncurry +import Data.TypeLevel.Maybe qualified as TMaybe +import Data.TypeLevel.ParMaybe qualified as TPMaybe +import Data.HeteroParList qualified as HeteroParList +import Data.Map qualified as Map +import Data.Word + +import Gpu.Vulkan.Framebuffer.Enum +import Gpu.Vulkan.Framebuffer.Type + +import qualified Gpu.Vulkan.AllocationCallbacks as AllocationCallbacks +import qualified Gpu.Vulkan.AllocationCallbacks.Type as AllocationCallbacks +import qualified Gpu.Vulkan.Device.Type as Device +import qualified Gpu.Vulkan.RenderPass.Type as RenderPass +import qualified Gpu.Vulkan.ImageView as ImageView +import qualified Gpu.Vulkan.ImageView.Type as ImageView +import qualified Gpu.Vulkan.Framebuffer.Middle as M + +data CreateInfo mn sr aargs = CreateInfo { + createInfoNext :: TMaybe.M mn, + createInfoFlags :: CreateFlags, + createInfoRenderPass :: RenderPass.R sr, + createInfoAttachments :: HeteroParList.PL (U3 ImageView.I) aargs, + createInfoWidth :: Word32, + createInfoHeight :: Word32, + createInfoLayers :: Word32 } + +type family MapThird (t :: [(j, k, l)]) where + MapThird '[] = '[] + MapThird ('(a, b, c) ': abcs) = c ': MapThird abcs + +createInfoToMiddle :: CreateInfo n sr fmtmnsis -> M.CreateInfo n +createInfoToMiddle CreateInfo { + createInfoNext = mnxt, + createInfoFlags = flgs, + createInfoRenderPass = RenderPass.R rp, + createInfoAttachments = HeteroParList.toList (\(U3 (ImageView.I iv)) -> iv) -> ivs, + createInfoWidth = w, + createInfoHeight = h, + createInfoLayers = lyrs } = M.CreateInfo { + M.createInfoNext = mnxt, + M.createInfoFlags = flgs, + M.createInfoRenderPass = rp, + M.createInfoAttachments = ivs, + M.createInfoWidth = w, + M.createInfoHeight = h, + M.createInfoLayers = lyrs } + +create :: (WithPoked (TMaybe.M mn), AllocationCallbacks.ToMiddle mac) => + Device.D sd -> CreateInfo mn sr aargs -> + TPMaybe.M (U2 AllocationCallbacks.A) mac -> + (forall s . F s -> IO a) -> IO a +create (Device.D dvc) ci + (AllocationCallbacks.toMiddle -> macc) f = bracket + (M.create dvc (createInfoToMiddle ci) macc) + (\fb -> M.destroy dvc fb macc) (f . F) + +unsafeRecreate :: (WithPoked (TMaybe.M mn), AllocationCallbacks.ToMiddle mac) => + Device.D sd -> CreateInfo mn sr aargs -> + TPMaybe.M (U2 AllocationCallbacks.A) mac -> + F sf -> IO () +unsafeRecreate (Device.D dvc) ci + (AllocationCallbacks.toMiddle -> macc) (F fb) = + M.recreate dvc (createInfoToMiddle ci) macc macc fb + +data Group sd ma sf k = Group (Device.D sd) + (TPMaybe.M (U2 AllocationCallbacks.A) ma) TSem (TVar (Map.Map k (F sf))) + +group :: AllocationCallbacks.ToMiddle ma => + Device.D sd -> TPMaybe.M (U2 AllocationCallbacks.A) ma -> + (forall sf . Group sd ma sf k -> IO a) -> IO a +group dvc@(Device.D mdvc) mac@(AllocationCallbacks.toMiddle -> mmac) f = do + (sem, m) <- atomically $ (,) <$> newTSem 1 <*> newTVar Map.empty + rtn <- f $ Group dvc mac sem m + ((\(F ff) -> M.destroy mdvc ff mmac) `mapM_`) =<< atomically (readTVar m) + pure rtn + +create' :: ( + Ord k, WithPoked (TMaybe.M mn), AllocationCallbacks.ToMiddle ma) => + Group sd ma sf k -> k -> CreateInfo mn sr aargs -> IO (Either String (F sf)) +create' (Group (Device.D mdvc) + (AllocationCallbacks.toMiddle -> mmac) sem sf) k + (createInfoToMiddle -> ci) = do + ok <- atomically do + mx <- Map.lookup k <$> readTVar sf + case mx of + Nothing -> waitTSem sem >> pure True + Just _ -> pure False + if ok + then do f <- M.create mdvc ci mmac + let f' = F f + atomically $ modifyTVar sf (Map.insert k f') >> signalTSem sem + pure $ Right f' + else pure . Left $ + "Gpu.Vulkan.Framebuffer.create': The key already exist" + +unsafeDestroy :: (Ord k, AllocationCallbacks.ToMiddle ma) => + Group sd ma sf k -> k -> IO (Either String ()) +unsafeDestroy (Group (Device.D mdvc) + (AllocationCallbacks.toMiddle -> ma) sem fs) k = do + mf <- atomically do + mx <- Map.lookup k <$> readTVar fs + case mx of + Nothing -> pure Nothing + Just _ -> waitTSem sem >> pure mx + case mf of + Nothing -> pure $ Left + "Gpu.Vulkan.Framebuffer.unsafeDestroy: No such key" + Just (F f) -> do + M.destroy mdvc f ma + atomically do + modifyTVar fs $ Map.delete k + signalTSem sem + pure $ Right () + +lookup :: Ord k => Group sd ma sf k -> k -> IO (Maybe (F sf)) +lookup (Group _ _ _sem fs) k = atomically $ Map.lookup k <$> readTVar fs diff --git a/src/Gpu/Vulkan/Framebuffer/Enum.hs b/src/Gpu/Vulkan/Framebuffer/Enum.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Framebuffer/Enum.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE PackageImports #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Framebuffer.Enum (module Gpu.Vulkan.Framebuffer.Enum) where + +import "gpu-vulkan-middle" Gpu.Vulkan.Framebuffer.Enum diff --git a/src/Gpu/Vulkan/Framebuffer/Type.hs b/src/Gpu/Vulkan/Framebuffer/Type.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Framebuffer/Type.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Framebuffer.Type where + +import qualified Gpu.Vulkan.Framebuffer.Middle as M + +newtype F s = F M.F diff --git a/src/Gpu/Vulkan/Image.hs b/src/Gpu/Vulkan/Image.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Image.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE ScopedTypeVariables, RankNTypes, TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds, PolyKinds #-} +{-# LANGUAGE KindSignatures, TypeOperators #-} +{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-} +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Image ( + + -- * CREATE + + create, unsafeRecreate, unsafeRecreate', I, Binded, CreateInfo(..), + + -- ** Manage Multiple Image + + Group, group, create', unsafeDestroy, lookup, + + -- * GET MEMORY REQUIREMENTS + + getMemoryRequirements, getMemoryRequirementsBinded, + + -- * MEMORY BARRIER + + MemoryBarrier(..), SubresourceRange(..), MemoryBarrierListToMiddle, + + -- * BLIT + + Blit(..), SubresourceLayers(..), + + -- * ENUM + + module Gpu.Vulkan.Image.Enum + + ) where + +import Prelude hiding (lookup) +import Gpu.Vulkan.Image.Internal +import Gpu.Vulkan.Image.Enum diff --git a/src/Gpu/Vulkan/Image/Enum.hs b/src/Gpu/Vulkan/Image/Enum.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Image/Enum.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE PackageImports #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Image.Enum (module Gpu.Vulkan.Image.Enum) where + +import "gpu-vulkan-middle" Gpu.Vulkan.Image.Enum diff --git a/src/Gpu/Vulkan/Image/Internal.hs b/src/Gpu/Vulkan/Image/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Image/Internal.hs @@ -0,0 +1,219 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE ScopedTypeVariables, RankNTypes, TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds, PolyKinds #-} +{-# LANGUAGE KindSignatures, TypeOperators #-} +{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-} +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Image.Internal ( + + -- * CREATE + + create, unsafeRecreate, unsafeRecreate', + I(..), Binded(..), CreateInfo(..), + + -- ** Manage Destruction + + Group, group, create', unsafeDestroy, lookup, + + -- * GET MEMORY REQUIREMENTS + + getMemoryRequirements, getMemoryRequirementsBinded, + + -- * MEMORY BARRIER + + MemoryBarrier(..), M.SubresourceRange(..), + MemoryBarrierListToMiddle(..), + + -- * BLIT + + M.Blit(..), M.SubresourceLayers(..) + + ) where + +import Prelude hiding (lookup) +import GHC.TypeLits +import Foreign.Storable.PeekPoke +import Control.Exception +import Data.Kind +import Data.TypeLevel.Tuple.Uncurry +import Data.TypeLevel.Tuple.MapIndex qualified as TMapIndex +import Data.TypeLevel.Maybe qualified as TMaybe +import Data.TypeLevel.ParMaybe qualified as TPMaybe +import qualified Data.HeteroParList as HeteroParList +import Data.HeteroParList (pattern (:**)) +import Data.Word + +import Gpu.Vulkan.Middle +import Gpu.Vulkan.Enum +import Gpu.Vulkan.Image.Type +import Gpu.Vulkan.Image.Enum hiding (Type) + +import qualified Gpu.Vulkan.TypeEnum as T +import qualified Gpu.Vulkan.AllocationCallbacks as AllocationCallbacks +import qualified Gpu.Vulkan.AllocationCallbacks.Type as AllocationCallbacks +import qualified Gpu.Vulkan.QueueFamily.Middle as QueueFamily +import qualified Gpu.Vulkan.Device.Type as Device +import qualified Gpu.Vulkan.Memory.Middle as Memory +import qualified Gpu.Vulkan.Image.Middle as M +import qualified Gpu.Vulkan.Sample.Enum as Sample +import qualified Gpu.Vulkan.Image.Enum as I + +create :: ( + WithPoked (TMaybe.M mn), T.FormatToValue fmt, + AllocationCallbacks.ToMiddle mac ) => + Device.D sd -> CreateInfo mn fmt -> + TPMaybe.M (U2 AllocationCallbacks.A) mac -> + (forall s . I s nm fmt -> IO a) -> IO a +create (Device.D mdvc) ci (AllocationCallbacks.toMiddle -> macd) f = bracket + (M.create mdvc (createInfoToMiddle ci) macd) + (\i -> M.destroy mdvc i macd) + (f .I) + +data Group sd ma s k nm fmt = Group + (Device.D sd) (TPMaybe.M (U2 AllocationCallbacks.A) ma) (M.Group s k) + +group :: AllocationCallbacks.ToMiddle mac => + Device.D sd -> TPMaybe.M (U2 AllocationCallbacks.A) mac -> + (forall s . Group sd mac s k nm fmt -> IO a) -> IO a +group dvc@(Device.D mdvc) ma@(AllocationCallbacks.toMiddle -> mac) f = + M.group mdvc mac (f . Group dvc ma) + +create' :: ( + Ord k, WithPoked (TMaybe.M mn), T.FormatToValue fmt, + AllocationCallbacks.ToMiddle mac ) => + Group sd mac sm k nm fmt -> k -> CreateInfo mn fmt -> + IO (Either String (I sm nm fmt)) +create' (Group (Device.D mdvc) (AllocationCallbacks.toMiddle -> macd) mngr) k ci = + (I <$>) <$> M.create' mdvc mngr k (createInfoToMiddle ci) macd + +unsafeDestroy :: (Ord k, AllocationCallbacks.ToMiddle mac) => + Group sd mac sm k nm fmt -> k -> IO (Either String ()) +unsafeDestroy (Group (Device.D mdvc) (AllocationCallbacks.toMiddle -> mac) mngr) k = + M.destroy' mdvc mngr k mac + +lookup :: Ord k => Group sd ma smng k nm fmt -> k -> IO (Maybe (I smng nm fmt)) +lookup (Group _ _ mng) k = (I <$>) <$> M.lookup mng k + +unsafeRecreate :: ( + WithPoked (TMaybe.M mn), AllocationCallbacks.ToMiddle mac, + T.FormatToValue fmt ) => + Device.D sd -> CreateInfo mn fmt -> + TPMaybe.M (U2 AllocationCallbacks.A) mac -> + Binded sm si nm fmt -> IO () +unsafeRecreate (Device.D mdvc) ci + (AllocationCallbacks.toMiddle -> macc) (Binded i) = + M.recreate mdvc (createInfoToMiddle ci) macc macc i + +unsafeRecreate' :: ( + WithPoked (TMaybe.M mn), AllocationCallbacks.ToMiddle mac, + T.FormatToValue fmt ) => + Device.D sd -> CreateInfo mn fmt -> + TPMaybe.M (U2 AllocationCallbacks.A) mac -> + Binded sm si nm fmt -> IO a -> IO () +unsafeRecreate' (Device.D mdvc) ci + (AllocationCallbacks.toMiddle -> macc) (Binded i) = + M.recreate' mdvc (createInfoToMiddle ci) macc macc i + +getMemoryRequirements :: Device.D sd -> I si nm fmt -> IO Memory.Requirements +getMemoryRequirements (Device.D dvc) (I img) = + M.getMemoryRequirements dvc img + +getMemoryRequirementsBinded :: Device.D sd -> Binded sm si nm fmt -> IO Memory.Requirements +getMemoryRequirementsBinded (Device.D dvc) (Binded img) = + M.getMemoryRequirements dvc img + +data MemoryBarrier mn sm si nm fmt = MemoryBarrier { + memoryBarrierNext :: TMaybe.M mn, + memoryBarrierSrcAccessMask :: AccessFlags, + memoryBarrierDstAccessMask :: AccessFlags, + memoryBarrierOldLayout :: Layout, + memoryBarrierNewLayout :: Layout, + memoryBarrierSrcQueueFamilyIndex :: QueueFamily.Index, + memoryBarrierDstQueueFamilyIndex :: QueueFamily.Index, + memoryBarrierImage :: Binded sm si nm fmt, + memoryBarrierSubresourceRange :: M.SubresourceRange } + +memoryBarrierToMiddle :: MemoryBarrier n si sm nm fmt -> M.MemoryBarrier n +memoryBarrierToMiddle MemoryBarrier { + memoryBarrierNext = mnxt, + memoryBarrierSrcAccessMask = sam, + memoryBarrierDstAccessMask = dam, + memoryBarrierOldLayout = olyt, + memoryBarrierNewLayout = nlyt, + memoryBarrierSrcQueueFamilyIndex = sqfi, + memoryBarrierDstQueueFamilyIndex = dqfi, + memoryBarrierImage = Binded img, + memoryBarrierSubresourceRange = srr } = M.MemoryBarrier { + M.memoryBarrierNext = mnxt, + M.memoryBarrierSrcAccessMask = sam, + M.memoryBarrierDstAccessMask = dam, + M.memoryBarrierOldLayout = olyt, + M.memoryBarrierNewLayout = nlyt, + M.memoryBarrierSrcQueueFamilyIndex = sqfi, + M.memoryBarrierDstQueueFamilyIndex = dqfi, + M.memoryBarrierImage = img, + M.memoryBarrierSubresourceRange = srr } + +class MemoryBarrierListToMiddle + (mbargs :: [(Maybe Type, Type, Type, Symbol, T.Format)]) where + memoryBarrierListToMiddle :: + HeteroParList.PL (U5 MemoryBarrier) mbargs -> + HeteroParList.PL M.MemoryBarrier (TMapIndex.M0_5 mbargs) + +instance MemoryBarrierListToMiddle '[] where + memoryBarrierListToMiddle HeteroParList.Nil = HeteroParList.Nil + +instance MemoryBarrierListToMiddle mbargs => + MemoryBarrierListToMiddle ('(mn, si, sm, nm, fmt) ': mbargs) where + memoryBarrierListToMiddle (U5 mb :** mbs) = + memoryBarrierToMiddle mb :** memoryBarrierListToMiddle mbs + +data CreateInfo mn (fmt :: T.Format) = CreateInfo { + createInfoNext :: TMaybe.M mn, + createInfoFlags :: CreateFlags, + createInfoImageType :: I.Type, + createInfoExtent :: Extent3d, + createInfoMipLevels :: Word32, + createInfoArrayLayers :: Word32, + createInfoSamples :: Sample.CountFlagBits, + createInfoTiling :: Tiling, + createInfoUsage :: UsageFlags, + createInfoSharingMode :: SharingMode, + createInfoQueueFamilyIndices :: [Word32], + createInfoInitialLayout :: Layout } + +deriving instance Show (TMaybe.M mn) => Show (CreateInfo mn fmt) + +createInfoToMiddle :: forall n fmt . + T.FormatToValue fmt => CreateInfo n fmt -> M.CreateInfo n +createInfoToMiddle CreateInfo { + createInfoNext = mnxt, + createInfoFlags = flgs, + createInfoImageType = itp, + createInfoExtent = ext, + createInfoMipLevels = mls, + createInfoArrayLayers = als, + createInfoSamples = smps, + createInfoTiling = tl, + createInfoUsage = usg, + createInfoSharingMode = sm, + createInfoQueueFamilyIndices = qfis, + createInfoInitialLayout =ilyt } = M.CreateInfo { + M.createInfoNext = mnxt, + M.createInfoFlags = flgs, + M.createInfoImageType = itp, + M.createInfoFormat = T.formatToValue @fmt, + M.createInfoExtent = ext, + M.createInfoMipLevels = mls, + M.createInfoArrayLayers = als, + M.createInfoSamples = smps, + M.createInfoTiling = tl, + M.createInfoUsage = usg, + M.createInfoSharingMode = sm, + M.createInfoQueueFamilyIndices = qfis, + M.createInfoInitialLayout = ilyt } diff --git a/src/Gpu/Vulkan/Image/Type.hs b/src/Gpu/Vulkan/Image/Type.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Image/Type.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Image.Type where + +import GHC.TypeLits + +import qualified Gpu.Vulkan.TypeEnum as T +import qualified Gpu.Vulkan.Image.Middle as M + +newtype I s (nm :: Symbol) (fmt :: T.Format) = I M.I + +newtype Binded sm si (nm :: Symbol) (fmt :: T.Format) = Binded M.I diff --git a/src/Gpu/Vulkan/ImageView.hs b/src/Gpu/Vulkan/ImageView.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/ImageView.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE ScopedTypeVariables, RankNTypes, TypeApplications #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.ImageView ( + + -- * CREATE + + create, unsafeRecreate, unsafeRecreate', I, CreateInfo(..), + + -- ** Manage Multiple Image View + + group, create', unsafeDestroy, lookup, Group, + + -- * ENUM + + module Gpu.Vulkan.ImageView.Enum + + ) where + +import Prelude hiding (lookup) +import GHC.TypeLits +import Foreign.Storable.PeekPoke +import Control.Exception +import Data.TypeLevel.Maybe qualified as TMaybe +import Data.TypeLevel.ParMaybe qualified as TPMaybe +import Data.TypeLevel.Tuple.Uncurry + +import Gpu.Vulkan.ImageView.Type +import Gpu.Vulkan.ImageView.Enum + +import qualified Gpu.Vulkan.TypeEnum as T +import qualified Gpu.Vulkan.AllocationCallbacks as AllocationCallbacks +import qualified Gpu.Vulkan.AllocationCallbacks.Type as AllocationCallbacks +import qualified Gpu.Vulkan.Device.Type as Device +import qualified Gpu.Vulkan.Component as Component +import qualified Gpu.Vulkan.Image.Type as Image +import qualified Gpu.Vulkan.Image.Middle as Image.M +import qualified Gpu.Vulkan.ImageView.Middle as M + +data CreateInfo n sm si nm ifmt (ivfmt :: T.Format) = CreateInfo { + createInfoNext :: TMaybe.M n, + createInfoFlags :: CreateFlags, + createInfoImage :: Image.Binded sm si nm ifmt, + createInfoViewType :: Type, + createInfoComponents :: Component.Mapping, + createInfoSubresourceRange :: Image.M.SubresourceRange } + +createInfoToMiddle :: forall n si sm nm ifmt ivfmt . T.FormatToValue ivfmt => + CreateInfo n si sm nm ifmt ivfmt -> M.CreateInfo n +createInfoToMiddle CreateInfo { + createInfoNext = mnxt, + createInfoFlags = flgs, + createInfoImage = Image.Binded img, + createInfoViewType = tp, + createInfoComponents = cps, + createInfoSubresourceRange = srr } = M.CreateInfo { + M.createInfoNext = mnxt, + M.createInfoFlags = flgs, + M.createInfoImage = img, + M.createInfoViewType = tp, + M.createInfoFormat = fmt, + M.createInfoComponents = cps, + M.createInfoSubresourceRange = srr } + where fmt = T.formatToValue @ivfmt + +create :: ( + WithPoked (TMaybe.M mn), T.FormatToValue ivfmt, + AllocationCallbacks.ToMiddle mac ) => + Device.D sd -> CreateInfo mn sm si nm ifmt ivfmt -> + TPMaybe.M (U2 AllocationCallbacks.A) mac -> + (forall s . I nm ivfmt s -> IO a) -> IO a +create (Device.D d) ci (AllocationCallbacks.toMiddle -> mac) f = bracket + (M.create d (createInfoToMiddle ci) mac) + (\i -> M.destroy d i mac) (f . I) + +group :: + AllocationCallbacks.ToMiddle ma => + Device.D sd -> TPMaybe.M (U2 AllocationCallbacks.A) ma -> + (forall s . Group sd ma s k nm ivfmt -> IO a) -> IO a +group dvc@(Device.D d) ma@(AllocationCallbacks.toMiddle -> mac) f = + M.group d mac $ f . Group dvc ma + +data Group sd ma s k (nm :: Symbol) (ivfmt :: T.Format) = Group + (Device.D sd) (TPMaybe.M (U2 AllocationCallbacks.A) ma) (M.Group s k) + +create' :: ( + Ord k, WithPoked (TMaybe.M mn), T.FormatToValue ivfmt, + AllocationCallbacks.ToMiddle ma ) => + Group sd ma smng k nm ivfmt -> k -> + CreateInfo mn sm si nm ifmt ivfmt -> + IO (Either String (I nm ivfmt smng)) +create' (Group (Device.D d) + (AllocationCallbacks.toMiddle -> mac) mng) k ci = + (I <$>) <$> M.create' d mng k (createInfoToMiddle ci) mac + +unsafeDestroy :: (Ord k, AllocationCallbacks.ToMiddle ma) => + Group sd ma sm k nm ivfmt -> k -> IO (Either String ()) +unsafeDestroy (Group (Device.D d) + (AllocationCallbacks.toMiddle -> mac) mng) k = + M.destroy' d mng k mac + +lookup :: Ord k => Group sd ma smng k nm ivfmt -> k -> IO (Maybe (I nm ivfmt smng)) +lookup (Group _ _ mng) k = (I <$>) <$> M.lookup mng k + +unsafeRecreate :: ( + WithPoked (TMaybe.M mn), T.FormatToValue ivfmt, + AllocationCallbacks.ToMiddle mac ) => + Device.D sd -> CreateInfo mn sm si nm ifmt ivfmt -> + TPMaybe.M (U2 AllocationCallbacks.A) mac -> I nm ivfmt siv -> IO () +unsafeRecreate (Device.D d) ci + (AllocationCallbacks.toMiddle -> mac) (I i) = + M.recreate d (createInfoToMiddle ci) mac mac i + +unsafeRecreate' :: ( + WithPoked (TMaybe.M mn), T.FormatToValue ivfmt, + AllocationCallbacks.ToMiddle mac ) => + Device.D sd -> CreateInfo mn sm si nm ifmt ivfmt -> + TPMaybe.M (U2 AllocationCallbacks.A) mac -> I nm ivfmt siv -> IO a -> IO () +unsafeRecreate' (Device.D d) ci + (AllocationCallbacks.toMiddle -> mac) (I i) = + M.recreate' d (createInfoToMiddle ci) mac mac i diff --git a/src/Gpu/Vulkan/ImageView/Enum.hs b/src/Gpu/Vulkan/ImageView/Enum.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/ImageView/Enum.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE PackageImports #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.ImageView.Enum (module Gpu.Vulkan.ImageView.Enum) where + +import "gpu-vulkan-middle" Gpu.Vulkan.ImageView.Enum diff --git a/src/Gpu/Vulkan/ImageView/Type.hs b/src/Gpu/Vulkan/ImageView/Type.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/ImageView/Type.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE KindSignatures #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.ImageView.Type where + +import GHC.TypeLits + +import Gpu.Vulkan.TypeEnum as T +import Gpu.Vulkan.ImageView.Middle qualified as M + +newtype I (nm :: Symbol) (fmt :: T.Format) si = I M.I deriving Show diff --git a/src/Gpu/Vulkan/Instance.hs b/src/Gpu/Vulkan/Instance.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Instance.hs @@ -0,0 +1,16 @@ +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Instance ( + + -- * CREATE + + create, I, CreateInfo(..), ExtensionName(..), + + -- * ENUMERATE + + enumerateLayerProperties, + enumerateExtensionProperties, ExtensionProperties(..), + + ) where + +import Gpu.Vulkan.Instance.Internal diff --git a/src/Gpu/Vulkan/Instance/Internal.hs b/src/Gpu/Vulkan/Instance/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Instance/Internal.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Instance.Internal ( + + -- * CREATE + + create, I(..), CreateInfo(..), ExtensionName(..), + + -- * ENUMERATE + + enumerateLayerProperties, + enumerateExtensionProperties, ExtensionProperties(..), + + ) where + +import Foreign.Storable.PeekPoke +import Control.Exception +import Data.TypeLevel.Maybe qualified as TMaybe +import Data.TypeLevel.ParMaybe qualified as TPMaybe +import Data.TypeLevel.Tuple.Uncurry +import Data.Default + +import Gpu.Vulkan.Internal +import Gpu.Vulkan.Instance.Type + +import qualified Gpu.Vulkan.AllocationCallbacks as AllocationCallbacks +import qualified Gpu.Vulkan.AllocationCallbacks.Type as AllocationCallbacks +import Gpu.Vulkan.Instance.Enum +import qualified Gpu.Vulkan.Instance.Middle as M + +import Data.Text qualified as T +import Gpu.Vulkan.Middle qualified as M + +create :: ( + WithPoked (TMaybe.M mn), WithPoked (TMaybe.M ai), + AllocationCallbacks.ToMiddle mac ) => + CreateInfo mn ai -> + TPMaybe.M (U2 AllocationCallbacks.A) mac -> + (forall s . I s -> IO a) -> IO a +create (createInfoToMiddle -> ci) (AllocationCallbacks.toMiddle -> mac) f = + bracket (M.create ci mac) (`M.destroy` mac) (f . I) + +data CreateInfo mn ai = CreateInfo { + createInfoNext :: TMaybe.M mn, + createInfoFlags :: CreateFlags, + createInfoApplicationInfo :: Maybe (ApplicationInfo ai), + createInfoEnabledLayerNames :: [LayerName], + createInfoEnabledExtensionNames :: [ExtensionName] } + +newtype ExtensionName = ExtensionName { unExtensionName :: T.Text } + deriving (Show, Eq) + +deriving instance (Show (TMaybe.M mn), Show (TMaybe.M ai)) => + Show (CreateInfo mn ai) + +instance Default (CreateInfo 'Nothing a) where + def = CreateInfo { + createInfoNext = TMaybe.N, + createInfoFlags = CreateFlagsZero, + createInfoApplicationInfo = Nothing, + createInfoEnabledLayerNames = [], + createInfoEnabledExtensionNames = [] } + +createInfoToMiddle :: CreateInfo mn ai -> M.CreateInfo mn ai +createInfoToMiddle CreateInfo { + createInfoNext = nxt, + createInfoFlags = flgs, + createInfoApplicationInfo = ai, + createInfoEnabledLayerNames = lns, + createInfoEnabledExtensionNames = ens } = M.CreateInfo { + M.createInfoNext = nxt, + M.createInfoFlags = flgs, + M.createInfoApplicationInfo = ai, + M.createInfoEnabledLayerNames = unLayerName <$> lns, + M.createInfoEnabledExtensionNames = unExtensionName <$> ens } + +enumerateLayerProperties :: IO [LayerProperties] +enumerateLayerProperties = + (layerPropertiesFromMiddle <$>) <$> M.enumerateLayerProperties + +enumerateExtensionProperties :: + Maybe LayerName -> IO [ExtensionProperties] +enumerateExtensionProperties (((\(LayerName ln) -> ln) <$>) -> mln) = + (extensionPropertiesFromMiddle <$>) + <$> M.enumerateExtensionProperties mln + +data ExtensionProperties = ExtensionProperties { + extensionPropertiesExtensionName :: ExtensionName, + extensionPropertiesSpecVersion :: M.ApiVersion } + deriving Show + +extensionPropertiesFromMiddle :: M.ExtensionProperties -> ExtensionProperties +extensionPropertiesFromMiddle M.ExtensionProperties { + M.extensionPropertiesExtensionName = en, + M.extensionPropertiesSpecVersion = sv } = ExtensionProperties { + extensionPropertiesExtensionName = ExtensionName en, + extensionPropertiesSpecVersion = sv } diff --git a/src/Gpu/Vulkan/Instance/Type.hs b/src/Gpu/Vulkan/Instance/Type.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Instance/Type.hs @@ -0,0 +1,7 @@ +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Instance.Type (I(..)) where + +import qualified Gpu.Vulkan.Instance.Middle as M + +newtype I s = I { unI :: M.I } deriving Show diff --git a/src/Gpu/Vulkan/Internal.hs b/src/Gpu/Vulkan/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Internal.hs @@ -0,0 +1,201 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE BlockArguments, LambdaCase, OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-} +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Internal ( + + -- * INFO + + -- ** ApplicationINfo + + M.ApplicationInfo(..), + M.ApiVersion, M.makeApiVersion, M.apiVersion_1_0, M.apiVersion_1_1, + + -- ** SubmitInfo + + SubmitInfo(..), + SubmitInfoListToMiddle(..), SemaphorePipelineStageFlags(..), + + -- * PROPERTIES + + LayerProperties(..), layerPropertiesFromMiddle, + M.FormatProperties(..), + + -- * NAME + + LayerName(..), layerKhronosValidation, + + -- * PIPELINE VALUES + + -- ** ViewPort + + M.Viewport, pattern M.Viewport, + M.viewportX, M.viewportY, M.viewportWidth, M.viewportHeight, + M.viewportMinDepth, M.viewportMaxDepth, + + -- ** StencilOpState + + M.StencilOpState(..), + + -- ** ClearValue + + M.ClearValue(..), M.ClearValueListToCore, + + -- *** ClearType + + M.ClearType(..), M.ClearColorType(..), + + -- *** ClearColorValue + + -- *** ClearDepthStencilValue + + M.ClearDepthStencilValue, pattern M.ClearDepthStencilValue, + M.clearDepthStencilValueDepth, M.clearDepthStencilValueStencil, + + -- * RECT, OFFSET AND EXTENT + + -- ** Rect + + M.Rect2d, pattern M.Rect2d, M.rect2dExtent, M.rect2dOffset, + + -- ** Offset + + M.Offset2d, pattern M.Offset2d, M.offset2dX, M.offset2dY, + M.Offset3d, pattern M.Offset3d, M.offset3dX, M.offset3dY, M.offset3dZ, + + -- ** Extent + + M.Extent2d, pattern M.Extent2d, + M.extent2dWidth, M.extent2dHeight, + + M.Extent3d, pattern M.Extent3d, + M.extent3dWidth, M.extent3dHeight, M.extent3dDepth, + + -- * OTHERS + + M.Size(..) + + ) where + +import Foreign.Storable.PeekPoke +import Data.Kind +import Data.TypeLevel.Maybe qualified as TMaybe +import Data.TypeLevel.Tuple.Uncurry +import Data.HeteroParList qualified as HeteroParList +import Data.HeteroParList (pattern (:**)) +import Data.Text qualified as T + +import qualified Gpu.Vulkan.Middle as M +import qualified Gpu.Vulkan.Semaphore.Type 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 + +data SubmitInfo n sss ss ssss = SubmitInfo { + submitInfoNext :: TMaybe.M n, + submitInfoWaitSemaphoreDstStageMasks :: + HeteroParList.PL SemaphorePipelineStageFlags sss, + submitInfoCommandBuffers :: HeteroParList.PL CommandBuffer.C ss, + submitInfoSignalSemaphores :: + HeteroParList.PL Semaphore.S ssss } + +class M.SubmitInfoListToCore (MiddleNextList ns3s2s4) => SubmitInfoListToMiddle + (ns3s2s4 :: [(Maybe Type, [Type], [Type], [Type])]) where + type MiddleNextList ns3s2s4 :: [Maybe Type] + submitInfoListToMiddle :: + HeteroParList.PL (U4 SubmitInfo) ns3s2s4 -> + HeteroParList.PL M.SubmitInfo (MiddleNextList ns3s2s4) + +instance SubmitInfoListToMiddle '[] where + type MiddleNextList '[] = '[] + submitInfoListToMiddle HeteroParList.Nil = HeteroParList.Nil + +instance ( + WithPoked (TMaybe.M n), + SubmitInfoListToMiddle nssvsss ) => + SubmitInfoListToMiddle ('(n, sss, svss, ssss) ': nssvsss) where + type MiddleNextList ('(n, sss, svss, ssss) ': nssvsss) = + n ': MiddleNextList nssvsss + submitInfoListToMiddle (U4 si :** sis) = + submitInfoToMiddle si :** submitInfoListToMiddle sis + +submitInfoToMiddle :: + SubmitInfo n sss svss ssss -> M.SubmitInfo n +submitInfoToMiddle SubmitInfo { + submitInfoNext = mnxt, + submitInfoWaitSemaphoreDstStageMasks = + semaphorePipelineStageFlagsToMiddle -> wsdsms, + submitInfoCommandBuffers = HeteroParList.toList (\x -> CommandBuffer.unC x) -> cbs, + submitInfoSignalSemaphores = + HeteroParList.toList (\(Semaphore.S s) -> s) -> ssmprs + } = M.SubmitInfo { + M.submitInfoNext = mnxt, + M.submitInfoWaitSemaphoreDstStageMasks = wsdsms, + M.submitInfoCommandBuffers = cbs, + M.submitInfoSignalSemaphores = ssmprs } + +data SemaphorePipelineStageFlags ss = + SemaphorePipelineStageFlags (Semaphore.S ss) Pipeline.StageFlags + deriving Show + +-- deriving instance (Show n, Show (HeteroParList SemaphorePipelineStageFlags sss)) => +-- Show (SubmitInfo n sss s vs) + +-- deriving instance Show (HeteroParList Semaphore.S ss) + +semaphorePipelineStageFlagsToMiddle :: + HeteroParList.PL SemaphorePipelineStageFlags sss -> + [(Semaphore.M.S, Pipeline.StageFlags)] +semaphorePipelineStageFlagsToMiddle = HeteroParList.toList + \(SemaphorePipelineStageFlags (Semaphore.S s) psfs) -> (s, psfs) + +class SemaphorePipelineStageFlagsFromMiddle sss where + semaphorePipelineStageFlagsFromMiddle :: + [(Semaphore.M.S, Pipeline.StageFlags)] -> + HeteroParList.PL SemaphorePipelineStageFlags sss + +instance SemaphorePipelineStageFlagsFromMiddle '[] where + semaphorePipelineStageFlagsFromMiddle = \case + [] -> HeteroParList.Nil + _ -> error $ + "semaphorePipelineStageFlagsFromMiddle @'[] xs: " ++ + "xs should be null" + +instance SemaphorePipelineStageFlagsFromMiddle sss => + SemaphorePipelineStageFlagsFromMiddle (ss ': sss) where + semaphorePipelineStageFlagsFromMiddle = \case + (s, psfs) : spsfss -> + SemaphorePipelineStageFlags (Semaphore.S s) psfs :** + semaphorePipelineStageFlagsFromMiddle spsfss + [] -> error $ + "semaphorePipelineStageFlagsFromMiddle " ++ + "@(ss ': sss) xs: xs should not be null" + +data LayerProperties = LayerProperties { + layerPropertiesLayerName :: LayerName, + layerPropertiesSpecVersion :: M.ApiVersion, + layerPropertiesImplementationVersion :: M.ApiVersion, + layerPropertiesDescription :: T.Text } + deriving Show + +layerPropertiesFromMiddle :: M.LayerProperties -> LayerProperties +layerPropertiesFromMiddle M.LayerProperties { + M.layerPropertiesLayerName = ln, + M.layerPropertiesSpecVersion = sv, + M.layerPropertiesImplementationVersion = iv, + M.layerPropertiesDescription = dsc } = LayerProperties { + layerPropertiesLayerName = LayerName ln, + layerPropertiesSpecVersion = sv, + layerPropertiesImplementationVersion = iv, + layerPropertiesDescription = dsc } + +newtype LayerName = LayerName { unLayerName :: T.Text } deriving (Show, Eq) + +layerKhronosValidation :: LayerName +layerKhronosValidation = LayerName "VK_LAYER_KHRONOS_validation" diff --git a/src/Gpu/Vulkan/Memory.hs b/src/Gpu/Vulkan/Memory.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Memory.hs @@ -0,0 +1,282 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE BlockArguments, LambdaCase, TupleSections #-} +{-# LANGUAGE ScopedTypeVariables, RankNTypes, TypeApplications #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures, TypeOperators #-} +{-# LANGUAGE MultiParamTypeClasses, AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-} +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Memory ( + + -- * ALLOCATE AND BIND + + allocateBind, unsafeReallocateBind, unsafeReallocateBind', + + -- ** Destruction Group + + Group, group, allocateBind', unsafeFree, lookup, + + -- ** MEMORY + + M, getBinded, ImageBuffer(..), ImageBufferBinded(..), ImageBufferArg(..), + + -- ** ALLOCATE INFO + + AllocateInfo(..), M.MType(..), M.TypeBits, M.TypeIndex, M.elemTypeIndex, + + -- ** BINDABLE AND REBINDABLE + + Bindable, Rebindable, + + -- * GET REQUREMENTS + + getRequirementsList, M.Requirements(..), + + -- * READ AND WRITE + + read, write, OffsetSize, + + -- * BARRIER + + M.Barrier(..), + + -- * ENUM + + module Gpu.Vulkan.Memory.Enum + + ) where + +import Prelude hiding (map, read, lookup) + +import Foreign.Ptr +import Foreign.Storable.PeekPoke +import Control.Concurrent.STM +import Control.Exception hiding (try) +import Gpu.Vulkan.Object qualified as VObj +import Data.TypeLevel.Maybe qualified as TMaybe +import Data.TypeLevel.ParMaybe qualified as TPMaybe +import Data.TypeLevel.Tuple.Uncurry +import Data.Maybe +import Data.Map qualified as Map +import Data.HeteroParList qualified as HeteroParList +import Data.IORef + +import qualified Gpu.Vulkan.AllocationCallbacks as AllocationCallbacks +import qualified Gpu.Vulkan.AllocationCallbacks.Type as AllocationCallbacks +import qualified Gpu.Vulkan.Device.Type as Device +import qualified Gpu.Vulkan.Device.Middle as Device.M +import qualified Gpu.Vulkan.Memory.Middle as M +import Gpu.Vulkan.Memory.Enum + +import Gpu.Vulkan.Memory.Bind +import Gpu.Vulkan.Memory.OffsetSize +import Gpu.Vulkan.Memory.Type +import Gpu.Vulkan.Memory.ImageBuffer + +import Control.Monad +import Debug + +-- ALLOCATE AND BIND + +-- Allocate Bind + +allocateBind :: ( + WithPoked (TMaybe.M mn), Bindable ibargs, + AllocationCallbacks.ToMiddle mac ) => + Device.D sd -> HeteroParList.PL (U2 ImageBuffer) ibargs -> + AllocateInfo mn -> TPMaybe.M (U2 AllocationCallbacks.A) mac -> + (forall s . HeteroParList.PL (U2 (ImageBufferBinded s)) ibargs -> + M s ibargs -> IO a) -> IO a +allocateBind dv ibs ai mac f = + allocate dv ibs ai mac \m -> (`f` m) =<< bindAll dv ibs m 0 + +allocate :: ( + WithPoked (TMaybe.M n), Alignments ibargs, + AllocationCallbacks.ToMiddle mac ) => + Device.D sd -> HeteroParList.PL (U2 ImageBuffer) ibargs -> + AllocateInfo n -> TPMaybe.M (U2 AllocationCallbacks.A) mac -> + (forall s . M s ibargs -> IO a) -> IO a +allocate dv@(Device.D mdv) ibs ai + (AllocationCallbacks.toMiddle -> mac) f = bracket + do mai <- allocateInfoToMiddle dv ibs ai + M.allocate mdv mai mac + (\m -> M.free mdv m mac) + \m -> f =<< newM ibs m + +group :: AllocationCallbacks.ToMiddle ma => + Device.D sd -> TPMaybe.M (U2 AllocationCallbacks.A) ma -> + (forall s . Group sd ma s k ibargs -> IO a) -> IO a +group dvc@(Device.D mdvc) ma@(AllocationCallbacks.toMiddle -> mac) f = + M.group mdvc mac \mmng -> do + ibargs <- atomically $ newTVar Map.empty + f $ Group dvc ma ibargs mmng + +allocateBind' :: ( + Ord k, + WithPoked (TMaybe.M mn), Bindable ibargs, + AllocationCallbacks.ToMiddle ma ) => + Group sd ma sm k ibargs -> k -> + HeteroParList.PL (U2 ImageBuffer) ibargs -> AllocateInfo mn -> + IO (Either String ( + HeteroParList.PL (U2 (ImageBufferBinded sm)) ibargs, + M sm ibargs)) +allocateBind' (Group dv mac mib mng) k ibs ai = do + allocate' dv mng k ibs ai mac >>= \case + Left msg -> pure $ Left msg + Right m -> do + rtn@(_, M iibs _) <- (, m) <$> bindAll dv ibs m 0 + atomically $ modifyTVar mib (Map.insert k iibs) + pure $ Right rtn + +allocate' :: ( + Ord k, + WithPoked (TMaybe.M n), Alignments ibargs, + AllocationCallbacks.ToMiddle mac ) => + Device.D sd -> M.Group sm k -> k -> + HeteroParList.PL (U2 ImageBuffer) ibargs -> + AllocateInfo n -> TPMaybe.M (U2 AllocationCallbacks.A) mac -> + IO (Either String (M sm ibargs)) +allocate' dv@(Device.D mdv) mng k ibs ai (AllocationCallbacks.toMiddle -> mac) = do + mai <- allocateInfoToMiddle dv ibs ai + (newM ibs `mapM`) =<< M.allocate' mdv mng k mai mac + +unsafeFree :: (Ord k, AllocationCallbacks.ToMiddle ma) => + Group sd ma smng k ibargs -> k -> IO (Either String ()) +unsafeFree (Group (Device.D mdv) (AllocationCallbacks.toMiddle -> mac) _ mng) k = + M.free' mdv mng k mac + +data Group sd ma s k ibargs = Group (Device.D sd) + (TPMaybe.M (U2 AllocationCallbacks.A) ma) + (TVar (Map.Map k (IORef (HeteroParList.PL (U2 ImageBuffer) ibargs)))) + (M.Group s k) + +lookup :: Ord k => + Group sd ma sm k ibargs -> k -> IO (Maybe (M s ibargs)) +lookup (Group _ _ ibargss mmng) k = do + mibargs <- atomically $ Map.lookup k <$> readTVar ibargss + mmem <- M.lookup mmng k + pure $ M <$> mibargs <*> mmem + +-- Reallocate Bind + +unsafeReallocateBind :: ( + WithPoked (TMaybe.M mn), Rebindable ibargs, + AllocationCallbacks.ToMiddle mac ) => + Device.D sd -> HeteroParList.PL (U2 (ImageBufferBinded sm)) ibargs -> + AllocateInfo mn -> TPMaybe.M (U2 AllocationCallbacks.A) mac -> + M sm ibargs -> IO () +unsafeReallocateBind dv ibs ai mac m = + reallocate dv ibs ai mac m >> rebindAll dv ibs m 0 + +unsafeReallocateBind' :: ( + WithPoked (TMaybe.M mn), Rebindable ibargs, + AllocationCallbacks.ToMiddle mac ) => + Device.D sd -> HeteroParList.PL (U2 (ImageBufferBinded sm)) ibargs -> + AllocateInfo mn -> TPMaybe.M (U2 AllocationCallbacks.A) mac -> + M sm ibargs -> IO a -> IO () +unsafeReallocateBind' dv ibs ai mac m act = + reallocate' dv ibs ai mac m $ rebindAll dv ibs m 0 >> act + +reallocate :: ( + WithPoked (TMaybe.M n), Alignments ibargs, + AllocationCallbacks.ToMiddle mac ) => + Device.D sd -> HeteroParList.PL (U2 (ImageBufferBinded sm)) ibargs -> + AllocateInfo n -> TPMaybe.M (U2 AllocationCallbacks.A) mac -> + M sm ibargs -> IO () +reallocate dv@(Device.D mdv) ibs ai (AllocationCallbacks.toMiddle -> mac) m = do + mai <- reallocateInfoToMiddle dv ibs ai + (_, mm) <- readM m + M.reallocate mdv mai mac mm + writeMBinded m ibs + +reallocate' :: ( + WithPoked (TMaybe.M n), Alignments ibargs, + AllocationCallbacks.ToMiddle mac ) => + Device.D sd -> HeteroParList.PL (U2 (ImageBufferBinded sm)) ibargs -> + AllocateInfo n -> TPMaybe.M (U2 AllocationCallbacks.A) mac -> + M sm ibargs -> IO a -> IO () +reallocate' dv@(Device.D mdv) ibs ai (AllocationCallbacks.toMiddle -> mac) m act = do + mai <- reallocateInfoToMiddle dv ibs ai + (_, mm) <- readM m + M.reallocate' mdv mai mac mm $ writeMBinded m ibs >> act + +-- Allocate Info + +data AllocateInfo mn = AllocateInfo { + allocateInfoNext :: TMaybe.M mn, + allocateInfoMemoryTypeIndex :: M.TypeIndex } + +deriving instance Show (TMaybe.M mn) => Show (AllocateInfo mn) +deriving instance Eq (TMaybe.M mn) => Eq (AllocateInfo mn) + +allocateInfoToMiddle :: forall sd ibargs mn . Alignments ibargs => + Device.D sd -> HeteroParList.PL (U2 ImageBuffer) ibargs -> + AllocateInfo mn -> IO (M.AllocateInfo mn) +allocateInfoToMiddle dv ibs AllocateInfo { + allocateInfoNext = mnxt, + allocateInfoMemoryTypeIndex = mti } = do + reqss <- getRequirementsList dv ibs + pure M.AllocateInfo { + M.allocateInfoNext = mnxt, + M.allocateInfoAllocationSize = memoryRequirementsListToSize + 0 (alignments @ibargs) reqss, + M.allocateInfoMemoryTypeIndex = mti } + +reallocateInfoToMiddle :: forall sd sm ibargs mn . Alignments ibargs => + Device.D sd -> HeteroParList.PL (U2 (ImageBufferBinded sm)) ibargs -> + AllocateInfo mn -> IO (M.AllocateInfo mn) +reallocateInfoToMiddle dv ibs AllocateInfo { + allocateInfoNext = mnxt, + allocateInfoMemoryTypeIndex = mti } = do + reqss <- getRequirementsListBinded dv ibs + pure M.AllocateInfo { + M.allocateInfoNext = mnxt, + M.allocateInfoAllocationSize = memoryRequirementsListToSize + 0 (alignments @ibargs) reqss, + M.allocateInfoMemoryTypeIndex = mti } + +memoryRequirementsListToSize :: + Device.M.Size -> [Maybe Device.M.Size] -> [M.Requirements] -> Device.M.Size +memoryRequirementsListToSize sz0 _ [] = sz0 +memoryRequirementsListToSize sz0 [] _ = sz0 +memoryRequirementsListToSize sz0 (malgn : malgns) (reqs : reqss) = + memoryRequirementsListToSize + (((sz0 - 1) `div` algn + 1) * algn + sz) malgns reqss + where + sz = M.requirementsSize reqs + algn = (fromMaybe 1 malgn) `lcm` + M.requirementsAlignment reqs + +-- READ AND WRITE + +read :: forall nm obj i v sd sm ibargs . + (VObj.Store v obj, OffsetSize nm obj ibargs i) => + Device.D sd -> M sm ibargs -> M.MapFlags -> IO v +read dv m flgs = bracket + (map @nm @obj @i dv m flgs) (const $ unmap dv m) + \(ptr :: Ptr (VObj.TypeOf obj)) -> + VObj.load @_ @obj ptr =<< objectLength @nm @obj m + +write :: forall nm obj i sd sm ibargs v . + (VObj.Store v obj, OffsetSize nm obj ibargs i) => + Device.D sd -> M sm ibargs -> M.MapFlags -> v -> IO () +write dv m flgs v = bracket + (map @nm @obj @i dv m flgs) (const $ unmap dv m) + \(ptr :: Ptr (VObj.TypeOf obj)) -> do + ln <- objectLength @nm @obj m + VObj.store @_ @obj ptr ln v + +map :: forall nm obj i sd sm ibargs . OffsetSize nm obj ibargs i => + Device.D sd -> M sm ibargs -> M.MapFlags -> + IO (Ptr (VObj.TypeOf obj)) +map dv@(Device.D mdv) m flgs = readM m >>= \(_, mm) -> do + (ost, sz) <- offsetSize @nm @obj @_ @i dv m 0 + when debug $ print (ost, sz) + M.map mdv mm ost sz flgs + +unmap :: Device.D sd -> M sm ibargs -> IO () +unmap (Device.D mdv) m = M.unmap mdv . snd =<< readM m diff --git a/src/Gpu/Vulkan/Memory/Bind.hs b/src/Gpu/Vulkan/Memory/Bind.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Memory/Bind.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE ScopedTypeVariables, RankNTypes, TypeApplications #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures, TypeOperators #-} +{-# LANGUAGE MultiParamTypeClasses, AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-} +{-# LANGUAGE PatternSynonyms #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Memory.Bind ( + + -- * BIND AND REBIND + + Bindable, Rebindable, BindAll(..), RebindAll(..) + + ) where + +import Data.TypeLevel.Tuple.Uncurry +import Data.HeteroParList qualified as HeteroParList +import Data.HeteroParList (pattern (:**)) + +import Gpu.Vulkan.Device.Type qualified as Device +import Gpu.Vulkan.Device.Middle qualified as Device.M +import Gpu.Vulkan.Memory.ImageBuffer + +import Gpu.Vulkan.Buffer.Type qualified as Buffer +import Gpu.Vulkan.Buffer.Middle qualified as Buffer.M + +import Gpu.Vulkan.Image.Type qualified as Image +import Gpu.Vulkan.Image.Middle qualified as Image.M + +import Gpu.Vulkan.Memory.Type + +class (BindAll ibargs ibargs, Alignments ibargs) => Bindable ibargs +instance (BindAll ibargs ibargs , Alignments ibargs) => Bindable ibargs + +class BindAll ibargs mibargs where + bindAll :: Device.D sd -> HeteroParList.PL (U2 ImageBuffer) ibargs -> + M sm mibargs -> Device.M.Size -> + IO (HeteroParList.PL (U2 (ImageBufferBinded sm)) ibargs) + +instance BindAll '[] mibargs where bindAll _ _ _ _ = pure HeteroParList.Nil + +instance BindAll ibargs mibargs => + BindAll ('(si, ('ImageArg nm fmt)) ': ibargs) mibargs where + bindAll dv@(Device.D mdv) (U2 ii@(Image (Image.I i)) :** ibs) m ost = do + (_, mm) <- readM m + (ost', sz) <- adjustOffsetSize dv ii ost + Image.M.bindMemory mdv i mm ost' + (U2 (ImageBinded $ Image.Binded i) :**) + <$> bindAll dv ibs m (ost' + sz) + +instance BindAll ibargs mibargs => + BindAll ('(sb, ('BufferArg nm objs)) ': ibargs) mibargs where + bindAll dv@(Device.D mdv) + (U2 bb@(Buffer (Buffer.B lns b)) :** ibs) m ost = do + (_, mm) <- readM m + (ost', sz) <- adjustOffsetSize dv bb ost + Buffer.M.bindMemory mdv b mm ost' + (U2 (BufferBinded $ Buffer.Binded lns b) :**) + <$> bindAll dv ibs m (ost' + sz) + +class (RebindAll ibargs ibargs, Alignments ibargs) => Rebindable ibargs +instance (RebindAll ibargs ibargs, Alignments ibargs) => Rebindable ibargs + +class RebindAll ibargs mibargs where + rebindAll :: Device.D sd -> + HeteroParList.PL (U2 (ImageBufferBinded sm)) ibargs -> + M sm mibargs -> Device.M.Size -> IO () + +instance RebindAll '[] mibargs where rebindAll _ _ _ _ = pure () + +instance RebindAll ibargs mibargs => + RebindAll ('(si, 'ImageArg nm fmt) ': ibargs) mibargs where + rebindAll dv@(Device.D mdv) + (U2 ii@(ImageBinded (Image.Binded i)) :** ibs) m ost = do + (_, mm) <- readM m + (ost', sz) <- adjustOffsetSizeBinded dv ii ost + Image.M.bindMemory mdv i mm ost' + rebindAll dv ibs m $ ost' + sz + +instance RebindAll ibargs mibargs => + RebindAll ('(sb, 'BufferArg nm objs) ': ibargs) mibargs where + rebindAll dv@(Device.D mdv) + (U2 bb@(BufferBinded (Buffer.Binded _lns b)) :** ibs) m ost = do + (_, mm) <- readM m + (ost', sz) <- adjustOffsetSizeBinded dv bb ost + Buffer.M.bindMemory mdv b mm ost' + rebindAll dv ibs m $ ost' + sz diff --git a/src/Gpu/Vulkan/Memory/Enum.hs b/src/Gpu/Vulkan/Memory/Enum.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Memory/Enum.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE PackageImports #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Memory.Enum (module Gpu.Vulkan.Memory.Enum) where + +import "gpu-vulkan-middle" Gpu.Vulkan.Memory.Enum diff --git a/src/Gpu/Vulkan/Memory/ImageBuffer.hs b/src/Gpu/Vulkan/Memory/ImageBuffer.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Memory/ImageBuffer.hs @@ -0,0 +1,147 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE BlockArguments, LambdaCase, TupleSections #-} +{-# LANGUAGE ScopedTypeVariables, RankNTypes, TypeApplications #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures, TypeOperators #-} +{-# LANGUAGE MultiParamTypeClasses, AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-} +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Memory.ImageBuffer ( + + -- * IMAGE BUFFER + + ImageBuffer(..), ImageBufferBinded(..), ImageBufferArg(..), + + -- * GET REQUIREMENTS LIST + + getRequirementsList, getRequirementsListBinded, + + -- * ADJUST OFFSET AND GET SIZE + + adjustOffsetSize, adjustOffsetSizeBinded, + + -- * FOR BIND + + Alignments(..), + + -- * FOR READ AND WRITE + + ObjectLength(..) + + ) where + +import Prelude hiding (map, read) +import GHC.TypeLits +import Data.Kind +import Data.TypeLevel.Tuple.Uncurry +import Gpu.Vulkan.Object qualified as VObj +import Data.HeteroParList qualified as HeteroParList +import Data.HeteroParList (pattern (:**)) + +import qualified Gpu.Vulkan.Image.Type as Image +import qualified Gpu.Vulkan.Buffer.Type as Buffer + +import qualified Gpu.Vulkan.TypeEnum as T + +import qualified Gpu.Vulkan.Device.Type as Device +import qualified Gpu.Vulkan.Device.Middle as Device.M + +import qualified Gpu.Vulkan.Image.Middle as Image.M +import qualified Gpu.Vulkan.Buffer.Middle as Buffer.M +import qualified Gpu.Vulkan.Memory.Middle as Memory.M + +-- IMAGE BUFFER + +data ImageBuffer s (ibarg :: ImageBufferArg) where + Image :: Image.I si nm fmt -> ImageBuffer si ('ImageArg nm fmt) + Buffer :: Buffer.B sb nm objs -> ImageBuffer sb ('BufferArg nm objs) + +deriving instance Show (HeteroParList.PL VObj.Length objs) => + Show (ImageBuffer sib ('BufferArg nm objs)) + +data ImageBufferBinded sm sib (ibarg :: ImageBufferArg) where + ImageBinded :: Image.Binded sm si nm fmt -> + ImageBufferBinded sm si ('ImageArg nm fmt) + BufferBinded :: Buffer.Binded sm sb nm objs -> + ImageBufferBinded sm sb ('BufferArg nm objs) + +deriving instance Show (HeteroParList.PL VObj.Length objs) => + Show (ImageBufferBinded sm sib ('BufferArg nm objs)) + +data ImageBufferArg = ImageArg Symbol T.Format | BufferArg Symbol [VObj.O] + +-- GET REQUIREMENTS LIST + +getRequirementsList :: Device.D sd -> + HeteroParList.PL (U2 ImageBuffer) ibargs -> IO [Memory.M.Requirements] +getRequirementsList dv = + HeteroParList.toListM \(U2 bi) -> getMemoryRequirements dv bi + +getRequirementsListBinded :: + Device.D sd -> HeteroParList.PL (U2 (ImageBufferBinded sm)) ibargs -> + IO [Memory.M.Requirements] +getRequirementsListBinded dv = + HeteroParList.toListM \(U2 bi) -> getMemoryRequirementsBinded dv bi + +getMemoryRequirements :: + Device.D sd -> ImageBuffer sib fos -> IO Memory.M.Requirements +getMemoryRequirements (Device.D dv) = \case + Buffer (Buffer.B _ b) -> Buffer.M.getMemoryRequirements dv b + Image (Image.I i) -> Image.M.getMemoryRequirements dv i + +getMemoryRequirementsBinded :: + Device.D sd -> ImageBufferBinded sm sib fos -> IO Memory.M.Requirements +getMemoryRequirementsBinded (Device.D dv) = \case + BufferBinded (Buffer.Binded _ b) -> Buffer.M.getMemoryRequirements dv b + ImageBinded (Image.Binded i) -> Image.M.getMemoryRequirements dv i + +-- ADJUST OFFSET AND GET SIZE + +adjustOffsetSize :: Device.D sd -> ImageBuffer sib ibarg -> Device.M.Size -> + IO (Device.M.Size, Device.M.Size) +adjustOffsetSize dv ib ost = (<$> getMemoryRequirements dv ib) \rs -> ( + adjust (Memory.M.requirementsAlignment rs) ost, + Memory.M.requirementsSize rs ) + +adjustOffsetSizeBinded :: Device.D sd -> ImageBufferBinded sm sib ibarg -> + Device.M.Size -> IO (Device.M.Size, Device.M.Size) +adjustOffsetSizeBinded dv ib ost = + (<$> getMemoryRequirementsBinded dv ib) \rs -> ( + adjust (Memory.M.requirementsAlignment rs) ost, + Memory.M.requirementsSize rs ) + +adjust :: Device.M.Size -> Device.M.Size -> Device.M.Size +adjust algn ost = ((ost - 1) `div` algn + 1) * algn + +-- ALIGNMENTS + +class Alignments (ibs :: [(Type, ImageBufferArg)]) where + alignments :: [Maybe Device.M.Size] + +instance Alignments '[] where alignments = [] + +instance Alignments ibs => Alignments ('(_s, 'ImageArg _nm _fmt) ': ibs) where + alignments = Nothing : alignments @ibs + +instance (VObj.WholeAlign objs, Alignments ibs) => + Alignments ('(_s, 'BufferArg _nm objs) ': ibs) where + alignments = Just (VObj.wholeAlign @objs) : alignments @ibs + +-- OBJECT LENGTH + +class ObjectLength (nm :: Symbol) (obj :: VObj.O) ibargs where + objectLength' :: HeteroParList.PL (U2 ImageBuffer) ibargs -> + VObj.Length obj + +instance VObj.LengthOf obj objs => + ObjectLength nm obj ('(sib, 'BufferArg nm objs) ': ibargs) where + objectLength' (U2 (Buffer (Buffer.B lns _)) :** _) = + VObj.lengthOf @obj lns + +instance {-# OVERLAPPABLE #-} ObjectLength nm obj ibargs => + ObjectLength nm obj (ibarg ': ibargs) where + objectLength' (_ :** lns) = objectLength' @nm @obj lns diff --git a/src/Gpu/Vulkan/Memory/OffsetSize.hs b/src/Gpu/Vulkan/Memory/OffsetSize.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Memory/OffsetSize.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE BlockArguments, TupleSections #-} +{-# LANGUAGE ScopedTypeVariables, RankNTypes, TypeApplications #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures, TypeOperators #-} +{-# LANGUAGE MultiParamTypeClasses, AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-} +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Memory.OffsetSize ( + + -- * OFFSET SIZE + + offsetSize, OffsetSize, + + ) where + +import Prelude hiding (map, read) +import GHC.TypeLits +import Gpu.Vulkan.Object qualified as VObj +import Data.TypeLevel.Tuple.Uncurry +import qualified Data.HeteroParList as HeteroParList +import Data.HeteroParList (pattern (:**)) + +import qualified Gpu.Vulkan.Device.Type as Device +import qualified Gpu.Vulkan.Device.Middle as Device.M +import qualified Gpu.Vulkan.Buffer.Type as Buffer + +import Gpu.Vulkan.Memory.Type +import Gpu.Vulkan.Memory.ImageBuffer + +offsetSize :: forall nm obj ibargs i sd sm . OffsetSize nm obj ibargs i => + Device.D sd -> M sm ibargs -> Device.M.Size -> + IO (Device.M.Size, Device.M.Size) +offsetSize dvc m ost = + readM m >>= \(ibs, _mm) -> offsetSize' @nm @obj @ibargs @i dvc ibs ost + +class ObjectLength nm obj ibargs => + OffsetSize (nm :: Symbol) (obj :: VObj.O) ibargs (i :: Nat) where + offsetSize' :: + Device.D sd -> HeteroParList.PL (U2 ImageBuffer) ibargs -> + Device.M.Size -> IO (Device.M.Size, Device.M.Size) + +instance (VObj.OffsetRange obj objs i, VObj.LengthOf obj objs) => + OffsetSize nm obj ('(sib, 'BufferArg nm objs) ': ibargs) i where + offsetSize' dvc ((U2 ib@(Buffer (Buffer.B lns _))) :** _ibs) ost = + (<$> adjustOffsetSize dvc ib ost) \(ost', _sz) -> + VObj.offsetSize @obj @_ @i ost' lns + +instance {-# OVERLAPPABLE #-} + OffsetSize nm obj ibargs i => + OffsetSize nm obj ('(sib, ib) ': ibargs) i where + offsetSize' dvc (U2 ib :** ibs) ost = + adjustOffsetSize dvc ib ost >>= + offsetSize' @nm @obj @_ @i dvc ibs . uncurry (+) diff --git a/src/Gpu/Vulkan/Memory/Type.hs b/src/Gpu/Vulkan/Memory/Type.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Memory/Type.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE BlockArguments, TupleSections #-} +{-# LANGUAGE ScopedTypeVariables, RankNTypes, TypeApplications #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures, TypeOperators #-} +{-# LANGUAGE MultiParamTypeClasses, AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PatternSynonyms #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Memory.Type ( + + -- * TYPE + + M(..), + + -- * NEW, READ AND WRITE + + newM, readM, writeMBinded, + + getBinded, + + -- * OBJECT LENGTH + + objectLength + + ) where + +import Data.Kind +import Data.TypeLevel.Tuple.Uncurry +import Data.HeteroParList qualified as HeteroParList +import Data.IORef + +import Gpu.Vulkan.Object qualified as VObj +import Gpu.Vulkan.Buffer.Type qualified as B +import Gpu.Vulkan.Image.Type qualified as I + +import Gpu.Vulkan.Memory.ImageBuffer +import Gpu.Vulkan.Memory.Middle qualified as M + +-- MEMORY + +data M s (ibargs :: [(Type, ImageBufferArg)]) = + M (IORef (HeteroParList.PL (U2 ImageBuffer) ibargs)) M.M + +-- NEW, READ AND WRITE + +newM :: HeteroParList.PL (U2 ImageBuffer) ibargs -> M.M -> IO (M s ibargs) +newM ibs mm = (`M` mm) <$> newIORef ibs + +getBinded :: M s ibargs -> IO (HeteroParList.PL (U2 (ImageBufferBinded s)) ibargs) +getBinded m = HeteroParList.map toBinded . fst <$> readM m + where + toBinded :: U2 ImageBuffer ibarg -> U2 (ImageBufferBinded sm) ibarg + toBinded (U2 (Image (I.I i))) = U2 . ImageBinded $ I.Binded i + toBinded (U2 (Buffer (B.B x b))) = U2 . BufferBinded $ B.Binded x b + +readM :: M s ibargs -> IO (HeteroParList.PL (U2 ImageBuffer) ibargs, M.M) +readM (M ib m) = (, m) <$> readIORef ib + +writeMBinded :: M s ibargs -> + HeteroParList.PL (U2 (ImageBufferBinded sm)) ibargs -> IO () +writeMBinded (M rib _r) ibs = + writeIORef rib (HeteroParList.map fromBinded ibs) + where + fromBinded :: U2 (ImageBufferBinded sm) ibarg -> U2 ImageBuffer ibarg + fromBinded (U2 (ImageBinded (I.Binded i))) = U2 . Image $ I.I i + fromBinded (U2 (BufferBinded (B.Binded x b))) = U2 . Buffer $ B.B x b + +-- OBJECT LENGTH + +objectLength :: forall nm obj ibargs sm . ObjectLength nm obj ibargs => + M sm ibargs -> IO (VObj.Length obj) +objectLength m = (<$> readM m) \(ibs, _m) -> objectLength' @nm @obj @ibargs ibs diff --git a/src/Gpu/Vulkan/Object.hs b/src/Gpu/Vulkan/Object.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Object.hs @@ -0,0 +1,376 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE ScopedTypeVariables, RankNTypes, TypeApplications #-} +{-# LANGUAGE GADTs, TypeFamilies #-} +{-# LANGUAGE DataKinds, PolyKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE MultiParamTypeClasses, AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Object ( + + -- * OBJECT + + O(..), + + -- ** Synonyms + + Static, Dynamic, + + -- *** static + + Atom, List, Image, + AtomNoName, ListNoName, ImageNoName, + AtomMaybeName, ListMaybeName, ImageMaybeName, + + -- *** dynamic + + DynAtomNew, DynList, DynImage, + DynAtomNoName, DynListNoName, DynImageNoName, + DynAtomMaybeName, DynListMaybeName, DynImageMaybeName, + + -- ** Type Of Object + + TypeOf, + + -- * OBJECT LENGTH + + Length, + + -- ** Synonyms + + pattern LengthAtom, + pattern LengthList, + pattern LengthImage, + pattern LengthDynAtom, + pattern LengthDynList, + pattern LengthDynImage, + + pattern LengthList', + + -- ** Find Length + + LengthOf(..), + + -- * ONLY DYNAMIC LENGTHS + + OnlyDynamicLengths(..), + + -- * STORE + + Store(..), + + -- * SIZE, ALIGNMENT AND OFFSET + + -- ** Whole Size + + wholeSize, WholeAlign(..), + + -- ** Offset Range + + offsetRange, offsetSize, OffsetRange, + + -- ** Offset Of List + + offsetOfList, OffsetOfList(..), + + -- ** Size AlignmentList + + SizeAlignmentList(..), SizeAlignment(..), + + ) where + +import Prelude hiding (length) + +import GHC.TypeLits (Symbol) +import GHC.TypeNats +import Foreign.Ptr +import Data.Proxy +import Data.HeteroParList qualified as HeteroParList +import Data.HeteroParList (pattern (:**)) + +import Data.Maybe +import Data.Word + +import Foreign.Storable (Storable) +import Gpu.Vulkan.Object.Base qualified as K +import Gpu.Vulkan.Device.Middle.Internal qualified as Device.M + +-- OBJECT + +data O = Static_ K.O | Dynamic Nat K.O + +type Static algn mnm ot v = 'Static_ ('K.O algn mnm ot v) +type Dynamic n algn mnm ot v = 'Dynamic n ('K.O algn mnm ot v) + +type Atom algn v nm = AtomMaybeName algn v ('Just nm) +type List algn v nm = ListMaybeName algn v ('Just nm) +type Image algn v nm = ImageMaybeName algn v ('Just nm) + +type AtomNoName algn v = AtomMaybeName algn v 'Nothing +type ListNoName algn v = ListMaybeName algn v 'Nothing +type ImageNoName algn v = ImageMaybeName algn v 'Nothing + +type AtomMaybeName algn v mnm = Static_ (K.AtomMaybeName algn v mnm) +type ListMaybeName algn v mnm = Static_ (K.ListMaybeName algn v mnm) +type ImageMaybeName algn v mnm = Static_ (K.ImageMaybeName algn v mnm) + +type DynAtomNew n algn v nm = 'Dynamic n (K.AtomNew algn v nm) +type DynList n algn v nm = 'Dynamic n (K.List algn v nm) +type DynImage n algn v nm = 'Dynamic n (K.Image algn v nm) + +type DynAtomNoName n algn v = 'Dynamic n (K.AtomNoName algn v) +type DynListNoName n algn v = 'Dynamic n (K.ListNoName algn v) +type DynImageNoName n algn v = 'Dynamic n (K.ImageNoName algn v) + +type DynAtomMaybeName n algn v mnm = 'Dynamic n (K.AtomMaybeName algn v mnm) +type DynListMaybeName n algn v mnm = 'Dynamic n (K.ListMaybeName algn v mnm) +type DynImageMaybeName n algn v mnm = 'Dynamic n (K.ImageMaybeName algn v mnm) + +type family TypeOf obj where + TypeOf (Static_ kobj) = K.TypeOf kobj + TypeOf ('Dynamic n kobj) = K.TypeOf kobj + +-- OBJECT LENGTH + +data Length obj where + LengthStatic :: K.Length kobj -> Length ('Static_ kobj) + LengthDynamic :: + K.Length kobj -> Length ('Dynamic n kobj) + +deriving instance Eq (Length obj) +deriving instance Show (Length obj) + +pattern LengthAtom :: Length ('Static_ (K.AtomMaybeName algn v mnm)) +pattern LengthAtom <- LengthStatic K.LengthAtom where + LengthAtom = LengthStatic K.LengthAtom + +{-# COMPLETE LengthList #-} +{-# COMPLETE LengthList' #-} + +pattern LengthList :: Device.M.Size -> + Length ('Static_ (K.ListMaybeName algn v mnm)) +pattern LengthList n <- LengthStatic (K.LengthList n) where + LengthList n = LengthStatic (K.LengthList n) + +pattern LengthList' :: Word64 -> Length ('Static_ (K.ListMaybeName algn v nm)) +pattern LengthList' n <- LengthStatic (K.LengthList (Device.M.Size n)) where + LengthList' n = LengthStatic (K.LengthList (Device.M.Size n)) + +{-# COMPLETE LengthImage #-} + +pattern LengthImage :: + Device.M.Size -> Device.M.Size -> Device.M.Size -> Device.M.Size -> + Length ('Static_ (K.ImageMaybeName algn v mnm)) +pattern LengthImage kr kw kh kd <- (LengthStatic (K.LengthImage kr kw kh kd)) + where LengthImage kr kw kh kd = LengthStatic (K.LengthImage kr kw kh kd) + +pattern LengthDynAtom :: Length ('Dynamic n (K.Atom algn v nm)) +pattern LengthDynAtom <- LengthDynamic K.LengthAtom where + LengthDynAtom = LengthDynamic K.LengthAtom + +pattern LengthDynList :: Device.M.Size -> Length ('Dynamic n (K.List algn v nm)) +pattern LengthDynList n <- LengthDynamic (K.LengthList n) where + LengthDynList n = LengthDynamic (K.LengthList n) + +pattern LengthDynImage :: + Device.M.Size -> Device.M.Size -> Device.M.Size -> Device.M.Size -> Length ('Dynamic n (K.Image algn v nm)) +pattern LengthDynImage kr kw kh kd <- (LengthDynamic (K.LengthImage kr kw kh kd)) + where LengthDynImage kr kw kh kd = LengthDynamic (K.LengthImage kr kw kh kd) + +class LengthOf (obj :: O) (objs :: [O]) where + lengthOf :: HeteroParList.PL Length objs -> Length obj + +instance LengthOf obj (obj ': objs) where lengthOf (ln :** _) = ln + +instance {-# OVERLAPPABLE #-} LengthOf obj objs => + LengthOf obj (obj' ': objs) where + lengthOf (_ :** lns) = lengthOf @obj lns + +-- ONLY DYNAMIC LENGTH + +class OnlyDynamicLengths (objs :: [O]) where + type OnlyDynamics objs :: [K.O] + onlyDynamicLength :: + HeteroParList.PL Length objs -> + HeteroParList.PL K.Length (OnlyDynamics objs) + +instance OnlyDynamicLengths '[] where + type OnlyDynamics '[] = '[] + onlyDynamicLength HeteroParList.Nil = HeteroParList.Nil + +instance OnlyDynamicLengths objs => OnlyDynamicLengths ('Static_ _o ': objs) where + type OnlyDynamics ('Static_ _o ': objs) = OnlyDynamics objs + onlyDynamicLength (LengthStatic _ :** lns) = onlyDynamicLength lns + +instance OnlyDynamicLengths objs => OnlyDynamicLengths ('Dynamic _n o ': objs) where + type OnlyDynamics ('Dynamic _n o ': objs) = o ': OnlyDynamics objs + onlyDynamicLength (LengthDynamic ln :** lns) = + ln :** onlyDynamicLength lns + +-- STORE + +class Store v obj where + store :: Ptr (TypeOf obj) -> Length obj -> v -> IO () + load :: Ptr (TypeOf obj) -> Length obj -> IO v + length :: v -> Length obj + +instance K.Store v bobj => Store v (Static_ bobj) where + store p (LengthStatic kln) = K.store p kln + load p (LengthStatic kln) = K.load p kln + length = LengthStatic . K.length + +instance (KnownNat n, K.Store v bobj) => Store [Maybe v] ('Dynamic n bobj) where + store p0 (LengthDynamic kln) = + go p0 (natVal (Proxy :: Proxy n)) + where + go _ _ [] = pure () + go _ n _ | n < 1 = pure () + go p n (Just x : xs) = do + K.store p kln x >> go (nextObject p kln) (n - 1) xs + go p n (Nothing : xs) = do + go (nextObject p kln) (n - 1) xs + load p0 (LengthDynamic kln) = go p0 (natVal (Proxy :: Proxy n)) + where + go _ n | n < 1 = pure [] + go p n = (:) <$> (Just <$> K.load p kln) <*> go (nextObject p kln) (n - 1) + length = LengthDynamic . K.length . fromJust . head + +nextObject :: forall kobj . K.SizeAlignment kobj => + Ptr (K.TypeOf kobj) -> K.Length kobj -> Ptr (K.TypeOf kobj) +nextObject p ln = p `plusPtr` fromIntegral n + where + n = ((K.size ln - 1) `div` algn + 1) * algn + algn = K.alignment @kobj + +-- SIZE, ALIGNMENT AND OFFSET + +-- WholeSize + +wholeSize :: SizeAlignmentList objs => + HeteroParList.PL Length objs -> Size +wholeSize = wholeSizeFromSzAlgns 0 . sizeAlignmentList + +wholeSizeFromSzAlgns :: + Size -> HeteroParList.PL SizeAlignmentOf objs -> Size +wholeSizeFromSzAlgns sz0 HeteroParList.Nil = sz0 +wholeSizeFromSzAlgns sz0 (SizeAlignmentOf dn sz algn :** saoo) = + wholeSizeFromSzAlgns (adjust algn sz0 + dn * sz) saoo + +class WholeAlign (objs :: [O]) where wholeAlign :: Size + +instance WholeAlign '[] where wholeAlign = 1 + +instance (SizeAlignment obj, WholeAlign objs) => + WholeAlign (obj ': objs) where + wholeAlign = alignment @obj `lcm` wholeAlign @objs + +-- OffsetRange + +offsetRange :: forall obj objs i . OffsetRange obj objs i => Device.M.Size -> + HeteroParList.PL Length objs -> (Device.M.Size, Device.M.Size) +offsetRange ost0 lns = offsetRangeFromSzAlgns' @obj @_ @i ost0 $ sizeAlignmentList lns + +offsetSize :: forall obj objs i . OffsetRange obj objs i => Device.M.Size -> + HeteroParList.PL Length objs -> (Device.M.Size, Device.M.Size) +offsetSize ost0 lns = offsetSizeFromSzAlgns' @obj @_ @i ost0 $ sizeAlignmentList lns + +class (SizeAlignmentList vs, HeteroParList.TypeIndex v vs) => + OffsetRange (v :: O) (vs :: [O]) (i :: Nat) where + offsetRangeFromSzAlgns' :: + Device.M.Size -> HeteroParList.PL SizeAlignmentOf vs -> + (Device.M.Size, Device.M.Size) + offsetSizeFromSzAlgns' :: + Device.M.Size -> HeteroParList.PL SizeAlignmentOf vs -> + (Device.M.Size, Device.M.Size) + +instance (SizeAlignment v, SizeAlignmentList vs) => + OffsetRange v (v ': vs) 0 where + offsetRangeFromSzAlgns' ost (SizeAlignmentOf _dn sz algn :** _) = + (adjust algn ost, sz) + offsetSizeFromSzAlgns' ost (SizeAlignmentOf dn sz algn :** _) = + (adjust algn ost, dn * sz) + +instance {-# OVERLAPPABLE #-} + (SizeAlignment v, OffsetRange v vs (i - 1)) => + OffsetRange v (v ': vs) i where + offsetRangeFromSzAlgns' ost (SizeAlignmentOf dn sz algn :** sas) = + offsetRangeFromSzAlgns' @v @vs @(i - 1) (adjust algn ost + dn * sz) sas + offsetSizeFromSzAlgns' ost (SizeAlignmentOf dn sz algn :** sas) = + offsetSizeFromSzAlgns' @v @vs @(i - 1) (adjust algn ost + dn * sz) sas + +instance {-# OVERLAPPABLE #-} (SizeAlignment v', OffsetRange v vs i) => + OffsetRange v (v' ': vs) i where + offsetRangeFromSzAlgns' ost (SizeAlignmentOf dn sz algn :** sas) = + offsetRangeFromSzAlgns' @v @vs @i (adjust algn ost + dn * sz) sas + offsetSizeFromSzAlgns' ost (SizeAlignmentOf dn sz algn :** sas) = + offsetSizeFromSzAlgns' @v @vs @i (adjust algn ost + dn * sz) sas + +-- OffsetOfList + +offsetOfList :: forall v onm vs . OffsetOfList v onm vs => + HeteroParList.PL Length vs -> (Device.M.Size, Device.M.Size) +offsetOfList = offsetRangeListFromSzAlgns @v @onm 0 . sizeAlignmentList + +class SizeAlignmentList objs => + OffsetOfList v (nm :: Symbol) (objs :: [O]) where + offsetRangeListFromSzAlgns :: + Device.M.Size -> HeteroParList.PL SizeAlignmentOf objs -> + (Device.M.Size, Device.M.Size) + +instance (Storable v, KnownNat oalgn, SizeAlignmentList objs) => + OffsetOfList v nm (List oalgn v nm ': objs) where + offsetRangeListFromSzAlgns ost (SizeAlignmentOf _ sz algn :** _) = + (adjust algn ost, sz) + +instance {-# OVERLAPPABLE #-} (SizeAlignment obj, OffsetOfList v nm objs) => + OffsetOfList v nm (obj ': objs) where + offsetRangeListFromSzAlgns ost (SizeAlignmentOf dn sz algn :** sas) = + offsetRangeListFromSzAlgns + @v @nm @objs (adjust algn ost + dn * sz) sas + +adjust :: Device.M.Size -> Device.M.Size -> Device.M.Size +adjust algn ost = ((ost - 1) `div` algn + 1) * algn + +-- SizeAlignmentList + +data SizeAlignmentOf (obj :: O) = SizeAlignmentOf DynNum Size ObjAlignment + deriving Show + +type DynNum = Device.M.Size +type Size = Device.M.Size +type ObjAlignment = Device.M.Size + +class SizeAlignmentList objs where + sizeAlignmentList :: HeteroParList.PL Length objs -> + HeteroParList.PL SizeAlignmentOf objs + +instance SizeAlignmentList '[] where + sizeAlignmentList HeteroParList.Nil = HeteroParList.Nil + +instance (SizeAlignment obj, SizeAlignmentList objs) => + SizeAlignmentList (obj ': objs) where + sizeAlignmentList (ln :** lns) = + SizeAlignmentOf + (dynNum @obj) (size ln) (alignment @obj) :** + sizeAlignmentList lns + +-- SizeAlignment + +class SizeAlignment obj where + dynNum :: Device.M.Size + size :: Length obj -> Device.M.Size + alignment :: Device.M.Size + +instance K.SizeAlignment kobj => SizeAlignment (Static_ kobj) where + dynNum = 1 + size (LengthStatic kln) = K.size kln + alignment = K.alignment @kobj + +instance (KnownNat n, K.SizeAlignment kobj) => + SizeAlignment ('Dynamic n kobj) where + dynNum = fromIntegral $ natVal (Proxy :: Proxy n) + size (LengthDynamic kln) = K.size kln + alignment = K.alignment @kobj diff --git a/src/Gpu/Vulkan/Object/Base.hs b/src/Gpu/Vulkan/Object/Base.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Object/Base.hs @@ -0,0 +1,194 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE ScopedTypeVariables, TypeApplications #-} +{-# LANGUAGE GADTs, TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE MultiParamTypeClasses, AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-} +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Object.Base ( + + -- * OBJECT + + O(..), IsImage(..), + + -- ** Synonyms + + Atom, AtomNew, List, Image, + AtomNoName, ListNoName, ImageNoName, + AtomMaybeName, ListMaybeName, ImageMaybeName, + + -- ** Type Of Object + + TypeOf, + + -- * OBJECT LENGTH + + Length(..), renameLength, + + -- * STORE OBJECT + + Store(..), + + -- * SIZE AND ALIGNMENT + + SizeAlignment(..) + + ) where + +import GHC.TypeLits +import Foreign.Ptr +import Foreign.Marshal.Array +import Foreign.Storable qualified as S +import Data.Kind +import Data.Foldable +import Data.Traversable +import Data.MonoTraversable +import Data.Proxy +import Data.Default + +import qualified Data.Sequences as Seq + +import Gpu.Vulkan.TypeEnum qualified as T + +import Gpu.Vulkan.Device.Middle qualified as Device.M + +-- OBJECT + +data O = O Alignment (Maybe Symbol) ObjectType Type + +type Alignment = Nat + +data ObjectType = AtomT | ListT | ImageT deriving Show + +class (S.Storable (ImagePixel img), T.FormatToValue (ImageFormat img)) => + IsImage img where + type ImagePixel img + type ImageFormat img :: T.Format + imageRow :: img -> Device.M.Size + imageWidth :: img -> Device.M.Size + imageHeight :: img -> Device.M.Size + imageDepth :: img -> Device.M.Size + imageBody :: img -> [[ImagePixel img]] + imageMake :: Device.M.Size -> Device.M.Size -> Device.M.Size -> + [[ImagePixel img]] -> img + +-- Synonyms + +type Atom algn t mnm = AtomMaybeName algn t mnm +type AtomNew algn t nm = AtomMaybeName algn t ('Just nm) +type List algn t nm = ListMaybeName algn t ('Just nm) +type Image algn t nm = ImageMaybeName algn t ('Just nm) + +type AtomNoName al t = AtomMaybeName al t 'Nothing +type ListNoName al t = ListMaybeName al t 'Nothing +type ImageNoName al t = ImageMaybeName al t 'Nothing + +type AtomMaybeName al t mnm = 'O al mnm AtomT t +type ListMaybeName al t mnm = 'O al mnm ListT t +type ImageMaybeName al t mnm = 'O al mnm ImageT t + +-- Type of Object + +type family TypeOf obj where + TypeOf ((Atom _algn t _nm)) = t + TypeOf ((List _algn t _nm)) = t + +-- OBJECT LENGTH + +data Length (obj :: O) where + LengthAtom :: Length (Atom algn t nm) + LengthList :: Device.M.Size -> Length ('O algn mnm ListT t) + LengthImage :: { + lengthImageRow :: Device.M.Size, + lengthImageWidth :: Device.M.Size, + lengthImageHeight :: Device.M.Size, + lengthImageDepth :: Device.M.Size } -> + Length ('O algn mnm ImageT t) + +deriving instance Eq (Length obj) +deriving instance Show (Length obj) + +instance Default (Length (Atom algn t mnm)) where def = LengthAtom +instance Default (Length (List algn t nm)) where def = LengthList 0 +instance Default (Length (Image algn t nm)) where def = LengthImage 0 0 0 0 + +renameLength :: Length ('O algn mnm ot t) -> Length ('O algn mnm' ot t) +renameLength LengthAtom = LengthAtom +renameLength (LengthList n) = LengthList n +renameLength (LengthImage r w h d) = LengthImage r w h d + +-- STORE OBJECT + +class SizeAlignment obj => Store v (obj :: O) where + store :: Ptr (TypeOf obj) -> Length obj -> v -> IO () + load :: Ptr (TypeOf obj) -> Length obj -> IO v + length :: v -> Length obj + +instance (S.Storable t, KnownNat algn) => Store t ((Atom algn t _nm)) where + store p (LengthAtom) x = S.poke p x + load p (LengthAtom) = S.peek p + length _ = LengthAtom + +instance (KnownNat algn, Seq.IsSequence v, S.Storable t, Element v ~ t) => + Store v ((List algn t _nm)) where + store p ((LengthList (fromIntegral -> n))) xs = + pokeArray p . take n $ otoList xs + load p (LengthList (fromIntegral -> n)) = Seq.fromList <$> peekArray n p + length = LengthList . fromIntegral . olength + +instance (KnownNat algn, IsImage img) => + Store img ((Image algn img nm)) where + store p0 (LengthImage (fromIntegral -> r) (fromIntegral -> w) _ _) img = + for_ (zip (iterate (`plusPtr` s) p0) $ imageBody img) + \(p, take w -> rw) -> pokeArray (castPtr p) rw + where s = r * S.sizeOf @(ImagePixel img) undefined + load p0 (LengthImage (fromIntegral -> r) + w_@(fromIntegral -> w) h_@(fromIntegral -> h) + d_@(fromIntegral -> d)) = + imageMake w_ h_ d_ + <$> for (take (h * d) $ iterate (`plusPtr` s) p0) \p -> + peekArray w (castPtr p) + where s = r * (S.sizeOf @(ImagePixel img) undefined) + length img = LengthImage + (imageRow img) (imageWidth img) (imageHeight img) + (imageDepth img) + +-- SIZE AND ALIGNMENT + +class SizeAlignment obj where + size :: Length obj -> Device.M.Size + alignment :: Device.M.Size + +instance (KnownNat algn, S.Storable t) => + SizeAlignment ((AtomMaybeName algn t _nm)) where + size (LengthAtom) = + applyAlign algn . fromIntegral $ S.sizeOf @t undefined + where algn = alignment @((AtomMaybeName algn t _nm)) + alignment = fromIntegral (natVal (Proxy :: Proxy algn)) `lcm` + fromIntegral (S.alignment @t undefined) + +instance (KnownNat algn, S.Storable t) => SizeAlignment (ListMaybeName algn t _nm) where + size (LengthList n) = applyAlign algn' $ n * applyAlign algn sz + where + sz = fromIntegral $ S.sizeOf @t undefined + algn = fromIntegral $ S.alignment @t undefined + algn' = alignment @((ListMaybeName algn t _nm)) + alignment = fromIntegral (natVal (Proxy :: Proxy algn)) `lcm` + fromIntegral (S.alignment @t undefined) + +instance (KnownNat algn, S.Storable (ImagePixel img)) => + SizeAlignment ((ImageMaybeName algn img nm)) where + size (LengthImage r _w h d) = r * h * d * applyAlign algn sz + where + sz = fromIntegral $ S.sizeOf @(ImagePixel img) undefined + algn = alignment @((ImageMaybeName algn img nm)) + alignment =fromIntegral (natVal (Proxy :: Proxy algn)) `lcm` + fromIntegral (S.alignment @(ImagePixel img) undefined) + +applyAlign :: Integral n => n -> n -> n +applyAlign algn ofst = ((ofst - 1) `div` algn + 1) * algn diff --git a/src/Gpu/Vulkan/Object/NoAlignment.hs b/src/Gpu/Vulkan/Object/NoAlignment.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Object/NoAlignment.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE DataKinds #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Object.NoAlignment ( + Atom, List, Image, + AtomNoName, ListNoName, ImageNoName, + AtomMaybeName, ListMaybeName, ImageMaybeName ) where + +import Gpu.Vulkan.Object qualified as Vk.Obj + +type Atom v nm = Vk.Obj.Atom 1 v nm +type List v nm = Vk.Obj.List 1 v nm +type Image v nm = Vk.Obj.Image 1 v nm + +type AtomNoName v = Vk.Obj.AtomNoName 1 v +type ListNoName v = Vk.Obj.ListNoName 1 v +type ImageNoName v = Vk.Obj.ImageNoName 1 v + +type AtomMaybeName v mnm = Vk.Obj.AtomMaybeName 1 v mnm +type ListMaybeName v mnm = Vk.Obj.ListMaybeName 1 v mnm +type ImageMaybeName v mnm = Vk.Obj.ImageMaybeName 1 v mnm diff --git a/src/Gpu/Vulkan/PhysicalDevice.hs b/src/Gpu/Vulkan/PhysicalDevice.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/PhysicalDevice.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.PhysicalDevice ( + + -- * ENUMERATE + + enumerate, M.P, + + -- * PHYSICAL DEVICE PROPERTIES AND FEATURES + + M.getProperties, M.Properties(..), M.getFeatures, + + -- ** Get Properties 2 + + getProperties2ExtensionName, + M.getFeatures2, M.Features2(..), + + -- * OTHER PROPERTIES + + M.getMemoryProperties, M.MemoryProperties(..), + M.getQueueFamilyProperties, M.getFormatProperties, + enumerateExtensionProperties, + ExtensionProperties(..), ExtensionName(..), + + -- * OTHER FEATURES + + M.ShaderDrawParametersFeatures(..), + + -- * EXTENSIONS + + maintenance3ExtensionName, + + -- * ENUM AND STRUCT + + module Gpu.Vulkan.PhysicalDevice.Enum, + + Limits(..), Features(..), + DescriptorIndexingFeatures(..), DescriptorIndexingFeaturesNoNext(..) + + ) where + +import Gpu.Vulkan.Internal +import Gpu.Vulkan.Instance.Internal qualified as Instance +import Gpu.Vulkan.Instance.Type qualified as Instance.T +import Gpu.Vulkan.PhysicalDevice.Middle qualified as M +import Gpu.Vulkan.PhysicalDevice.Enum +import Gpu.Vulkan.PhysicalDevice.Struct + +import Gpu.Vulkan.Middle qualified as M +import Data.Text qualified as T + +enumerate :: Instance.T.I s -> IO [M.P] +enumerate (Instance.T.I i) = M.enumerate i + +enumerateExtensionProperties :: + M.P -> Maybe LayerName -> IO [ExtensionProperties] +enumerateExtensionProperties p (((\(LayerName ln) -> ln) <$>) -> mlnm) = + (extensionPropertiesFromMiddle <$>) + <$> M.enumerateExtensionProperties p mlnm + +data ExtensionProperties = ExtensionProperties { + extensionPropertiesExtensionName :: ExtensionName, + extensionPropertiesSpecVersion :: M.ApiVersion } + deriving Show + +extensionPropertiesFromMiddle :: M.ExtensionProperties -> ExtensionProperties +extensionPropertiesFromMiddle M.ExtensionProperties { + M.extensionPropertiesExtensionName = en, + M.extensionPropertiesSpecVersion = sv } = ExtensionProperties { + extensionPropertiesExtensionName = ExtensionName en, + extensionPropertiesSpecVersion = sv } + +newtype ExtensionName = ExtensionName { unExtensionName :: T.Text } + deriving (Show, Eq) + +maintenance3ExtensionName :: ExtensionName +maintenance3ExtensionName = ExtensionName M.maintenance3ExtensionName + +getProperties2ExtensionName :: Instance.ExtensionName +getProperties2ExtensionName = Instance.ExtensionName M.getProperties2ExtensionName diff --git a/src/Gpu/Vulkan/PhysicalDevice/Enum.hs b/src/Gpu/Vulkan/PhysicalDevice/Enum.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/PhysicalDevice/Enum.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE PackageImports #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.PhysicalDevice.Enum ( + module Gpu.Vulkan.PhysicalDevice.Enum ) where + +import "gpu-vulkan-middle" Gpu.Vulkan.PhysicalDevice.Enum diff --git a/src/Gpu/Vulkan/PhysicalDevice/Struct.hs b/src/Gpu/Vulkan/PhysicalDevice/Struct.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/PhysicalDevice/Struct.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE PackageImports #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.PhysicalDevice.Struct ( + module Gpu.Vulkan.PhysicalDevice.Struct ) where + +import "gpu-vulkan-middle" Gpu.Vulkan.PhysicalDevice.Struct diff --git a/src/Gpu/Vulkan/Pipeline.hs b/src/Gpu/Vulkan/Pipeline.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Pipeline.hs @@ -0,0 +1,5 @@ +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Pipeline (module Gpu.Vulkan.Pipeline.Enum) where + +import Gpu.Vulkan.Pipeline.Enum diff --git a/src/Gpu/Vulkan/Pipeline/ColorBlendAttachment.hs b/src/Gpu/Vulkan/Pipeline/ColorBlendAttachment.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Pipeline/ColorBlendAttachment.hs @@ -0,0 +1,11 @@ +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Pipeline.ColorBlendAttachment ( + + -- * STATE + + State(..) + + ) where + +import Gpu.Vulkan.Pipeline.ColorBlendAttachment.Middle diff --git a/src/Gpu/Vulkan/Pipeline/ColorBlendState.hs b/src/Gpu/Vulkan/Pipeline/ColorBlendState.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Pipeline/ColorBlendState.hs @@ -0,0 +1,11 @@ +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Pipeline.ColorBlendState ( + + -- * CREATE INFO + + CreateInfo(..) + + ) where + +import Gpu.Vulkan.Pipeline.ColorBlendState.Middle diff --git a/src/Gpu/Vulkan/Pipeline/Compute.hs b/src/Gpu/Vulkan/Pipeline/Compute.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Pipeline/Compute.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE TypeApplications, RankNTypes #-} +{-# LANGUAGE MonoLocalBinds, GADTs, TypeFamilies #-} +{-# LANGUAGE DataKinds, PolyKinds #-} +{-# LANGUAGE KindSignatures, TypeOperators #-} +{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, FlexibleInstances #-} +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Pipeline.Compute ( + + -- * CREATE + + createCs, C(..), CreateInfo(..), + CreateInfoListToMiddle, FromMiddleList + + ) where + +import Foreign.Storable.PeekPoke +import Foreign.Storable.HeteroList +import Control.Exception +import Data.TypeLevel.Maybe qualified as TMaybe +import Data.TypeLevel.ParMaybe qualified as TPMaybe +import Data.TypeLevel.Tuple.Uncurry +import Data.TypeLevel.Tuple.MapIndex qualified as TMapIndex +import qualified Data.HeteroParList as HeteroParList +import Data.HeteroParList (pattern (:**)) +import Data.Kind +import Data.Int + +import Language.SpirV.ShaderKind + +import Gpu.Vulkan.Pipeline.Enum + +import qualified Gpu.Vulkan.AllocationCallbacks as AllocationCallbacks +import qualified Gpu.Vulkan.AllocationCallbacks.Type as AllocationCallbacks +import qualified Gpu.Vulkan.Device.Type as Device +import qualified Gpu.Vulkan.Pipeline.ShaderStage.Internal as ShaderStage +import qualified Gpu.Vulkan.DescriptorSetLayout.Type as DescriptorSetLayout +import qualified Gpu.Vulkan.PipelineLayout.Type as Layout +import qualified Gpu.Vulkan.PipelineCache.Type as Cache +import qualified Gpu.Vulkan.Pipeline.Compute.Middle as M + + +newtype C s (lyta :: + (Type, [(Type, [DescriptorSetLayout.BindingType])], [Type])) = C M.C + deriving Show + +data CreateInfo mn ssta lyta bpha = CreateInfo { + createInfoNext :: TMaybe.M mn, + createInfoFlags :: CreateFlags, + createInfoStage :: U5 ShaderStage.CreateInfo ssta, + createInfoLayout :: U3 Layout.P lyta, + createInfoBasePipelineHandleOrIndex :: + Maybe (Either (U2 C bpha) Int32) } + +createInfoToMiddle :: + (WithPoked (TMaybe.M n'), AllocationCallbacks.ToMiddle mscc) => + Device.D ds -> + CreateInfo n '(n1, n', 'GlslComputeShader, mscc, vs) lyta bpha -> + IO (M.CreateInfo n n1 vs) +createInfoToMiddle dvc CreateInfo { + createInfoNext = mnxt, + createInfoFlags = flgs, + createInfoStage = U5 stg, + createInfoLayout = U3 (Layout.P lyt), + createInfoBasePipelineHandleOrIndex = mbphi } = do + stg' <- ShaderStage.createInfoToMiddle dvc stg + let (bph, bpi) = case mbphi of + Nothing -> (Nothing, Nothing) + Just (Left (U2 (C h))) -> (Just h, Nothing) + Just (Right i) -> (Nothing, Just i) + pure M.CreateInfo { + M.createInfoNext = mnxt, + M.createInfoFlags = flgs, + M.createInfoStage = stg', + M.createInfoLayout = lyt, + M.createInfoBasePipelineHandle = bph, + M.createInfoBasePipelineIndex = bpi } + +class ( M.CreateInfoListToCore (MiddleArgs as), + DestroyCreateInfoMiddleList (MiddleArgs as) as ) => + CreateInfoListToMiddle as where + type MiddleArgs as :: [(Maybe Type, Maybe Type, [Type])] + createInfoListToMiddle :: + Device.D sd -> HeteroParList.PL (U4 CreateInfo) as -> + IO (HeteroParList.PL (U3 M.CreateInfo) (MiddleArgs as)) + +instance CreateInfoListToMiddle '[] where + type MiddleArgs '[] = '[] + createInfoListToMiddle _ HeteroParList.Nil = pure HeteroParList.Nil + +instance ( + WithPoked (TMaybe.M n'), CreateInfoListToMiddle as, + AllocationCallbacks.ToMiddle mscc, + + WithPoked (TMaybe.M n), WithPoked (TMaybe.M n1), PokableList vs + ) => + CreateInfoListToMiddle ( + '(n, '(n1, n', 'GlslComputeShader, mscc, vs), lyta, bpha + ) ': as) where + type MiddleArgs ( + '(n, '(n1, n', 'GlslComputeShader, mscc, vs), lyta, bpha) ': + as ) = '(n, n1, vs) ': MiddleArgs as + createInfoListToMiddle dvc (U4 ci :** cis) = (:**) + <$> (U3 <$> createInfoToMiddle dvc ci) + <*> createInfoListToMiddle dvc cis + +destroyCreateInfoMiddle :: + AllocationCallbacks.ToMiddle mscc => + Device.D sd -> M.CreateInfo n n1 vs -> + CreateInfo n '(n1, n2, 'GlslComputeShader, mscc, vs) lyta bpha -> IO () +destroyCreateInfoMiddle dvc mci ci = ShaderStage.destroyShaderModule dvc + (M.createInfoStage mci) ((\(U5 s) -> snd $ ShaderStage.createInfoModule s) $ createInfoStage ci) + +class DestroyCreateInfoMiddleList vss vss' where + destroyCreateInfoMiddleList :: + Device.D sd -> + HeteroParList.PL (U3 M.CreateInfo) vss -> + HeteroParList.PL (U4 CreateInfo) vss' -> IO () + +instance DestroyCreateInfoMiddleList '[] '[] where + destroyCreateInfoMiddleList _ HeteroParList.Nil HeteroParList.Nil = pure () + +instance ( + DestroyCreateInfoMiddleList vss vss', + AllocationCallbacks.ToMiddle mscc ) => + DestroyCreateInfoMiddleList + ('(n, n1, vs) ': vss) + ('(n, '(n1, n2, 'GlslComputeShader, mscc, vs), lyta, bpha) ': vss') where + destroyCreateInfoMiddleList dvc + (U3 mci :** mcis) (U4 ci :** cis) = do + destroyCreateInfoMiddle dvc mci ci + destroyCreateInfoMiddleList dvc mcis cis + +createCs :: ( + CreateInfoListToMiddle cias, AllocationCallbacks.ToMiddle mac, + FromMiddleList (TMapIndex.M2_4 cias) ) => + Device.D sd -> Maybe (Cache.P spc) -> HeteroParList.PL (U4 CreateInfo) cias -> + TPMaybe.M (U2 AllocationCallbacks.A) mac -> + (forall s . HeteroParList.PL (C s) (TMapIndex.M2_4 cias) -> IO a) -> IO a +createCs dvc@(Device.D mdvc) mcch cis + (AllocationCallbacks.toMiddle -> mac) f = do + cis' <- createInfoListToMiddle dvc cis + let mcch' = (\(Cache.P c) -> c) <$> mcch + bracket + (M.createCs mdvc mcch' cis' mac + <* destroyCreateInfoMiddleList dvc cis' cis) + (mapM_ \c -> M.destroy mdvc c mac) + (f . fromMiddleList) + +class FromMiddleList ss where + fromMiddleList :: [M.C] -> HeteroParList.PL (C sc) ss + +instance FromMiddleList '[] where fromMiddleList [] = HeteroParList.Nil + +instance FromMiddleList ss => FromMiddleList (s ': ss) where + fromMiddleList (c : cs) = C c :** fromMiddleList cs diff --git a/src/Gpu/Vulkan/Pipeline/DepthStencilState.hs b/src/Gpu/Vulkan/Pipeline/DepthStencilState.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Pipeline/DepthStencilState.hs @@ -0,0 +1,11 @@ +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Pipeline.DepthStencilState ( + + -- * CREATE INFO + + CreateInfo(..), CreateFlags(..) + + ) where + +import Gpu.Vulkan.Pipeline.DepthStencilState.Middle diff --git a/src/Gpu/Vulkan/Pipeline/DynamicState.hs b/src/Gpu/Vulkan/Pipeline/DynamicState.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Pipeline/DynamicState.hs @@ -0,0 +1,11 @@ +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Pipeline.DynamicState ( + + -- * CREATE INFO + + CreateInfo(..), CreateFlags + + ) where + +import Gpu.Vulkan.Pipeline.DynamicState.Middle diff --git a/src/Gpu/Vulkan/Pipeline/Enum.hs b/src/Gpu/Vulkan/Pipeline/Enum.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Pipeline/Enum.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE PackageImports #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Pipeline.Enum (module Gpu.Vulkan.Pipeline.Enum) where + +import "gpu-vulkan-middle" Gpu.Vulkan.Pipeline.Enum diff --git a/src/Gpu/Vulkan/Pipeline/Graphics.hs b/src/Gpu/Vulkan/Pipeline/Graphics.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Pipeline/Graphics.hs @@ -0,0 +1,360 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE BlockArguments, LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables, RankNTypes, TypeApplications #-} +{-# LANGUAGE GADTs, TypeFamilies #-} +{-# LANGUAGE DataKinds, PolyKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-} +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Pipeline.Graphics ( + + -- * CREATE AND RECREATE + + createGs, unsafeRecreateGs, G, CreateInfo(..), + CreateInfoListArgsToGArgs, CreateInfoListToMiddle, + + -- ** Group + + group, Group, createGs', unsafeDestroyGs, lookup + + ) where + +import Prelude hiding (lookup) +import Foreign.Storable.PeekPoke +import Control.Concurrent.STM +import Control.Concurrent.STM.TSem +import Control.Exception +import Data.Kind +import Data.TypeLevel.Maybe qualified as TMaybe +import Data.TypeLevel.ParMaybe qualified as TPMaybe +import Data.TypeLevel.Tuple.Uncurry +import Data.TypeLevel.Tuple.Index qualified as TIndex +import Data.TypeLevel.Tuple.MapIndex qualified as TMapIndex +import Data.Map qualified as Map +import Data.HeteroParList qualified as HeteroParList +import Data.HeteroParList (pattern (:**)) +import Data.HeteroParList.Tuple qualified as HeteroParList +import Data.Word +import Data.Int + +import Language.SpirV.ShaderKind + +import Gpu.Vulkan.Pipeline.Enum +import Gpu.Vulkan.Pipeline.Graphics.Type + +import qualified Gpu.Vulkan.AllocationCallbacks as AllocationCallbacks +import qualified Gpu.Vulkan.AllocationCallbacks.Type as AllocationCallbacks +import qualified Gpu.Vulkan.Device.Type as Device +import qualified Gpu.Vulkan.Pipeline.Graphics.Middle as M +import qualified Gpu.Vulkan.PipelineCache.Type as Cache +import qualified Gpu.Vulkan.PipelineLayout.Type as Layout + +import qualified Gpu.Vulkan.RenderPass.Type as RenderPass +import qualified Gpu.Vulkan.Pipeline.DynamicState as DynamicState +import qualified Gpu.Vulkan.Pipeline.ColorBlendState as ColorBlendState +import qualified Gpu.Vulkan.Pipeline.DepthStencilState as DepthStencilState +import qualified Gpu.Vulkan.Pipeline.MultisampleState as MultisampleState +import qualified Gpu.Vulkan.Pipeline.RasterizationState as RasterizationState +import qualified Gpu.Vulkan.Pipeline.ViewportState as ViewportState +import qualified Gpu.Vulkan.Pipeline.TessellationState as TessellationState +import qualified Gpu.Vulkan.Pipeline.InputAssemblyState as InputAssemblyState +import Gpu.Vulkan.Pipeline.VertexInputState.Internal + qualified as VertexInputState +import qualified Gpu.Vulkan.Pipeline.ShaderStage.Internal as ShaderStage + +import Gpu.Vulkan.VertexInput qualified as VertexInput + +import qualified Gpu.Vulkan.Pipeline.ShaderStage.Middle as ShaderStage.M + +-- CREATE AND RECREATE + +createGs :: (CreateInfoListToMiddle cias, AllocationCallbacks.ToMiddle mac) => + Device.D sd -> Maybe (Cache.P sc) -> + HeteroParList.PL (U14 CreateInfo) cias -> + TPMaybe.M (U2 AllocationCallbacks.A) mac -> + (forall sg . + HeteroParList.PL + (U3 (G sg)) (CreateInfoListArgsToGArgs cias) -> + IO a) -> IO a +createGs d@(Device.D dvc) ((Cache.pToMiddle <$>) -> mc) cis + macc@(AllocationCallbacks.toMiddle -> macd) f = bracket + (createInfoListToMiddle d cis >>= \cis' -> M.createGs dvc mc cis' + (AllocationCallbacks.toMiddle macc) + <* destroyShaderStages' d cis' (allocationCallbacksListListFromCreateInfoList cis)) + (\gs -> M.destroyGs dvc gs macd) (f . gListFromMiddle) + +class GListFromMiddle ss where + gListFromMiddle :: [M.G] -> HeteroParList.PL (U3 (G sg)) ss +instance GListFromMiddle '[] where + gListFromMiddle = \case + [] -> HeteroParList.Nil + _ : _ -> error "Wrong number of elements" + +instance GListFromMiddle ss => GListFromMiddle ('(s, t, foo) ': ss) where + gListFromMiddle = \case + g : gs -> U3 (G @_ @s @t g) :** gListFromMiddle @ss gs + [] -> error "Wrong number of elements" + +unsafeRecreateGs :: (CreateInfoListToMiddle cias, AllocationCallbacks.ToMiddle mac) => + Device.D sd -> Maybe (Cache.P s) -> HeteroParList.PL (U14 CreateInfo) cias -> + TPMaybe.M (U2 AllocationCallbacks.A) mac -> + HeteroParList.PL (U3 (G sg)) (CreateInfoListArgsToGArgs cias) -> IO () +unsafeRecreateGs d@(Device.D dvc) ((Cache.pToMiddle <$>) -> mc) cis macc gpls = do + cis' <- createInfoListToMiddle d cis + M.recreateGs dvc mc cis' + (AllocationCallbacks.toMiddle macc) $ gListToMiddle gpls + destroyShaderStages' d cis' $ allocationCallbacksListListFromCreateInfoList cis + +gListToMiddle :: HeteroParList.PL (U3 (G sg)) ss -> [M.G] +gListToMiddle = HeteroParList.toList $ \(U3 (G g)) -> g + +-- CREATE INFO + +data CreateInfo + mn ssas visa iasa tsssa vpsa rstsa mssa dssa cbsa dsa lyta rpa bpha = + CreateInfo { + createInfoNext :: TMaybe.M mn, + createInfoFlags :: CreateFlags, + createInfoStages :: + HeteroParList.PL (U5 ShaderStage.CreateInfo) ssas, + createInfoVertexInputState :: + Maybe (U3 VertexInputState.CreateInfo visa), + createInfoInputAssemblyState :: + Maybe (InputAssemblyState.CreateInfo iasa), + createInfoTessellationState :: + Maybe (TessellationState.CreateInfo tsssa), + createInfoViewportState :: Maybe (ViewportState.CreateInfo vpsa), + createInfoRasterizationState :: + Maybe (RasterizationState.CreateInfo rstsa), + createInfoMultisampleState :: + Maybe (MultisampleState.CreateInfo mssa), + createInfoDepthStencilState :: + Maybe (DepthStencilState.CreateInfo dssa), + createInfoColorBlendState :: + Maybe (ColorBlendState.CreateInfo cbsa), + createInfoDynamicState :: Maybe (DynamicState.CreateInfo dsa), + createInfoLayout :: U3 Layout.P lyta, + createInfoRenderPass :: RenderPass.R rpa, + createInfoSubpass :: Word32, + createInfoBasePipelineHandle :: Maybe (U4 G bpha), + createInfoBasePipelineIndex :: Int32 } + +-- CREATE INFO LIST ARGS TO G ARGS + +type family CreateInfoListArgsToGArgs cias where + CreateInfoListArgsToGArgs '[] = '[] + CreateInfoListArgsToGArgs (cia ': cias) = + CreateInfoArgsToGArgs cia ': CreateInfoListArgsToGArgs cias + +type family CreateInfoArgsToGArgs cia where + CreateInfoArgsToGArgs '( + n, ssas, '(nv, vibs, vias), iasa, tsssa, vpsa, rstsa, mssa, dssa, cbsa, dsa, + slbtss, rpa, bpha ) = '(vibs, vias, slbtss) + +-- CREATE INFO LIST TO MIDDLE + +class ( GListFromMiddle (CreateInfoListArgsToGArgs cias), + DestroyShaderStages + (MiddleArgs cias) (TAllocationCallbacksListList cias), + AllocationCallbacksListListFromCreateInfoList cias, + M.CreateInfoListToCore (MiddleArgs cias) ) => + CreateInfoListToMiddle cias where + type MiddleArgs cias :: [( + Maybe Type, [(Maybe Type, ShaderKind, [Type])], Maybe Type, + Maybe Type, Maybe Type, Maybe Type, Maybe Type, Maybe Type, + Maybe Type, Maybe Type, Maybe Type)] + createInfoListToMiddle :: + Device.D sd -> HeteroParList.PL (U14 CreateInfo) cias -> + IO (HeteroParList.PL (U11 M.CreateInfo) (MiddleArgs cias)) + +instance CreateInfoListToMiddle '[] where + type MiddleArgs '[] = '[] + createInfoListToMiddle _ HeteroParList.Nil = pure HeteroParList.Nil + +instance ( + + HeteroParList.Map3_5 ssas, + ShaderStage.CreateInfoListToMiddle ssas, + ShaderStage.M.CreateInfoListToCore (ShaderStage.MiddleArgs ssas), + VertexInputState.BindingStrideList vibs VertexInput.Rate, + VertexInputState.AttributeDescriptions vibs vias, + WithPoked (TMaybe.M mn), WithPoked (TMaybe.M nvis), + WithPoked (TMaybe.M iasa), WithPoked (TMaybe.M tsssa), + WithPoked (TMaybe.M vpsa), WithPoked (TMaybe.M rstsa), + WithPoked (TMaybe.M mssa), WithPoked (TMaybe.M dssa), + WithPoked (TMaybe.M cbsa), WithPoked (TMaybe.M dsa), + CreateInfoListToMiddle ss ) => + CreateInfoListToMiddle ('( + mn, ssas, '(nvis, vibs, vias), iasa, tsssa, vpsa, rstsa, mssa, dssa, cbsa, dsa, + '(sl, sbtss, pcl), rpa, '(sb, vibs', vias', slbtss') ) ': ss) where + type MiddleArgs ('( + mn, ssas, '(nvis, vibs, vias), iasa, tsssa, vpsa, rstsa, mssa, dssa, cbsa, dsa, + '(sl, sbtss, pcl), rpa, '(sb, vibs', vias', slbtss') ) ': ss) = + '(mn, ShaderStage.MiddleArgs ssas, nvis, iasa, tsssa, vpsa, rstsa, + mssa, dssa, cbsa, dsa) ': MiddleArgs ss + createInfoListToMiddle dvc (U14 ci :** cis) = (:**) + <$> (U11 <$> createInfoToMiddle dvc ci) + <*> createInfoListToMiddle dvc cis + +createInfoToMiddle :: ( + ShaderStage.CreateInfoListToMiddle ssas, + VertexInputState.BindingStrideList vibs VertexInput.Rate, + VertexInputState.AttributeDescriptions vibs vias ) => + Device.D sd -> + CreateInfo n ssas '(nvis, vibs, vias) + iasa tsssa vpsa rstsa mssa dssa cbsa dsa sl rpa '(sb, vibs', vias', slbtss') -> + IO (M.CreateInfo n (ShaderStage.MiddleArgs ssas) + nvis iasa tsssa vpsa rstsa mssa dssa cbsa dsa) +createInfoToMiddle dvc CreateInfo { + createInfoNext = mnxt, + createInfoFlags = flgs, + createInfoStages = stgs, + createInfoVertexInputState = vis, + createInfoInputAssemblyState = ias, + createInfoTessellationState = ts, + createInfoViewportState = vs, + createInfoRasterizationState = rs, + createInfoMultisampleState = ms, + createInfoDepthStencilState = dss, + createInfoColorBlendState = cbs, + createInfoDynamicState = ds, + createInfoLayout = U3 (Layout.P lyt), + createInfoRenderPass = RenderPass.R rp, + createInfoSubpass = sp, + createInfoBasePipelineHandle = bph, + createInfoBasePipelineIndex = bpi } = do + stgs' <- ShaderStage.createInfoListToMiddle dvc stgs + bph' <- maybe M.gNull (\(U4 (G g)) -> pure g) bph + pure M.CreateInfo { + M.createInfoNext = mnxt, + M.createInfoFlags = flgs, + M.createInfoStages = stgs', + M.createInfoVertexInputState = + VertexInputState.createInfoToMiddle . unU3 <$> vis, + M.createInfoInputAssemblyState = ias, + M.createInfoTessellationState = ts, + M.createInfoViewportState = vs, + M.createInfoRasterizationState = rs, + M.createInfoMultisampleState = ms, + M.createInfoDepthStencilState = dss, + M.createInfoColorBlendState = cbs, + M.createInfoDynamicState = ds, + M.createInfoLayout = lyt, + M.createInfoRenderPass = rp, + M.createInfoSubpass = sp, + M.createInfoBasePipelineHandle = bph', + M.createInfoBasePipelineIndex = bpi } + +-- DESTROY SHADER STAGES + +class DestroyShaderStages mvs macs where + destroyShaderStages' :: Device.D sd -> + HeteroParList.PL (U11 M.CreateInfo) mvs -> + HeteroParList.PL2 + (TPMaybe.M (U2 AllocationCallbacks.A)) macs -> IO () + +instance DestroyShaderStages '[] '[] where + destroyShaderStages' _ HeteroParList.Nil HeteroParList.Nil = pure () + +instance (ShaderStage.DestroyShaderModuleList a2 mac, DestroyShaderStages ss macs) => + DestroyShaderStages ('(a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11) ': ss) (mac ': macs) where + destroyShaderStages' dvc (U11 cim :** cims) (mac :** macs) = do + ShaderStage.destroyShaderModuleList dvc (M.createInfoStages cim) mac + destroyShaderStages' dvc cims macs + +class AllocationCallbacksListListFromCreateInfoList cias where + type TAllocationCallbacksListList cias :: [[Maybe (Type, Type)]] + allocationCallbacksListListFromCreateInfoList :: + HeteroParList.PL (U14 CreateInfo) cias -> + HeteroParList.PL2 + (TPMaybe.M (U2 AllocationCallbacks.A)) + (TAllocationCallbacksListList cias) + +instance AllocationCallbacksListListFromCreateInfoList '[] where + type TAllocationCallbacksListList '[] = '[] + allocationCallbacksListListFromCreateInfoList + HeteroParList.Nil = HeteroParList.Nil + +instance ( + HeteroParList.Map3_5 (TIndex.I1_14 cia), + AllocationCallbacksListListFromCreateInfoList cias ) => + AllocationCallbacksListListFromCreateInfoList (cia ': cias) where + type TAllocationCallbacksListList (cia ': cias) = + TMapIndex.M3_5 (TIndex.I1_14 cia) ': + TAllocationCallbacksListList cias + allocationCallbacksListListFromCreateInfoList (U14 ci :** cis) = + allocationCallbacksListFromCreateInfo ci :** + allocationCallbacksListListFromCreateInfoList cis + +allocationCallbacksListFromCreateInfo :: HeteroParList.Map3_5 ssas => + CreateInfo mn ssas visa iasa tsssa vpsa rstsa mssa dssa cbsa dsa lyta rpa bpha -> + HeteroParList.PL (TPMaybe.M (U2 AllocationCallbacks.A)) (TMapIndex.M3_5 ssas) +allocationCallbacksListFromCreateInfo = + ShaderStage.allocationCallbacksListFromCreateInfoList . createInfoStages + +-- Group + +data Group sd ma sg k gas = Group (Device.D sd) + (TPMaybe.M (U2 AllocationCallbacks.A) ma) + TSem (TVar (Map.Map k ( HeteroParList.PL (U3 (G sg)) gas))) + +group :: AllocationCallbacks.ToMiddle ma => + Device.D sd -> TPMaybe.M (U2 AllocationCallbacks.A) ma -> + (forall sg . Group sd ma sg k gas -> IO a) -> IO a +group dvc@(Device.D mdvc) mac@(AllocationCallbacks.toMiddle -> mmac) f = do + (sem, m) <- atomically $ (,) <$> newTSem 1 <*> newTVar Map.empty + rtn <- f $ Group dvc mac sem m + ((\gs -> M.destroyGs mdvc (gListToMiddle gs) mmac) `mapM_`) + =<< atomically (readTVar m) + pure rtn + +createGs' :: ( + Ord k, + CreateInfoListToMiddle cias, AllocationCallbacks.ToMiddle mac ) => + Group sd mac sg k (CreateInfoListArgsToGArgs cias) -> k -> + Maybe (Cache.P sc) -> + HeteroParList.PL (U14 CreateInfo) cias -> + IO (Either String + (HeteroParList.PL (U3 (G sg)) (CreateInfoListArgsToGArgs cias))) +createGs' (Group d@(Device.D dvc) + (AllocationCallbacks.toMiddle -> mmac) sem gss) k + ((Cache.pToMiddle <$>) -> mc) cis = do + ok <- atomically do + mx <- Map.lookup k <$> readTVar gss + case mx of + Nothing -> waitTSem sem >> pure True + Just _ -> pure False + if ok + then do gs <- createInfoListToMiddle d cis >>= \cis' -> M.createGs dvc mc cis' mmac + <* destroyShaderStages' d cis' + (allocationCallbacksListListFromCreateInfoList cis) + let gs' = gListFromMiddle gs + atomically $ modifyTVar gss (Map.insert k gs') >> signalTSem sem + pure $ Right gs' + else pure . Left $ + "Gpu.Vulkan.Pipeline.Graphics.create' :: The key already exist" + +unsafeDestroyGs :: (Ord k, AllocationCallbacks.ToMiddle ma) => + Group sd ma sg k gas -> k -> IO (Either String ()) +unsafeDestroyGs (Group (Device.D mdvc) + (AllocationCallbacks.toMiddle -> mma) sem gss) k = do + mgs <- atomically do + mx <- Map.lookup k <$> readTVar gss + case mx of + Nothing -> pure Nothing + Just _ -> waitTSem sem >> pure mx + case mgs of + Nothing -> pure $ Left + "Gpu.Vulkan.Pipeline.Graphics.unsafeDestroyGs: No such key" + Just gs -> do + atomically . modifyTVar gss $ Map.delete k + M.destroyGs mdvc (gListToMiddle gs) mma + Right <$> atomically (signalTSem sem) + +lookup :: Ord k => + Group sd ma sg k gas -> k -> IO (Maybe (HeteroParList.PL (U3 (G sg)) gas)) +lookup (Group _ _ _sem gss) k = atomically $ Map.lookup k <$> readTVar gss diff --git a/src/Gpu/Vulkan/Pipeline/Graphics/Type.hs b/src/Gpu/Vulkan/Pipeline/Graphics/Type.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Pipeline/Graphics/Type.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures, TypeOperators #-} +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Pipeline.Graphics.Type (G(..)) where + +import GHC.TypeNats +import Data.Kind + +import Gpu.Vulkan.DescriptorSetLayout.Type qualified as DscStLyt +import Gpu.Vulkan.Pipeline.Graphics.Middle qualified as M + +import Gpu.Vulkan.VertexInput qualified as VertexInput + +newtype G s (vibs :: [(Type, VertexInput.Rate)]) (vias :: [(Nat, Type)]) + (lyta :: (Type, [(Type, [DscStLyt.BindingType])], [Type])) = G M.G diff --git a/src/Gpu/Vulkan/Pipeline/InputAssemblyState.hs b/src/Gpu/Vulkan/Pipeline/InputAssemblyState.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Pipeline/InputAssemblyState.hs @@ -0,0 +1,11 @@ +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Pipeline.InputAssemblyState ( + + -- * CREATE INFO + + CreateInfo(..) + + ) where + +import Gpu.Vulkan.Pipeline.InputAssemblyState.Middle diff --git a/src/Gpu/Vulkan/Pipeline/MultisampleState.hs b/src/Gpu/Vulkan/Pipeline/MultisampleState.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Pipeline/MultisampleState.hs @@ -0,0 +1,11 @@ +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Pipeline.MultisampleState ( + + -- * CREATE INFO + + CreateInfo(..) + + ) where + +import Gpu.Vulkan.Pipeline.MultisampleState.Middle diff --git a/src/Gpu/Vulkan/Pipeline/RasterizationState.hs b/src/Gpu/Vulkan/Pipeline/RasterizationState.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Pipeline/RasterizationState.hs @@ -0,0 +1,11 @@ +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Pipeline.RasterizationState ( + + -- * CREATE INFO + + CreateInfo(..) + + ) where + +import Gpu.Vulkan.Pipeline.RasterizationState.Middle diff --git a/src/Gpu/Vulkan/Pipeline/ShaderStage.hs b/src/Gpu/Vulkan/Pipeline/ShaderStage.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Pipeline/ShaderStage.hs @@ -0,0 +1,16 @@ +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Pipeline.ShaderStage ( + + -- * CREATE INFO + + CreateInfo(..), CreateInfoListToMiddle, + + -- * ENUM + + module Gpu.Vulkan.Pipeline.ShaderStage.Enum + + ) where + +import Gpu.Vulkan.Pipeline.ShaderStage.Internal +import Gpu.Vulkan.Pipeline.ShaderStage.Enum diff --git a/src/Gpu/Vulkan/Pipeline/ShaderStage/Enum.hs b/src/Gpu/Vulkan/Pipeline/ShaderStage/Enum.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Pipeline/ShaderStage/Enum.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE PackageImports #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Pipeline.ShaderStage.Enum ( + module Gpu.Vulkan.Pipeline.ShaderStage.Enum ) where + +import "gpu-vulkan-middle" Gpu.Vulkan.Pipeline.ShaderStage.Enum diff --git a/src/Gpu/Vulkan/Pipeline/ShaderStage/Internal.hs b/src/Gpu/Vulkan/Pipeline/ShaderStage/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Pipeline/ShaderStage/Internal.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE GADTs, TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts, FlexibleInstances #-} +{-# LANGUAGE PatternSynonyms #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Pipeline.ShaderStage.Internal ( + + -- * CREATE INFO + + CreateInfo(..), + + -- ** To Middle + + CreateInfoListToMiddle(..), createInfoToMiddle, + + -- ** Destroy Shader Module + + DestroyShaderModuleList(..), destroyShaderModule, + allocationCallbacksListFromCreateInfoList + + ) where + +import Foreign.Storable.PeekPoke +import Data.Kind +import Data.TypeLevel.Maybe qualified as TMaybe +import Data.TypeLevel.ParMaybe qualified as TPMaybe +import Data.TypeLevel.Tuple.Uncurry +import Data.TypeLevel.Tuple.MapIndex qualified as TMapIndex +import qualified Data.HeteroParList as HeteroParList +import Data.HeteroParList (pattern (:**)) +import Data.HeteroParList.Tuple qualified as HeteroParList + +import Language.SpirV.ShaderKind + +import qualified Data.ByteString as BS + +import Gpu.Vulkan.Enum +import Gpu.Vulkan.AllocationCallbacks.Type qualified as AllocationCallbacks +import Gpu.Vulkan.Pipeline.ShaderStage.Enum + +import qualified Gpu.Vulkan.Device.Type as Device +import qualified Gpu.Vulkan.ShaderModule.Internal as ShaderModule +import qualified Gpu.Vulkan.Pipeline.ShaderStage.Middle as M + +data CreateInfo mn mnsm sknd mac vs = CreateInfo { + createInfoNext :: TMaybe.M mn, + createInfoFlags :: CreateFlags, + createInfoStage :: ShaderStageFlagBits, + createInfoModule :: ( + ShaderModule.CreateInfo mnsm sknd, TPMaybe.M (U2 AllocationCallbacks.A) mac ), + createInfoName :: BS.ByteString, + createInfoSpecializationInfo :: Maybe (HeteroParList.L vs) } + +allocationCallbacksFromCreateInfo :: + CreateInfo mn mnsm sknd mac vs -> + TPMaybe.M (U2 AllocationCallbacks.A) mac +allocationCallbacksFromCreateInfo CreateInfo { createInfoModule = (_, mac) } = + mac + +allocationCallbacksListFromCreateInfoList :: HeteroParList.Map3_5 cias => + HeteroParList.PL (U5 CreateInfo) cias -> + HeteroParList.PL + (TPMaybe.M (U2 AllocationCallbacks.A)) (TMapIndex.M3_5 cias) +allocationCallbacksListFromCreateInfoList = + HeteroParList.map3_5 (allocationCallbacksFromCreateInfo . unU5) + +createInfoToMiddle :: + (WithPoked (TMaybe.M mnsm), AllocationCallbacks.ToMiddle mac) => + Device.D ds -> CreateInfo n mnsm sknd mac vs -> + IO (M.CreateInfo n sknd vs) +createInfoToMiddle dvc CreateInfo { + createInfoNext = mnxt, + createInfoFlags = flgs, + createInfoStage = stg, + createInfoModule = (mdl, mac), + createInfoName = nm, + createInfoSpecializationInfo = spi + } = do + mdl' <- ShaderModule.create dvc mdl mac + pure M.CreateInfo { + M.createInfoNext = mnxt, + M.createInfoFlags = flgs, + M.createInfoStage = stg, + M.createInfoModule = mdl', + M.createInfoName = nm, + M.createInfoSpecializationInfo = spi } + +class DestroyShaderModuleList (MiddleArgs cias) (TMapIndex.M3_5 cias) => + CreateInfoListToMiddle cias where + type MiddleArgs cias :: [(Maybe Type, ShaderKind, [Type])] + createInfoListToMiddle :: + Device.D ds -> + HeteroParList.PL (U5 CreateInfo) cias -> + IO (HeteroParList.PL (U3 M.CreateInfo) (MiddleArgs cias)) + +instance CreateInfoListToMiddle '[] where + type MiddleArgs '[] = '[] + createInfoListToMiddle _ HeteroParList.Nil = pure HeteroParList.Nil + +instance ( + WithPoked (TMaybe.M mnsm), AllocationCallbacks.ToMiddle mac, + CreateInfoListToMiddle cias ) => + CreateInfoListToMiddle ('(n, mnsm, sknd, mac, vs) ': cias) where + type MiddleArgs ('(n, mnsm, sknd, mac, vs) ': cias) = + '(n, sknd, vs) ': MiddleArgs cias + createInfoListToMiddle dvc (U5 ci :** cis) = (:**) + <$> (U3 <$> createInfoToMiddle dvc ci) + <*> createInfoListToMiddle dvc cis + +class DestroyShaderModuleList cias macs where + destroyShaderModuleList :: + Device.D sd -> HeteroParList.PL (U3 M.CreateInfo) cias -> + HeteroParList.PL (TPMaybe.M (U2 AllocationCallbacks.A)) macs -> + IO () + +instance DestroyShaderModuleList '[] '[] where + destroyShaderModuleList _ HeteroParList.Nil HeteroParList.Nil = pure () + +instance ( + AllocationCallbacks.ToMiddle mac, + DestroyShaderModuleList cias macs ) => + DestroyShaderModuleList (cia ': cias) (mac ': macs) where + destroyShaderModuleList dvc (U3 cim :** cims) (mac :** macs) = + destroyShaderModule dvc cim mac >> + destroyShaderModuleList dvc cims macs + +destroyShaderModule :: AllocationCallbacks.ToMiddle mac => + Device.D sd -> M.CreateInfo n sknd vs -> + TPMaybe.M (U2 AllocationCallbacks.A) mac -> IO () +destroyShaderModule dvc M.CreateInfo { M.createInfoModule = mmdl } mac = + ShaderModule.destroy dvc mmdl mac diff --git a/src/Gpu/Vulkan/Pipeline/TessellationState.hs b/src/Gpu/Vulkan/Pipeline/TessellationState.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Pipeline/TessellationState.hs @@ -0,0 +1,11 @@ +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Pipeline.TessellationState ( + + -- * CREATE INFO + + CreateInfo(..) + + ) where + +import Gpu.Vulkan.Pipeline.TessellationState.Middle diff --git a/src/Gpu/Vulkan/Pipeline/VertexInputState.hs b/src/Gpu/Vulkan/Pipeline/VertexInputState.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Pipeline/VertexInputState.hs @@ -0,0 +1,15 @@ +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Pipeline.VertexInputState ( + + -- * CREATE INFO + + CreateInfo(..), + + -- * FORMATTABLE + + Formattable(..) + + ) where + +import Gpu.Vulkan.Pipeline.VertexInputState.Internal diff --git a/src/Gpu/Vulkan/Pipeline/VertexInputState/BindingOffset.hs b/src/Gpu/Vulkan/Pipeline/VertexInputState/BindingOffset.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Pipeline/VertexInputState/BindingOffset.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ScopedTypeVariables, TypeApplications #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures, TypeOperators #-} +{-# LANGUAGE MultiParamTypeClasses, AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-} +{-# LANGUAGE DefaultSignatures #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Pipeline.VertexInputState.BindingOffset (BindingOffsetNew(..)) where + +import GHC.Generics +import Foreign.Storable +import Control.Arrow +import Data.Kind + +type Offset = Int + +class BindingOffsetNew (ts :: [Type]) (a :: Type) where + bindingOffsetNew :: (Int, Offset) + +instance BindingOffsetNew' (Rep t) ts a => BindingOffsetNew (t ': ts) a where + bindingOffsetNew = bindingOffsetNew' @(Rep t) @ts @a 0 + +class BindingOffsetNew' (t :: Type -> Type) (ts :: [Type]) (a :: Type) where + bindingOffsetNew' :: Offset -> (Int, Offset) + +instance BindingOffsetNew' body ts a => + BindingOffsetNew' (M1 _i _c body) ts a where + bindingOffsetNew' = bindingOffsetNew' @body @ts @a + +instance Storable a => BindingOffsetNew' (K1 _i a) ts a where + bindingOffsetNew' = (0 ,) . align @a + +instance {-# OVERLAPPABLE #-} BindingOffsetNew ts a => + BindingOffsetNew' (K1 _i t) ts a where + bindingOffsetNew' _ = (+ 1) `first` bindingOffsetNew @ts @a + +instance BindingOffsetNew' (body :*: bs) ts a => + BindingOffsetNew' (M1 _i _c body :*: bs) ts a where + bindingOffsetNew' = bindingOffsetNew' @(body :*: bs) @ts @a + +instance Storable a => BindingOffsetNew' (K1 _i a :*: _bs) ts a where + bindingOffsetNew' = (0 ,) . align @a + +instance BindingOffsetNew' (b :*: (b' :*: bs)) ts a => + BindingOffsetNew' ((b :*: b') :*: bs) ts a where + bindingOffsetNew' = bindingOffsetNew' @(b :*: (b' :*: bs)) @ts @a + +instance {-# OVERLAPPABLE #-} (Storable t, BindingOffsetNew' bs ts a) => + BindingOffsetNew' (K1 _i t :*: bs) ts a where + bindingOffsetNew' ofst = bindingOffsetNew' @bs @ts @a (nextEnd @t ofst) + +nextEnd :: forall t . Storable t => Offset -> Offset +nextEnd ofst = align @t ofst + sizeOf @t undefined + +align :: forall t . Storable t => Offset -> Offset +align ofst = ((ofst - 1) `div` algn + 1) * algn + where algn = alignment @t undefined diff --git a/src/Gpu/Vulkan/Pipeline/VertexInputState/Data/Type/TypeFam.hs b/src/Gpu/Vulkan/Pipeline/VertexInputState/Data/Type/TypeFam.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Pipeline/VertexInputState/Data/Type/TypeFam.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds, PolyKinds #-} +{-# LANGUAGE KindSignatures, TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Pipeline.VertexInputState.Data.Type.TypeFam (Until) where + +import Data.Kind + +type family AppMaybe (f :: x -> y) (mx :: Maybe x) :: Maybe y where + AppMaybe _ 'Nothing = 'Nothing + AppMaybe f ('Just x) = 'Just (f x) + +type family Until t (ts :: [Type]) :: Maybe [Type] where + Until _ '[] = 'Nothing + Until t (t : ts) = 'Just '[t] + Until t (t' : ts) = AppMaybe ((:) t') (Until t ts) diff --git a/src/Gpu/Vulkan/Pipeline/VertexInputState/Data/Type/TypeValMap.hs b/src/Gpu/Vulkan/Pipeline/VertexInputState/Data/Type/TypeValMap.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Pipeline/VertexInputState/Data/Type/TypeValMap.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE ScopedTypeVariables, RankNTypes, TypeApplications #-} +{-# LANGUAGE KindSignatures, DataKinds, ConstraintKinds, TypeOperators #-} +{-# LANGUAGE MultiParamTypeClasses, AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Pipeline.VertexInputState.Data.Type.TypeValMap (MapTypeVal2(..), MapTypeValMaybe2(..)) where + +import Data.Kind + +class MapTypeVal2 c (as :: [Type]) where + mapTypeVal2 :: (forall a . c a => a -> b) -> [b] + +instance MapTypeVal2 c '[] where mapTypeVal2 _ = [] + +instance (c a, MapTypeVal2 c as) => MapTypeVal2 c (a ': as) where + mapTypeVal2 x = x (undefined :: a) : mapTypeVal2 @c @as x + +class MapTypeValMaybe2 c (mas :: Maybe [Type]) where + mapTypeValMaybe2 :: (forall a . c a => a -> b) -> Maybe [b] + +instance MapTypeValMaybe2 c 'Nothing where mapTypeValMaybe2 _ = Nothing + +instance MapTypeVal2 c as => MapTypeValMaybe2 c ('Just as) where + mapTypeValMaybe2 x = Just $ mapTypeVal2 @c @as x diff --git a/src/Gpu/Vulkan/Pipeline/VertexInputState/Formattable.hs b/src/Gpu/Vulkan/Pipeline/VertexInputState/Formattable.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Pipeline/VertexInputState/Formattable.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Pipeline.VertexInputState.Formattable where + +import Gpu.Vulkan.Enum + +class Formattable a where formatOf :: Format +instance Formattable Int where formatOf = FormatUndefined diff --git a/src/Gpu/Vulkan/Pipeline/VertexInputState/GHC/Generics/TypeFam.hs b/src/Gpu/Vulkan/Pipeline/VertexInputState/GHC/Generics/TypeFam.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Pipeline/VertexInputState/GHC/Generics/TypeFam.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures, TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Pipeline.VertexInputState.GHC.Generics.TypeFam (Flatten) where + +import GHC.Generics +import Data.Kind + +type family GetType (x :: Type -> Type) :: Type where + GetType (K1 i a) = a + GetType (M1 m i a) = GetType a + +type family Flatten (x :: Type -> Type) :: [Type] where + Flatten U1 = '[] + Flatten (K1 i a) = '[a] + Flatten (M1 m i a) = Flatten a + Flatten (M1 m i a :*: t2) = GetType a ': Flatten t2 + Flatten ((t1 :*: t2) :*: t3) = Flatten (t1 :*: t2 :*: t3) diff --git a/src/Gpu/Vulkan/Pipeline/VertexInputState/Internal.hs b/src/Gpu/Vulkan/Pipeline/VertexInputState/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Pipeline/VertexInputState/Internal.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE ScopedTypeVariables, TypeApplications #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE DataKinds, PolyKinds #-} +{-# LANGUAGE KindSignatures, TypeOperators #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses, AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Pipeline.VertexInputState.Internal ( + + -- * CREATE INFO + + CreateInfo(..), + + -- * CREATE INFO TO MIDDLE + + createInfoToMiddle, + BindingStrideList, AttributeDescriptions, Formattable(..) + + ) where + +import GHC.TypeNats +import GHC.Generics +import Foreign.Storable.PeekPoke +import Data.TypeLevel.TypeVal qualified as TypeVal +import Data.TypeLevel.Maybe qualified as TMaybe +import Data.TypeLevel.Tuple.MapIndex qualified as TMapIndex +import Data.Kind +import Data.Bits +import Data.Default + +import qualified Gpu.Vulkan.Pipeline.VertexInputState.Middle as M +import qualified Gpu.Vulkan.VertexInput.Internal as VtxInp +import qualified Gpu.Vulkan.VertexInput.Middle as VtxInp.M + +import Gpu.Vulkan.Pipeline.VertexInputState.BindingOffset +import Gpu.Vulkan.Pipeline.VertexInputState.Formattable +import Gpu.Vulkan.Pipeline.VertexInputState.SizeAlignment +import Gpu.Vulkan.Pipeline.VertexInputState.Data.Type.TypeValMap +import Gpu.Vulkan.Pipeline.VertexInputState.GHC.Generics.TypeFam + +-- CREATE INFO + +data CreateInfo mn (vibs :: [(Type, VtxInp.Rate)]) (vias :: [(Nat, Type)]) = + CreateInfo { + createInfoNext :: TMaybe.M mn, + createInfoFlags :: M.CreateFlags } + +deriving instance Show (TMaybe.M mn) => Show (CreateInfo mn vibs vias) + +instance Default (CreateInfo 'Nothing vibs vias) where + def = CreateInfo { + createInfoNext = TMaybe.N, createInfoFlags = zeroBits } + +-- CREATE INFO TO MIDDLE + +createInfoToMiddle :: forall n vibs vias . ( + BindingStrideList vibs VtxInp.Rate, + AttributeDescriptions vibs vias ) => + CreateInfo n vibs vias -> M.CreateInfo n +createInfoToMiddle CreateInfo { + createInfoNext = mnxt, createInfoFlags = flgs } = M.CreateInfo { + M.createInfoNext = mnxt, + M.createInfoFlags = flgs, + M.createInfoVertexBindingDescriptions = bindingDescriptions @vibs, + M.createInfoVertexAttributeDescriptions = + attributeDescriptions @vibs @vias } + +-- Binding Descriptions + +bindingDescriptions :: + forall vibs . BindingStrideList vibs VtxInp.Rate => + [VtxInp.M.BindingDescription] +bindingDescriptions = fmap VtxInp.bindingDescriptionToMiddle + . VtxInp.bindingDescriptionFromRaw + $ bindingStrideList @_ @vibs @VtxInp.Rate + +class BindingStrideList (ts :: [(Type, k)]) v where + bindingStrideList :: [(SizeAlignment, v)] + +instance BindingStrideList '[] v where bindingStrideList = [] + +instance (MapTypeVal2 Sizable (Flatten (Rep t)), BindingStrideList ts v, TypeVal.T a v) => + BindingStrideList ('(t, a) ': ts) v where + bindingStrideList = + (wholeSizeAlignment @t, TypeVal.t @_ @a @v) : + bindingStrideList @_ @ts @v + +-- Attribute Descriptions + +class AttributeDescriptions + (vibs :: [(Type, VtxInp.Rate)]) (vias :: [(Nat, Type)]) where + attributeDescriptions :: [VtxInp.AttributeDescription] + +instance AttributeDescriptions vibs '[] where attributeDescriptions = [] + +instance ( + KnownNat i, BindingOffsetNew (TMapIndex.M0_2 vibs) t, Formattable t, + AttributeDescriptions vibs vias ) => + AttributeDescriptions vibs ('(i, t) ': vias) where + attributeDescriptions = VtxInp.AttributeDescription { + VtxInp.attributeDescriptionLocation = + fromIntegral $ natVal @i undefined, + VtxInp.attributeDescriptionBinding = bdng, + VtxInp.attributeDescriptionFormat = formatOf @t, + VtxInp.attributeDescriptionOffset = ost } : ads + where + (fromIntegral -> bdng, fromIntegral -> ost) = + bindingOffsetNew @(TMapIndex.M0_2 vibs) @t + ads = attributeDescriptions @vibs @vias diff --git a/src/Gpu/Vulkan/Pipeline/VertexInputState/SizeAlignment.hs b/src/Gpu/Vulkan/Pipeline/VertexInputState/SizeAlignment.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Pipeline/VertexInputState/SizeAlignment.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ScopedTypeVariables, TypeApplications #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE DataKinds, ConstraintKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses, AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs -fno-warn-orphans #-} + +module Gpu.Vulkan.Pipeline.VertexInputState.SizeAlignment ( + wholeSizeAlignment, offsetOf, + module Gpu.Vulkan.Pipeline.VertexInputState.SizeAlignment.Internal, Offset ) where + +import GHC.Generics +import Foreign.Storable.PeekPoke +import Data.Kind + +import Gpu.Vulkan.Pipeline.VertexInputState.SizeAlignment.Internal +import Gpu.Vulkan.Pipeline.VertexInputState.SizeAlignment.TH + +import Gpu.Vulkan.Pipeline.VertexInputState.Data.Type.TypeValMap +import Gpu.Vulkan.Pipeline.VertexInputState.GHC.Generics.TypeFam + +concat <$> instanceSizeAlignmentListTuple `mapM` filter (/= 1) [0 .. 15] +concat <$> instanceSizeAlignmentListUntilTuple `mapM` filter (/= 1) [0 .. 15] + +wholeSizeAlignment :: forall a . MapTypeVal2 Sizable (Flatten (Rep a)) => SizeAlignment +wholeSizeAlignment = let sas = sizeAlignmentListNew @a in + (calcWholeSize sas, calcWholeAlignment sas) + +sizeAlignmentListNew :: forall a . MapTypeVal2 Sizable (Flatten (Rep a)) => [SizeAlignment] +sizeAlignmentListNew = sizeAlignmentTypeList @(Flatten (Rep a)) + +sizeAlignmentTypeList :: + forall (as :: [Type]) . MapTypeVal2 Sizable as => [SizeAlignment] +sizeAlignmentTypeList = mapTypeVal2 @Sizable @as (\(_ :: a) -> (sizeOf' @a, alignment' @a)) + +calcWholeAlignment :: [SizeAlignment] -> Alignment +calcWholeAlignment = foldl lcm 1 . (snd <$>) + +calcWholeSize :: [SizeAlignment] -> Size +calcWholeSize = foldl next 0 . rotateAlignmentL + +type Offset = Int + +offsetOf :: forall t ts . SizeAlignmentListUntil t ts => Maybe Offset +offsetOf = calcOffset <$> sizeAlignmentListUntil @t @ts + +calcOffset :: [SizeAlignment] -> Offset +calcOffset = foldl next 0 . shiftAlignmentL + +next :: Offset -> SizeAlignment -> Offset +next os (sz, algn) = ((os + sz - 1) `div` algn + 1) * algn + +shiftAlignmentL :: [SizeAlignment] -> [SizeAlignment] +shiftAlignmentL [] = error "empty size and alignment list" +shiftAlignmentL sas = zip ss as where (ss, _ : as) = unzip sas + +rotateAlignmentL :: [SizeAlignment] -> [SizeAlignment] +rotateAlignmentL [] = error "empty size and alignment list" +rotateAlignmentL sas = zip ss (as ++ [a]) where (ss, a : as) = unzip sas diff --git a/src/Gpu/Vulkan/Pipeline/VertexInputState/SizeAlignment/Internal.hs b/src/Gpu/Vulkan/Pipeline/VertexInputState/SizeAlignment/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Pipeline/VertexInputState/SizeAlignment/Internal.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE ScopedTypeVariables, TypeApplications #-} +{-# LANGUAGE KindSignatures, DataKinds, ConstraintKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE MultiParamTypeClasses, AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Pipeline.VertexInputState.SizeAlignment.Internal ( + SizeAlignmentList(sizeAlignmentList), + SizeAlignmentListUntil(sizeAlignmentListUntil), MapSizableUntil, + Size, Alignment, SizeAlignment ) where + +import GHC.Generics +import Data.Kind +import Gpu.Vulkan.Pipeline.VertexInputState.GHC.Generics.TypeFam +import Gpu.Vulkan.Pipeline.VertexInputState.Data.Type.TypeFam +import Gpu.Vulkan.Pipeline.VertexInputState.Data.Type.TypeValMap + +import Foreign.Storable.PeekPoke + +type Size = Int +type Alignment = Int +type SizeAlignment = (Size, Alignment) + +sizeAlignmentTypeList :: + forall (as :: [Type]) . MapTypeVal2 Sizable as => [SizeAlignment] +sizeAlignmentTypeList = mapTypeVal2 @Sizable @as (\(_ :: a) -> (sizeOf' @a, alignment' @a)) + +class SizeAlignmentList a where + sizeAlignmentList :: [SizeAlignment] + + default sizeAlignmentList :: ( + MapTypeVal2 Sizable (Flatten (Rep a)) ) => [SizeAlignment] + sizeAlignmentList = sizeAlignmentTypeList @(Flatten (Rep a)) + +sizeAlignmentTypeMaybeList :: + forall (mas :: Maybe [Type]) . MapTypeValMaybe2 Sizable mas => + Maybe [SizeAlignment] +sizeAlignmentTypeMaybeList = + mapTypeValMaybe2 @Sizable @mas (\(_ :: a) -> (sizeOf' @a, alignment' @a)) + +class SizeAlignmentListUntil t a where + sizeAlignmentListUntil :: Maybe [SizeAlignment] + + default sizeAlignmentListUntil :: ( + MapTypeValMaybe2 Sizable (Until t (Flatten (Rep a))) ) => + Maybe [SizeAlignment] + sizeAlignmentListUntil = + sizeAlignmentTypeMaybeList @(Until t (Flatten (Rep a))) + +type MapSizableUntil t ts = MapTypeValMaybe2 Sizable (Until t (Flatten (Rep ts))) diff --git a/src/Gpu/Vulkan/Pipeline/VertexInputState/SizeAlignment/TH.hs b/src/Gpu/Vulkan/Pipeline/VertexInputState/SizeAlignment/TH.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Pipeline/VertexInputState/SizeAlignment/TH.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Pipeline.VertexInputState.SizeAlignment.TH ( + instanceSizeAlignmentListTuple, + instanceSizeAlignmentListUntilTuple ) where + +import Language.Haskell.TH +import Foreign.Storable.PeekPoke +import Gpu.Vulkan.Pipeline.VertexInputState.SizeAlignment.Internal +import Data.Bool + +instanceSizeAlignmentListTuple :: Int -> DecsQ +instanceSizeAlignmentListTuple n = newTypes n >>= \ts -> do + let tpl = tupT ts + (isInstance ''SizeAlignmentList . (: []) =<< tpl) >>= bool + ((: []) <$> instanceD + (cxt $ (conT ''Sizable `appT`) <$> ts) + (conT ''SizeAlignmentList `appT` tpl) []) + (pure []) + +tupT :: [TypeQ] -> TypeQ +tupT ts = foldl appT (tupleT $ length ts) ts + +newTypes :: Int -> Q [TypeQ] +newTypes = ((varT <$>) <$>) . newNames + +newNames :: Int -> Q [Name] +newNames n = newName `mapM` take n ((: "") <$> ['a' .. 'z']) + +instanceSizeAlignmentListUntilTuple :: Int -> DecsQ +instanceSizeAlignmentListUntilTuple n = + newName "t" >>= \t -> newTypes n >>= \ts -> do + let tpl = tupT ts + (isInstance ''SizeAlignmentListUntil . (: []) =<< tpl) >>= bool + ((: []) <$> instanceD + (cxt [conT ''MapSizableUntil `appT` varT t `appT` tpl]) +-- varT t `appT` promotedListT ts]) + (conT ''SizeAlignmentListUntil `appT` + varT t `appT` tpl) []) + (pure []) diff --git a/src/Gpu/Vulkan/Pipeline/ViewportState.hs b/src/Gpu/Vulkan/Pipeline/ViewportState.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Pipeline/ViewportState.hs @@ -0,0 +1,11 @@ +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Pipeline.ViewportState ( + + -- * CREATE INFO + + CreateInfo(..), CreateFlags + + ) where + +import Gpu.Vulkan.Pipeline.ViewportState.Middle diff --git a/src/Gpu/Vulkan/PipelineCache.hs b/src/Gpu/Vulkan/PipelineCache.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/PipelineCache.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE ScopedTypeVariables, RankNTypes, TypeApplications #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.PipelineCache ( + + -- * CREATE + + create, P, M.CreateInfo(..), + + -- * GET DATA + + getData, M.Data(..), + + -- * READ AND WRITE DATA + + readFile, writeFile, hRead, hWrite + + ) where + +import Prelude hiding (readFile, writeFile) + +import Foreign.Storable.PeekPoke +import Control.Exception +import Data.TypeLevel.Maybe qualified as TMaybe +import Data.TypeLevel.ParMaybe qualified as TPMaybe +import Data.TypeLevel.Tuple.Uncurry + +import Gpu.Vulkan.PipelineCache.Type + +import Gpu.Vulkan.AllocationCallbacks qualified as AllocationCallbacks +import Gpu.Vulkan.AllocationCallbacks.Type qualified as AllocationCallbacks +import Gpu.Vulkan.Device qualified as Device +import Gpu.Vulkan.Device.Type qualified as Device +import Gpu.Vulkan.PipelineCache.Middle qualified as M ( + create, destroy, CreateInfo(..), getData, Data(..) ) + +import Foreign.Ptr +import Foreign.Storable +import Foreign.Marshal.Alloc +import Foreign.C.Types +import Data.Word +import System.IO (Handle, hGetBuf, hPutBuf, withBinaryFile, IOMode(..)) + +import Data.ByteString qualified as BS + +create :: (WithPoked (TMaybe.M mn), AllocationCallbacks.ToMiddle mscc) => + Device.D sd -> M.CreateInfo mn -> + TPMaybe.M (U2 AllocationCallbacks.A) mscc -> (forall s . P s -> IO a) -> IO a +create (Device.D dv) ci + (AllocationCallbacks.toMiddle -> mac) f = + bracket (M.create dv ci mac) (\c -> M.destroy dv c mac) (f . P) + +getData :: Device.D sd -> P s -> IO M.Data +getData (Device.D dv) (P c) = M.getData dv c + +readFile :: FilePath -> IO M.Data +readFile fp = withBinaryFile fp ReadMode hRead + +hRead :: Handle -> IO M.Data +hRead h = do + sz <- readDataSize h + allocaBytes (fromIntegral sz) \pd -> do + _ <- hGetBuf h pd (fromIntegral sz) + dataFromRaw sz pd + +writeFile :: FilePath -> M.Data -> IO () +writeFile fp d = withBinaryFile fp WriteMode (`hWrite` d) + +hWrite :: Handle -> M.Data -> IO () +hWrite h d = dataToRaw d \sz pd -> + writeDataSize h sz >> hPutBuf h pd (fromIntegral sz) + +readDataSize :: Handle -> IO Word64 +readDataSize = readStorable + +readStorable :: forall a . Storable a => Handle -> IO a +readStorable h = alloca \px -> hGetBuf h px (sizeOf @a undefined) >> peek px + +writeDataSize :: Handle -> Word64 -> IO () +writeDataSize = writeStorable + +writeStorable :: Storable a => Handle -> a -> IO () +writeStorable h x = alloca \px -> poke px x >> hPutBuf h px (sizeOf x) + +dataFromRaw :: Word64 -> Ptr CChar -> IO M.Data +dataFromRaw sz pd = M.Data <$> BS.packCStringLen (pd, fromIntegral sz) + +dataToRaw :: M.Data -> (Word64 -> Ptr CChar -> IO a) -> IO a +dataToRaw (M.Data bs) f = BS.useAsCStringLen bs \(pd, sz) -> f (fromIntegral sz) pd diff --git a/src/Gpu/Vulkan/PipelineCache/Type.hs b/src/Gpu/Vulkan/PipelineCache/Type.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/PipelineCache/Type.hs @@ -0,0 +1,13 @@ +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.PipelineCache.Type ( + + -- * PIPELINE CACHE + + P(..) + + ) where + +import qualified Gpu.Vulkan.PipelineCache.Middle as M + +newtype P s = P { pToMiddle :: M.P } deriving Show diff --git a/src/Gpu/Vulkan/PipelineLayout.hs b/src/Gpu/Vulkan/PipelineLayout.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/PipelineLayout.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE ScopedTypeVariables, RankNTypes, TypeApplications #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds, PolyKinds #-} +{-# LANGUAGE KindSignatures, TypeOperators #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-} +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.PipelineLayout ( + + -- * CREATE + + create, P, CreateInfo(..), M.CreateFlags + + ) where + +import Foreign.Storable.PeekPoke +import Control.Exception +import Data.Kind +import Data.TypeLevel.Maybe qualified as TMaybe +import Data.TypeLevel.ParMaybe qualified as TPMaybe +import Data.TypeLevel.Tuple.Uncurry +import qualified Data.HeteroParList as HeteroParList + +import Gpu.Vulkan.PipelineLayout.Type + +import qualified Gpu.Vulkan.AllocationCallbacks as AllocationCallbacks +import qualified Gpu.Vulkan.AllocationCallbacks.Type as AllocationCallbacks +import qualified Gpu.Vulkan.Device.Type as Device +import qualified Gpu.Vulkan.DescriptorSetLayout.Type as DscStLyt +import qualified Gpu.Vulkan.PushConstant.Internal as PushConstant +import qualified Gpu.Vulkan.PipelineLayout.Middle as M + +-- CREATE + +create :: ( + WithPoked (TMaybe.M mn), + HeteroParList.ToListT2 Type [DscStLyt.BindingType] lytas, + PushConstant.RangeListToMiddle whole ranges, + AllocationCallbacks.ToMiddle mac ) => + Device.D sd -> + CreateInfo mn lytas ('PushConstant.Layout whole ranges) -> + TPMaybe.M (U2 AllocationCallbacks.A) mac -> + (forall s . P s lytas whole -> IO a) -> IO a +create (Device.D dvc) (createInfoToMiddle -> ci) + (AllocationCallbacks.toMiddle -> mac) f = + bracket (M.create dvc ci mac) (\l -> M.destroy dvc l mac) (f . P) + +-- CREATE INFO + +data CreateInfo mn lytas (pcl :: PushConstant.Layout) = CreateInfo { + createInfoNext :: TMaybe.M mn, createInfoFlags :: M.CreateFlags, + createInfoSetLayouts :: HeteroParList.PL (U2 DscStLyt.D) lytas } + +deriving instance ( + Show (TMaybe.M mn), Show (HeteroParList.PL (U2 DscStLyt.D) lytas) ) => + Show (CreateInfo mn lytas pcl) + +createInfoToMiddle :: forall n k lytas whole ranges . ( + PushConstant.RangeListToMiddle whole ranges, + HeteroParList.ToListT2 k [DscStLyt.BindingType] lytas ) => + CreateInfo n lytas ('PushConstant.Layout whole ranges) -> M.CreateInfo n +createInfoToMiddle CreateInfo { + createInfoNext = mnxt, + createInfoFlags = flgs, + createInfoSetLayouts = HeteroParList.toListT2 + $ DscStLyt.unL . unU2 -> sls } = M.CreateInfo { + M.createInfoNext = mnxt, + M.createInfoFlags = flgs, + M.createInfoSetLayouts = sls, + M.createInfoPushConstantRanges = + PushConstant.rangeListToMiddle @whole @ranges } diff --git a/src/Gpu/Vulkan/PipelineLayout/Type.hs b/src/Gpu/Vulkan/PipelineLayout/Type.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/PipelineLayout/Type.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.PipelineLayout.Type where + +import Data.Kind + +import qualified Gpu.Vulkan.DescriptorSetLayout.Type as DescriptorSetLayout +import qualified Gpu.Vulkan.PipelineLayout.Middle as M + +newtype P s + (sbtss :: [(Type, [DescriptorSetLayout.BindingType])]) (pcw :: [Type]) = + P M.P deriving Show diff --git a/src/Gpu/Vulkan/PushConstant.hs b/src/Gpu/Vulkan/PushConstant.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/PushConstant.hs @@ -0,0 +1,11 @@ +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.PushConstant ( + + -- * PUSHCONSTANT LAYOUT + + Layout(..), Range(..), RangeListToMiddle + + ) where + +import Gpu.Vulkan.PushConstant.Internal diff --git a/src/Gpu/Vulkan/PushConstant/Internal.hs b/src/Gpu/Vulkan/PushConstant/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/PushConstant/Internal.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE ScopedTypeVariables, TypeApplications #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures, TypeOperators #-} +{-# LANGUAGE MultiParamTypeClasses, AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-} +{-# LANGUAGE PatternSynonyms #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.PushConstant.Internal ( + + -- * PUSHCONSTANT LAYOUT + + Layout(..), Range(..), + + -- * PUSH CONSTANT LAYOUT TO RANGES + + RangeListToMiddle(..) + + ) where + +import Foreign.Storable.HeteroList +import Data.Kind + +import Gpu.Vulkan.TypeEnum qualified as T +import Gpu.Vulkan.PushConstant.Middle qualified as M + +data Layout = Layout [Type] [Range] + +data Range = Range [T.ShaderStageFlagBits] [Type] + +class RangeListToMiddle (whole :: [Type]) (ranges :: [Range]) where + rangeListToMiddle :: [M.Range] + +instance RangeListToMiddle whole '[] where rangeListToMiddle = [] + +instance (RangeToMiddle whole range, RangeListToMiddle whole ranges) => + RangeListToMiddle whole (range ': ranges) where + rangeListToMiddle = + rangeToMiddle @whole @range : rangeListToMiddle @whole @ranges + +class RangeToMiddle (whole :: [Type]) (range :: Range) where + rangeToMiddle :: M.Range + +instance (T.ShaderStageFlagBitsListToValue sss, InfixOffsetSize part whole) => + RangeToMiddle whole ('Range sss part) where + rangeToMiddle = M.Range { + M.rangeStageFlags = T.shaderStageFlagBitsListToValue @sss, + M.rangeOffset = fromIntegral offt, + M.rangeSize = fromIntegral sz } + where + (offt, sz) = infixOffsetSize @part @whole diff --git a/src/Gpu/Vulkan/Query.hs b/src/Gpu/Vulkan/Query.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Query.hs @@ -0,0 +1,20 @@ +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Query ( + + -- * TYPE SYNONYMS + + Q, First, Count, + + -- * ENUM + + module Gpu.Vulkan.Query.Enum + + ) where + +import Data.Word +import Gpu.Vulkan.Query.Enum + +type First = Word32 +type Count = Word32 +type Q = Word32 diff --git a/src/Gpu/Vulkan/Query/Enum.hs b/src/Gpu/Vulkan/Query/Enum.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Query/Enum.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE PackageImports #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Query.Enum (module Gpu.Vulkan.Query.Enum) where + +import "gpu-vulkan-middle" Gpu.Vulkan.Query.Enum diff --git a/src/Gpu/Vulkan/QueryPool.hs b/src/Gpu/Vulkan/QueryPool.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/QueryPool.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables, RankNTypes, TypeApplications #-} +{-# LANGUAGE GADTs, TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts, UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.QueryPool ( + + -- * CREATE + + create, Q, CreateInfo(..), + + -- * GET RESULTS + + getResults, QueryType, PipelineStatistics(..), Timestamp(..), + + M.Availability(..) + + ) where + +import Foreign.Storable +import Foreign.Storable.PeekPoke +import Control.Exception +import Data.TypeLevel.Maybe qualified as TMaybe +import Data.TypeLevel.ParMaybe qualified as TPMaybe +import Data.TypeLevel.Tuple.Uncurry +import Data.Kind +import Data.Word + +import Gpu.Vulkan.AllocationCallbacks qualified as AllocationCallbacks +import Gpu.Vulkan.AllocationCallbacks.Type qualified as AllocationCallbacks +import Gpu.Vulkan.PhysicalDevice qualified as PhysicalDevice +import Gpu.Vulkan.PhysicalDevice.Struct qualified as PhysicalDevice +import Gpu.Vulkan.Device.Type qualified as Device +import Gpu.Vulkan.Query qualified as Q +import Gpu.Vulkan.QueryPool.Type +import Gpu.Vulkan.QueryPool.Middle qualified as M + +-- CREATE + +create :: ( + WithPoked (TMaybe.M mn), QueryType tp, + AllocationCallbacks.ToMiddle mac ) => + Device.D sd -> CreateInfo mn tp -> + TPMaybe.M (U2 AllocationCallbacks.A) mac -> + (forall s . Q s tp -> IO a) -> IO a +create (Device.D dv) ci + (AllocationCallbacks.toMiddle -> macc) f = bracket + (M.create dv (createInfoToMiddle ci) macc) + (\qp -> M.destroy dv qp macc) (f . Q) + +data CreateInfo mn (tp :: Bool -> Type) = CreateInfo { + createInfoNext :: TMaybe.M mn, + createInfoFlags :: M.CreateFlags, + createInfoQueryCount :: Q.Count, + createInfoPipelineStatistics :: Q.PipelineStatisticFlags } + +deriving instance Show (TMaybe.M mn) => Show (CreateInfo mn tp) + +createInfoToMiddle :: + forall n tp . QueryType tp => CreateInfo n tp -> M.CreateInfo n +createInfoToMiddle CreateInfo { + createInfoNext = mnxt, + createInfoFlags = flgs, + createInfoQueryCount = qc, + createInfoPipelineStatistics = ps } = M.CreateInfo { + M.createInfoNext = mnxt, + M.createInfoFlags = flgs, + M.createInfoQueryType = queryType @tp, + M.createInfoQueryCount = qc, + M.createInfoPipelineStatistics = ps } + +-- GET RESULTS + +getResults :: forall sd sq av tp w64 . ( + QueryType tp, + Storable (M.W32W64 w64), M.W32W64Tools w64, + M.AvailabilityTools av (M.W32W64 w64) ) => + PhysicalDevice.P -> + Device.D sd -> Q sq tp -> Q.First -> Q.Count -> Q.ResultFlags -> + IO [M.Availability av (tp w64)] +getResults pd (Device.D dv) (Q qp) fq qc flgs = do + a <- getQueryArg @tp pd + ((fromWord a <$>) <$>) <$> M.getResults dv qp fq qc flgs + +class QueryType (qt :: Bool -> Type) where + type QueryArg qt + queryType :: Q.Type + fromWord :: QueryArg qt -> M.W32W64 w64 -> qt w64 + getQueryArg :: PhysicalDevice.P -> IO (QueryArg qt) + +-- Pipeline Statistics + +instance QueryType PipelineStatistics where + type QueryArg PipelineStatistics = () + queryType = Q.TypePipelineStatistics + fromWord () = pipelineStatisticsFromWord + getQueryArg _ = pure () + +data PipelineStatistics (w64 :: Bool) where + PipelineStatistics32 :: Word32 -> PipelineStatistics 'False + PipelineStatistics64 :: Word64 -> PipelineStatistics 'True + +deriving instance Show (PipelineStatistics w64) + +pipelineStatisticsFromWord :: M.W32W64 w64 -> PipelineStatistics w64 +pipelineStatisticsFromWord = \case + M.W32 w -> PipelineStatistics32 w; M.W64 w -> PipelineStatistics64 w + +-- Timestamp + +data Timestamp w64 where + Timestamp32 :: { + timestampPeriod32 :: Float, + timestampW32 :: Word32 } -> Timestamp 'False + Timestamp64 :: { + timestampPeriod64 :: Float, + timestampW64 :: Word64 } -> Timestamp 'True + +instance Show (Timestamp w64) where + show = \case + Timestamp32 p w -> + show @Double (realToFrac p * fromIntegral w) ++ "ns" + Timestamp64 p w -> + show @Double (realToFrac p * fromIntegral w) ++ "ns" + +instance QueryType Timestamp where + type QueryArg Timestamp = Float + queryType = Q.TypeTimestamp + fromWord p = \case + M.W32 w -> Timestamp32 p w; M.W64 w -> Timestamp64 p w + getQueryArg pd = do + lmts <- PhysicalDevice.propertiesLimits + <$> PhysicalDevice.getProperties pd + pure $ PhysicalDevice.limitsTimestampPeriod lmts diff --git a/src/Gpu/Vulkan/QueryPool/Type.hs b/src/Gpu/Vulkan/QueryPool/Type.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/QueryPool/Type.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE KindSignatures #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.QueryPool.Type ( + + -- * QUERY POOL + + Q(..) + + ) where + +import Data.Kind + +import Gpu.Vulkan.QueryPool.Middle qualified as M + +newtype Q sq (tp :: Bool -> Type) = Q M.Q deriving Show diff --git a/src/Gpu/Vulkan/Queue.hs b/src/Gpu/Vulkan/Queue.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Queue.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Queue ( + + -- * SUBMIT AND WAIT IDLE + + submit, M.waitIdle, M.Q, + + -- * TYPE SYNONYM + + Index, + + -- * ENUM + + module Gpu.Vulkan.Queue.Enum + + ) where + +import Data.TypeLevel.Tuple.Uncurry +import Data.HeteroParList qualified as HeteroParList +import Data.Word + +import Gpu.Vulkan.Internal + +import qualified Gpu.Vulkan.Fence.Type as Fence + +import Gpu.Vulkan.Queue.Middle qualified as M +import Gpu.Vulkan.Queue.Enum + +submit :: SubmitInfoListToMiddle sias => M.Q -> + HeteroParList.PL (U4 SubmitInfo) sias -> Maybe (Fence.F sf) -> IO () +submit q sis mf = + M.submit q (submitInfoListToMiddle sis) $ (\(Fence.F f) -> f) <$> mf + +type Index = Word32 diff --git a/src/Gpu/Vulkan/Queue/Enum.hs b/src/Gpu/Vulkan/Queue/Enum.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Queue/Enum.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE PackageImports #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Queue.Enum (module Gpu.Vulkan.Queue.Enum) where + +import "gpu-vulkan-middle" Gpu.Vulkan.Queue.Enum diff --git a/src/Gpu/Vulkan/QueueFamily.hs b/src/Gpu/Vulkan/QueueFamily.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/QueueFamily.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.QueueFamily ( + + -- * PROPERTIES + + Properties(..), + + -- * INDEX + + Index, pattern Ignored + + ) where + +import Gpu.Vulkan.QueueFamily.Middle diff --git a/src/Gpu/Vulkan/RenderPass.hs b/src/Gpu/Vulkan/RenderPass.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/RenderPass.hs @@ -0,0 +1,25 @@ +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.RenderPass ( + + -- * CREATE + + create, R, CreateInfo(..), + + -- ** Group + + group, Group, create', unsafeDestroy, lookup, + + -- * BEGIN INFO + + BeginInfo(..), + + -- * ENUM + + module Gpu.Vulkan.RenderPass.Enum + + ) where + +import Prelude hiding (lookup) +import Gpu.Vulkan.RenderPass.Internal +import Gpu.Vulkan.RenderPass.Enum diff --git a/src/Gpu/Vulkan/RenderPass/Enum.hs b/src/Gpu/Vulkan/RenderPass/Enum.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/RenderPass/Enum.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE PackageImports #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.RenderPass.Enum (module Gpu.Vulkan.RenderPass.Enum) where + +import "gpu-vulkan-middle" Gpu.Vulkan.RenderPass.Enum diff --git a/src/Gpu/Vulkan/RenderPass/Internal.hs b/src/Gpu/Vulkan/RenderPass/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/RenderPass/Internal.hs @@ -0,0 +1,163 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.RenderPass.Internal ( + + -- * CREATE + + create, R, CreateInfo(..), + + -- ** Group + + group, Group, create', unsafeDestroy, lookup, + + -- * BEGIN INFO + + BeginInfo(..), beginInfoToMiddle + + ) where + +import Prelude hiding (lookup) + +import Foreign.Storable.PeekPoke +import Control.Concurrent.STM +import Control.Concurrent.STM.TSem +import Control.Exception +import Data.TypeLevel.Maybe qualified as TMaybe +import Data.TypeLevel.ParMaybe qualified as TPMaybe +import Data.TypeLevel.Tuple.Uncurry +import Data.Map qualified as Map +import Data.HeteroParList qualified as HeteroParList + +import Gpu.Vulkan.RenderPass.Type + +import qualified Gpu.Vulkan.AllocationCallbacks as AllocationCallbacks +import qualified Gpu.Vulkan.AllocationCallbacks.Type as AllocationCallbacks +import qualified Gpu.Vulkan.Device.Type as Device +import Gpu.Vulkan.RenderPass.Enum +import qualified Gpu.Vulkan.RenderPass.Middle as M +import qualified Gpu.Vulkan.Attachment as Attachment + +import qualified Gpu.Vulkan.Subpass.Middle as Subpass + +import qualified Gpu.Vulkan.Framebuffer.Type as Framebuffer +import Gpu.Vulkan.Middle + +-- CREATE + +create :: ( + WithPoked (TMaybe.M mn), Attachment.DescriptionListToMiddle fmts, + AllocationCallbacks.ToMiddle mac ) => + Device.D sd -> CreateInfo mn fmts -> + TPMaybe.M (U2 AllocationCallbacks.A) mac -> + (forall s . R s -> IO a) -> IO a +create (Device.D dvc) ci (AllocationCallbacks.toMiddle -> mac) f = bracket + (M.create dvc (createInfoToMiddle ci) mac) + (\r -> M.destroy dvc r mac) (f . R) + +data CreateInfo mn fmts = CreateInfo { + createInfoNext :: TMaybe.M mn, + createInfoFlags :: CreateFlags, + createInfoAttachments :: + HeteroParList.PL Attachment.Description fmts, + createInfoSubpasses :: [Subpass.Description], + createInfoDependencies :: [Subpass.Dependency] } + +createInfoToMiddle :: Attachment.DescriptionListToMiddle fmts => + CreateInfo n fmts -> M.CreateInfo n +createInfoToMiddle CreateInfo { + createInfoNext = mnxt, + createInfoFlags = flgs, + createInfoAttachments = atts, + createInfoSubpasses = spss, + createInfoDependencies = dps } = M.CreateInfo { + M.createInfoNext = mnxt, + M.createInfoFlags = flgs, + M.createInfoAttachments = Attachment.descriptionListToMiddle atts, + M.createInfoSubpasses = spss, + M.createInfoDependencies = dps } + +-- Group + +data Group sd ma sr k = Group (Device.D sd) + (TPMaybe.M (U2 AllocationCallbacks.A) ma) + TSem (TVar (Map.Map k (R sr))) + +group :: AllocationCallbacks.ToMiddle ma => + Device.D sd -> TPMaybe.M (U2 AllocationCallbacks.A) ma -> + (forall sr . Group sd ma sr k -> IO a) -> IO a +group dvc@(Device.D mdvc) mac@(AllocationCallbacks.toMiddle -> mmac) f = do + (sem, m) <- atomically $ (,) <$> newTSem 1 <*> newTVar Map.empty + rtn <- f $ Group dvc mac sem m + ((\(R mr) -> M.destroy mdvc mr mmac) `mapM_`) + =<< atomically (readTVar m) + pure rtn + +create' :: ( + Ord k, WithPoked (TMaybe.M mn), Attachment.DescriptionListToMiddle fmts, + AllocationCallbacks.ToMiddle mac ) => + Group sd mac sr k -> k -> CreateInfo mn fmts -> + IO (Either String (R sr)) +create' (Group (Device.D mdvc) + (AllocationCallbacks.toMiddle -> mac) sem rs) k ci = do + ok <- atomically do + mx <- Map.lookup k <$> readTVar rs + case mx of + Nothing -> waitTSem sem >> pure True + Just _ -> pure False + if ok + then do r <- M.create mdvc (createInfoToMiddle ci) mac + let r' = R r + atomically $ modifyTVar rs (Map.insert k r') >> signalTSem sem + pure $ Right r' + else pure . Left $ + "Gpu.Vulkan.RenderPass.Internal.create': The key already exist" + +unsafeDestroy :: (Ord k, AllocationCallbacks.ToMiddle ma) => + Group sd ma sr k -> k -> IO (Either String ()) +unsafeDestroy (Group (Device.D mdvc) + (AllocationCallbacks.toMiddle -> ma) sem rs) k = do + mr <- atomically do + mx <- Map.lookup k <$> readTVar rs + case mx of + Nothing -> pure Nothing + Just _ -> waitTSem sem >> pure mx + case mr of + Nothing -> pure $ Left + "Gpu.Vulkan.RenderPass.Internal.unsafeDestroy: No such key" + Just (R r) -> do + M.destroy mdvc r ma + atomically do + modifyTVar rs $ Map.delete k + signalTSem sem + pure $ Right () + +lookup :: Ord k => Group sd ma sr k -> k -> IO (Maybe (R sr)) +lookup (Group _ _ _sem rs) k = atomically $ Map.lookup k <$> readTVar rs + +-- BEGIN INFO + +data BeginInfo mn sr sf cts = BeginInfo { + beginInfoNext :: TMaybe.M mn, + beginInfoRenderPass :: R sr, + beginInfoFramebuffer :: Framebuffer.F sf, + beginInfoRenderArea :: Rect2d, + beginInfoClearValues :: HeteroParList.PL ClearValue cts } + +beginInfoToMiddle :: BeginInfo n sr sf cts -> M.BeginInfo n cts +beginInfoToMiddle BeginInfo { + beginInfoNext = mnxt, + beginInfoRenderPass = R rp, + beginInfoFramebuffer = Framebuffer.F fb, + beginInfoRenderArea = ra, + beginInfoClearValues = cvs } = M.BeginInfo { + M.beginInfoNext = mnxt, + M.beginInfoRenderPass = rp, + M.beginInfoFramebuffer = fb, + M.beginInfoRenderArea = ra, + M.beginInfoClearValues = cvs } diff --git a/src/Gpu/Vulkan/RenderPass/Type.hs b/src/Gpu/Vulkan/RenderPass/Type.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/RenderPass/Type.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE PatternSynonyms #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.RenderPass.Type where + +import qualified Gpu.Vulkan.RenderPass.Middle as M + +newtype R s = R M.R deriving Show diff --git a/src/Gpu/Vulkan/Sample.hs b/src/Gpu/Vulkan/Sample.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Sample.hs @@ -0,0 +1,16 @@ +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Sample ( + + -- * COUNT AND MASK + + CountAndMask(..), + + -- ENUM + + module Gpu.Vulkan.Sample.Enum + + ) where + +import Gpu.Vulkan.Sample.Middle +import Gpu.Vulkan.Sample.Enum diff --git a/src/Gpu/Vulkan/Sample/Enum.hs b/src/Gpu/Vulkan/Sample/Enum.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Sample/Enum.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE PackageImports #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Sample.Enum (module Gpu.Vulkan.Sample.Enum) where + +import "gpu-vulkan-middle" Gpu.Vulkan.Sample.Enum diff --git a/src/Gpu/Vulkan/Sampler.hs b/src/Gpu/Vulkan/Sampler.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Sampler.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Sampler ( + + -- * CREATE + + create, S, M.CreateInfo(..), + + -- * ENUM + + module Gpu.Vulkan.Sampler.Enum + + ) where + +import Foreign.Storable.PeekPoke +import Control.Exception +import Data.TypeLevel.Maybe qualified as TMaybe +import Data.TypeLevel.ParMaybe qualified as TPMaybe +import Data.TypeLevel.Tuple.Uncurry + +import qualified Gpu.Vulkan.AllocationCallbacks as AllocationCallbacks +import qualified Gpu.Vulkan.AllocationCallbacks.Type as AllocationCallbacks +import qualified Gpu.Vulkan.Device.Type as Device +import qualified Gpu.Vulkan.Sampler.Middle as M +import Gpu.Vulkan.Sampler.Enum + +import Gpu.Vulkan.Sampler.Type + +create :: (WithPoked (TMaybe.M mn), AllocationCallbacks.ToMiddle mac) => + Device.D sd -> M.CreateInfo mn -> + TPMaybe.M (U2 AllocationCallbacks.A) mac -> + (forall s . S s -> IO a) -> IO a +create (Device.D dvc) ci + (AllocationCallbacks.toMiddle -> mac) f = + bracket (M.create dvc ci mac) (\s -> M.destroy dvc s mac) (f . S) diff --git a/src/Gpu/Vulkan/Sampler/Enum.hs b/src/Gpu/Vulkan/Sampler/Enum.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Sampler/Enum.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE PackageImports #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Sampler.Enum (module Gpu.Vulkan.Sampler.Enum) where + +import "gpu-vulkan-middle" Gpu.Vulkan.Sampler.Enum diff --git a/src/Gpu/Vulkan/Sampler/Type.hs b/src/Gpu/Vulkan/Sampler/Type.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Sampler/Type.hs @@ -0,0 +1,7 @@ +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Sampler.Type where + +import qualified Gpu.Vulkan.Sampler.Middle as M + +newtype S s = S { sToMiddle :: M.S } deriving Show diff --git a/src/Gpu/Vulkan/Semaphore.hs b/src/Gpu/Vulkan/Semaphore.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Semaphore.hs @@ -0,0 +1,16 @@ +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Semaphore ( + + -- * CREATE + + create, S, CreateInfo(..), + + -- ** Group + + group, Group, create', unsafeDestroy, lookup, + + ) where + +import Prelude hiding (lookup) +import Gpu.Vulkan.Semaphore.Internal diff --git a/src/Gpu/Vulkan/Semaphore/Internal.hs b/src/Gpu/Vulkan/Semaphore/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Semaphore/Internal.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Semaphore.Internal ( + + -- * CREATE + + create, S(..), M.CreateInfo(..), + + -- ** Group + + group, Group, create', unsafeDestroy, lookup, + + ) where + +import Prelude hiding (lookup) +import Foreign.Storable.PeekPoke +import Control.Concurrent.STM +import Control.Concurrent.STM.TSem +import Control.Exception +import Data.TypeLevel.Maybe qualified as TMaybe +import Data.TypeLevel.ParMaybe qualified as TPMaybe +import Data.TypeLevel.Tuple.Uncurry +import Data.Map qualified as Map +import Data.Word + +import qualified Gpu.Vulkan.Device.Type as Device +import qualified Gpu.Vulkan.AllocationCallbacks as AllocationCallbacks +import qualified Gpu.Vulkan.AllocationCallbacks.Type as AllocationCallbacks +import qualified Gpu.Vulkan.Semaphore.Middle as M + +import Gpu.Vulkan.Semaphore.Type + +create :: (WithPoked (TMaybe.M mn), AllocationCallbacks.ToMiddle mac) => + Device.D sd -> M.CreateInfo mn -> + TPMaybe.M (U2 AllocationCallbacks.A) mac -> + (forall ss . S ss -> IO a) -> IO a +create (Device.D dvc) ci + (AllocationCallbacks.toMiddle -> macc) f = bracket + (M.create dvc ci macc) (\s -> M.destroy dvc s macc) (f . S) + +data Group sd ma ss k = Group (Device.D sd) + (TPMaybe.M (U2 AllocationCallbacks.A) ma) TSem (TVar (Map.Map k (S ss))) + +group :: AllocationCallbacks.ToMiddle ma => + Device.D sd -> TPMaybe.M (U2 AllocationCallbacks.A) ma -> + (forall ss . Group sd ma ss k -> IO a) -> IO a +group dvc@(Device.D mdvc) mac@(AllocationCallbacks.toMiddle -> mmac) f = do + (sem, m) <- atomically $ (,) <$> newTSem 1 <*> newTVar Map.empty + rtn <- f $ Group dvc mac sem m + ((\(S s) -> M.destroy mdvc s mmac) `mapM_`) =<< atomically (readTVar m) + pure rtn + +create' :: ( + Ord k, WithPoked (TMaybe.M mn), AllocationCallbacks.ToMiddle ma) => + Group sd ma ss k -> k -> M.CreateInfo mn -> IO (Either String (S ss)) +create' (Group (Device.D mdvc) + (AllocationCallbacks.toMiddle -> mmac) sem ss) k ci = do + ok <- atomically do + mx <- Map.lookup k <$> readTVar ss + case mx of + Nothing -> waitTSem sem >> pure True + Just _ -> pure False + if ok + then do s <- M.create mdvc ci mmac + let s' = S s + atomically $ modifyTVar ss (Map.insert k s') >> signalTSem sem + pure $ Right s' + else pure . Left $ + "Gpu.Vulkan.Semaphore.Internal.create': The key already exist" + +unsafeDestroy :: (Ord k, AllocationCallbacks.ToMiddle ma) => + Group sd ma ss k -> k -> IO (Either String ()) +unsafeDestroy (Group (Device.D mdvc) + (AllocationCallbacks.toMiddle -> ma) sem ss) k = do + ms <- atomically do + mx <- Map.lookup k <$> readTVar ss + case mx of + Nothing -> pure Nothing + Just _ -> waitTSem sem >> pure mx + case ms of + Nothing -> pure $ Left + "Gpu.Vulkan.Semaphore.unsafeDestroy: No such key" + Just (S s) -> do + M.destroy mdvc s ma + atomically do + modifyTVar ss $ Map.delete k + signalTSem sem + pure $ Right () + +lookup :: Ord k => Group sd ma ss k -> k -> IO (Maybe (S ss)) +lookup (Group _ _ _sem ss) k = atomically $ Map.lookup k <$> readTVar ss diff --git a/src/Gpu/Vulkan/Semaphore/Type.hs b/src/Gpu/Vulkan/Semaphore/Type.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Semaphore/Type.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Semaphore.Type where + +import Gpu.Vulkan.Semaphore.Middle qualified as M + +newtype S s = S M.S deriving Show diff --git a/src/Gpu/Vulkan/ShaderModule.hs b/src/Gpu/Vulkan/ShaderModule.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/ShaderModule.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.ShaderModule ( + + -- * CREATE INFO + + CreateInfo(..), CreateFlags + + ) where + +import Gpu.Vulkan.ShaderModule.Internal diff --git a/src/Gpu/Vulkan/ShaderModule/Internal.hs b/src/Gpu/Vulkan/ShaderModule/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/ShaderModule/Internal.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PatternSynonyms #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.ShaderModule.Internal ( + + -- * CREATE AND DESTROY + + create, destroy, M.CreateInfo(..), M.CreateFlags + + ) where + +import Foreign.Storable.PeekPoke +import Data.TypeLevel.Maybe qualified as TMaybe +import Data.TypeLevel.ParMaybe qualified as TPMaybe +import Data.TypeLevel.Tuple.Uncurry + +import qualified Gpu.Vulkan.AllocationCallbacks as AllocationCallbacks +import qualified Gpu.Vulkan.AllocationCallbacks.Type as AllocationCallbacks +import qualified Gpu.Vulkan.Device.Type as Device +import qualified Gpu.Vulkan.ShaderModule.Middle as M + +create :: (WithPoked (TMaybe.M mn), AllocationCallbacks.ToMiddle mscc) => + Device.D sd -> M.CreateInfo mn sknd -> TPMaybe.M (U2 AllocationCallbacks.A) mscc -> IO (M.S sknd) +create (Device.D dvc) m mac = + M.create dvc m $ AllocationCallbacks.toMiddle mac + +destroy :: AllocationCallbacks.ToMiddle mscc => + Device.D sd -> M.S sknd -> TPMaybe.M (U2 AllocationCallbacks.A) mscc -> IO () +destroy (Device.D dvc) mm mac = + M.destroy dvc mm $ AllocationCallbacks.toMiddle mac diff --git a/src/Gpu/Vulkan/Subpass.hs b/src/Gpu/Vulkan/Subpass.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Subpass.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Subpass ( + + -- * SUBPASS DESCRIPTION + + Description(..), + + -- * SUBPASS DEPENDENCY + + Dependency(..), S, pattern SExternal, + + -- * ENUM + + module Gpu.Vulkan.Subpass.Enum + + ) where + +import Gpu.Vulkan.Subpass.Middle +import Gpu.Vulkan.Subpass.Enum diff --git a/src/Gpu/Vulkan/Subpass/Enum.hs b/src/Gpu/Vulkan/Subpass/Enum.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Subpass/Enum.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE PackageImports #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Subpass.Enum (module Gpu.Vulkan.Subpass.Enum) where + +import "gpu-vulkan-middle" Gpu.Vulkan.Subpass.Enum diff --git a/src/Gpu/Vulkan/TypeEnum.hs b/src/Gpu/Vulkan/TypeEnum.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/TypeEnum.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE ScopedTypeVariables, RankNTypes, TypeApplications #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures, TypeOperators #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.TypeEnum where + +import Language.Haskell.TH +import Data.Bits + +import Gpu.Vulkan.TypeEnum.Th + +import qualified Gpu.Vulkan.Enum as E + +import Gpu.Vulkan.TypeEnum.TypeValues + +do is <- lines <$> runIO (readFile "th/vkShaderStageFlagBits.txt") + (: []) <$> dataD (pure []) (mkName "ShaderStageFlagBits") [] Nothing + ((`normalC` []) . mkName <$> is) + [] + +class ShaderStageFlagBitsListToValue (ts :: [ShaderStageFlagBits]) where + shaderStageFlagBitsListToValue :: E.ShaderStageFlagBits + +instance ShaderStageFlagBitsListToValue '[] where + shaderStageFlagBitsListToValue = zeroBits + +instance (ShaderStageFlagBitsToValue t, ShaderStageFlagBitsListToValue ts) => + ShaderStageFlagBitsListToValue (t ': ts) where + shaderStageFlagBitsListToValue = + shaderStageFlagBitsToValue @t .|. + shaderStageFlagBitsListToValue @ts + +class ShaderStageFlagBitsToValue (t :: ShaderStageFlagBits) where + shaderStageFlagBitsToValue :: E.ShaderStageFlagBits + +do is <- lines <$> runIO (readFile "th/vkShaderStageFlagBits.txt") + sequence $ mkInstance <$> is + +typeValues "E" "Format" =<< lines <$> runIO (readFile "th/vkFormat.txt") diff --git a/src/Gpu/Vulkan/TypeEnum/Th.hs b/src/Gpu/Vulkan/TypeEnum/Th.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/TypeEnum/Th.hs @@ -0,0 +1,11 @@ +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.TypeEnum.Th where + +import Language.Haskell.TH + +mkInstance :: String -> Q Dec +mkInstance ss = + instanceD (pure []) (conT (mkName "ShaderStageFlagBitsToValue") `appT` promotedT (mkName ss)) [ + valD (varP $ mkName "shaderStageFlagBitsToValue") (normalB . conE . mkName $ "E." ++ ss) [] + ] diff --git a/src/Gpu/Vulkan/TypeEnum/TypeValues.hs b/src/Gpu/Vulkan/TypeEnum/TypeValues.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/TypeEnum/TypeValues.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.TypeEnum.TypeValues (typeValues) where + +import Language.Haskell.TH +import Data.Proxy +import Data.Char + +typeValues :: String -> String -> [String] -> Q [Dec] +typeValues mdl tp elms = + (\a b c -> a ++ b ++ c) + <$> ((: []) <$> mkType tp elms) + <*> ((:) <$> mkClass mdl tp + <*> sequence (mkInstance mdl tp <$> elms)) + <*> sequence [ + sigFoo mdl tp, + funD (mkName $ hd toLower tp ++ "ToType") (foo <$> elms) ] + +mkType :: String -> [String] -> Q Dec +mkType tp elms = dataD (pure []) (mkName tp) [] Nothing + ((`normalC` []) . mkName <$> elms) [derivClause Nothing [conT ''Show]] + +mkClass :: String -> String -> Q Dec +mkClass mdl tp = do + t <- newName "t" + classD (cxt []) (mkName $ tp ++ "ToValue") + [kindedTV t (ConT $ mkName tp)] + [] + [sigD (mkName $ hd toLower tp ++ "ToValue") . conT . mkName $ mdl ++ "." ++ tp] + +hd :: (a -> a) -> [a] -> [a] +hd _ [] = [] +hd f (x : xs) = f x : xs + +mkInstance :: String -> String -> String -> Q Dec +mkInstance mdl tp ss = + instanceD (pure []) (conT (mkName $ tp ++ "ToValue") `appT` promotedT (mkName ss)) [ + valD (varP . mkName $ hd toLower tp ++ "ToValue") + (normalB . conE . mkName $ mdl ++ "." ++ ss) [] + ] + +sigFoo :: String -> String -> Q Dec +sigFoo mdl tp = do + t <- newName "t" + a <- newName "a" + tv <- kindedInvisTV t SpecifiedSpec (conT $ mkName tp) + sigD (mkName $ hd toLower tp ++ "ToType") + $ conT (mkName $ mdl ++ "." ++ tp) + `arrT` ((forallT [tv] + (cxt [conT (mkName $ tp ++ "ToValue") `appT` varT t]) + ((conT ''Proxy `appT` varT t) `arrT` varT a)) + `arrT` varT a) + +foo :: String -> Q Clause +foo nm = do + f <- newName "f" + clause + [conP (mkName $ "E." ++ nm) [], varP f] + (normalB $ varE f `appE` + (conE 'Proxy `appTypeE` promotedT (mkName nm))) + [] + +arrT :: Q Type -> Q Type -> Q Type +t1 `arrT` t2 = arrowT `appT` t1 `appT` t2 diff --git a/src/Gpu/Vulkan/VertexInput.hs b/src/Gpu/Vulkan/VertexInput.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/VertexInput.hs @@ -0,0 +1,5 @@ +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.VertexInput (Rate(..)) where + +import Gpu.Vulkan.VertexInput.Internal diff --git a/src/Gpu/Vulkan/VertexInput/Internal.hs b/src/Gpu/Vulkan/VertexInput/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/VertexInput/Internal.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE BlockArguments, LambdaCase #-} +{-# LANGUAGE DataKinds, PolyKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGe MultiParamTypeClasses, AllowAmbiguousTypes #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.VertexInput.Internal ( + Rate(..), + M.AttributeDescription(..), + BindingDescription(..), + + bindingDescriptionFromRaw, + bindingDescriptionToMiddle, + + ) where + +import Data.Word +import Data.TypeLevel.TypeVal qualified as TypeVal + +import Gpu.Vulkan.VertexInput.Middle qualified as M +import Gpu.Vulkan.VertexInput.Enum qualified as M + +data Rate = RateVertex | RateInstance deriving Show + +instance TypeVal.T 'RateVertex Rate where t = RateVertex +instance TypeVal.T 'RateInstance Rate where t = RateInstance + +data BindingDescription = BindingDescription { + bindingDescriptionBinding :: Word32, + bindingDescriptionStride :: Word32, + bindingDescriptionInputRate :: Rate } + deriving Show + +type SizeAlignment = (Int, Int) + +bindingDescriptionFromRaw :: [(SizeAlignment, Rate)] -> [BindingDescription] +bindingDescriptionFromRaw sars = (<$> zip [0 ..] sars) + \(b, ((fromIntegral -> sz, _algn), r)) -> BindingDescription b sz r + +bindingDescriptionToMiddle :: BindingDescription -> M.BindingDescription +bindingDescriptionToMiddle BindingDescription { + bindingDescriptionBinding = bdg, + bindingDescriptionStride = strd, + bindingDescriptionInputRate = rt } = M.BindingDescription { + M.bindingDescriptionBinding = bdg, + M.bindingDescriptionStride = strd, + M.bindingDescriptionInputRate = rateToEnum rt } + where rateToEnum = \case + RateVertex -> M.RateVertex; RateInstance -> M.RateInstance diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented" diff --git a/th/vkFormat.txt b/th/vkFormat.txt new file mode 100644 --- /dev/null +++ b/th/vkFormat.txt @@ -0,0 +1,303 @@ +FormatUndefined +FormatR4g4UnormPack8 +FormatR4g4b4a4UnormPack16 +FormatB4g4r4a4UnormPack16 +FormatR5g6b5UnormPack16 +FormatB5g6r5UnormPack16 +FormatR5g5b5a1UnormPack16 +FormatB5g5r5a1UnormPack16 +FormatA1r5g5b5UnormPack16 +FormatR8Unorm +FormatR8Snorm +FormatR8Uscaled +FormatR8Sscaled +FormatR8Uint +FormatR8Sint +FormatR8Srgb +FormatR8g8Unorm +FormatR8g8Snorm +FormatR8g8Uscaled +FormatR8g8Sscaled +FormatR8g8Uint +FormatR8g8Sint +FormatR8g8Srgb +FormatR8g8b8Unorm +FormatR8g8b8Snorm +FormatR8g8b8Uscaled +FormatR8g8b8Sscaled +FormatR8g8b8Uint +FormatR8g8b8Sint +FormatR8g8b8Srgb +FormatB8g8r8Unorm +FormatB8g8r8Snorm +FormatB8g8r8Uscaled +FormatB8g8r8Sscaled +FormatB8g8r8Uint +FormatB8g8r8Sint +FormatB8g8r8Srgb +FormatR8g8b8a8Unorm +FormatR8g8b8a8Snorm +FormatR8g8b8a8Uscaled +FormatR8g8b8a8Sscaled +FormatR8g8b8a8Uint +FormatR8g8b8a8Sint +FormatR8g8b8a8Srgb +FormatB8g8r8a8Unorm +FormatB8g8r8a8Snorm +FormatB8g8r8a8Uscaled +FormatB8g8r8a8Sscaled +FormatB8g8r8a8Uint +FormatB8g8r8a8Sint +FormatB8g8r8a8Srgb +FormatA8b8g8r8UnormPack32 +FormatA8b8g8r8SnormPack32 +FormatA8b8g8r8UscaledPack32 +FormatA8b8g8r8SscaledPack32 +FormatA8b8g8r8UintPack32 +FormatA8b8g8r8SintPack32 +FormatA8b8g8r8SrgbPack32 +FormatA2r10g10b10UnormPack32 +FormatA2r10g10b10SnormPack32 +FormatA2r10g10b10UscaledPack32 +FormatA2r10g10b10SscaledPack32 +FormatA2r10g10b10UintPack32 +FormatA2r10g10b10SintPack32 +FormatA2b10g10r10UnormPack32 +FormatA2b10g10r10SnormPack32 +FormatA2b10g10r10UscaledPack32 +FormatA2b10g10r10SscaledPack32 +FormatA2b10g10r10UintPack32 +FormatA2b10g10r10SintPack32 +FormatR16Unorm +FormatR16Snorm +FormatR16Uscaled +FormatR16Sscaled +FormatR16Uint +FormatR16Sint +FormatR16Sfloat +FormatR16g16Unorm +FormatR16g16Snorm +FormatR16g16Uscaled +FormatR16g16Sscaled +FormatR16g16Uint +FormatR16g16Sint +FormatR16g16Sfloat +FormatR16g16b16Unorm +FormatR16g16b16Snorm +FormatR16g16b16Uscaled +FormatR16g16b16Sscaled +FormatR16g16b16Uint +FormatR16g16b16Sint +FormatR16g16b16Sfloat +FormatR16g16b16a16Unorm +FormatR16g16b16a16Snorm +FormatR16g16b16a16Uscaled +FormatR16g16b16a16Sscaled +FormatR16g16b16a16Uint +FormatR16g16b16a16Sint +FormatR16g16b16a16Sfloat +FormatR32Uint +FormatR32Sint +FormatR32Sfloat +FormatR32g32Uint +FormatR32g32Sint +FormatR32g32Sfloat +FormatR32g32b32Uint +FormatR32g32b32Sint +FormatR32g32b32Sfloat +FormatR32g32b32a32Uint +FormatR32g32b32a32Sint +FormatR32g32b32a32Sfloat +FormatR64Uint +FormatR64Sint +FormatR64Sfloat +FormatR64g64Uint +FormatR64g64Sint +FormatR64g64Sfloat +FormatR64g64b64Uint +FormatR64g64b64Sint +FormatR64g64b64Sfloat +FormatR64g64b64a64Uint +FormatR64g64b64a64Sint +FormatR64g64b64a64Sfloat +FormatB10g11r11UfloatPack32 +FormatE5b9g9r9UfloatPack32 +FormatD16Unorm +FormatX8D24UnormPack32 +FormatD32Sfloat +FormatS8Uint +FormatD16UnormS8Uint +FormatD24UnormS8Uint +FormatD32SfloatS8Uint +FormatBc1RgbUnormBlock +FormatBc1RgbSrgbBlock +FormatBc1RgbaUnormBlock +FormatBc1RgbaSrgbBlock +FormatBc2UnormBlock +FormatBc2SrgbBlock +FormatBc3UnormBlock +FormatBc3SrgbBlock +FormatBc4UnormBlock +FormatBc4SnormBlock +FormatBc5UnormBlock +FormatBc5SnormBlock +FormatBc6hUfloatBlock +FormatBc6hSfloatBlock +FormatBc7UnormBlock +FormatBc7SrgbBlock +FormatEtc2R8g8b8UnormBlock +FormatEtc2R8g8b8SrgbBlock +FormatEtc2R8g8b8a1UnormBlock +FormatEtc2R8g8b8a1SrgbBlock +FormatEtc2R8g8b8a8UnormBlock +FormatEtc2R8g8b8a8SrgbBlock +FormatEacR11UnormBlock +FormatEacR11SnormBlock +FormatEacR11g11UnormBlock +FormatEacR11g11SnormBlock +FormatAstc4x4UnormBlock +FormatAstc4x4SrgbBlock +FormatAstc5x4UnormBlock +FormatAstc5x4SrgbBlock +FormatAstc5x5UnormBlock +FormatAstc5x5SrgbBlock +FormatAstc6x5UnormBlock +FormatAstc6x5SrgbBlock +FormatAstc6x6UnormBlock +FormatAstc6x6SrgbBlock +FormatAstc8x5UnormBlock +FormatAstc8x5SrgbBlock +FormatAstc8x6UnormBlock +FormatAstc8x6SrgbBlock +FormatAstc8x8UnormBlock +FormatAstc8x8SrgbBlock +FormatAstc10x5UnormBlock +FormatAstc10x5SrgbBlock +FormatAstc10x6UnormBlock +FormatAstc10x6SrgbBlock +FormatAstc10x8UnormBlock +FormatAstc10x8SrgbBlock +FormatAstc10x10UnormBlock +FormatAstc10x10SrgbBlock +FormatAstc12x10UnormBlock +FormatAstc12x10SrgbBlock +FormatAstc12x12UnormBlock +FormatAstc12x12SrgbBlock +FormatG8b8g8r8422Unorm +FormatB8g8r8g8422Unorm +FormatG8B8R83plane420Unorm +FormatG8B8r82plane420Unorm +FormatG8B8R83plane422Unorm +FormatG8B8r82plane422Unorm +FormatG8B8R83plane444Unorm +FormatR10x6UnormPack16 +FormatR10x6g10x6Unorm2pack16 +FormatR10x6g10x6b10x6a10x6Unorm4pack16 +FormatG10x6b10x6g10x6r10x6422Unorm4pack16 +FormatB10x6g10x6r10x6g10x6422Unorm4pack16 +FormatG10x6B10x6R10x63plane420Unorm3pack16 +FormatG10x6B10x6r10x62plane420Unorm3pack16 +FormatG10x6B10x6R10x63plane422Unorm3pack16 +FormatG10x6B10x6r10x62plane422Unorm3pack16 +FormatG10x6B10x6R10x63plane444Unorm3pack16 +FormatR12x4UnormPack16 +FormatR12x4g12x4Unorm2pack16 +FormatR12x4g12x4b12x4a12x4Unorm4pack16 +FormatG12x4b12x4g12x4r12x4422Unorm4pack16 +FormatB12x4g12x4r12x4g12x4422Unorm4pack16 +FormatG12x4B12x4R12x43plane420Unorm3pack16 +FormatG12x4B12x4r12x42plane420Unorm3pack16 +FormatG12x4B12x4R12x43plane422Unorm3pack16 +FormatG12x4B12x4r12x42plane422Unorm3pack16 +FormatG12x4B12x4R12x43plane444Unorm3pack16 +FormatG16b16g16r16422Unorm +FormatB16g16r16g16422Unorm +FormatG16B16R163plane420Unorm +FormatG16B16r162plane420Unorm +FormatG16B16R163plane422Unorm +FormatG16B16r162plane422Unorm +FormatG16B16R163plane444Unorm +FormatG8B8r82plane444Unorm +FormatG10x6B10x6r10x62plane444Unorm3pack16 +FormatG12x4B12x4r12x42plane444Unorm3pack16 +FormatG16B16r162plane444Unorm +FormatA4r4g4b4UnormPack16 +FormatA4b4g4r4UnormPack16 +FormatAstc4x4SfloatBlock +FormatAstc5x4SfloatBlock +FormatAstc5x5SfloatBlock +FormatAstc6x5SfloatBlock +FormatAstc6x6SfloatBlock +FormatAstc8x5SfloatBlock +FormatAstc8x6SfloatBlock +FormatAstc8x8SfloatBlock +FormatAstc10x5SfloatBlock +FormatAstc10x6SfloatBlock +FormatAstc10x8SfloatBlock +FormatAstc10x10SfloatBlock +FormatAstc12x10SfloatBlock +FormatAstc12x12SfloatBlock +FormatPvrtc12bppUnormBlockImg +FormatPvrtc14bppUnormBlockImg +FormatPvrtc22bppUnormBlockImg +FormatPvrtc24bppUnormBlockImg +FormatPvrtc12bppSrgbBlockImg +FormatPvrtc14bppSrgbBlockImg +FormatPvrtc22bppSrgbBlockImg +FormatPvrtc24bppSrgbBlockImg +FormatR16g16S105Nv +FormatAstc4x4SfloatBlockExt +FormatAstc5x4SfloatBlockExt +FormatAstc5x5SfloatBlockExt +FormatAstc6x5SfloatBlockExt +FormatAstc6x6SfloatBlockExt +FormatAstc8x5SfloatBlockExt +FormatAstc8x6SfloatBlockExt +FormatAstc8x8SfloatBlockExt +FormatAstc10x5SfloatBlockExt +FormatAstc10x6SfloatBlockExt +FormatAstc10x8SfloatBlockExt +FormatAstc10x10SfloatBlockExt +FormatAstc12x10SfloatBlockExt +FormatAstc12x12SfloatBlockExt +FormatG8b8g8r8422UnormKhr +FormatB8g8r8g8422UnormKhr +FormatG8B8R83plane420UnormKhr +FormatG8B8r82plane420UnormKhr +FormatG8B8R83plane422UnormKhr +FormatG8B8r82plane422UnormKhr +FormatG8B8R83plane444UnormKhr +FormatR10x6UnormPack16Khr +FormatR10x6g10x6Unorm2pack16Khr +FormatR10x6g10x6b10x6a10x6Unorm4pack16Khr +FormatG10x6b10x6g10x6r10x6422Unorm4pack16Khr +FormatB10x6g10x6r10x6g10x6422Unorm4pack16Khr +FormatG10x6B10x6R10x63plane420Unorm3pack16Khr +FormatG10x6B10x6r10x62plane420Unorm3pack16Khr +FormatG10x6B10x6R10x63plane422Unorm3pack16Khr +FormatG10x6B10x6r10x62plane422Unorm3pack16Khr +FormatG10x6B10x6R10x63plane444Unorm3pack16Khr +FormatR12x4UnormPack16Khr +FormatR12x4g12x4Unorm2pack16Khr +FormatR12x4g12x4b12x4a12x4Unorm4pack16Khr +FormatG12x4b12x4g12x4r12x4422Unorm4pack16Khr +FormatB12x4g12x4r12x4g12x4422Unorm4pack16Khr +FormatG12x4B12x4R12x43plane420Unorm3pack16Khr +FormatG12x4B12x4r12x42plane420Unorm3pack16Khr +FormatG12x4B12x4R12x43plane422Unorm3pack16Khr +FormatG12x4B12x4r12x42plane422Unorm3pack16Khr +FormatG12x4B12x4R12x43plane444Unorm3pack16Khr +FormatG16b16g16r16422UnormKhr +FormatB16g16r16g16422UnormKhr +FormatG16B16R163plane420UnormKhr +FormatG16B16r162plane420UnormKhr +FormatG16B16R163plane422UnormKhr +FormatG16B16r162plane422UnormKhr +FormatG16B16R163plane444UnormKhr +FormatG8B8r82plane444UnormExt +FormatG10x6B10x6r10x62plane444Unorm3pack16Ext +FormatG12x4B12x4r12x42plane444Unorm3pack16Ext +FormatG16B16r162plane444UnormExt +FormatA4r4g4b4UnormPack16Ext +FormatA4b4g4r4UnormPack16Ext +FormatMaxEnum diff --git a/th/vkPhysicalDeviceFeatures.txt b/th/vkPhysicalDeviceFeatures.txt new file mode 100644 --- /dev/null +++ b/th/vkPhysicalDeviceFeatures.txt @@ -0,0 +1,55 @@ +VkBool32|A robustBufferAccess +VkBool32|A fullDrawIndexUint32 +VkBool32|A imageCubeArray +VkBool32|A independentBlend +VkBool32|A geometryShader +VkBool32|A tessellationShader +VkBool32|A sampleRateShading +VkBool32|A dualSrcBlend +VkBool32|A logicOp +VkBool32|A multiDrawIndirect +VkBool32|A drawIndirectFirstInstance +VkBool32|A depthClamp +VkBool32|A depthBiasClamp +VkBool32|A fillModeNonSolid +VkBool32|A depthBounds +VkBool32|A wideLines +VkBool32|A largePoints +VkBool32|A alphaToOne +VkBool32|A multiViewport +VkBool32|A samplerAnisotropy +VkBool32|A textureCompressionETC2 +VkBool32|A textureCompressionASTC_LDR +VkBool32|A textureCompressionBC +VkBool32|A occlusionQueryPrecise +VkBool32|A pipelineStatisticsQuery +VkBool32|A vertexPipelineStoresAndAtomics +VkBool32|A fragmentStoresAndAtomics +VkBool32|A shaderTessellationAndGeometryPointSize +VkBool32|A shaderImageGatherExtended +VkBool32|A shaderStorageImageExtendedFormats +VkBool32|A shaderStorageImageMultisample +VkBool32|A shaderStorageImageReadWithoutFormat +VkBool32|A shaderStorageImageWriteWithoutFormat +VkBool32|A shaderUniformBufferArrayDynamicIndexing +VkBool32|A shaderSampledImageArrayDynamicIndexing +VkBool32|A shaderStorageBufferArrayDynamicIndexing +VkBool32|A shaderStorageImageArrayDynamicIndexing +VkBool32|A shaderClipDistance +VkBool32|A shaderCullDistance +VkBool32|A shaderFloat64 +VkBool32|A shaderInt64 +VkBool32|A shaderInt16 +VkBool32|A shaderResourceResidency +VkBool32|A shaderResourceMinLod +VkBool32|A sparseBinding +VkBool32|A sparseResidencyBuffer +VkBool32|A sparseResidencyImage2D +VkBool32|A sparseResidencyImage3D +VkBool32|A sparseResidency2Samples +VkBool32|A sparseResidency4Samples +VkBool32|A sparseResidency8Samples +VkBool32|A sparseResidency16Samples +VkBool32|A sparseResidencyAliased +VkBool32|A variableMultisampleRate +VkBool32|A inheritedQueries diff --git a/th/vkPhysicalDeviceLimits.txt b/th/vkPhysicalDeviceLimits.txt new file mode 100644 --- /dev/null +++ b/th/vkPhysicalDeviceLimits.txt @@ -0,0 +1,106 @@ +uint32_t|A maxImageDimension1D +uint32_t|A maxImageDimension2D +uint32_t|A maxImageDimension3D +uint32_t|A maxImageDimensionCube +uint32_t|A maxImageArrayLayers +uint32_t|A maxTexelBufferElements +uint32_t|A maxUniformBufferRange +uint32_t|A maxStorageBufferRange +uint32_t|A maxPushConstantsSize +uint32_t|A maxMemoryAllocationCount +uint32_t|A maxSamplerAllocationCount +VkDeviceSize|A bufferImageGranularity +VkDeviceSize|A sparseAddressSpaceSize +uint32_t|A maxBoundDescriptorSets +uint32_t|A maxPerStageDescriptorSamplers +uint32_t|A maxPerStageDescriptorUniformBuffers +uint32_t|A maxPerStageDescriptorStorageBuffers +uint32_t|A maxPerStageDescriptorSampledImages +uint32_t|A maxPerStageDescriptorStorageImages +uint32_t|A maxPerStageDescriptorInputAttachments +uint32_t|A maxPerStageResources +uint32_t|A maxDescriptorSetSamplers +uint32_t|A maxDescriptorSetUniformBuffers +uint32_t|A maxDescriptorSetUniformBuffersDynamic +uint32_t|A maxDescriptorSetStorageBuffers +uint32_t|A maxDescriptorSetStorageBuffersDynamic +uint32_t|A maxDescriptorSetSampledImages +uint32_t|A maxDescriptorSetStorageImages +uint32_t|A maxDescriptorSetInputAttachments +uint32_t|A maxVertexInputAttributes +uint32_t|A maxVertexInputBindings +uint32_t|A maxVertexInputAttributeOffset +uint32_t|A maxVertexInputBindingStride +uint32_t|A maxVertexOutputComponents +uint32_t|A maxTessellationGenerationLevel +uint32_t|A maxTessellationPatchSize +uint32_t|A maxTessellationControlPerVertexInputComponents +uint32_t|A maxTessellationControlPerVertexOutputComponents +uint32_t|A maxTessellationControlPerPatchOutputComponents +uint32_t|A maxTessellationControlTotalOutputComponents +uint32_t|A maxTessellationEvaluationInputComponents +uint32_t|A maxTessellationEvaluationOutputComponents +uint32_t|A maxGeometryShaderInvocations +uint32_t|A maxGeometryInputComponents +uint32_t|A maxGeometryOutputComponents +uint32_t|A maxGeometryOutputVertices +uint32_t|A maxGeometryTotalOutputComponents +uint32_t|A maxFragmentInputComponents +uint32_t|A maxFragmentOutputAttachments +uint32_t|A maxFragmentDualSrcAttachments +uint32_t|A maxFragmentCombinedOutputResources +uint32_t|A maxComputeSharedMemorySize +uint32_t|L maxComputeWorkGroupCount 3 +uint32_t|A maxComputeWorkGroupInvocations +uint32_t|L maxComputeWorkGroupSize 3 +uint32_t|A subPixelPrecisionBits +uint32_t|A subTexelPrecisionBits +uint32_t|A mipmapPrecisionBits +uint32_t|A maxDrawIndexedIndexValue +uint32_t|A maxDrawIndirectCount +float|A maxSamplerLodBias +float|A maxSamplerAnisotropy +uint32_t|A maxViewports +uint32_t|L maxViewportDimensions 2 +float|L viewportBoundsRange 2 +uint32_t|A viewportSubPixelBits +size_t|A minMemoryMapAlignment +VkDeviceSize|A minTexelBufferOffsetAlignment +VkDeviceSize|A minUniformBufferOffsetAlignment +VkDeviceSize|A minStorageBufferOffsetAlignment +int32_t|A minTexelOffset +uint32_t|A maxTexelOffset +int32_t|A minTexelGatherOffset +uint32_t|A maxTexelGatherOffset +float|A minInterpolationOffset +float|A maxInterpolationOffset +uint32_t|A subPixelInterpolationOffsetBits +uint32_t|A maxFramebufferWidth +uint32_t|A maxFramebufferHeight +uint32_t|A maxFramebufferLayers +VkSampleCountFlags|A framebufferColorSampleCounts +VkSampleCountFlags|A framebufferDepthSampleCounts +VkSampleCountFlags|A framebufferStencilSampleCounts +VkSampleCountFlags|A framebufferNoAttachmentsSampleCounts +uint32_t|A maxColorAttachments +VkSampleCountFlags|A sampledImageColorSampleCounts +VkSampleCountFlags|A sampledImageIntegerSampleCounts +VkSampleCountFlags|A sampledImageDepthSampleCounts +VkSampleCountFlags|A sampledImageStencilSampleCounts +VkSampleCountFlags|A storageImageSampleCounts +uint32_t|A maxSampleMaskWords +VkBool32|A timestampComputeAndGraphics +float|A timestampPeriod +uint32_t|A maxClipDistances +uint32_t|A maxCullDistances +uint32_t|A maxCombinedClipAndCullDistances +uint32_t|A discreteQueuePriorities +float|L pointSizeRange 2 +float|L lineWidthRange 2 +float|A pointSizeGranularity +float|A lineWidthGranularity +VkBool32|A strictLines +VkBool32|A standardSampleLocations +VkDeviceSize|A optimalBufferCopyOffsetAlignment +VkDeviceSize|A optimalBufferCopyRowPitchAlignment +VkDeviceSize|A nonCoherentAtomSize diff --git a/th/vkShaderStageFlagBits.txt b/th/vkShaderStageFlagBits.txt new file mode 100644 --- /dev/null +++ b/th/vkShaderStageFlagBits.txt @@ -0,0 +1,28 @@ +ShaderStageFlagsZero +ShaderStageVertexBit +ShaderStageTessellationControlBit +ShaderStageTessellationEvaluationBit +ShaderStageGeometryBit +ShaderStageFragmentBit +ShaderStageComputeBit +ShaderStageAllGraphics +ShaderStageAll +ShaderStageRaygenBitKhr +ShaderStageAnyHitBitKhr +ShaderStageClosestHitBitKhr +ShaderStageMissBitKhr +ShaderStageIntersectionBitKhr +ShaderStageCallableBitKhr +ShaderStageTaskBitExt +ShaderStageMeshBitExt +ShaderStageSubpassShadingBitHuawei +ShaderStageClusterCullingBitHuawei +ShaderStageRaygenBitNv +ShaderStageAnyHitBitNv +ShaderStageClosestHitBitNv +ShaderStageMissBitNv +ShaderStageIntersectionBitNv +ShaderStageCallableBitNv +ShaderStageTaskBitNv +ShaderStageMeshBitNv +ShaderStageFlagBitsMaxEnum