diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,6 +1,72 @@ # Change Log -## WIP +## [0.5.11.0] - 2026-07-01 + +A large additive release: helpers for dynamic rendering, dynamic pipeline +state, specialization constants, synchronization, swapchain/frame management, +and window abstraction. + +Resource-managing helpers follow the `create`/`with`/`allocate` naming +convention: anything that slots a `ResourceT.allocate` into a `withXxx` is named +`allocate*`. The three pre-existing `Initialization` helpers were renamed to +match, with the old names kept as deprecated aliases (see Deprecations); no +existing API was removed. The baseline is vulkan-3.27 and GHC-9.2. + +### Pipelines and dynamic rendering +- `Vulkan.Utils.DynamicRendering`: `allocatePipeline` and + `allocatePipelineFromShaders` for render-pass-less pipelines, plus + `renderingInfo`, `colorAttachmentRenderingInfo`, and + `dynamicRenderingRequirements`. +- `Vulkan.Utils.DynamicState`: a `DynamicState` record with + `defaultDynamicState`, `dynamicStateFor`, and `applyDynamicStates`, plus named + state sets (`allDynamicStates`, `minimalDynamicStates`, `noDynamicStates`, + `preRasterizationStates`, `fragmentTestStates`, `fragmentOutputStates`, + `depthOnlyDynamicStates`, `defaultDynamicStatesFor`) covering the dynamic + states available without vendor or experimental extensions. +- `Vulkan.Utils.Pipeline.Specialization`: the `Specialization` and + `SpecializationConst` classes with `withSpecialization` / + `allocateSpecialization` for packing specialization constants. +- `Vulkan.Utils.RenderPass`: `allocateRenderPass`, `allocateColorRenderPass`, and + a generic `allocatePipeline` / `allocatePipelineFromShaders`. +- `Vulkan.Utils.Framebuffer`: `allocateFramebuffer`. +- `Vulkan.Utils.Shader`: `shaderStage` and `shaderModuleStage`. + +### Synchronization and descriptors +- `Vulkan.Utils.Barrier`: `imageBarrier`, `bufferBarrier`, and the common + transitions `transitionColorAttachment`, `transitionDepthAttachment`, and + `transitionPresent`. +- `Vulkan.Utils.Descriptors`: `bufferWrite` and `imageWrite` for common + single-binding descriptor writes. +- `Vulkan.Utils.RefCounted`: a reference-counted release primitive + (`newRefCounted`, `takeRefCounted`, `releaseRefCounted`, + `resourceTRefCount`). + +### Swapchain, frames, and windowing +- `Vulkan.Utils.Swapchain`: `Swapchain` and `SwapchainConfig` with + `defaultSwapchainConfig`, `allocateSwapchain`, `recreateSwapchain`, and + `threwSwapchainError`. +- `Vulkan.Utils.Frame`: a `Frame` record driving frames-in-flight — + `advanceFrame`, `runFrame`, `recordCommands`, `queueSubmitFrame`, + `acquireFrameImage`, `presentFrameImage`, `drainFrames`, + `allocateTimelineSemaphore`, and the matching requirements helpers. +- `Vulkan.Utils.VulkanContext`: `VulkanContext` and `RecycledResources` with + `mkVulkanContext`. +- `Vulkan.Utils.WindowAdapter`: a backend-agnostic `WindowAdapter` record (the + `vulkan-init-sdl2` and `vulkan-init-glfw` packages provide instances). +- `Vulkan.Utils.WindowLoop`: `runWindowLoop` with the `WindowLoop` record and + the `noWindowState` / `noOnFrame` / `noOnExit` defaults. +- `Vulkan.Utils.Queues`: a `Queues` record and `allocateDevice`. +- `Vulkan.Utils.Init.Headless`: `allocateInstance` for headless setup. + +### Dependencies +- Now depends on `unagi-chan` and `unliftio-core`. + +### Deprecations +- `Vulkan.Utils.Initialization`: `createInstanceFromRequirements`, + `createDebugInstanceFromRequirements`, and `createDeviceFromRequirements` are + renamed to `allocateInstanceFromRequirements`, + `allocateDebugInstanceFromRequirements`, and `allocateDeviceFromRequirements`. + The old names remain as deprecated aliases. ## [0.5.10.6] - 2023-10-21 diff --git a/package.yaml b/package.yaml --- a/package.yaml +++ b/package.yaml @@ -1,9 +1,9 @@ name: vulkan-utils -version: "0.5.10.6" +version: "0.5.11.0" synopsis: Utils for the vulkan package category: Graphics -maintainer: Ellie Hermaszewska -github: expipiplus1/vulkan +maintainer: IC Rainbow , Ellie Hermaszewska +github: haskell-game/vulkan extra-source-files: - readme.md - changelog.md @@ -23,11 +23,9 @@ - Vulkan.Utils.ShaderQQ.HLSL dependencies: - - base <5 + - base >= 4.16 && <5 - bytestring - containers - - dependent-map - - dependent-sum - extra - file-embed - filepath @@ -37,9 +35,11 @@ - text - transformers - typed-process + - unagi-chan + - unliftio-core - unordered-containers - vector - - vulkan >= 3.6.14 && < 3.27 + - vulkan >= 3.27 && < 3.28 tests: doctests: @@ -80,6 +80,7 @@ - MagicHash - NamedFieldPuns - NoMonomorphismRestriction +- OverloadedRecordDot - OverloadedStrings - PartialTypeSignatures - PatternSynonyms diff --git a/src/Vulkan/Utils/Barrier.hs b/src/Vulkan/Utils/Barrier.hs new file mode 100644 --- /dev/null +++ b/src/Vulkan/Utils/Barrier.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE OverloadedLists #-} + +{-| Whole-resource pipeline barriers. The @transition*@ helpers issue the +common swapchain-and-attachment transitions as complete +'Vk.cmdPipelineBarrier' calls; 'imageBarrier' is the building block behind +them, exposed for assembling barriers they don't cover (handing a rendered +image to a compute pass, a storage image to a blit, …) — combining several +into one 'Vk.cmdPipelineBarrier' call where the stage scopes allow. +'bufferBarrier' is its buffer-flavoured sibling (a compute-written vertex +SSBO handed to the vertex shader, …). +-} +module Vulkan.Utils.Barrier + ( transitionColorAttachment + , transitionPresent + , transitionDepthAttachment + , imageBarrier + , bufferBarrier + ) where + +import Control.Monad.IO.Class (MonadIO) +import Data.Bits ((.|.)) +import Vulkan.CStruct.Extends (SomeStruct (..)) +import qualified Vulkan.Core10 as Vk +import Vulkan.Zero (zero) + +transitionColorAttachment :: (MonadIO m) => Vk.CommandBuffer -> Vk.Image -> m () +transitionColorAttachment cb image = + Vk.cmdPipelineBarrier + cb + Vk.PIPELINE_STAGE_TOP_OF_PIPE_BIT + Vk.PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT + zero + [] + [] + [ imageBarrier + Vk.IMAGE_ASPECT_COLOR_BIT + zero + Vk.ACCESS_COLOR_ATTACHMENT_WRITE_BIT + Vk.IMAGE_LAYOUT_UNDEFINED + Vk.IMAGE_LAYOUT_COLOR_ATTACHMENT_OPTIMAL + image + ] + +transitionPresent :: (MonadIO m) => Vk.CommandBuffer -> Vk.Image -> m () +transitionPresent cb image = + Vk.cmdPipelineBarrier + cb + Vk.PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT + Vk.PIPELINE_STAGE_BOTTOM_OF_PIPE_BIT + zero + [] + [] + [ imageBarrier + Vk.IMAGE_ASPECT_COLOR_BIT + Vk.ACCESS_COLOR_ATTACHMENT_WRITE_BIT + zero + Vk.IMAGE_LAYOUT_COLOR_ATTACHMENT_OPTIMAL + Vk.IMAGE_LAYOUT_PRESENT_SRC_KHR + image + ] + +{- | Transition a depth image from @UNDEFINED@ (discarding any previous contents) +to @DEPTH_ATTACHMENT_OPTIMAL@, ready to be used as a depth attachment. Issue it +before rendering whenever the attachment is about to be cleared on load — every +frame, like the colour images. + +The destination scope covers both fragment-test stages with read and write +access: the @loadOp@ clear and late depth writes are writes, the depth test +itself is a read, and all of them must see the transition. +-} +transitionDepthAttachment :: (MonadIO m) => Vk.CommandBuffer -> Vk.Image -> m () +transitionDepthAttachment cb image = + Vk.cmdPipelineBarrier + cb + Vk.PIPELINE_STAGE_TOP_OF_PIPE_BIT + (Vk.PIPELINE_STAGE_EARLY_FRAGMENT_TESTS_BIT .|. Vk.PIPELINE_STAGE_LATE_FRAGMENT_TESTS_BIT) + zero + [] + [] + [ imageBarrier + Vk.IMAGE_ASPECT_DEPTH_BIT + zero + ( Vk.ACCESS_DEPTH_STENCIL_ATTACHMENT_READ_BIT + .|. Vk.ACCESS_DEPTH_STENCIL_ATTACHMENT_WRITE_BIT + ) + Vk.IMAGE_LAYOUT_UNDEFINED + Vk.IMAGE_LAYOUT_DEPTH_ATTACHMENT_OPTIMAL + image + ] + +{- | A whole-image memory barrier over the given aspect, from one +(access mask, layout) scope to another, with no queue-family ownership +transfer. The execution scopes (stage masks) live on the enclosing +'Vk.cmdPipelineBarrier' call, shared by every barrier in it. +-} +imageBarrier + :: Vk.ImageAspectFlags + -> Vk.AccessFlags + -- ^ Source access mask. + -> Vk.AccessFlags + -- ^ Destination access mask. + -> Vk.ImageLayout + -- ^ Old layout; @UNDEFINED@ discards the image's previous contents. + -> Vk.ImageLayout + -- ^ New layout. + -> Vk.Image + -> SomeStruct Vk.ImageMemoryBarrier +imageBarrier aspect srcAccessMask dstAccessMask oldLayout newLayout image = + SomeStruct + zero + { Vk.srcAccessMask = srcAccessMask + , Vk.dstAccessMask = dstAccessMask + , Vk.oldLayout = oldLayout + , Vk.newLayout = newLayout + , Vk.image = image + , Vk.subresourceRange = + zero + { Vk.aspectMask = aspect + , Vk.baseMipLevel = 0 + , Vk.levelCount = 1 + , Vk.baseArrayLayer = 0 + , Vk.layerCount = 1 + } + } + +{- | A whole-buffer memory barrier from one access scope to another, with no +queue-family ownership transfer. As with 'imageBarrier', the execution +scopes (stage masks) live on the enclosing 'Vk.cmdPipelineBarrier' call. +-} +bufferBarrier + :: Vk.AccessFlags + -- ^ Source access mask. + -> Vk.AccessFlags + -- ^ Destination access mask. + -> Vk.Buffer + -> SomeStruct Vk.BufferMemoryBarrier +bufferBarrier srcAccessMask dstAccessMask buffer = + SomeStruct + zero + { Vk.srcAccessMask = srcAccessMask + , Vk.dstAccessMask = dstAccessMask + , Vk.buffer = buffer + , Vk.offset = 0 + , Vk.size = Vk.WHOLE_SIZE + } diff --git a/src/Vulkan/Utils/CommandCheck.hs b/src/Vulkan/Utils/CommandCheck.hs --- a/src/Vulkan/Utils/CommandCheck.hs +++ b/src/Vulkan/Utils/CommandCheck.hs @@ -1,164 +1,180 @@ -{-# language TemplateHaskell #-} -{-# language NoMonadComprehensions #-} -{-# language MultiWayIf #-} -{-# language QuasiQuotes #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NoMonadComprehensions #-} module Vulkan.Utils.CommandCheck ( checkCommandsExp ) where -import Control.Applicative ( (<|>) ) -import Control.Arrow ( (&&&) ) -import Data.Char -import Data.Functor ( (<&>) ) -import Data.List ( isPrefixOf - , isSuffixOf - , nub - ) -import Data.List.Extra ( dropEnd ) -import Data.Maybe ( catMaybes ) -import Foreign.Ptr -import Language.Haskell.TH -import Language.Haskell.TH.Syntax -import Vulkan.Core10 (Instance(..), Device(..)) -import Vulkan.Dynamic +import Control.Applicative ((<|>)) +import Control.Arrow ((&&&)) +import Data.Char +import Data.Functor ((<&>)) +import Data.List + ( isPrefixOf + , isSuffixOf + , nub + ) +import Data.List.Extra (dropEnd) +import Data.Maybe (catMaybes) +import Foreign.Ptr +import Language.Haskell.TH +import Language.Haskell.TH.Syntax +import Vulkan.Core10 (Device (..), Instance (..)) +import Vulkan.Dynamic --- | Create an expression which checks the function pointers for all the Vulkan --- commands depended upon by the specified list of function names. --- --- It returns a list of function names corresponding to those functions with --- null pointers. --- --- Your program can use this function to fail early if a command couldn't be --- loaded for some reason (missing extension or layer for example). --- --- One can create a function called @checkCommands@ with the following: --- @ --- [d| checkCommands = $(checkCommandsExp ['withInstance, 'cmdDraw, ...]) |] --- @ --- --- It has the type @IsString a => Instance -> Device -> [a]@ --- --- It looks basically like --- --- @ --- \inst dev -> --- [ name --- | True <- [ nullFunPtr == pVkCreateDevice inst --- , nullFunPtr == pVkCreateFence dev --- .. --- ] --- | name <- [ "vkCreateDevice" --- , "vkCreateFence" --- .. --- ] --- ] --- @ +{- | Create an expression which checks the function pointers for all the Vulkan +commands depended upon by the specified list of function names. + +It returns a list of function names corresponding to those functions with +null pointers. + +Your program can use this function to fail early if a command couldn't be +loaded for some reason (missing extension or layer for example). + +One can create a function called @checkCommands@ with the following: +@ +[d| checkCommands = $(checkCommandsExp ['withInstance, 'cmdDraw, ...]) |] +@ + +It has the type @IsString a => Instance -> Device -> [a]@ + +It looks basically like + +@ +\inst dev -> + [ name + | True <- [ nullFunPtr == pVkCreateDevice inst + , nullFunPtr == pVkCreateFence dev + .. + ] + | name <- [ "vkCreateDevice" + , "vkCreateFence" + .. + ] + ] +@ +-} checkCommandsExp :: [Name] - -- ^ The names of functions from the @vulkan@ package. Unknown commands are - -- ignored + {- ^ The names of functions from the @vulkan@ package. Unknown commands are + ignored + -} -> Q Exp checkCommandsExp requestedCommands = do - instAccessors <- accessorNames ''InstanceCmds + instAccessors <- accessorNames ''InstanceCmds deviceAccessors <- accessorNames ''DeviceCmds let vkCommandNames = nub . commandNames instAccessors deviceAccessors =<< requestedCommands - inst <- newName "inst" + inst <- newName "inst" device <- newName "device" let isNull = \case InstanceCmd i -> [|nullFunPtr == $(varE i) $(varE inst)|] - DeviceCmd i -> [|nullFunPtr == $(varE i) $(varE device)|] - [| \(Instance _ $(varP inst)) (Device _ $(varP device)) -> + DeviceCmd i -> [|nullFunPtr == $(varE i) $(varE device)|] + [| + \(Instance _ $(varP inst)) (Device _ $(varP device)) -> [ name - | (True, name) <- zip - $(listE (isNull <$> vkCommandNames)) - $(lift (commandString <$> vkCommandNames)) + | (True, name) <- + zip + $(listE (isNull <$> vkCommandNames)) + $(lift (commandString <$> vkCommandNames)) ] |] --- | Given instance and device accessors and a function, find the function --- pointer accessor names which it depends on --- --- >>> commandNames ['pVkCreateDevice, 'pVkDestroyDevice] ['pVkCreateFence] (mkName "withDevice") --- [InstanceCmd Vulkan.Dynamic.pVkCreateDevice,InstanceCmd Vulkan.Dynamic.pVkDestroyDevice] +{- | Given instance and device accessors and a function, find the function +pointer accessor names which it depends on + +>>> commandNames ['pVkCreateDevice, 'pVkDestroyDevice] ['pVkCreateFence] (mkName "withDevice") +[InstanceCmd Vulkan.Dynamic.pVkCreateDevice,InstanceCmd Vulkan.Dynamic.pVkDestroyDevice] +-} commandNames :: [Name] -> [Name] -> Name -> [DeviceOrInstanceCommand] commandNames instAccessors deviceAccessors = - let instNames = (nameBase &&& id) <$> instAccessors - deviceNames = (nameBase &&& id) <$> deviceAccessors - findCommand :: String -> Maybe DeviceOrInstanceCommand - findCommand command = - (InstanceCmd <$> lookup command instNames) - <|> (DeviceCmd <$> lookup command deviceNames) - in \n -> - let candidates = commandCandidates (nameBase n) - in catMaybes $ findCommand <$> candidates + let + instNames = (nameBase &&& id) <$> instAccessors + deviceNames = (nameBase &&& id) <$> deviceAccessors + findCommand :: String -> Maybe DeviceOrInstanceCommand + findCommand command = + (InstanceCmd <$> lookup command instNames) + <|> (DeviceCmd <$> lookup command deviceNames) + in + \n -> + let candidates = commandCandidates (nameBase n) + in catMaybes $ findCommand <$> candidates data DeviceOrInstanceCommand = DeviceCmd Name | InstanceCmd Name deriving (Eq, Show) --- | Get the C name of a function --- --- >>> commandString (DeviceCmd (mkName "pVkCreateInstance")) --- "vkCreateInstance" +{- | Get the C name of a function + +>>> commandString (DeviceCmd (mkName "pVkCreateInstance")) +"vkCreateInstance" +-} commandString :: DeviceOrInstanceCommand -> String -commandString = unPtrName . nameBase . \case - InstanceCmd n -> n - DeviceCmd n -> n +commandString = + unPtrName . nameBase . \case + InstanceCmd n -> n + DeviceCmd n -> n --- | A list of potential sets of vulkan commands this name depends on, not all --- of them will be valid names. --- --- >>> commandCandidates "withDevice" --- ["pVkAllocateDevice","pVkFreeDevice","pVkCreateDevice","pVkDestroyDevice"] --- --- >>> commandCandidates "waitSemaphoresSafe" --- ["pVkWaitSemaphores"] --- --- >>> commandCandidates "useCmdBuffer" --- ["pVkBeginCmdBuffer","pVkEndCmdBuffer"] --- --- >>> commandCandidates "withSemaphore" --- ["pVkAllocateSemaphore","pVkFreeSemaphore","pVkCreateSemaphore","pVkDestroySemaphore"] +{- | A list of potential sets of vulkan commands this name depends on, not all +of them will be valid names. + +>>> commandCandidates "withDevice" +["pVkAllocateDevice","pVkFreeDevice","pVkCreateDevice","pVkDestroyDevice"] + +>>> commandCandidates "waitSemaphoresSafe" +["pVkWaitSemaphores"] + +>>> commandCandidates "useCmdBuffer" +["pVkBeginCmdBuffer","pVkEndCmdBuffer"] + +>>> commandCandidates "withSemaphore" +["pVkAllocateSemaphore","pVkFreeSemaphore","pVkCreateSemaphore","pVkDestroySemaphore"] +-} commandCandidates :: String -> [String] -commandCandidates n = if - | "Safe" `isSuffixOf` n - -> commandCandidates (dropEnd 4 n) - | Just u <- stripPrefix "with" - -> (<> u) <$> ["pVkAllocate", "pVkFree", "pVkCreate", "pVkDestroy"] - | Just u <- stripPrefix "withMapped" - -> (<> u) <$> ["pVkMap", "pVkUnmap"] - | Just u <- stripPrefix "use" - -> (<> u) <$> ["pVkBegin", "pVkEnd"] - | Just u <- stripPrefix "cmdUse" - -> (<> u) <$> ["pVkCmdBegin", "pVkCmdEnd"] - | otherwise - -> ["pVk" <> upperCaseFirst n] - where - stripPrefix p = if p `isPrefixOf` n - then Just (upperCaseFirst (drop (length p) n)) - else Nothing +commandCandidates n = + if + | "Safe" `isSuffixOf` n -> + commandCandidates (dropEnd 4 n) + | Just u <- stripPrefix "with" -> + (<> u) <$> ["pVkAllocate", "pVkFree", "pVkCreate", "pVkDestroy"] + | Just u <- stripPrefix "withMapped" -> + (<> u) <$> ["pVkMap", "pVkUnmap"] + | Just u <- stripPrefix "use" -> + (<> u) <$> ["pVkBegin", "pVkEnd"] + | Just u <- stripPrefix "cmdUse" -> + (<> u) <$> ["pVkCmdBegin", "pVkCmdEnd"] + | otherwise -> + ["pVk" <> upperCaseFirst n] + where + stripPrefix p = + if p `isPrefixOf` n + then Just (upperCaseFirst (drop (length p) n)) + else Nothing --- | Get the record accessors of a type --- --- >>> $(lift . fmap show =<< accessorNames ''Device) --- ["Vulkan.Core10.Handles.deviceHandle","Vulkan.Core10.Handles.deviceCmds"] +{- | Get the record accessors of a type + +>>> $(lift . fmap show =<< accessorNames ''Device) +["Vulkan.Core10.Handles.deviceHandle","Vulkan.Core10.Handles.deviceCmds"] +-} accessorNames :: Name -> Q [Name] -accessorNames record = reify record <&> \case - TyConI (DataD _ _ _ _ [con] _) - | RecC _ vars <- con -> firstOfThree <$> vars - | RecGadtC _ vars _ <- con -> firstOfThree <$> vars - _ -> fail "Name wasn't a TyConI" - where firstOfThree (a, _, _) = a +accessorNames record = + reify record <&> \case + TyConI (DataD _ _ _ _ [con] _) + | RecC _ vars <- con -> firstOfThree <$> vars + | RecGadtC _ vars _ <- con -> firstOfThree <$> vars + _ -> fail "Name wasn't a TyConI" + where + firstOfThree (a, _, _) = a unPtrName :: String -> String unPtrName = \case 'p' : 'V' : xs -> 'v' : xs - s -> s + s -> s upperCaseFirst :: String -> String upperCaseFirst = \case - x:xs -> toUpper x : xs + x : xs -> toUpper x : xs [] -> [] diff --git a/src/Vulkan/Utils/Debug.hs b/src/Vulkan/Utils/Debug.hs --- a/src/Vulkan/Utils/Debug.hs +++ b/src/Vulkan/Utils/Debug.hs @@ -4,25 +4,29 @@ , nameObject ) where -import Control.Monad.IO.Class -import Data.ByteString +import Control.Monad.IO.Class +import Data.ByteString -import Vulkan.Core10 -import Vulkan.Extensions.VK_EXT_debug_utils +import Vulkan.Core10 +import Vulkan.Extensions.VK_EXT_debug_utils --- | A debug callback which prints the message prefixed with "Validation: " to --- stderr. +{- | A debug callback which prints the message prefixed with "Validation: " to +stderr. +-} foreign import ccall unsafe "DebugCallback.c &debugCallback" debugCallbackPtr :: PFN_vkDebugUtilsMessengerCallbackEXT --- | A debug callback the same as 'debugCallbackPtr' except it will call --- @abort@ when @VK_DEBUG_UTILS_MESSAGE_SEVERITY_ERROR_BIT_EXT@ is set. +{- | A debug callback the same as 'debugCallbackPtr' except it will call +@abort@ when @VK_DEBUG_UTILS_MESSAGE_SEVERITY_ERROR_BIT_EXT@ is set. +-} foreign import ccall unsafe "DebugCallback.c &debugCallbackFatal" debugCallbackFatalPtr :: PFN_vkDebugUtilsMessengerCallbackEXT --- | Assign a name to a handle using 'setDebugUtilsObjectNameEXT', note that --- the @VK_EXT_debug_utils@ extension must be enabled. +{- | Assign a name to a handle using 'setDebugUtilsObjectNameEXT', note that +the @VK_EXT_debug_utils@ extension must be enabled. +-} nameObject :: (HasObjectType a, MonadIO m) => Device -> a -> ByteString -> m () -nameObject device object name = setDebugUtilsObjectNameEXT - device - (uncurry DebugUtilsObjectNameInfoEXT (objectTypeAndHandle object) (Just name)) +nameObject device object name = + setDebugUtilsObjectNameEXT + device + (uncurry DebugUtilsObjectNameInfoEXT (objectTypeAndHandle object) (Just name)) diff --git a/src/Vulkan/Utils/Descriptors.hs b/src/Vulkan/Utils/Descriptors.hs new file mode 100644 --- /dev/null +++ b/src/Vulkan/Utils/Descriptors.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE OverloadedLists #-} + +{-| Single-resource descriptor writes for 'Vk.updateDescriptorSets'. +'bufferWrite' covers the whole-buffer case (a uniform or storage buffer +bound in its entirety); 'imageWrite' is its samplerless image sibling (a +storage image in @GENERAL@ layout, a sampled image in +@SHADER_READ_ONLY_OPTIMAL@, …); 'combinedImageSamplerWrite' binds an image +together with a sampler. Bindings needing partial buffer ranges or +descriptor arrays are out of scope — assemble those 'Vk.WriteDescriptorSet's +directly. +-} +module Vulkan.Utils.Descriptors + ( bufferWrite + , imageWrite + , combinedImageSamplerWrite + ) where + +import Data.Word (Word32) +import Vulkan.CStruct.Extends (SomeStruct (..)) +import qualified Vulkan.Core10 as Vk +import Vulkan.Zero (zero) + +bufferWrite + :: Vk.DescriptorSet + -> Word32 + -- ^ Binding. + -> Vk.DescriptorType + -- ^ 'Vk.DESCRIPTOR_TYPE_UNIFORM_BUFFER', 'Vk.DESCRIPTOR_TYPE_STORAGE_BUFFER', … + -> Vk.Buffer + -> SomeStruct Vk.WriteDescriptorSet +bufferWrite set binding descriptorType buffer = + SomeStruct + zero + { Vk.dstSet = set + , Vk.dstBinding = binding + , Vk.descriptorType = descriptorType + , Vk.descriptorCount = 1 + , Vk.bufferInfo = [Vk.DescriptorBufferInfo buffer 0 Vk.WHOLE_SIZE] + } + +imageWrite + :: Vk.DescriptorSet + -> Word32 + -- ^ Binding. + -> Vk.DescriptorType + -- ^ 'Vk.DESCRIPTOR_TYPE_STORAGE_IMAGE', 'Vk.DESCRIPTOR_TYPE_SAMPLED_IMAGE', … + -> Vk.ImageLayout + -- ^ The layout the image will be in when the set is bound. + -> Vk.ImageView + -> SomeStruct Vk.WriteDescriptorSet +imageWrite set binding descriptorType layout view = + SomeStruct + zero + { Vk.dstSet = set + , Vk.dstBinding = binding + , Vk.descriptorType = descriptorType + , Vk.descriptorCount = 1 + , Vk.imageInfo = [Vk.DescriptorImageInfo Vk.NULL_HANDLE view layout] + } + +-- | A combined image+sampler descriptor write ('Vk.DESCRIPTOR_TYPE_COMBINED_IMAGE_SAMPLER'). +combinedImageSamplerWrite + :: Vk.DescriptorSet + -> Word32 + -- ^ Binding. + -> Vk.Sampler + -> Vk.ImageView + -> Vk.ImageLayout + -- ^ The layout the image will be in when the set is bound. + -> SomeStruct Vk.WriteDescriptorSet +combinedImageSamplerWrite set binding sampler view layout = + SomeStruct + zero + { Vk.dstSet = set + , Vk.dstBinding = binding + , Vk.descriptorType = Vk.DESCRIPTOR_TYPE_COMBINED_IMAGE_SAMPLER + , Vk.descriptorCount = 1 + , Vk.imageInfo = [Vk.DescriptorImageInfo sampler view layout] + } diff --git a/src/Vulkan/Utils/DynamicRendering.hs b/src/Vulkan/Utils/DynamicRendering.hs new file mode 100644 --- /dev/null +++ b/src/Vulkan/Utils/DynamicRendering.hs @@ -0,0 +1,230 @@ +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE QuasiQuotes #-} + +{-| The @VK_KHR_dynamic_rendering@ (Vulkan 1.3 core) drawing path: no +'Vk.RenderPass' and no framebuffers. The swapchain image's layout transitions +are handled by explicit pipeline barriers, and the rendering region is opened +with 'Vk.cmdUseRendering' against a 'Vk.RenderingInfo' pointing straight at an +image view. The pipeline carries a @PipelineRenderingCreateInfo@ instead of a +render pass. + +This is one of two self-contained alternatives — see "Vulkan.Utils.RenderPass" +for the classic path. Pick one and import only it. Callers must have enabled +the @dynamicRendering@ feature on the device. +-} +module Vulkan.Utils.DynamicRendering + ( -- * Pipeline + PipelineConfig (..) + , allocatePipeline + , allocatePipelineFromShaders + + -- * Device requirements + , dynamicRenderingRequirements + + -- * Rendering + , colorAttachmentRenderingInfo + , renderingInfo + , loadRenderingInfo + ) where + +import Control.Monad.IO.Unlift (MonadUnliftIO) +import Control.Monad.Trans.Resource (MonadResource, ReleaseKey) +import Data.ByteString (ByteString) +import Data.Maybe (fromMaybe, isJust) +import Data.Vector (Vector) +import qualified Data.Vector as V +import Vulkan.CStruct.Extends (SomeStruct (..), pattern (:&), pattern (::&)) +import qualified Vulkan.Core10 as Vk +import qualified Vulkan.Core13 as Vk +import Vulkan.Core13.Promoted_From_VK_KHR_dynamic_rendering (PhysicalDeviceDynamicRenderingFeatures, PipelineRenderingCreateInfo (..)) +import Vulkan.Requirement (DeviceRequirement) +import Vulkan.Utils.DynamicState (defaultDynamicStatesFor) +import Vulkan.Utils.Pipeline.Internal (basePipelineCreateInfo, buildColorPipeline, withCompiledStages) +import Vulkan.Utils.Pipeline.Specialization (Specialization) +import qualified Vulkan.Utils.Requirements.TH as U +import Vulkan.Zero (Zero (..)) + +{- | The device requirements for this path: the @VK_KHR_dynamic_rendering@ +extension (core since Vulkan 1.3) and the @dynamicRendering@ feature it gates. +Use it directly as — or append it to — a consumer's device requirements (e.g. +@WindowedBoot@'s @wcDeviceReqs@) so callers need not spell out the feature. +-} +dynamicRenderingRequirements :: [DeviceRequirement] +dynamicRenderingRequirements = + [U.reqs| + VK_KHR_dynamic_rendering + PhysicalDeviceDynamicRenderingFeatures.dynamicRendering + |] + +{- | Attachment + fixed-function knobs for a dynamic-rendering pipeline. + +Construct with 'zero' and override what differs, e.g. +@zero { Dynamic.colorFormats = [fmt], Dynamic.depthFormat = Just d }@. +-} +data PipelineConfig = PipelineConfig + { colorFormats :: [Vk.Format] + -- ^ Colour attachment formats (@0@..@N@); @[]@ for a depth-only pipeline. + , depthFormat :: Maybe Vk.Format + , vertexInput :: Vk.PipelineVertexInputStateCreateInfo '[] + -- ^ Vertex input (bindings + attributes); 'zero' for none. + , dynamicStates :: Maybe (Vector Vk.DynamicState) + {- ^ Dynamic states; 'Nothing' defaults layout-aware to + 'Vulkan.Utils.DynamicState.depthOnlyDynamicStates' (no colour) or + 'allDynamicStates'. Drive with 'Vulkan.Utils.DynamicState.applyDynamicStates'. + -} + , layout :: Maybe Vk.PipelineLayout + {- ^ Pipeline layout for descriptor sets \/ push constants; 'Nothing' uses a + transient empty layout (shaders take no resources). A supplied layout stays + owned by the caller, who must keep it alive for the pipeline's lifetime. + -} + } + +instance Zero PipelineConfig where + zero = + PipelineConfig + { colorFormats = [] + , depthFormat = Nothing + , vertexInput = zero + , dynamicStates = Nothing + , layout = Nothing + } + +{- | Build a graphics pipeline for the dynamic-rendering path: no render pass, the +attachment formats carried in a 'PipelineRenderingCreateInfo' on the pNext chain. +The attachment shape — 'colorFormats' and 'depthFormat' — selects the pipeline kind: + + * @[fmt]@ + 'Nothing' — a single-colour pipeline (as the classic path). + * @[fmt]@ + @Just d@ — colour + depth (depth driven dynamically). + * @[]@ + @Just d@ — depth-only (e.g. a shadow map / z-prepass). + * @[f0, f1, …]@ — multiple colour attachments (MRT / G-buffer). + +Stencil is out of scope: no @stencilAttachmentFormat@ is declared, matching +'renderingInfo', which never supplies a stencil attachment (declaring one +without supplying it is invalid at draw time). For stencil, build the +'PipelineRenderingCreateInfo' and 'Vk.RenderingInfo' by hand. The formats MUST +match the views passed to 'Vk.cmdUseRendering' at draw time (see 'renderingInfo'). +Intended to be used qualified, e.g. @Dynamic.allocatePipeline@. +-} +allocatePipeline + :: (MonadResource m, MonadFail m) + => Vk.Device + -> PipelineConfig + -> Vector (SomeStruct Vk.PipelineShaderStageCreateInfo) + -> m (ReleaseKey, Vk.Pipeline) +allocatePipeline dev PipelineConfig{..} stages = + buildColorPipeline dev layout $ \resolvedLayout -> + SomeStruct $ + basePipelineCreateInfo + resolvedLayout + Nothing + (length colorFormats) + (isJust depthFormat) + vertexInput + (fromMaybe (defaultDynamicStatesFor (not (null colorFormats))) dynamicStates) + stages + ::& renderingCreateInfo + :& () + where + renderingCreateInfo :: PipelineRenderingCreateInfo + renderingCreateInfo = + zero + { colorAttachmentFormats = V.fromList colorFormats + , depthAttachmentFormat = fromMaybe Vk.FORMAT_UNDEFINED depthFormat + } + +{- | 'allocatePipeline' from @(stage, SPIR-V)@ pairs: compile each into a shader +module, build the pipeline, then release the now-redundant module handles. +-} +allocatePipelineFromShaders + :: (MonadResource m, MonadUnliftIO m, MonadFail m, Specialization spec) + => Vk.Device + -> PipelineConfig + -> spec + -- ^ Specialization shared by every stage (see "Vulkan.Utils.Pipeline.Specialization"); @()@ for none. + -> [(Vk.ShaderStageFlagBits, ByteString)] + -> m (ReleaseKey, Vk.Pipeline) +allocatePipelineFromShaders dev config spec shaders = + withCompiledStages dev spec shaders $ + allocatePipeline dev config + +{- | A 'Vk.RenderingInfo' targeting a single color attachment that is cleared +on load and stored on completion. The attachment is expected to already be in +@IMAGE_LAYOUT_COLOR_ATTACHMENT_OPTIMAL@ (e.g. via +'Vulkan.Utils.Barrier.transitionColorAttachment'). The single-colour special +case of 'renderingInfo'. +-} +colorAttachmentRenderingInfo + :: Vk.Rect2D + -- ^ Render area (typically the full swapchain extent). + -> Vk.ImageView + -- ^ Target color attachment view. + -> Vk.ClearColorValue + -- ^ Clear color applied by the @LOAD_OP_CLEAR@. + -> Vk.RenderingInfo '[] +colorAttachmentRenderingInfo renderArea imageView clearColor = + renderingInfo renderArea [(imageView, clearColor)] Nothing + +{- | A 'Vk.RenderingInfo' over any number of colour attachments plus an optional +depth attachment, each cleared on load and stored on completion. Colour +attachments are expected in @IMAGE_LAYOUT_COLOR_ATTACHMENT_OPTIMAL@ and the depth +attachment in @IMAGE_LAYOUT_DEPTH_ATTACHMENT_OPTIMAL@ (e.g. via +'Vulkan.Utils.Barrier.transitionColorAttachment' / +'Vulkan.Utils.Barrier.transitionDepthAttachment'). The attachment shape MUST +match the pipeline ('allocatePipeline'). No stencil attachment is supplied, +matching 'allocatePipeline' never declaring one. +-} +renderingInfo + :: Vk.Rect2D + -- ^ Render area (typically the full swapchain extent). + -> Vector (Vk.ImageView, Vk.ClearColorValue) + -- ^ Colour attachment views with the clear colour applied by @LOAD_OP_CLEAR@. + -> Maybe (Vk.ImageView, Float) + -- ^ Optional depth attachment view with the clear depth applied by @LOAD_OP_CLEAR@. + -> Vk.RenderingInfo '[] +renderingInfo renderArea colorTargets depthTarget = + attachmentsInfo + renderArea + (fmap (\(v, c) -> (v, Just (Vk.Color c))) colorTargets) + (fmap (\(v, d) -> (v, Just (Vk.DepthStencil (Vk.ClearDepthStencilValue d 0)))) depthTarget) + +{- | Continue over stored contents. + +'renderingInfo' with @LOAD_OP_LOAD@ on every attachment — e.g. a second +geometry pass into the same targets. Layout expectations as in 'renderingInfo'. +-} +loadRenderingInfo + :: Vk.Rect2D + -- ^ Render area (typically the full swapchain extent). + -> Vector Vk.ImageView + -- ^ Colour attachment views, loaded. + -> Maybe Vk.ImageView + -- ^ Optional depth attachment view, loaded. + -> Vk.RenderingInfo '[] +loadRenderingInfo renderArea colorTargets depthTarget = + attachmentsInfo renderArea (fmap (\v -> (v, Nothing)) colorTargets) (fmap (\v -> (v, Nothing)) depthTarget) + +-- | The shared assembly: an attachment clears when given a value, else loads. +attachmentsInfo + :: Vk.Rect2D + -> Vector (Vk.ImageView, Maybe Vk.ClearValue) + -> Maybe (Vk.ImageView, Maybe Vk.ClearValue) + -> Vk.RenderingInfo '[] +attachmentsInfo renderArea colorTargets depthTarget = + zero + { Vk.renderArea = renderArea + , Vk.layerCount = 1 + , Vk.colorAttachments = fmap (attachment Vk.IMAGE_LAYOUT_COLOR_ATTACHMENT_OPTIMAL) colorTargets + , Vk.depthAttachment = fmap (attachment Vk.IMAGE_LAYOUT_DEPTH_ATTACHMENT_OPTIMAL) depthTarget + } + where + attachment :: Vk.ImageLayout -> (Vk.ImageView, Maybe Vk.ClearValue) -> SomeStruct Vk.RenderingAttachmentInfo + attachment layout (imageView, clear) = + SomeStruct + zero + { Vk.imageView = imageView + , Vk.imageLayout = layout + , Vk.loadOp = maybe Vk.ATTACHMENT_LOAD_OP_LOAD (const Vk.ATTACHMENT_LOAD_OP_CLEAR) clear + , Vk.storeOp = Vk.ATTACHMENT_STORE_OP_STORE + , -- Ignored by @LOAD_OP_LOAD@; any value satisfies the struct. + Vk.clearValue = fromMaybe (Vk.Color (Vk.Float32 0 0 0 0)) clear + } diff --git a/src/Vulkan/Utils/DynamicState.hs b/src/Vulkan/Utils/DynamicState.hs new file mode 100644 --- /dev/null +++ b/src/Vulkan/Utils/DynamicState.hs @@ -0,0 +1,282 @@ +{-# LANGUAGE OverloadedLists #-} + +{-| The Vulkan-1.3-core "always-on" dynamic state: the set of pipeline state +that can be made dynamic without any vendor or experimental extension, so a +single pipeline object serves every combination instead of permuting into one +'Vk.Pipeline' per variation. See 'Vulkan.Utils.RenderPass.allocatePipeline' +and 'Vulkan.Utils.DynamicRendering.allocatePipeline'. + +Because these states are declared dynamic, the matching @cmdSet*@ MUST be issued +before each draw (an unset dynamic state is undefined behaviour). The +'DynamicState' record carries the whole set with safe defaults; amend it with +the per-frame situation (the swapchain extent via 'dynamicStateFor') and emit +the lot in one go with 'applyDynamicStates' over 'allDynamicStates'. + +Defaults mirror Vulkan's zero-initialized values, deviating only where a +non-zero is required for validity ('lineWidth' @= 1@) or to match the pipeline's +baked topology class ('topology' @= TRIANGLE_LIST@). They are feature-free +(no @wideLines@, no @depthBounds@) and valid with a colour-only attachment (all +depth/stencil tests disabled). +-} +module Vulkan.Utils.DynamicState + ( -- * The dynamic-state record + DynamicState (..) + , defaultDynamicState + , dynamicStateFor + + -- * Applying it + , applyDynamicStates + + -- * The state set (pipeline @dynamicStates@ ⇆ apply, single source of truth) + , allDynamicStates + , depthOnlyDynamicStates + , defaultDynamicStatesFor + , minimalDynamicStates + , noDynamicStates + , preRasterizationStates + , fragmentTestStates + , fragmentOutputStates + + -- * Whole-extent viewport/scissor + , fullViewport + , fullScissor + ) where + +import Control.Monad.IO.Class (MonadIO) +import Data.Foldable (traverse_) +import Data.Vector (Vector) +import qualified Data.Vector as V +import Data.Word (Word32) +import qualified Vulkan.Core10 as Rect2D (Rect2D (..)) +import qualified Vulkan.Core10 as Viewport (Viewport (..)) +import qualified Vulkan.Core10 as Vk +import qualified Vulkan.Core13 as Vk +import Vulkan.Zero (zero) + +-- | A viewport covering the whole extent, with depth range @0@ to @1@. +fullViewport :: Vk.Extent2D -> Vk.Viewport +fullViewport (Vk.Extent2D w h) = + zero + { Viewport.width = realToFrac w + , Viewport.height = realToFrac h + , Viewport.maxDepth = 1 + } + +-- | A scissor rectangle covering the whole extent (offset at the origin). +fullScissor :: Vk.Extent2D -> Vk.Rect2D +fullScissor extent = zero{Rect2D.extent = extent} + +---------------------------------------------------------------- +-- The record +---------------------------------------------------------------- + +{- | Every Vulkan-1.3-core always-on dynamic state, as plain values. Field types +match the @cmdSet*@ argument shapes. The stencil ops apply to +@STENCIL_FACE_FRONT_AND_BACK@. +-} +data DynamicState = DynamicState + { -- Pre-rasterization + viewports :: Vector Vk.Viewport + , scissors :: Vector Vk.Rect2D + , topology :: Vk.PrimitiveTopology + , primitiveRestart :: Bool + , cullMode :: Vk.CullModeFlags + , frontFace :: Vk.FrontFace + , rasterizerDiscard :: Bool + , lineWidth :: Float + -- ^ @/= 1@ requires the @wideLines@ feature. + , depthBiasEnable :: Bool + , depthBias :: (Float, Float, Float) + -- ^ @(constantFactor, clamp, slopeFactor)@. + , -- Fragment-shader depth/stencil tests + depthTest :: Bool + , depthWrite :: Bool + , depthCompareOp :: Vk.CompareOp + , depthBoundsTest :: Bool + -- ^ Requires the @depthBounds@ feature. + , depthBounds :: (Float, Float) + -- ^ @(min, max)@. + , stencilTest :: Bool + , stencilFailOp :: Vk.StencilOp + , stencilPassOp :: Vk.StencilOp + , stencilDepthFailOp :: Vk.StencilOp + , stencilCompareOp :: Vk.CompareOp + , stencilCompareMask :: Word32 + , stencilWriteMask :: Word32 + , stencilReference :: Word32 + , -- Fragment-output + blendConstants :: (Float, Float, Float, Float) + } + +{- | Safe, feature-free defaults (see module header). 'viewports' and 'scissors' +are empty — supply them with 'dynamicStateFor' or by record update before +applying. +-} +defaultDynamicState :: DynamicState +defaultDynamicState = + DynamicState + { viewports = V.empty + , scissors = V.empty + , topology = Vk.PRIMITIVE_TOPOLOGY_TRIANGLE_LIST + , primitiveRestart = False + , cullMode = Vk.CULL_MODE_NONE + , frontFace = Vk.FRONT_FACE_COUNTER_CLOCKWISE + , rasterizerDiscard = False + , lineWidth = 1 + , depthBiasEnable = False + , depthBias = (0, 0, 0) + , depthTest = False + , depthWrite = False + , depthCompareOp = Vk.COMPARE_OP_NEVER + , depthBoundsTest = False + , depthBounds = (0, 0) + , stencilTest = False + , stencilFailOp = Vk.STENCIL_OP_KEEP + , stencilPassOp = Vk.STENCIL_OP_KEEP + , stencilDepthFailOp = Vk.STENCIL_OP_KEEP + , stencilCompareOp = Vk.COMPARE_OP_NEVER + , stencilCompareMask = 0 + , stencilWriteMask = 0 + , stencilReference = 0 + , blendConstants = (0, 0, 0, 0) + } + +{- | 'defaultDynamicState' with the whole-extent viewport and scissor filled in. +The common entry point; amend further by record update, e.g. + +@ +'applyDynamicStates' 'allDynamicStates' cb ('dynamicStateFor' ext){ 'cullMode' = Vk.CULL_MODE_BACK_BIT } +@ +-} +dynamicStateFor :: Vk.Extent2D -> DynamicState +dynamicStateFor ext = + defaultDynamicState + { viewports = V.singleton (fullViewport ext) + , scissors = V.singleton (fullScissor ext) + } + +---------------------------------------------------------------- +-- The state set (single source of truth) +---------------------------------------------------------------- + +preRasterizationStates :: Vector Vk.DynamicState +preRasterizationStates = + [ Vk.DYNAMIC_STATE_VIEWPORT_WITH_COUNT + , Vk.DYNAMIC_STATE_SCISSOR_WITH_COUNT + , Vk.DYNAMIC_STATE_PRIMITIVE_TOPOLOGY + , Vk.DYNAMIC_STATE_PRIMITIVE_RESTART_ENABLE + , Vk.DYNAMIC_STATE_CULL_MODE + , Vk.DYNAMIC_STATE_FRONT_FACE + , Vk.DYNAMIC_STATE_RASTERIZER_DISCARD_ENABLE + , Vk.DYNAMIC_STATE_LINE_WIDTH + , Vk.DYNAMIC_STATE_DEPTH_BIAS_ENABLE + , Vk.DYNAMIC_STATE_DEPTH_BIAS + ] + +-- | Fragment-shader depth/stencil dynamic states. +fragmentTestStates :: Vector Vk.DynamicState +fragmentTestStates = + [ Vk.DYNAMIC_STATE_DEPTH_TEST_ENABLE + , Vk.DYNAMIC_STATE_DEPTH_WRITE_ENABLE + , Vk.DYNAMIC_STATE_DEPTH_COMPARE_OP + , Vk.DYNAMIC_STATE_DEPTH_BOUNDS_TEST_ENABLE + , Vk.DYNAMIC_STATE_DEPTH_BOUNDS + , Vk.DYNAMIC_STATE_STENCIL_TEST_ENABLE + , Vk.DYNAMIC_STATE_STENCIL_OP + , Vk.DYNAMIC_STATE_STENCIL_COMPARE_MASK + , Vk.DYNAMIC_STATE_STENCIL_WRITE_MASK + , Vk.DYNAMIC_STATE_STENCIL_REFERENCE + ] + +fragmentOutputStates :: Vector Vk.DynamicState +fragmentOutputStates = [Vk.DYNAMIC_STATE_BLEND_CONSTANTS] + +{- | The whole always-on set: pass this (or 'Nothing', which resolves to it) to a +full-dynamic pipeline builder, and feed the same set to 'applyDynamicStates' so +the pipeline's @dynamicStates@ and the per-frame applies stay in lockstep. +-} +allDynamicStates :: Vector Vk.DynamicState +allDynamicStates = + preRasterizationStates <> fragmentTestStates <> fragmentOutputStates + +{- | The set for a depth-only pipeline (no colour attachment): everything in +'allDynamicStates' except 'fragmentOutputStates' ('Vk.DYNAMIC_STATE_BLEND_CONSTANTS'), +which has no colour attachment to act on. Pair it with a depth-only pipeline and +feed the same set to 'applyDynamicStates'. +-} +depthOnlyDynamicStates :: Vector Vk.DynamicState +depthOnlyDynamicStates = preRasterizationStates <> fragmentTestStates + +{- | The default dynamic-state set for an attachment shape: 'allDynamicStates' when +there is at least one colour attachment, otherwise 'depthOnlyDynamicStates'. The +default a pipeline builder resolves @Nothing@ to. +-} +defaultDynamicStatesFor + :: Bool + -- ^ Whether the pipeline has any colour attachment. + -> Vector Vk.DynamicState +defaultDynamicStatesFor hasColor + | hasColor = allDynamicStates + | otherwise = depthOnlyDynamicStates + +{- | Just the (fixed-count) viewport and scissor. For pipelines that want only +those dynamic and set them with 'Vk.cmdSetViewport' / 'Vk.cmdSetScissor' (not the +with-count variants 'applyDynamicStates' issues for 'allDynamicStates'). +-} +minimalDynamicStates :: Vector Vk.DynamicState +minimalDynamicStates = + [Vk.DYNAMIC_STATE_VIEWPORT, Vk.DYNAMIC_STATE_SCISSOR] + +{- | Declare /nothing/ dynamic: every state is baked into the pipeline, so no +@cmdSet*@ need be issued (skip 'applyDynamicStates' entirely). Pass it where a +builder takes @Maybe (Vector Vk.DynamicState)@. + +The pipeline must then carry a complete static state — crucially a baked viewport +and scissor — so this suits a builder that bakes those (typically a fixed-size +offscreen target). The colour-pipeline builders here instead leave viewport and +scissor dynamic, so they pair with 'Nothing' / 'allDynamicStates', not this. +-} +noDynamicStates :: Maybe (Vector Vk.DynamicState) +noDynamicStates = Just V.empty + +---------------------------------------------------------------- +-- Applying +---------------------------------------------------------------- + +{- | Issue the @cmdSet*@ for exactly the given states, pulling values from the +record. Use the same set passed to the pipeline builder for exact lockstep. +States not modelled by 'DynamicState' are skipped (the caller must set those +themselves). +-} +applyDynamicStates + :: (MonadIO m) => Vector Vk.DynamicState -> Vk.CommandBuffer -> DynamicState -> m () +applyDynamicStates states cb s = traverse_ go states + where + DynamicState{..} = s + bothFaces = Vk.STENCIL_FACE_FRONT_AND_BACK + (biasConstant, biasClamp, biasSlope) = depthBias + (minBound', maxBound') = depthBounds + go = \case + Vk.DYNAMIC_STATE_VIEWPORT_WITH_COUNT -> Vk.cmdSetViewportWithCount cb viewports + Vk.DYNAMIC_STATE_SCISSOR_WITH_COUNT -> Vk.cmdSetScissorWithCount cb scissors + Vk.DYNAMIC_STATE_PRIMITIVE_TOPOLOGY -> Vk.cmdSetPrimitiveTopology cb topology + Vk.DYNAMIC_STATE_PRIMITIVE_RESTART_ENABLE -> Vk.cmdSetPrimitiveRestartEnable cb primitiveRestart + Vk.DYNAMIC_STATE_CULL_MODE -> Vk.cmdSetCullMode cb cullMode + Vk.DYNAMIC_STATE_FRONT_FACE -> Vk.cmdSetFrontFace cb frontFace + Vk.DYNAMIC_STATE_RASTERIZER_DISCARD_ENABLE -> Vk.cmdSetRasterizerDiscardEnable cb rasterizerDiscard + Vk.DYNAMIC_STATE_LINE_WIDTH -> Vk.cmdSetLineWidth cb lineWidth + Vk.DYNAMIC_STATE_DEPTH_BIAS_ENABLE -> Vk.cmdSetDepthBiasEnable cb depthBiasEnable + Vk.DYNAMIC_STATE_DEPTH_BIAS -> Vk.cmdSetDepthBias cb biasConstant biasClamp biasSlope + Vk.DYNAMIC_STATE_DEPTH_TEST_ENABLE -> Vk.cmdSetDepthTestEnable cb depthTest + Vk.DYNAMIC_STATE_DEPTH_WRITE_ENABLE -> Vk.cmdSetDepthWriteEnable cb depthWrite + Vk.DYNAMIC_STATE_DEPTH_COMPARE_OP -> Vk.cmdSetDepthCompareOp cb depthCompareOp + Vk.DYNAMIC_STATE_DEPTH_BOUNDS_TEST_ENABLE -> Vk.cmdSetDepthBoundsTestEnable cb depthBoundsTest + Vk.DYNAMIC_STATE_DEPTH_BOUNDS -> Vk.cmdSetDepthBounds cb minBound' maxBound' + Vk.DYNAMIC_STATE_STENCIL_TEST_ENABLE -> Vk.cmdSetStencilTestEnable cb stencilTest + Vk.DYNAMIC_STATE_STENCIL_OP -> + Vk.cmdSetStencilOp cb bothFaces stencilFailOp stencilPassOp stencilDepthFailOp stencilCompareOp + Vk.DYNAMIC_STATE_STENCIL_COMPARE_MASK -> Vk.cmdSetStencilCompareMask cb bothFaces stencilCompareMask + Vk.DYNAMIC_STATE_STENCIL_WRITE_MASK -> Vk.cmdSetStencilWriteMask cb bothFaces stencilWriteMask + Vk.DYNAMIC_STATE_STENCIL_REFERENCE -> Vk.cmdSetStencilReference cb bothFaces stencilReference + Vk.DYNAMIC_STATE_BLEND_CONSTANTS -> Vk.cmdSetBlendConstants cb blendConstants + _ -> pure () diff --git a/src/Vulkan/Utils/Frame.hs b/src/Vulkan/Utils/Frame.hs new file mode 100644 --- /dev/null +++ b/src/Vulkan/Utils/Frame.hs @@ -0,0 +1,502 @@ +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} + +{-| Per-frame state and the recycling-Frame loop. Each frame owns a binary +image-available semaphore and a command pool — those are 'RecycledResources' +that get handed back to a channel in 'VulkanContext' once the frame's GPU work +has completed. (The present-wait/render-finished semaphore is per swapchain +image, on the 'Vulkan.Utils.Swapchain.Swapchain', because it is only safe to +reuse once its image is re-acquired — not when the frame's render finishes.) + +The host-side timeline semaphore (@fHostTimeline@) lives across frames: +each frame increments it to its own 'fIndex' on the GPU, and the host +waits on it inside the spawned wait-and-recycle thread. + +This module requires Vulkan 1.2-level timeline-semaphore support. See +'frameInstanceRequirements' / 'frameDeviceRequirements' for the +extension/feature requirements to merge into your boot sequence. +-} +module Vulkan.Utils.Frame + ( Frame (..) + , initialFrame + , advanceFrame + , runFrame + , recordCommands + , queueSubmitFrame + , acquireFrameImage + , presentFrameImage + , drainFrames + , allocateTimelineSemaphore + , allocateCommandPool + , allocatePrimary + , SubmitExtras (..) + , noExtras + , frameSubmitExtras + , waitTwice + , frameInstanceRequirements + , frameDeviceRequirements + , syncDeviceRequirements + , InitRecycledResources + ) where + +import Control.Concurrent (forkIO) +import Control.Exception (finally, mask_, throwIO) +import Control.Monad +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Trans.Resource +import Data.Foldable (for_, toList) +import Data.IORef +import Data.List (nub) +import qualified Data.Map.Strict as Map +import qualified Data.Vector as V +import Data.Word +import System.IO (hPutStrLn, stderr) +import Vulkan.CStruct.Extends (SomeStruct (..), pattern (:&), pattern (::&)) +import qualified Vulkan.Core10 as CommandBufferBeginInfo (CommandBufferBeginInfo (..)) +import qualified Vulkan.Core10 as CommandPoolCreateInfo (CommandPoolCreateInfo (..)) +import qualified Vulkan.Core10 as Vk +import Vulkan.Core12.Promoted_From_VK_KHR_timeline_semaphore as Timeline +import Vulkan.Core13 (PhysicalDeviceSynchronization2Features) +import Vulkan.Core13.Enums.PipelineStageFlags2 (PipelineStageFlagBits2 (..), PipelineStageFlags2) +import Vulkan.Core13.Promoted_From_VK_KHR_synchronization2 (SubmitInfo2 (..), queueSubmit2) +import qualified Vulkan.Core13.Promoted_From_VK_KHR_synchronization2 as CommandBufferSubmitInfo (CommandBufferSubmitInfo (..)) +import qualified Vulkan.Core13.Promoted_From_VK_KHR_synchronization2 as SemaphoreSubmitInfo (SemaphoreSubmitInfo (..)) +import Vulkan.Exception (VulkanException (..)) +import Vulkan.Extensions.VK_KHR_get_physical_device_properties2 +import qualified Vulkan.Extensions.VK_KHR_swapchain as KHR +import Vulkan.Requirement (DeviceRequirement, InstanceRequirement (..)) +import Vulkan.Utils.QueueAssignment (QueueFamilyIndex (..)) +import Vulkan.Utils.Queues (Queues (..)) +import Vulkan.Utils.RefCounted (resourceTRefCount) +import qualified Vulkan.Utils.Requirements.TH as U +import Vulkan.Utils.Swapchain (Swapchain (..), sRelease) +import Vulkan.Utils.VulkanContext (RecycledResources (..), VulkanContext (..)) +import Vulkan.Zero (zero) + +data Frame rr = Frame + { fIndex :: Word64 + -- ^ Monotonic, used as the timeline-semaphore signal value for this frame. + , fSwapchain :: Swapchain + {- ^ The swapchain this frame targets. Held by reference so a frame + in flight keeps its swapchain alive across recreation. + -} + , fRecycled :: RecycledResources rr + {- ^ This frame's image-available semaphore + command pool — borrowed from + the recycle channel; returned at retire time. + -} + , fHostTimeline :: Vk.Semaphore + {- ^ Long-lived timeline semaphore. Each frame increments it to 'fIndex' + on the GPU; the host wait thread blocks on this. + -} + , fGPUWork :: IORef [(Vk.Semaphore, Word64)] + {- ^ (Timeline semaphore, value) pairs the host wait thread will block on. + Appended to by 'queueSubmitFrame'. + -} + , fDeferredWork :: IORef [IO ()] + {- ^ Host work the recycle thread runs before the 'fGPUWork' wait — e.g. + a frame graph's host-pass tail, which blocks on its own timeline values + and signals values listed in 'fGPUWork'. Runs in registration order, off + the render thread. + -} + , fResources :: (ReleaseKey, InternalState) + {- ^ ResourceT scope for frame-local allocations; closed when the frame + retires. The 'ReleaseKey' lives in the outer ResourceT so the + scope is freed cleanly even on early shutdown. + -} + } + +{- | Instance-level requirements for the recycling 'Frame' machinery. Merge +with your application's other 'InstanceRequirement's at instance creation. + +Required because checking @PhysicalDeviceTimelineSemaphoreFeatures@ at +physical-device pick time goes through @VkPhysicalDeviceFeatures2@, which +needs either Vulkan 1.1+ or this extension. +-} +frameInstanceRequirements :: [InstanceRequirement] +frameInstanceRequirements = + [ RequireInstanceExtension + Nothing + KHR_GET_PHYSICAL_DEVICE_PROPERTIES_2_EXTENSION_NAME + minBound + ] + +{- | Timeline semaphores and synchronization2. + +The two primitives everything here synchronizes with: 'queueSubmitFrame' and +'allocateTimelineSemaphore', and any submit built by hand. Both are core in +1.3 and universally available in practice, so a headless boot wants them too +— 'frameDeviceRequirements' is these plus a swapchain. +-} +syncDeviceRequirements :: [DeviceRequirement] +syncDeviceRequirements = + [U.reqs| + VK_KHR_timeline_semaphore + PhysicalDeviceTimelineSemaphoreFeatures.timelineSemaphore + VK_KHR_synchronization2 + PhysicalDeviceSynchronization2Features.synchronization2 + |] + +{- | The device-level requirements needed by 'runFrame' / 'queueSubmitFrame' / +'allocateTimelineSemaphore'. Merge into your other 'DeviceRequirement's when +calling 'Vulkan.Utils.Initialization.allocateDeviceFromRequirements'. +-} +frameDeviceRequirements :: [DeviceRequirement] +frameDeviceRequirements = [U.reqs|VK_KHR_swapchain|] <> syncDeviceRequirements + +---------------------------------------------------------------- +-- Construction +---------------------------------------------------------------- + +type InitRecycledResources m rr = VulkanContext rr -> Int -> Queues Vk.CommandPool -> m rr + +{- | Build the initial frame with one spare 'RecycledResources' seeded +into the recycle channel. That, plus the set attached to this frame, +caps max-in-flight at 2 (CPU recording + GPU executing the previous). +-} +initialFrame + :: forall rr m + . (MonadResource m) + => VulkanContext rr + -> Swapchain + -> InitRecycledResources m rr + -> m (Frame rr) +initialFrame vc fSwapchain mkRecycled = do + fResources <- allocate createInternalState closeInternalState + fRecycled <- mkRecycledResources vc $ mkRecycled vc 0 + spare <- mkRecycledResources vc $ mkRecycled vc 1 + liftIO (vcRecycleBin vc spare) + (_, fHostTimeline) <- allocateTimelineSemaphore (vcDevice vc) 0 + fGPUWork <- liftIO $ newIORef mempty + fDeferredWork <- liftIO $ newIORef mempty + liftIO $ runInternalState (resourceTRefCount (sRelease fSwapchain)) (snd fResources) + pure Frame{fIndex = 1, ..} + +{- | Build the next frame, taking one set of recycled resources from the bin. +Caller passes the (possibly-recreated) 'Swapchain'. +-} +advanceFrame + :: (MonadResource m) + => VulkanContext rr + -> Swapchain + -- ^ Same as old, or freshly recreated + -> Frame rr + -- ^ The just-finished frame + -> m (Frame rr) +advanceFrame vc sc f = do + fResources <- allocate createInternalState closeInternalState + fRecycled <- + liftIO $ + vcRecycleNib vc >>= \case + Left block -> block + Right rr -> pure rr + fGPUWork <- liftIO $ newIORef mempty + fDeferredWork <- liftIO $ newIORef mempty + liftIO $ runInternalState (resourceTRefCount (sRelease sc)) (snd fResources) + pure + Frame + { fIndex = succ (fIndex f) + , fSwapchain = sc + , fRecycled + , fHostTimeline = fHostTimeline f + , fGPUWork + , fDeferredWork + , fResources + } + +---------------------------------------------------------------- +-- Loop +---------------------------------------------------------------- + +{- | Run a per-frame action against this frame's per-frame ResourceT scope, +then asynchronously wait for the GPU work and recycle. The deferred host +work and the wait/recycle run in a forked thread so the next frame can +begin recording immediately. + +Anything 'allocate'd inside @action@ is freed when the frame retires. +-} +runFrame :: VulkanContext rr -> Frame rr -> ResourceT IO a -> IO a +runFrame vc f action = + runInternalState action (snd (fResources f)) + `finally` waitAndRecycle vc f + +waitAndRecycle :: VulkanContext rr -> Frame rr -> IO () +waitAndRecycle vc f = do + waits <- readIORef (fGPUWork f) + deferred <- readIORef (fDeferredWork f) + void . forkIO $ do + -- The frame's host work first: it blocks on its own timeline values and + -- signals values the wait below (and in-flight submits) depend on. + sequence_ (reverse deferred) + unless (null waits) $ do + let waitInfo = + zero + { semaphores = V.fromList (fst <$> waits) + , values = V.fromList (snd <$> waits) + } + r <- waitTwice (vcDevice vc) waitInfo oneSecond + case r of + Vk.TIMEOUT -> hPutStrLn stderr "Frame wait timed out (1s) — GPU may be hung" + _ -> pure () + -- Pool reuse: reset each distinct pool, dropping all recorded buffers. + -- No RELEASE_RESOURCES: the point of recycling a pool is to keep its + -- arena warm for the next frame's buffers. + for_ (nub (toList (rrCommandPools (fRecycled f)))) $ \pool -> + Vk.resetCommandPool (vcDevice vc) pool zero + -- Free the per-frame ResourceT scope. Must precede the channel deposit so + -- the deposit signals "all per-frame cleanup done" — otherwise the next + -- frame could pick up the recycled pool while this frame's cleanup is + -- still calling vkFreeCommandBuffers on it. + release (fst (fResources f)) + -- Hand the borrowed resources back to whoever's waiting on them. + vcRecycleBin vc (fRecycled f) + where + oneSecond :: Word64 + oneSecond = 1000000000 + +{- | Allocate a primary command buffer from this frame's recycled command pool, +begin it with 'Vk.COMMAND_BUFFER_USAGE_ONE_TIME_SUBMIT_BIT', run the caller's +recording action, end recording, and return the buffer ready to hand to +'queueSubmitFrame'. + +For a non-standard begin shape (secondary level, different usage flags, +inheritance info) call 'Vk.withCommandBuffers' and 'Vk.useCommandBuffer' +directly. +-} +recordCommands + :: (MonadResource m, MonadFail m) + => VulkanContext rr + -> Frame rr + -> (Vk.CommandBuffer -> m ()) + -> m Vk.CommandBuffer +{-# INLINE recordCommands #-} +recordCommands vc Frame{fRecycled} record = do + (_, [cb]) <- + Vk.withCommandBuffers + (vcDevice vc) + zero + { Vk.commandPool = qGraphics (rrCommandPools fRecycled) + , Vk.level = Vk.COMMAND_BUFFER_LEVEL_PRIMARY + , Vk.commandBufferCount = 1 + } + allocate + Vk.useCommandBuffer cb zero{CommandBufferBeginInfo.flags = Vk.COMMAND_BUFFER_USAGE_ONE_TIME_SUBMIT_BIT} $ + record cb + pure cb + +{- | Submit a per-frame command buffer batch and record the timeline-wait +bookkeeping the host wait thread will block on. + +Builds the standard frame submit from context/frame: waits on the frame's +image-available semaphore at @COLOR_ATTACHMENT_OUTPUT@, signals the +swapchain's per-image render-finished semaphore (at @imageIndex@) plus its +timeline value, and submits on the graphics queue. + +For a non-standard submit shape (multiple submit infos, different wait +stage, extra signals), call 'queueSubmit2' directly and append +@(fHostTimeline f, fIndex f)@ to @fGPUWork f@. +-} +queueSubmitFrame + :: (MonadIO m) + => VulkanContext rr + -> Frame rr + -> Word32 + {- ^ Acquired image index (from 'acquireFrameImage'); selects the per-image + present-wait semaphore to signal. + -} + -> V.Vector Vk.CommandBuffer + -> m () +{-# INLINE queueSubmitFrame #-} +queueSubmitFrame vc Frame{..} imageIndex cbs = liftIO . mask_ $ do + queueSubmit2 gQ [SomeStruct submitInfo] Vk.NULL_HANDLE + atomicModifyIORef' fGPUWork $ \jobs -> ((fHostTimeline, fIndex) : jobs, ()) + where + gQ = snd (qGraphics (vcQueues vc)) + renderFinished = sRenderFinished fSwapchain V.! fromIntegral imageIndex + -- The two WSI semaphores are binary (mandated: acquire signals one, + -- present waits on one) and ignore their values; the timeline is ours. + submitInfo = + zero + { waitSemaphoreInfos = + [zero{SemaphoreSubmitInfo.semaphore = rrImageAvailable, SemaphoreSubmitInfo.stageMask = PIPELINE_STAGE_2_TOP_OF_PIPE_BIT}] + , commandBufferInfos = + fmap (\cb -> SomeStruct zero{CommandBufferSubmitInfo.commandBuffer = Vk.commandBufferHandle cb}) cbs + , signalSemaphoreInfos = + [ zero{SemaphoreSubmitInfo.semaphore = renderFinished, SemaphoreSubmitInfo.stageMask = PIPELINE_STAGE_2_ALL_COMMANDS_BIT} + , zero{SemaphoreSubmitInfo.semaphore = fHostTimeline, SemaphoreSubmitInfo.stageMask = PIPELINE_STAGE_2_ALL_COMMANDS_BIT, SemaphoreSubmitInfo.value = fIndex} + ] + } + :: SubmitInfo2 '[] + RecycledResources{rrImageAvailable} = fRecycled + +{- | Acquire the next swapchain image for this frame, signalling the frame's +image-available semaphore on completion. + +The acquire result is returned alongside the image index so the caller can +thread it into 'presentFrameImage', which honours 'SUBOPTIMAL_KHR' from +either side by raising 'ERROR_OUT_OF_DATE_KHR' to drive a swapchain +recreation. Timeouts and unexpected results are also translated to +'ERROR_OUT_OF_DATE_KHR' — the main loop's swapchain-recreation path is the +right place to recover. +-} +acquireFrameImage :: (MonadIO m) => VulkanContext rr -> Frame rr -> m (Vk.Result, Word32) +{-# INLINE acquireFrameImage #-} +acquireFrameImage vc Frame{..} = + liftIO $ + acquire >>= \case + r@(Vk.SUCCESS, _) -> pure r + r@(Vk.SUBOPTIMAL_KHR, _) -> pure r + _ -> throwIO (VulkanException Vk.ERROR_OUT_OF_DATE_KHR) + where + acquire = + KHR.acquireNextImageKHRSafe + (vcDevice vc) + (sSwapchain fSwapchain) + oneSecond + (rrImageAvailable fRecycled) + Vk.NULL_HANDLE + + oneSecond :: Word64 + oneSecond = 1000000000 + +{- | Present this frame's acquired image, waiting on the swapchain's per-image +render-finished semaphore (at @imageIndex@). Presents on the graphics queue +(@qGraphics . vcQueues@). + +If either the prior acquire (passed in) or this present reports +'SUBOPTIMAL_KHR', raises 'ERROR_OUT_OF_DATE_KHR' so the main loop +recreates the swapchain. +-} +presentFrameImage :: (MonadIO m) => VulkanContext rr -> Frame rr -> Vk.Result -> Word32 -> m () +{-# INLINE presentFrameImage #-} +presentFrameImage vc f acquireResult imageIndex = liftIO $ do + presentResult <- + KHR.queuePresentKHR + gQ + zero + { KHR.waitSemaphores = [renderFinished] + , KHR.swapchains = [sSwapchain (fSwapchain f)] + , KHR.imageIndices = [imageIndex] + } + when (acquireResult == Vk.SUBOPTIMAL_KHR || presentResult == Vk.SUBOPTIMAL_KHR) $ + throwIO (VulkanException Vk.ERROR_OUT_OF_DATE_KHR) + where + renderFinished = sRenderFinished (fSwapchain f) V.! fromIntegral imageIndex + gQ = snd (qGraphics (vcQueues vc)) + +{- | Shutdown drain: spawn the unrendered current frame's wait/recycle thread, +then block on the recycle channel until both this frame's and the previous +in-flight frame's deposits have arrived. After this returns, every forked +wait thread has run its per-frame cleanup, so the outer 'ResourceT' is safe +to tear down GPU resources. + +Assumes max-in-flight is 2 (see 'initialFrame'). +-} +drainFrames :: VulkanContext rr -> Frame rr -> IO () +drainFrames vc f = do + waitAndRecycle vc f + let take1 = vcRecycleNib vc >>= either id pure + _ <- take1 + _ <- take1 + pure () + +---------------------------------------------------------------- +-- Small helpers +---------------------------------------------------------------- + +-- | Allocate a timeline semaphore initialised to the given value. +allocateTimelineSemaphore :: (MonadResource m) => Vk.Device -> Word64 -> m (ReleaseKey, Vk.Semaphore) +allocateTimelineSemaphore dev initial = + Vk.withSemaphore + dev + (zero ::& SemaphoreTypeCreateInfo SEMAPHORE_TYPE_TIMELINE initial :& ()) + Nothing + allocate + +---------------------------------------------------------------- +-- Internals +---------------------------------------------------------------- + +{- | Build one set of recycled resources: a binary image-available semaphore ++ a command pool keyed to the graphics queue family. (The present-wait +semaphore is per swapchain image, on the 'Swapchain', not here.) +-} +mkRecycledResources + :: (MonadResource m) + => VulkanContext rr + -> (Queues Vk.CommandPool -> m rr) + -> m (RecycledResources rr) +mkRecycledResources vc mkData = do + (_, rrImageAvailable) <- + Vk.withSemaphore + dev + (zero ::& SemaphoreTypeCreateInfo SEMAPHORE_TYPE_BINARY 0 :& ()) + Nothing + allocate + -- One pool per distinct family, shared by every role on it. + byFamily <- + fmap Map.fromList $ + traverse (\fam -> fmap (fam,) (allocateCommandPool dev fam)) (nub (toList families)) + let rrCommandPools = fmap (byFamily Map.!) families + rrData <- mkData rrCommandPools + pure RecycledResources{..} + where + dev = vcDevice vc + families = fmap (\(QueueFamilyIndex fam, _) -> fam) (vcQueues vc) + +-- | Allocate a command pool for the family, released with the scope. +allocateCommandPool :: (MonadResource m) => Vk.Device -> Word32 -> m Vk.CommandPool +allocateCommandPool dev family = do + (_, pool) <- Vk.withCommandPool dev zero{CommandPoolCreateInfo.queueFamilyIndex = family} Nothing allocate + pure pool + +-- | Allocate a primary command buffer from the pool and begin it, one-time-submit. +allocatePrimary :: (MonadResource m) => Vk.Device -> Vk.CommandPool -> m Vk.CommandBuffer +allocatePrimary dev pool = do + (_, cbs) <- + Vk.withCommandBuffers + dev + zero{Vk.commandPool = pool, Vk.level = Vk.COMMAND_BUFFER_LEVEL_PRIMARY, Vk.commandBufferCount = 1} + allocate + let cb = V.head cbs + Vk.beginCommandBuffer cb zero{CommandBufferBeginInfo.flags = Vk.COMMAND_BUFFER_USAGE_ONE_TIME_SUBMIT_BIT} + pure cb + +{- | Frame-level waits and signals spliced into one submit. + +Timeline semaphores carry their value; a binary semaphore's value is +ignored (pass 0). +-} +data SubmitExtras = SubmitExtras + { waits :: [(Vk.Semaphore, PipelineStageFlags2, Word64)] + , signals :: [(Vk.Semaphore, Word64)] + } + +noExtras :: SubmitExtras +noExtras = SubmitExtras [] [] + +{- | The canonical windowed frame extras. + +Wait image-available; signal this image's render-finished and the host +timeline at the frame index — the shape 'queueSubmitFrame' hard-codes, +for drivers that assemble their own submits. +-} +frameSubmitExtras :: Frame rr -> Word32 -> SubmitExtras +frameSubmitExtras f imageIndex = + SubmitExtras + { waits = [(rrImageAvailable (fRecycled f), PIPELINE_STAGE_2_TOP_OF_PIPE_BIT, 0)] + , signals = + [ (sRenderFinished (fSwapchain f) V.! fromIntegral imageIndex, 0) + , (fHostTimeline f, fIndex f) + ] + } + +{- | Wait for some semaphores; if the wait times out, give the device one +more chance with a zero timeout. Catches the case where the host was +suspended during the wait and the GPU has actually finished. +-} +waitTwice :: Vk.Device -> SemaphoreWaitInfo -> Word64 -> IO Vk.Result +waitTwice dev waitInfo t = + Timeline.waitSemaphoresSafe dev waitInfo t >>= \case + Vk.TIMEOUT -> Timeline.waitSemaphores dev waitInfo 0 + r -> pure r diff --git a/src/Vulkan/Utils/Framebuffer.hs b/src/Vulkan/Utils/Framebuffer.hs new file mode 100644 --- /dev/null +++ b/src/Vulkan/Utils/Framebuffer.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE OverloadedLists #-} + +{-| Tiny helpers for the boilerplate that each rendering example needs: +a framebuffer over a single image view, and a vanilla 2D color image view. +-} +module Vulkan.Utils.Framebuffer + ( allocateFramebuffer + ) where + +import Control.Monad.Trans.Resource (MonadResource, ReleaseKey, allocate) +import Vulkan.Core10 as Extent2D (Extent2D (..)) +import qualified Vulkan.Core10 as Vk +import Vulkan.Zero (zero) + +-- | Create a framebuffer covering the whole image with a single attachment. +allocateFramebuffer + :: (MonadResource m) + => Vk.Device + -> Vk.RenderPass + -> Vk.ImageView + -> Vk.Extent2D + -> m (ReleaseKey, Vk.Framebuffer) +allocateFramebuffer dev renderPass imageView Vk.Extent2D{width, height} = + Vk.withFramebuffer dev framebufferCreateInfo Nothing allocate + where + framebufferCreateInfo :: Vk.FramebufferCreateInfo '[] + framebufferCreateInfo = + zero + { Vk.renderPass = renderPass + , Vk.attachments = [imageView] + , Vk.width = width + , Vk.height = height + , Vk.layers = 1 + } diff --git a/src/Vulkan/Utils/FromGL.hs b/src/Vulkan/Utils/FromGL.hs --- a/src/Vulkan/Utils/FromGL.hs +++ b/src/Vulkan/Utils/FromGL.hs @@ -26,160 +26,143 @@ #include "gl_enums.h" --- | Convert an OpenGL format enum into a 'Vk.Format' --- --- >>> internalFormat GL_RGB8 --- Just FORMAT_R8G8B8_UNORM +{- | Convert an OpenGL format enum into a 'Vk.Format' + +>>> internalFormat GL_RGB8 +Just FORMAT_R8G8B8_UNORM +-} internalFormat :: (Eq a, Num a) => a -> Maybe Vk.Format internalFormat = \case - GL_R8 -> Just Vk.FORMAT_R8_UNORM -- 1-component, 8-bit unsigned normalized - GL_RG8 -> Just Vk.FORMAT_R8G8_UNORM -- 2-component, 8-bit unsigned normalized - GL_RGB8 -> Just Vk.FORMAT_R8G8B8_UNORM -- 3-component, 8-bit unsigned normalized + GL_R8 -> Just Vk.FORMAT_R8_UNORM -- 1-component, 8-bit unsigned normalized + GL_RG8 -> Just Vk.FORMAT_R8G8_UNORM -- 2-component, 8-bit unsigned normalized + GL_RGB8 -> Just Vk.FORMAT_R8G8B8_UNORM -- 3-component, 8-bit unsigned normalized GL_RGBA8 -> Just Vk.FORMAT_R8G8B8A8_UNORM -- 4-component, 8-bit unsigned normalized - - GL_R8_SNORM -> Just Vk.FORMAT_R8_SNORM -- 1-component, 8-bit signed normalized - GL_RG8_SNORM -> Just Vk.FORMAT_R8G8_SNORM -- 2-component, 8-bit signed normalized - GL_RGB8_SNORM -> Just Vk.FORMAT_R8G8B8_SNORM -- 3-component, 8-bit signed normalized + GL_R8_SNORM -> Just Vk.FORMAT_R8_SNORM -- 1-component, 8-bit signed normalized + GL_RG8_SNORM -> Just Vk.FORMAT_R8G8_SNORM -- 2-component, 8-bit signed normalized + GL_RGB8_SNORM -> Just Vk.FORMAT_R8G8B8_SNORM -- 3-component, 8-bit signed normalized GL_RGBA8_SNORM -> Just Vk.FORMAT_R8G8B8A8_SNORM -- 4-component, 8-bit signed normalized - - GL_R8UI -> Just Vk.FORMAT_R8_UINT -- 1-component, 8-bit unsigned integer - GL_RG8UI -> Just Vk.FORMAT_R8G8_UINT -- 2-component, 8-bit unsigned integer - GL_RGB8UI -> Just Vk.FORMAT_R8G8B8_UINT -- 3-component, 8-bit unsigned integer + GL_R8UI -> Just Vk.FORMAT_R8_UINT -- 1-component, 8-bit unsigned integer + GL_RG8UI -> Just Vk.FORMAT_R8G8_UINT -- 2-component, 8-bit unsigned integer + GL_RGB8UI -> Just Vk.FORMAT_R8G8B8_UINT -- 3-component, 8-bit unsigned integer GL_RGBA8UI -> Just Vk.FORMAT_R8G8B8A8_UINT -- 4-component, 8-bit unsigned integer - - GL_R8I -> Just Vk.FORMAT_R8_SINT -- 1-component, 8-bit signed integer - GL_RG8I -> Just Vk.FORMAT_R8G8_SINT -- 2-component, 8-bit signed integer - GL_RGB8I -> Just Vk.FORMAT_R8G8B8_SINT -- 3-component, 8-bit signed integer + GL_R8I -> Just Vk.FORMAT_R8_SINT -- 1-component, 8-bit signed integer + GL_RG8I -> Just Vk.FORMAT_R8G8_SINT -- 2-component, 8-bit signed integer + GL_RGB8I -> Just Vk.FORMAT_R8G8B8_SINT -- 3-component, 8-bit signed integer GL_RGBA8I -> Just Vk.FORMAT_R8G8B8A8_SINT -- 4-component, 8-bit signed integer - - GL_SR8 -> Just Vk.FORMAT_R8_SRGB -- 1-component, 8-bit sRGB - GL_SRG8 -> Just Vk.FORMAT_R8G8_SRGB -- 2-component, 8-bit sRGB - GL_SRGB8 -> Just Vk.FORMAT_R8G8B8_SRGB -- 3-component, 8-bit sRGB + GL_SR8 -> Just Vk.FORMAT_R8_SRGB -- 1-component, 8-bit sRGB + GL_SRG8 -> Just Vk.FORMAT_R8G8_SRGB -- 2-component, 8-bit sRGB + GL_SRGB8 -> Just Vk.FORMAT_R8G8B8_SRGB -- 3-component, 8-bit sRGB GL_SRGB8_ALPHA8 -> Just Vk.FORMAT_R8G8B8A8_SRGB -- 4-component, 8-bit sRGB -- -- 16 bits per component -- - GL_R16 -> Just Vk.FORMAT_R16_UNORM -- 1-component, 16-bit unsigned normalized - GL_RG16 -> Just Vk.FORMAT_R16G16_UNORM -- 2-component, 16-bit unsigned normalized - GL_RGB16 -> Just Vk.FORMAT_R16G16B16_UNORM -- 3-component, 16-bit unsigned normalized + GL_R16 -> Just Vk.FORMAT_R16_UNORM -- 1-component, 16-bit unsigned normalized + GL_RG16 -> Just Vk.FORMAT_R16G16_UNORM -- 2-component, 16-bit unsigned normalized + GL_RGB16 -> Just Vk.FORMAT_R16G16B16_UNORM -- 3-component, 16-bit unsigned normalized GL_RGBA16 -> Just Vk.FORMAT_R16G16B16A16_UNORM -- 4-component, 16-bit unsigned normalized - - GL_R16_SNORM -> Just Vk.FORMAT_R16_SNORM -- 1-component, 16-bit signed normalized - GL_RG16_SNORM -> Just Vk.FORMAT_R16G16_SNORM -- 2-component, 16-bit signed normalized - GL_RGB16_SNORM -> Just Vk.FORMAT_R16G16B16_SNORM -- 3-component, 16-bit signed normalized + GL_R16_SNORM -> Just Vk.FORMAT_R16_SNORM -- 1-component, 16-bit signed normalized + GL_RG16_SNORM -> Just Vk.FORMAT_R16G16_SNORM -- 2-component, 16-bit signed normalized + GL_RGB16_SNORM -> Just Vk.FORMAT_R16G16B16_SNORM -- 3-component, 16-bit signed normalized GL_RGBA16_SNORM -> Just Vk.FORMAT_R16G16B16A16_SNORM -- 4-component, 16-bit signed normalized - - GL_R16UI -> Just Vk.FORMAT_R16_UINT -- 1-component, 16-bit unsigned integer - GL_RG16UI -> Just Vk.FORMAT_R16G16_UINT -- 2-component, 16-bit unsigned integer - GL_RGB16UI -> Just Vk.FORMAT_R16G16B16_UINT -- 3-component, 16-bit unsigned integer + GL_R16UI -> Just Vk.FORMAT_R16_UINT -- 1-component, 16-bit unsigned integer + GL_RG16UI -> Just Vk.FORMAT_R16G16_UINT -- 2-component, 16-bit unsigned integer + GL_RGB16UI -> Just Vk.FORMAT_R16G16B16_UINT -- 3-component, 16-bit unsigned integer GL_RGBA16UI -> Just Vk.FORMAT_R16G16B16A16_UINT -- 4-component, 16-bit unsigned integer - - GL_R16I -> Just Vk.FORMAT_R16_SINT -- 1-component, 16-bit signed integer - GL_RG16I -> Just Vk.FORMAT_R16G16_SINT -- 2-component, 16-bit signed integer - GL_RGB16I -> Just Vk.FORMAT_R16G16B16_SINT -- 3-component, 16-bit signed integer + GL_R16I -> Just Vk.FORMAT_R16_SINT -- 1-component, 16-bit signed integer + GL_RG16I -> Just Vk.FORMAT_R16G16_SINT -- 2-component, 16-bit signed integer + GL_RGB16I -> Just Vk.FORMAT_R16G16B16_SINT -- 3-component, 16-bit signed integer GL_RGBA16I -> Just Vk.FORMAT_R16G16B16A16_SINT -- 4-component, 16-bit signed integer - - GL_R16F -> Just Vk.FORMAT_R16_SFLOAT -- 1-component, 16-bit floating-point - GL_RG16F -> Just Vk.FORMAT_R16G16_SFLOAT -- 2-component, 16-bit floating-point - GL_RGB16F -> Just Vk.FORMAT_R16G16B16_SFLOAT -- 3-component, 16-bit floating-point + GL_R16F -> Just Vk.FORMAT_R16_SFLOAT -- 1-component, 16-bit floating-point + GL_RG16F -> Just Vk.FORMAT_R16G16_SFLOAT -- 2-component, 16-bit floating-point + GL_RGB16F -> Just Vk.FORMAT_R16G16B16_SFLOAT -- 3-component, 16-bit floating-point GL_RGBA16F -> Just Vk.FORMAT_R16G16B16A16_SFLOAT -- 4-component, 16-bit floating-point -- -- 32 bits per component -- - GL_R32UI -> Just Vk.FORMAT_R32_UINT -- 1-component, 32-bit unsigned integer - GL_RG32UI -> Just Vk.FORMAT_R32G32_UINT -- 2-component, 32-bit unsigned integer - GL_RGB32UI -> Just Vk.FORMAT_R32G32B32_UINT -- 3-component, 32-bit unsigned integer + GL_R32UI -> Just Vk.FORMAT_R32_UINT -- 1-component, 32-bit unsigned integer + GL_RG32UI -> Just Vk.FORMAT_R32G32_UINT -- 2-component, 32-bit unsigned integer + GL_RGB32UI -> Just Vk.FORMAT_R32G32B32_UINT -- 3-component, 32-bit unsigned integer GL_RGBA32UI -> Just Vk.FORMAT_R32G32B32A32_UINT -- 4-component, 32-bit unsigned integer - - GL_R32I -> Just Vk.FORMAT_R32_SINT -- 1-component, 32-bit signed integer - GL_RG32I -> Just Vk.FORMAT_R32G32_SINT -- 2-component, 32-bit signed integer - GL_RGB32I -> Just Vk.FORMAT_R32G32B32_SINT -- 3-component, 32-bit signed integer + GL_R32I -> Just Vk.FORMAT_R32_SINT -- 1-component, 32-bit signed integer + GL_RG32I -> Just Vk.FORMAT_R32G32_SINT -- 2-component, 32-bit signed integer + GL_RGB32I -> Just Vk.FORMAT_R32G32B32_SINT -- 3-component, 32-bit signed integer GL_RGBA32I -> Just Vk.FORMAT_R32G32B32A32_SINT -- 4-component, 32-bit signed integer - - GL_R32F -> Just Vk.FORMAT_R32_SFLOAT -- 1-component, 32-bit floating-point - GL_RG32F -> Just Vk.FORMAT_R32G32_SFLOAT -- 2-component, 32-bit floating-point - GL_RGB32F -> Just Vk.FORMAT_R32G32B32_SFLOAT -- 3-component, 32-bit floating-point + GL_R32F -> Just Vk.FORMAT_R32_SFLOAT -- 1-component, 32-bit floating-point + GL_RG32F -> Just Vk.FORMAT_R32G32_SFLOAT -- 2-component, 32-bit floating-point + GL_RGB32F -> Just Vk.FORMAT_R32G32B32_SFLOAT -- 3-component, 32-bit floating-point GL_RGBA32F -> Just Vk.FORMAT_R32G32B32A32_SFLOAT -- 4-component, 32-bit floating-point -- -- Packed -- - GL_R3_G3_B2 -> Nothing -- 3-component 3:3:2, unsigned normalized - GL_RGB4 -> Nothing -- 3-component 4:4:4, unsigned normalized - GL_RGB5 -> Just Vk.FORMAT_R5G5B5A1_UNORM_PACK16 -- 3-component 5:5:5, unsigned normalized - GL_RGB565 -> Just Vk.FORMAT_R5G6B5_UNORM_PACK16 -- 3-component 5:6:5, unsigned normalized - GL_RGB10 -> Just Vk.FORMAT_A2R10G10B10_UNORM_PACK32 -- 3-component 10:10:10, unsigned normalized - GL_RGB12 -> Nothing -- 3-component 12:12:12, unsigned normalized - GL_RGBA2 -> Nothing -- 4-component 2:2:2:2, unsigned normalized - GL_RGBA4 -> Just Vk.FORMAT_R4G4B4A4_UNORM_PACK16 -- 4-component 4:4:4:4, unsigned normalized - GL_RGBA12 -> Nothing -- 4-component 12:12:12:12, unsigned normalized - GL_RGB5_A1 -> Just Vk.FORMAT_A1R5G5B5_UNORM_PACK16 -- 4-component 5:5:5:1, unsigned normalized - GL_RGB10_A2 -> Just Vk.FORMAT_A2R10G10B10_UNORM_PACK32 -- 4-component 10:10:10:2, unsigned normalized - GL_RGB10_A2UI -> Just Vk.FORMAT_A2R10G10B10_UINT_PACK32 -- 4-component 10:10:10:2, unsigned integer - GL_R11F_G11F_B10F -> Just Vk.FORMAT_B10G11R11_UFLOAT_PACK32 -- 3-component 11:11:10, floating-point - GL_RGB9_E5 -> Just Vk.FORMAT_E5B9G9R9_UFLOAT_PACK32 -- 3-component/exp 9:9:9/5, floating-point + GL_R3_G3_B2 -> Nothing -- 3-component 3:3:2, unsigned normalized + GL_RGB4 -> Nothing -- 3-component 4:4:4, unsigned normalized + GL_RGB5 -> Just Vk.FORMAT_R5G5B5A1_UNORM_PACK16 -- 3-component 5:5:5, unsigned normalized + GL_RGB565 -> Just Vk.FORMAT_R5G6B5_UNORM_PACK16 -- 3-component 5:6:5, unsigned normalized + GL_RGB10 -> Just Vk.FORMAT_A2R10G10B10_UNORM_PACK32 -- 3-component 10:10:10, unsigned normalized + GL_RGB12 -> Nothing -- 3-component 12:12:12, unsigned normalized + GL_RGBA2 -> Nothing -- 4-component 2:2:2:2, unsigned normalized + GL_RGBA4 -> Just Vk.FORMAT_R4G4B4A4_UNORM_PACK16 -- 4-component 4:4:4:4, unsigned normalized + GL_RGBA12 -> Nothing -- 4-component 12:12:12:12, unsigned normalized + GL_RGB5_A1 -> Just Vk.FORMAT_A1R5G5B5_UNORM_PACK16 -- 4-component 5:5:5:1, unsigned normalized + GL_RGB10_A2 -> Just Vk.FORMAT_A2R10G10B10_UNORM_PACK32 -- 4-component 10:10:10:2, unsigned normalized + GL_RGB10_A2UI -> Just Vk.FORMAT_A2R10G10B10_UINT_PACK32 -- 4-component 10:10:10:2, unsigned integer + GL_R11F_G11F_B10F -> Just Vk.FORMAT_B10G11R11_UFLOAT_PACK32 -- 3-component 11:11:10, floating-point + GL_RGB9_E5 -> Just Vk.FORMAT_E5B9G9R9_UFLOAT_PACK32 -- 3-component/exp 9:9:9/5, floating-point -- -- S3TC/DXT/BC -- - GL_COMPRESSED_RGB_S3TC_DXT1_EXT -> Just Vk.FORMAT_BC1_RGB_UNORM_BLOCK -- line through 3D space, 4x4 blocks, unsigned normalized + GL_COMPRESSED_RGB_S3TC_DXT1_EXT -> Just Vk.FORMAT_BC1_RGB_UNORM_BLOCK -- line through 3D space, 4x4 blocks, unsigned normalized GL_COMPRESSED_RGBA_S3TC_DXT1_EXT -> Just Vk.FORMAT_BC1_RGBA_UNORM_BLOCK -- line through 3D space plus 1-bit alpha, 4x4 blocks, unsigned normalized - GL_COMPRESSED_RGBA_S3TC_DXT3_EXT -> Just Vk.FORMAT_BC2_UNORM_BLOCK -- line through 3D space plus line through 1D space, 4x4 blocks, unsigned normalized - GL_COMPRESSED_RGBA_S3TC_DXT5_EXT -> Just Vk.FORMAT_BC3_UNORM_BLOCK -- line through 3D space plus 4-bit alpha, 4x4 blocks, unsigned normalized - - GL_COMPRESSED_SRGB_S3TC_DXT1_EXT -> Just Vk.FORMAT_BC1_RGB_SRGB_BLOCK -- line through 3D space, 4x4 blocks, sRGB + GL_COMPRESSED_RGBA_S3TC_DXT3_EXT -> Just Vk.FORMAT_BC2_UNORM_BLOCK -- line through 3D space plus line through 1D space, 4x4 blocks, unsigned normalized + GL_COMPRESSED_RGBA_S3TC_DXT5_EXT -> Just Vk.FORMAT_BC3_UNORM_BLOCK -- line through 3D space plus 4-bit alpha, 4x4 blocks, unsigned normalized + GL_COMPRESSED_SRGB_S3TC_DXT1_EXT -> Just Vk.FORMAT_BC1_RGB_SRGB_BLOCK -- line through 3D space, 4x4 blocks, sRGB GL_COMPRESSED_SRGB_ALPHA_S3TC_DXT1_EXT -> Just Vk.FORMAT_BC1_RGBA_SRGB_BLOCK -- line through 3D space plus 1-bit alpha, 4x4 blocks, sRGB - GL_COMPRESSED_SRGB_ALPHA_S3TC_DXT3_EXT -> Just Vk.FORMAT_BC2_SRGB_BLOCK -- line through 3D space plus line through 1D space, 4x4 blocks, sRGB - GL_COMPRESSED_SRGB_ALPHA_S3TC_DXT5_EXT -> Just Vk.FORMAT_BC3_SRGB_BLOCK -- line through 3D space plus 4-bit alpha, 4x4 blocks, sRGB - - GL_COMPRESSED_LUMINANCE_LATC1_EXT -> Just Vk.FORMAT_BC4_UNORM_BLOCK -- line through 1D space, 4x4 blocks, unsigned normalized - GL_COMPRESSED_LUMINANCE_ALPHA_LATC2_EXT -> Just Vk.FORMAT_BC5_UNORM_BLOCK -- two lines through 1D space, 4x4 blocks, unsigned normalized - GL_COMPRESSED_SIGNED_LUMINANCE_LATC1_EXT -> Just Vk.FORMAT_BC4_SNORM_BLOCK -- line through 1D space, 4x4 blocks, signed normalized + GL_COMPRESSED_SRGB_ALPHA_S3TC_DXT3_EXT -> Just Vk.FORMAT_BC2_SRGB_BLOCK -- line through 3D space plus line through 1D space, 4x4 blocks, sRGB + GL_COMPRESSED_SRGB_ALPHA_S3TC_DXT5_EXT -> Just Vk.FORMAT_BC3_SRGB_BLOCK -- line through 3D space plus 4-bit alpha, 4x4 blocks, sRGB + GL_COMPRESSED_LUMINANCE_LATC1_EXT -> Just Vk.FORMAT_BC4_UNORM_BLOCK -- line through 1D space, 4x4 blocks, unsigned normalized + GL_COMPRESSED_LUMINANCE_ALPHA_LATC2_EXT -> Just Vk.FORMAT_BC5_UNORM_BLOCK -- two lines through 1D space, 4x4 blocks, unsigned normalized + GL_COMPRESSED_SIGNED_LUMINANCE_LATC1_EXT -> Just Vk.FORMAT_BC4_SNORM_BLOCK -- line through 1D space, 4x4 blocks, signed normalized GL_COMPRESSED_SIGNED_LUMINANCE_ALPHA_LATC2_EXT -> Just Vk.FORMAT_BC5_SNORM_BLOCK -- two lines through 1D space, 4x4 blocks, signed normalized - - GL_COMPRESSED_RED_RGTC1 -> Just Vk.FORMAT_BC4_UNORM_BLOCK -- line through 1D space, 4x4 blocks, unsigned normalized - GL_COMPRESSED_RG_RGTC2 -> Just Vk.FORMAT_BC5_UNORM_BLOCK -- two lines through 1D space, 4x4 blocks, unsigned normalized + GL_COMPRESSED_RED_RGTC1 -> Just Vk.FORMAT_BC4_UNORM_BLOCK -- line through 1D space, 4x4 blocks, unsigned normalized + GL_COMPRESSED_RG_RGTC2 -> Just Vk.FORMAT_BC5_UNORM_BLOCK -- two lines through 1D space, 4x4 blocks, unsigned normalized GL_COMPRESSED_SIGNED_RED_RGTC1 -> Just Vk.FORMAT_BC4_SNORM_BLOCK -- line through 1D space, 4x4 blocks, signed normalized - GL_COMPRESSED_SIGNED_RG_RGTC2 -> Just Vk.FORMAT_BC5_SNORM_BLOCK -- two lines through 1D space, 4x4 blocks, signed normalized - + GL_COMPRESSED_SIGNED_RG_RGTC2 -> Just Vk.FORMAT_BC5_SNORM_BLOCK -- two lines through 1D space, 4x4 blocks, signed normalized GL_COMPRESSED_RGB_BPTC_UNSIGNED_FLOAT -> Just Vk.FORMAT_BC6H_UFLOAT_BLOCK -- 3-component, 4x4 blocks, unsigned floating-point - GL_COMPRESSED_RGB_BPTC_SIGNED_FLOAT -> Just Vk.FORMAT_BC6H_SFLOAT_BLOCK -- 3-component, 4x4 blocks, signed floating-point - GL_COMPRESSED_RGBA_BPTC_UNORM -> Just Vk.FORMAT_BC7_UNORM_BLOCK -- 4-component, 4x4 blocks, unsigned normalized - GL_COMPRESSED_SRGB_ALPHA_BPTC_UNORM -> Just Vk.FORMAT_BC7_SRGB_BLOCK -- 4-component, 4x4 blocks, sRGB + GL_COMPRESSED_RGB_BPTC_SIGNED_FLOAT -> Just Vk.FORMAT_BC6H_SFLOAT_BLOCK -- 3-component, 4x4 blocks, signed floating-point + GL_COMPRESSED_RGBA_BPTC_UNORM -> Just Vk.FORMAT_BC7_UNORM_BLOCK -- 4-component, 4x4 blocks, unsigned normalized + GL_COMPRESSED_SRGB_ALPHA_BPTC_UNORM -> Just Vk.FORMAT_BC7_SRGB_BLOCK -- 4-component, 4x4 blocks, sRGB -- -- ETC -- GL_ETC1_RGB8_OES -> Just Vk.FORMAT_ETC2_R8G8B8_UNORM_BLOCK -- 3-component ETC1, 4x4 blocks, unsigned normalized - - GL_COMPRESSED_RGB8_ETC2 -> Just Vk.FORMAT_ETC2_R8G8B8_UNORM_BLOCK -- 3-component ETC2, 4x4 blocks, unsigned normalized + GL_COMPRESSED_RGB8_ETC2 -> Just Vk.FORMAT_ETC2_R8G8B8_UNORM_BLOCK -- 3-component ETC2, 4x4 blocks, unsigned normalized GL_COMPRESSED_RGB8_PUNCHTHROUGH_ALPHA1_ETC2 -> Just Vk.FORMAT_ETC2_R8G8B8A1_UNORM_BLOCK -- 4-component ETC2 with 1-bit alpha, 4x4 blocks, unsigned normalized - GL_COMPRESSED_RGBA8_ETC2_EAC -> Just Vk.FORMAT_ETC2_R8G8B8A8_UNORM_BLOCK -- 4-component ETC2, 4x4 blocks, unsigned normalized - - GL_COMPRESSED_SRGB8_ETC2 -> Just Vk.FORMAT_ETC2_R8G8B8_SRGB_BLOCK -- 3-component ETC2, 4x4 blocks, sRGB + GL_COMPRESSED_RGBA8_ETC2_EAC -> Just Vk.FORMAT_ETC2_R8G8B8A8_UNORM_BLOCK -- 4-component ETC2, 4x4 blocks, unsigned normalized + GL_COMPRESSED_SRGB8_ETC2 -> Just Vk.FORMAT_ETC2_R8G8B8_SRGB_BLOCK -- 3-component ETC2, 4x4 blocks, sRGB GL_COMPRESSED_SRGB8_PUNCHTHROUGH_ALPHA1_ETC2 -> Just Vk.FORMAT_ETC2_R8G8B8A1_SRGB_BLOCK -- 4-component ETC2 with 1-bit alpha, 4x4 blocks, sRGB - GL_COMPRESSED_SRGB8_ALPHA8_ETC2_EAC -> Just Vk.FORMAT_ETC2_R8G8B8A8_SRGB_BLOCK -- 4-component ETC2, 4x4 blocks, sRGB - - GL_COMPRESSED_R11_EAC -> Just Vk.FORMAT_EAC_R11_UNORM_BLOCK -- 1-component ETC, 4x4 blocks, unsigned normalized - GL_COMPRESSED_RG11_EAC -> Just Vk.FORMAT_EAC_R11G11_UNORM_BLOCK -- 2-component ETC, 4x4 blocks, unsigned normalized - GL_COMPRESSED_SIGNED_R11_EAC -> Just Vk.FORMAT_EAC_R11_SNORM_BLOCK -- 1-component ETC, 4x4 blocks, signed normalized + GL_COMPRESSED_SRGB8_ALPHA8_ETC2_EAC -> Just Vk.FORMAT_ETC2_R8G8B8A8_SRGB_BLOCK -- 4-component ETC2, 4x4 blocks, sRGB + GL_COMPRESSED_R11_EAC -> Just Vk.FORMAT_EAC_R11_UNORM_BLOCK -- 1-component ETC, 4x4 blocks, unsigned normalized + GL_COMPRESSED_RG11_EAC -> Just Vk.FORMAT_EAC_R11G11_UNORM_BLOCK -- 2-component ETC, 4x4 blocks, unsigned normalized + GL_COMPRESSED_SIGNED_R11_EAC -> Just Vk.FORMAT_EAC_R11_SNORM_BLOCK -- 1-component ETC, 4x4 blocks, signed normalized GL_COMPRESSED_SIGNED_RG11_EAC -> Just Vk.FORMAT_EAC_R11G11_SNORM_BLOCK -- 2-component ETC, 4x4 blocks, signed normalized -- -- PVRTC -- - GL_COMPRESSED_RGB_PVRTC_2BPPV1_IMG -> Just Vk.FORMAT_PVRTC1_2BPP_UNORM_BLOCK_IMG -- 3-component PVRTC, 16x8 blocks, unsigned normalized - GL_COMPRESSED_RGB_PVRTC_4BPPV1_IMG -> Just Vk.FORMAT_PVRTC1_4BPP_UNORM_BLOCK_IMG -- 3-component PVRTC, 8x8 blocks, unsigned normalized + GL_COMPRESSED_RGB_PVRTC_2BPPV1_IMG -> Just Vk.FORMAT_PVRTC1_2BPP_UNORM_BLOCK_IMG -- 3-component PVRTC, 16x8 blocks, unsigned normalized + GL_COMPRESSED_RGB_PVRTC_4BPPV1_IMG -> Just Vk.FORMAT_PVRTC1_4BPP_UNORM_BLOCK_IMG -- 3-component PVRTC, 8x8 blocks, unsigned normalized GL_COMPRESSED_RGBA_PVRTC_2BPPV1_IMG -> Just Vk.FORMAT_PVRTC1_2BPP_UNORM_BLOCK_IMG -- 4-component PVRTC, 16x8 blocks, unsigned normalized GL_COMPRESSED_RGBA_PVRTC_4BPPV1_IMG -> Just Vk.FORMAT_PVRTC1_4BPP_UNORM_BLOCK_IMG -- 4-component PVRTC, 8x8 blocks, unsigned normalized GL_COMPRESSED_RGBA_PVRTC_2BPPV2_IMG -> Just Vk.FORMAT_PVRTC2_2BPP_UNORM_BLOCK_IMG -- 4-component PVRTC, 8x4 blocks, unsigned normalized GL_COMPRESSED_RGBA_PVRTC_4BPPV2_IMG -> Just Vk.FORMAT_PVRTC2_4BPP_UNORM_BLOCK_IMG -- 4-component PVRTC, 4x4 blocks, unsigned normalized - - GL_COMPRESSED_SRGB_PVRTC_2BPPV1_EXT -> Just Vk.FORMAT_PVRTC1_2BPP_SRGB_BLOCK_IMG -- 3-component PVRTC, 16x8 blocks, sRGB - GL_COMPRESSED_SRGB_PVRTC_4BPPV1_EXT -> Just Vk.FORMAT_PVRTC1_4BPP_SRGB_BLOCK_IMG -- 3-component PVRTC, 8x8 blocks, sRGB + GL_COMPRESSED_SRGB_PVRTC_2BPPV1_EXT -> Just Vk.FORMAT_PVRTC1_2BPP_SRGB_BLOCK_IMG -- 3-component PVRTC, 16x8 blocks, sRGB + GL_COMPRESSED_SRGB_PVRTC_4BPPV1_EXT -> Just Vk.FORMAT_PVRTC1_4BPP_SRGB_BLOCK_IMG -- 3-component PVRTC, 8x8 blocks, sRGB GL_COMPRESSED_SRGB_ALPHA_PVRTC_2BPPV1_EXT -> Just Vk.FORMAT_PVRTC1_2BPP_SRGB_BLOCK_IMG -- 4-component PVRTC, 16x8 blocks, sRGB GL_COMPRESSED_SRGB_ALPHA_PVRTC_4BPPV1_EXT -> Just Vk.FORMAT_PVRTC1_4BPP_SRGB_BLOCK_IMG -- 4-component PVRTC, 8x8 blocks, sRGB GL_COMPRESSED_SRGB_ALPHA_PVRTC_2BPPV2_IMG -> Just Vk.FORMAT_PVRTC2_2BPP_SRGB_BLOCK_IMG -- 4-component PVRTC, 8x4 blocks, sRGB @@ -188,36 +171,34 @@ -- -- ASTC -- - GL_COMPRESSED_RGBA_ASTC_4x4_KHR -> Just Vk.FORMAT_ASTC_4x4_UNORM_BLOCK -- 4-component ASTC, 4x4 blocks, unsigned normalized - GL_COMPRESSED_RGBA_ASTC_5x4_KHR -> Just Vk.FORMAT_ASTC_5x4_UNORM_BLOCK -- 4-component ASTC, 5x4 blocks, unsigned normalized - GL_COMPRESSED_RGBA_ASTC_5x5_KHR -> Just Vk.FORMAT_ASTC_5x5_UNORM_BLOCK -- 4-component ASTC, 5x5 blocks, unsigned normalized - GL_COMPRESSED_RGBA_ASTC_6x5_KHR -> Just Vk.FORMAT_ASTC_6x5_UNORM_BLOCK -- 4-component ASTC, 6x5 blocks, unsigned normalized - GL_COMPRESSED_RGBA_ASTC_6x6_KHR -> Just Vk.FORMAT_ASTC_6x6_UNORM_BLOCK -- 4-component ASTC, 6x6 blocks, unsigned normalized - GL_COMPRESSED_RGBA_ASTC_8x5_KHR -> Just Vk.FORMAT_ASTC_8x5_UNORM_BLOCK -- 4-component ASTC, 8x5 blocks, unsigned normalized - GL_COMPRESSED_RGBA_ASTC_8x6_KHR -> Just Vk.FORMAT_ASTC_8x6_UNORM_BLOCK -- 4-component ASTC, 8x6 blocks, unsigned normalized - GL_COMPRESSED_RGBA_ASTC_8x8_KHR -> Just Vk.FORMAT_ASTC_8x8_UNORM_BLOCK -- 4-component ASTC, 8x8 blocks, unsigned normalized - GL_COMPRESSED_RGBA_ASTC_10x5_KHR -> Just Vk.FORMAT_ASTC_10x5_UNORM_BLOCK -- 4-component ASTC, 10x5 blocks, unsigned normalized - GL_COMPRESSED_RGBA_ASTC_10x6_KHR -> Just Vk.FORMAT_ASTC_10x6_UNORM_BLOCK -- 4-component ASTC, 10x6 blocks, unsigned normalized - GL_COMPRESSED_RGBA_ASTC_10x8_KHR -> Just Vk.FORMAT_ASTC_10x8_UNORM_BLOCK -- 4-component ASTC, 10x8 blocks, unsigned normalized + GL_COMPRESSED_RGBA_ASTC_4x4_KHR -> Just Vk.FORMAT_ASTC_4x4_UNORM_BLOCK -- 4-component ASTC, 4x4 blocks, unsigned normalized + GL_COMPRESSED_RGBA_ASTC_5x4_KHR -> Just Vk.FORMAT_ASTC_5x4_UNORM_BLOCK -- 4-component ASTC, 5x4 blocks, unsigned normalized + GL_COMPRESSED_RGBA_ASTC_5x5_KHR -> Just Vk.FORMAT_ASTC_5x5_UNORM_BLOCK -- 4-component ASTC, 5x5 blocks, unsigned normalized + GL_COMPRESSED_RGBA_ASTC_6x5_KHR -> Just Vk.FORMAT_ASTC_6x5_UNORM_BLOCK -- 4-component ASTC, 6x5 blocks, unsigned normalized + GL_COMPRESSED_RGBA_ASTC_6x6_KHR -> Just Vk.FORMAT_ASTC_6x6_UNORM_BLOCK -- 4-component ASTC, 6x6 blocks, unsigned normalized + GL_COMPRESSED_RGBA_ASTC_8x5_KHR -> Just Vk.FORMAT_ASTC_8x5_UNORM_BLOCK -- 4-component ASTC, 8x5 blocks, unsigned normalized + GL_COMPRESSED_RGBA_ASTC_8x6_KHR -> Just Vk.FORMAT_ASTC_8x6_UNORM_BLOCK -- 4-component ASTC, 8x6 blocks, unsigned normalized + GL_COMPRESSED_RGBA_ASTC_8x8_KHR -> Just Vk.FORMAT_ASTC_8x8_UNORM_BLOCK -- 4-component ASTC, 8x8 blocks, unsigned normalized + GL_COMPRESSED_RGBA_ASTC_10x5_KHR -> Just Vk.FORMAT_ASTC_10x5_UNORM_BLOCK -- 4-component ASTC, 10x5 blocks, unsigned normalized + GL_COMPRESSED_RGBA_ASTC_10x6_KHR -> Just Vk.FORMAT_ASTC_10x6_UNORM_BLOCK -- 4-component ASTC, 10x6 blocks, unsigned normalized + GL_COMPRESSED_RGBA_ASTC_10x8_KHR -> Just Vk.FORMAT_ASTC_10x8_UNORM_BLOCK -- 4-component ASTC, 10x8 blocks, unsigned normalized GL_COMPRESSED_RGBA_ASTC_10x10_KHR -> Just Vk.FORMAT_ASTC_10x10_UNORM_BLOCK -- 4-component ASTC, 10x10 blocks, unsigned normalized GL_COMPRESSED_RGBA_ASTC_12x10_KHR -> Just Vk.FORMAT_ASTC_12x10_UNORM_BLOCK -- 4-component ASTC, 12x10 blocks, unsigned normalized GL_COMPRESSED_RGBA_ASTC_12x12_KHR -> Just Vk.FORMAT_ASTC_12x12_UNORM_BLOCK -- 4-component ASTC, 12x12 blocks, unsigned normalized - - GL_COMPRESSED_SRGB8_ALPHA8_ASTC_4x4_KHR -> Just Vk.FORMAT_ASTC_4x4_SRGB_BLOCK -- 4-component ASTC, 4x4 blocks, sRGB - GL_COMPRESSED_SRGB8_ALPHA8_ASTC_5x4_KHR -> Just Vk.FORMAT_ASTC_5x4_SRGB_BLOCK -- 4-component ASTC, 5x4 blocks, sRGB - GL_COMPRESSED_SRGB8_ALPHA8_ASTC_5x5_KHR -> Just Vk.FORMAT_ASTC_5x5_SRGB_BLOCK -- 4-component ASTC, 5x5 blocks, sRGB - GL_COMPRESSED_SRGB8_ALPHA8_ASTC_6x5_KHR -> Just Vk.FORMAT_ASTC_6x5_SRGB_BLOCK -- 4-component ASTC, 6x5 blocks, sRGB - GL_COMPRESSED_SRGB8_ALPHA8_ASTC_6x6_KHR -> Just Vk.FORMAT_ASTC_6x6_SRGB_BLOCK -- 4-component ASTC, 6x6 blocks, sRGB - GL_COMPRESSED_SRGB8_ALPHA8_ASTC_8x5_KHR -> Just Vk.FORMAT_ASTC_8x5_SRGB_BLOCK -- 4-component ASTC, 8x5 blocks, sRGB - GL_COMPRESSED_SRGB8_ALPHA8_ASTC_8x6_KHR -> Just Vk.FORMAT_ASTC_8x6_SRGB_BLOCK -- 4-component ASTC, 8x6 blocks, sRGB - GL_COMPRESSED_SRGB8_ALPHA8_ASTC_8x8_KHR -> Just Vk.FORMAT_ASTC_8x8_SRGB_BLOCK -- 4-component ASTC, 8x8 blocks, sRGB - GL_COMPRESSED_SRGB8_ALPHA8_ASTC_10x5_KHR -> Just Vk.FORMAT_ASTC_10x5_SRGB_BLOCK -- 4-component ASTC, 10x5 blocks, sRGB - GL_COMPRESSED_SRGB8_ALPHA8_ASTC_10x6_KHR -> Just Vk.FORMAT_ASTC_10x6_SRGB_BLOCK -- 4-component ASTC, 10x6 blocks, sRGB - GL_COMPRESSED_SRGB8_ALPHA8_ASTC_10x8_KHR -> Just Vk.FORMAT_ASTC_10x8_SRGB_BLOCK -- 4-component ASTC, 10x8 blocks, sRGB + GL_COMPRESSED_SRGB8_ALPHA8_ASTC_4x4_KHR -> Just Vk.FORMAT_ASTC_4x4_SRGB_BLOCK -- 4-component ASTC, 4x4 blocks, sRGB + GL_COMPRESSED_SRGB8_ALPHA8_ASTC_5x4_KHR -> Just Vk.FORMAT_ASTC_5x4_SRGB_BLOCK -- 4-component ASTC, 5x4 blocks, sRGB + GL_COMPRESSED_SRGB8_ALPHA8_ASTC_5x5_KHR -> Just Vk.FORMAT_ASTC_5x5_SRGB_BLOCK -- 4-component ASTC, 5x5 blocks, sRGB + GL_COMPRESSED_SRGB8_ALPHA8_ASTC_6x5_KHR -> Just Vk.FORMAT_ASTC_6x5_SRGB_BLOCK -- 4-component ASTC, 6x5 blocks, sRGB + GL_COMPRESSED_SRGB8_ALPHA8_ASTC_6x6_KHR -> Just Vk.FORMAT_ASTC_6x6_SRGB_BLOCK -- 4-component ASTC, 6x6 blocks, sRGB + GL_COMPRESSED_SRGB8_ALPHA8_ASTC_8x5_KHR -> Just Vk.FORMAT_ASTC_8x5_SRGB_BLOCK -- 4-component ASTC, 8x5 blocks, sRGB + GL_COMPRESSED_SRGB8_ALPHA8_ASTC_8x6_KHR -> Just Vk.FORMAT_ASTC_8x6_SRGB_BLOCK -- 4-component ASTC, 8x6 blocks, sRGB + GL_COMPRESSED_SRGB8_ALPHA8_ASTC_8x8_KHR -> Just Vk.FORMAT_ASTC_8x8_SRGB_BLOCK -- 4-component ASTC, 8x8 blocks, sRGB + GL_COMPRESSED_SRGB8_ALPHA8_ASTC_10x5_KHR -> Just Vk.FORMAT_ASTC_10x5_SRGB_BLOCK -- 4-component ASTC, 10x5 blocks, sRGB + GL_COMPRESSED_SRGB8_ALPHA8_ASTC_10x6_KHR -> Just Vk.FORMAT_ASTC_10x6_SRGB_BLOCK -- 4-component ASTC, 10x6 blocks, sRGB + GL_COMPRESSED_SRGB8_ALPHA8_ASTC_10x8_KHR -> Just Vk.FORMAT_ASTC_10x8_SRGB_BLOCK -- 4-component ASTC, 10x8 blocks, sRGB GL_COMPRESSED_SRGB8_ALPHA8_ASTC_10x10_KHR -> Just Vk.FORMAT_ASTC_10x10_SRGB_BLOCK -- 4-component ASTC, 10x10 blocks, sRGB GL_COMPRESSED_SRGB8_ALPHA8_ASTC_12x10_KHR -> Just Vk.FORMAT_ASTC_12x10_SRGB_BLOCK -- 4-component ASTC, 12x10 blocks, sRGB GL_COMPRESSED_SRGB8_ALPHA8_ASTC_12x12_KHR -> Just Vk.FORMAT_ASTC_12x12_SRGB_BLOCK -- 4-component ASTC, 12x12 blocks, sRGB - GL_COMPRESSED_RGBA_ASTC_3x3x3_OES -> Nothing -- 4-component ASTC, 3x3x3 blocks, unsigned normalized GL_COMPRESSED_RGBA_ASTC_4x3x3_OES -> Nothing -- 4-component ASTC, 4x3x3 blocks, unsigned normalized GL_COMPRESSED_RGBA_ASTC_4x4x3_OES -> Nothing -- 4-component ASTC, 4x4x3 blocks, unsigned normalized @@ -228,7 +209,6 @@ GL_COMPRESSED_RGBA_ASTC_6x5x5_OES -> Nothing -- 4-component ASTC, 6x5x5 blocks, unsigned normalized GL_COMPRESSED_RGBA_ASTC_6x6x5_OES -> Nothing -- 4-component ASTC, 6x6x5 blocks, unsigned normalized GL_COMPRESSED_RGBA_ASTC_6x6x6_OES -> Nothing -- 4-component ASTC, 6x6x6 blocks, unsigned normalized - GL_COMPRESSED_SRGB8_ALPHA8_ASTC_3x3x3_OES -> Nothing -- 4-component ASTC, 3x3x3 blocks, sRGB GL_COMPRESSED_SRGB8_ALPHA8_ASTC_4x3x3_OES -> Nothing -- 4-component ASTC, 4x3x3 blocks, sRGB GL_COMPRESSED_SRGB8_ALPHA8_ASTC_4x4x3_OES -> Nothing -- 4-component ASTC, 4x4x3 blocks, sRGB @@ -243,38 +223,37 @@ -- -- ATC -- - GL_ATC_RGB_AMD -> Nothing -- 3-component, 4x4 blocks, unsigned normalized - GL_ATC_RGBA_EXPLICIT_ALPHA_AMD -> Nothing -- 4-component, 4x4 blocks, unsigned normalized + GL_ATC_RGB_AMD -> Nothing -- 3-component, 4x4 blocks, unsigned normalized + GL_ATC_RGBA_EXPLICIT_ALPHA_AMD -> Nothing -- 4-component, 4x4 blocks, unsigned normalized GL_ATC_RGBA_INTERPOLATED_ALPHA_AMD -> Nothing -- 4-component, 4x4 blocks, unsigned normalized -- -- Palletized -- - GL_PALETTE4_RGB8_OES -> Nothing -- 3-component 8:8:8, 4-bit palette, unsigned normalized - GL_PALETTE4_RGBA8_OES -> Nothing -- 4-component 8:8:8:8, 4-bit palette, unsigned normalized + GL_PALETTE4_RGB8_OES -> Nothing -- 3-component 8:8:8, 4-bit palette, unsigned normalized + GL_PALETTE4_RGBA8_OES -> Nothing -- 4-component 8:8:8:8, 4-bit palette, unsigned normalized GL_PALETTE4_R5_G6_B5_OES -> Nothing -- 3-component 5:6:5, 4-bit palette, unsigned normalized - GL_PALETTE4_RGBA4_OES -> Nothing -- 4-component 4:4:4:4, 4-bit palette, unsigned normalized - GL_PALETTE4_RGB5_A1_OES -> Nothing -- 4-component 5:5:5:1, 4-bit palette, unsigned normalized - GL_PALETTE8_RGB8_OES -> Nothing -- 3-component 8:8:8, 8-bit palette, unsigned normalized - GL_PALETTE8_RGBA8_OES -> Nothing -- 4-component 8:8:8:8, 8-bit palette, unsigned normalized + GL_PALETTE4_RGBA4_OES -> Nothing -- 4-component 4:4:4:4, 4-bit palette, unsigned normalized + GL_PALETTE4_RGB5_A1_OES -> Nothing -- 4-component 5:5:5:1, 4-bit palette, unsigned normalized + GL_PALETTE8_RGB8_OES -> Nothing -- 3-component 8:8:8, 8-bit palette, unsigned normalized + GL_PALETTE8_RGBA8_OES -> Nothing -- 4-component 8:8:8:8, 8-bit palette, unsigned normalized GL_PALETTE8_R5_G6_B5_OES -> Nothing -- 3-component 5:6:5, 8-bit palette, unsigned normalized - GL_PALETTE8_RGBA4_OES -> Nothing -- 4-component 4:4:4:4, 8-bit palette, unsigned normalized - GL_PALETTE8_RGB5_A1_OES -> Nothing -- 4-component 5:5:5:1, 8-bit palette, unsigned normalized + GL_PALETTE8_RGBA4_OES -> Nothing -- 4-component 4:4:4:4, 8-bit palette, unsigned normalized + GL_PALETTE8_RGB5_A1_OES -> Nothing -- 4-component 5:5:5:1, 8-bit palette, unsigned normalized -- -- Depth/stencil -- - GL_DEPTH_COMPONENT16 -> Just Vk.FORMAT_D16_UNORM - GL_DEPTH_COMPONENT24 -> Just Vk.FORMAT_X8_D24_UNORM_PACK32 - GL_DEPTH_COMPONENT32 -> Nothing - GL_DEPTH_COMPONENT32F -> Just Vk.FORMAT_D32_SFLOAT + GL_DEPTH_COMPONENT16 -> Just Vk.FORMAT_D16_UNORM + GL_DEPTH_COMPONENT24 -> Just Vk.FORMAT_X8_D24_UNORM_PACK32 + GL_DEPTH_COMPONENT32 -> Nothing + GL_DEPTH_COMPONENT32F -> Just Vk.FORMAT_D32_SFLOAT GL_DEPTH_COMPONENT32F_NV -> Just Vk.FORMAT_D32_SFLOAT - GL_STENCIL_INDEX1 -> Nothing - GL_STENCIL_INDEX4 -> Nothing - GL_STENCIL_INDEX8 -> Just Vk.FORMAT_S8_UINT - GL_STENCIL_INDEX16 -> Nothing - GL_DEPTH24_STENCIL8 -> Just Vk.FORMAT_D24_UNORM_S8_UINT - GL_DEPTH32F_STENCIL8 -> Just Vk.FORMAT_D32_SFLOAT_S8_UINT - GL_DEPTH32F_STENCIL8_NV -> Just Vk.FORMAT_D32_SFLOAT_S8_UINT - + GL_STENCIL_INDEX1 -> Nothing + GL_STENCIL_INDEX4 -> Nothing + GL_STENCIL_INDEX8 -> Just Vk.FORMAT_S8_UINT + GL_STENCIL_INDEX16 -> Nothing + GL_DEPTH24_STENCIL8 -> Just Vk.FORMAT_D24_UNORM_S8_UINT + GL_DEPTH32F_STENCIL8 -> Just Vk.FORMAT_D32_SFLOAT_S8_UINT + GL_DEPTH32F_STENCIL8_NV -> Just Vk.FORMAT_D32_SFLOAT_S8_UINT _ -> Nothing diff --git a/src/Vulkan/Utils/Init/Headless.hs b/src/Vulkan/Utils/Init/Headless.hs new file mode 100644 --- /dev/null +++ b/src/Vulkan/Utils/Init/Headless.hs @@ -0,0 +1,22 @@ +{-| Init helpers for headless applications — no window, no surface, no +window-system instance extensions. +-} +module Vulkan.Utils.Init.Headless + ( allocateInstance + ) where + +import Control.Monad.Trans.Resource (MonadResource) +import Vulkan.Core10 (ApplicationInfo, Instance) +import Vulkan.Requirement (InstanceRequirement) +import Vulkan.Utils.Initialization (allocateVulkanInstance) + +{- | Build a Vulkan 'Instance' for a headless application. Equivalent to +@'allocateVulkanInstance' 'mempty'@. +-} +allocateInstance + :: (MonadResource m) + => Maybe ApplicationInfo + -> [InstanceRequirement] + -> [InstanceRequirement] + -> m Instance +allocateInstance = allocateVulkanInstance mempty diff --git a/src/Vulkan/Utils/Initialization.hs b/src/Vulkan/Utils/Initialization.hs --- a/src/Vulkan/Utils/Initialization.hs +++ b/src/Vulkan/Utils/Initialization.hs @@ -1,46 +1,72 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedLists #-} module Vulkan.Utils.Initialization ( -- * Instance creation - createInstanceFromRequirements - , createDebugInstanceFromRequirements + allocateInstanceFromRequirements + , allocateDebugInstanceFromRequirements + , allocateVulkanInstance + + -- * macOS portability + , portabilityRequirements + , portabilityFlags + , devicePortabilityRequirements + -- * Device creation - , createDeviceFromRequirements - , -- * Physical device selection - pickPhysicalDevice + , allocateDeviceFromRequirements + + -- * Physical device selection + , pickPhysicalDevice , physicalDeviceName + + -- * Deprecated aliases + , createInstanceFromRequirements + , createDebugInstanceFromRequirements + , createDeviceFromRequirements ) where -import Control.Monad.IO.Class -import Control.Monad.Trans.Resource -import Data.Bits -import Data.Foldable -import Data.Maybe -import Data.Ord -import Data.Text ( Text ) -import Data.Text.Encoding ( decodeUtf8 ) -import Vulkan.CStruct.Extends -import Vulkan.Core10 -import qualified Vulkan.Core10 as Instance ( InstanceCreateInfo(..) ) -import Vulkan.Extensions.VK_EXT_debug_utils -import Vulkan.Extensions.VK_EXT_validation_features -import Vulkan.Requirement -import Vulkan.Utils.Debug -import Vulkan.Utils.Internal -import Vulkan.Utils.Requirements -import Vulkan.Zero +import Control.Monad.IO.Class +import Control.Monad.Trans.Resource +import Data.Bits +import Data.ByteString (ByteString) +import Data.Foldable +import Data.Maybe +import Data.Ord +import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8) +import Data.Vector (Vector) +import Vulkan.CStruct.Extends +import Vulkan.Core10 +import qualified Vulkan.Core10 as Instance (InstanceCreateInfo (..)) +import Vulkan.Extensions.VK_EXT_debug_utils +import Vulkan.Extensions.VK_EXT_validation_features +import Vulkan.Requirement +import Vulkan.Utils.Debug +import Vulkan.Utils.Internal +import Vulkan.Utils.Requirements +import Vulkan.Zero +#if defined(darwin_HOST_OS) +import Vulkan.Core10.Enums.InstanceCreateFlagBits + ( pattern INSTANCE_CREATE_ENUMERATE_PORTABILITY_BIT_KHR ) +import Vulkan.Extensions.VK_KHR_portability_enumeration + ( pattern KHR_PORTABILITY_ENUMERATION_EXTENSION_NAME ) +import Vulkan.Extensions.VK_KHR_portability_subset + ( pattern KHR_PORTABILITY_SUBSET_EXTENSION_NAME ) +#endif + ---------------------------------------------------------------- -- Instance ---------------------------------------------------------------- --- | Like 'createInstanceFromRequirements' except it will create a debug utils --- messenger (from the @VK_EXT_debug_utils@ extension). --- --- If the @VK_EXT_validation_features@ extension (from the --- @VK_LAYER_KHRONOS_validation@ layer) is available is it will be enabled and --- best practices messages enabled. -createDebugInstanceFromRequirements +{- | Like 'allocateInstanceFromRequirements' except it will create a debug utils +messenger (from the @VK_EXT_debug_utils@ extension). + +If the @VK_EXT_validation_features@ extension (from the +@VK_LAYER_KHRONOS_validation@ layer) is available is it will be enabled and +best practices messages enabled. +-} +allocateDebugInstanceFromRequirements :: forall m es . (MonadResource m, Extendss InstanceCreateInfo es, PokeChain es) => [InstanceRequirement] @@ -49,55 +75,63 @@ -- ^ Optional -> InstanceCreateInfo es -> m Instance -createDebugInstanceFromRequirements required optional baseCreateInfo = do - let debugMessengerCreateInfo = zero - { messageSeverity = DEBUG_UTILS_MESSAGE_SEVERITY_WARNING_BIT_EXT - .|. DEBUG_UTILS_MESSAGE_SEVERITY_ERROR_BIT_EXT - , messageType = DEBUG_UTILS_MESSAGE_TYPE_GENERAL_BIT_EXT - .|. DEBUG_UTILS_MESSAGE_TYPE_VALIDATION_BIT_EXT - .|. DEBUG_UTILS_MESSAGE_TYPE_PERFORMANCE_BIT_EXT +allocateDebugInstanceFromRequirements required optional baseCreateInfo = do + let + debugMessengerCreateInfo = + zero + { messageSeverity = + DEBUG_UTILS_MESSAGE_SEVERITY_WARNING_BIT_EXT + .|. DEBUG_UTILS_MESSAGE_SEVERITY_ERROR_BIT_EXT + , messageType = + DEBUG_UTILS_MESSAGE_TYPE_GENERAL_BIT_EXT + .|. DEBUG_UTILS_MESSAGE_TYPE_VALIDATION_BIT_EXT + .|. DEBUG_UTILS_MESSAGE_TYPE_PERFORMANCE_BIT_EXT , pfnUserCallback = debugCallbackPtr } - validationFeatures = - ValidationFeaturesEXT [VALIDATION_FEATURE_ENABLE_BEST_PRACTICES_EXT] [] - instanceCreateInfo - :: InstanceCreateInfo - (DebugUtilsMessengerCreateInfoEXT : ValidationFeaturesEXT : es) - instanceCreateInfo = baseCreateInfo - { Instance.next = debugMessengerCreateInfo - :& validationFeatures - :& Instance.next baseCreateInfo + validationFeatures = + ValidationFeaturesEXT [VALIDATION_FEATURE_ENABLE_BEST_PRACTICES_EXT] [] + instanceCreateInfo + :: InstanceCreateInfo + (DebugUtilsMessengerCreateInfoEXT : ValidationFeaturesEXT : es) + instanceCreateInfo = + baseCreateInfo + { Instance.next = + debugMessengerCreateInfo + :& validationFeatures + :& Instance.next baseCreateInfo } - additionalRequirements = - [ RequireInstanceExtension - { instanceExtensionLayerName = Nothing - , instanceExtensionName = EXT_DEBUG_UTILS_EXTENSION_NAME - , instanceExtensionMinVersion = minBound - } - ] - additionalOptionalRequirements = - [ RequireInstanceLayer - { instanceLayerName = "VK_LAYER_KHRONOS_validation" + additionalRequirements = + [ RequireInstanceExtension + { instanceExtensionLayerName = Nothing + , instanceExtensionName = EXT_DEBUG_UTILS_EXTENSION_NAME + , instanceExtensionMinVersion = minBound + } + ] + additionalOptionalRequirements = + [ RequireInstanceLayer + { instanceLayerName = "VK_LAYER_KHRONOS_validation" , instanceLayerMinVersion = minBound } - , RequireInstanceExtension - { instanceExtensionLayerName = Just "VK_LAYER_KHRONOS_validation" - , instanceExtensionName = EXT_VALIDATION_FEATURES_EXTENSION_NAME + , RequireInstanceExtension + { instanceExtensionLayerName = Just "VK_LAYER_KHRONOS_validation" + , instanceExtensionName = EXT_VALIDATION_FEATURES_EXTENSION_NAME , instanceExtensionMinVersion = minBound } - ] - inst <- createInstanceFromRequirements - (additionalRequirements <> toList required) - (additionalOptionalRequirements <> toList optional) - instanceCreateInfo + ] + inst <- + allocateInstanceFromRequirements + (additionalRequirements <> toList required) + (additionalOptionalRequirements <> toList optional) + instanceCreateInfo _ <- withDebugUtilsMessengerEXT inst debugMessengerCreateInfo Nothing allocate pure inst --- | Create an 'Instance from some requirements. --- --- Will throw an 'IOError in the case of unsatisfied non-optional requirements. --- Unsatisfied requirements will be listed on stderr. -createInstanceFromRequirements +{- | Create an 'Instance from some requirements. + +Will throw an 'IOError in the case of unsatisfied non-optional requirements. +Unsatisfied requirements will be listed on stderr. +-} +allocateInstanceFromRequirements :: (MonadResource m, Extendss InstanceCreateInfo es, PokeChain es) => [InstanceRequirement] -- ^ Required @@ -105,26 +139,101 @@ -- ^ Optional -> InstanceCreateInfo es -> m Instance -createInstanceFromRequirements required optional baseCreateInfo = do - (mbICI, rrs, ors) <- checkInstanceRequirements required - optional - baseCreateInfo +allocateInstanceFromRequirements required optional baseCreateInfo = do + (mbICI, rrs, ors) <- + checkInstanceRequirements + required + optional + baseCreateInfo traverse_ sayErr (requirementReport rrs ors) case mbICI of - Nothing -> liftIO $ unsatisfiedConstraints "Failed to create instance" + Nothing -> liftIO $ unsatisfiedConstraints "Failed to create instance" Just ici -> snd <$> withInstance ici Nothing allocate ---------------------------------------------------------------- +-- macOS portability + windowing-friendly instance creation +---------------------------------------------------------------- + +portabilityRequirements :: [InstanceRequirement] + +{- | Instance create flag bits that pair with 'portabilityRequirements'. +'zero' on every non-macOS platform. +-} +portabilityFlags :: InstanceCreateFlags + +{- | Device requirements needed on macOS: the Vulkan spec mandates that +@VK_KHR_portability_subset@ be enabled whenever a physical device advertises +it (as MoltenVK does). Empty on every other platform. +-} +devicePortabilityRequirements :: [DeviceRequirement] + +#if defined(darwin_HOST_OS) +portabilityRequirements = + [ RequireInstanceExtension + { instanceExtensionLayerName = Nothing + , instanceExtensionName = KHR_PORTABILITY_ENUMERATION_EXTENSION_NAME + , instanceExtensionMinVersion = minBound + } + ] +portabilityFlags = INSTANCE_CREATE_ENUMERATE_PORTABILITY_BIT_KHR +devicePortabilityRequirements = + [ RequireDeviceExtension + { deviceExtensionLayerName = Nothing + , deviceExtensionName = KHR_PORTABILITY_SUBSET_EXTENSION_NAME + , deviceExtensionMinVersion = minBound + } + ] +#else +portabilityRequirements = [] +portabilityFlags = zero +devicePortabilityRequirements = [] +#endif + +{- | Build a Vulkan 'Instance' from a backend-supplied extension list plus +caller-supplied requirements. Automatically merges 'portabilityRequirements' +into the required list and 'portabilityFlags' into the create flags so +macOS apps work without per-call plumbing. + +Pass 'mempty' for the extension list when running headless; or call +'Vulkan.Utils.Init.Headless.allocateInstance' which does so. +-} +allocateVulkanInstance + :: (MonadResource m) + => Vector ByteString + {- ^ Backend-required instance extensions (e.g. from + @Vulkan.Utils.Init.SDL2.getRequiredInstanceExtensions@). 'mempty' for + headless. + -} + -> Maybe ApplicationInfo + -> [InstanceRequirement] + -- ^ Caller's required requirements + -> [InstanceRequirement] + -- ^ Caller's optional requirements + -> m Instance +allocateVulkanInstance exts appInfo reqs optReqs = + allocateInstanceFromRequirements + (portabilityRequirements <> reqs) + optReqs + zero + { applicationInfo = appInfo + , enabledExtensionNames = exts + , flags = portabilityFlags + } + +---------------------------------------------------------------- + -- * Device creation + ---------------------------------------------------------------- --- | Create a 'Device' from some requirements. --- --- Will throw an 'IOError in the case of unsatisfied non-optional requirements. --- Unsatisfied requirements will be listed on stderr. -createDeviceFromRequirements +{- | Create a 'Device' from some requirements. + +Will throw an 'IOError in the case of unsatisfied non-optional requirements. +Unsatisfied requirements will be listed on stderr. +-} +allocateDeviceFromRequirements :: forall m - . MonadResource m + . (MonadResource m) => [DeviceRequirement] -- ^ Required -> [DeviceRequirement] @@ -132,62 +241,106 @@ -> PhysicalDevice -> DeviceCreateInfo '[] -> m Device -createDeviceFromRequirements required optional phys baseCreateInfo = do - (mbDCI, rrs, ors) <- checkDeviceRequirements required - optional - phys - baseCreateInfo +allocateDeviceFromRequirements required optional phys baseCreateInfo = do + (mbDCI, rrs, ors) <- + checkDeviceRequirements + (devicePortabilityRequirements <> required) + optional + phys + baseCreateInfo traverse_ sayErr (requirementReport rrs ors) case mbDCI of Nothing -> liftIO $ unsatisfiedConstraints "Failed to create instance" Just (SomeStruct dci) -> snd <$> withDevice phys dci Nothing allocate ---------------------------------------------------------------- + -- * Physical device selection + ---------------------------------------------------------------- --- | Get a single 'PhysicalDevice' deciding with a scoring function --- --- Pass a function which will extract any required values from a device in the --- spirit of parse-don't-validate. Also provide a function to compare these --- results for sorting multiple suitable devices. --- --- As an example, the suitability function could return a tuple of device --- memory and the compute queue family index, and the scoring function could be --- 'fst' to select devices based on their memory capacity. Consider using --- 'Vulkan.Utils.QueueAssignment.assignQueues' to find your desired queues in --- the suitability function. --- --- Pehaps also use the functionality in 'Vulkan.Utils.Requirements' and return --- the 'DeviceCreateInfo' too. --- --- If no devices are deemed suitable then a 'NoSuchThing' 'IOError' is thrown. +{- | Get a single 'PhysicalDevice' deciding with a scoring function + +Pass a function which will extract any required values from a device in the +spirit of parse-don't-validate. Also provide a function to compare these +results for sorting multiple suitable devices. + +As an example, the suitability function could return a tuple of device +memory and the compute queue family index, and the scoring function could be +'fst' to select devices based on their memory capacity. Consider using +'Vulkan.Utils.QueueAssignment.assignQueues' to find your desired queues in +the suitability function. + +Pehaps also use the functionality in 'Vulkan.Utils.Requirements' and return +the 'DeviceCreateInfo' too. + +If no devices are deemed suitable then a 'NoSuchThing' 'IOError' is thrown. +-} pickPhysicalDevice :: (MonadIO m, Ord b) => Instance -> (PhysicalDevice -> m (Maybe a)) - -- ^ A suitability funcion for a 'PhysicalDevice', 'Nothing' if it is not to - -- be chosen. + {- ^ A suitability funcion for a 'PhysicalDevice', 'Nothing' if it is not to + be chosen. + -} -> (a -> b) -- ^ Scoring function to rate this result -> m (Maybe (a, PhysicalDevice)) -- ^ The score and the device pickPhysicalDevice inst devInfo score = do (_, devs) <- enumeratePhysicalDevices inst - infos <- catMaybes - <$> sequence [ fmap (, d) <$> devInfo d | d <- toList devs ] - pure $ maximumByMay (comparing (score . fst)) infos + infos <- + catMaybes + <$> sequence + [ do + isCPU <- + (PHYSICAL_DEVICE_TYPE_CPU ==) . deviceType + <$> getPhysicalDeviceProperties d + if isCPU then pure Nothing else fmap (,d) <$> devInfo d + | d <- toList devs + ] + pure $ maximumBy_ (comparing (score . fst)) infos -- | Extract the name of a 'PhysicalDevice' with 'getPhysicalDeviceProperties' -physicalDeviceName :: MonadIO m => PhysicalDevice -> m Text +physicalDeviceName :: (MonadIO m) => PhysicalDevice -> m Text physicalDeviceName = fmap (decodeUtf8 . deviceName) . getPhysicalDeviceProperties - ---------------------------------------------------------------- -- Utils ---------------------------------------------------------------- -maximumByMay :: Foldable t => (a -> a -> Ordering) -> t a -> Maybe a -maximumByMay f xs = if null xs then Nothing else Just (maximumBy f xs) +maximumBy_ :: (Foldable t) => (a -> a -> Ordering) -> t a -> Maybe a +maximumBy_ f xs = if null xs then Nothing else Just (maximumBy f xs) +---------------------------------------------------------------- +-- Deprecated aliases +---------------------------------------------------------------- + +{-# DEPRECATED createInstanceFromRequirements "Renamed to allocateInstanceFromRequirements" #-} +createInstanceFromRequirements + :: (MonadResource m, Extendss InstanceCreateInfo es, PokeChain es) + => [InstanceRequirement] + -> [InstanceRequirement] + -> InstanceCreateInfo es + -> m Instance +createInstanceFromRequirements = allocateInstanceFromRequirements + +{-# DEPRECATED createDebugInstanceFromRequirements "Renamed to allocateDebugInstanceFromRequirements" #-} +createDebugInstanceFromRequirements + :: (MonadResource m, Extendss InstanceCreateInfo es, PokeChain es) + => [InstanceRequirement] + -> [InstanceRequirement] + -> InstanceCreateInfo es + -> m Instance +createDebugInstanceFromRequirements = allocateDebugInstanceFromRequirements + +{-# DEPRECATED createDeviceFromRequirements "Renamed to allocateDeviceFromRequirements" #-} +createDeviceFromRequirements + :: (MonadResource m) + => [DeviceRequirement] + -> [DeviceRequirement] + -> PhysicalDevice + -> DeviceCreateInfo '[] + -> m Device +createDeviceFromRequirements = allocateDeviceFromRequirements diff --git a/src/Vulkan/Utils/Internal.hs b/src/Vulkan/Utils/Internal.hs --- a/src/Vulkan/Utils/Internal.hs +++ b/src/Vulkan/Utils/Internal.hs @@ -1,14 +1,16 @@ module Vulkan.Utils.Internal where -import Control.Monad.IO.Class -import GHC.IO ( throwIO ) -import GHC.IO.Exception ( IOErrorType(..) - , IOException(..) - ) -import System.IO ( hPutStrLn - , stderr - ) +import Control.Monad.IO.Class +import GHC.IO (throwIO) +import GHC.IO.Exception + ( IOErrorType (..) + , IOException (..) + ) import Language.Haskell.TH.Quote +import System.IO + ( hPutStrLn + , stderr + ) ---------------------------------------------------------------- -- Internal utils @@ -22,15 +24,17 @@ noSuchThing message = throwIO $ IOError Nothing NoSuchThing "" message Nothing Nothing -sayErr :: MonadIO m => String -> m () +sayErr :: (MonadIO m) => String -> m () sayErr = liftIO . hPutStrLn stderr badQQ :: String -> QuasiQuoter -badQQ name = QuasiQuoter (bad "expression") - (bad "pattern") - (bad "type") - (bad "declaration") - where - bad :: String -> a - bad context = - error $ "Can't use " <> name <> " quote in a " <> context <> " context" +badQQ name = + QuasiQuoter + (bad "expression") + (bad "pattern") + (bad "type") + (bad "declaration") + where + bad :: String -> a + bad context = + error $ "Can't use " <> name <> " quote in a " <> context <> " context" diff --git a/src/Vulkan/Utils/Misc.hs b/src/Vulkan/Utils/Misc.hs --- a/src/Vulkan/Utils/Misc.hs +++ b/src/Vulkan/Utils/Misc.hs @@ -2,23 +2,26 @@ ( -- * Sorting things partitionOptReq , partitionOptReqIO + -- * Bit Utils , showBits , (.&&.) ) where -import Control.Monad.IO.Class -import Data.Bits -import Data.Foldable -import Data.List ( intercalate - , partition - ) -import Vulkan.Utils.Internal +import Control.Monad.IO.Class +import Data.Bits +import Data.Foldable +import Data.List + ( intercalate + , partition + ) +import Vulkan.Utils.Internal --- | From a list of things, take all the required things and as many optional --- things as possible. +{- | From a list of things, take all the required things and as many optional +things as possible. +-} partitionOptReq - :: Eq a + :: (Eq a) => [a] -- ^ What do we have available -> [a] @@ -26,23 +29,27 @@ -> [a] -- ^ Required desired elements -> ([a], Either [a] [a]) - -- ^ (Missing optional elements, Either (missing required elements) or (all - -- required elements and as many optional elements as possible) + {- ^ (Missing optional elements, Either (missing required elements) or (all + required elements and as many optional elements as possible) + -} partitionOptReq available optional required = - let (optHave, optMissing) = partition (`elem` available) optional - (reqHave, reqMissing) = partition (`elem` available) required - in ( optMissing - , case reqMissing of + let + (optHave, optMissing) = partition (`elem` available) optional + (reqHave, reqMissing) = partition (`elem` available) required + in + ( optMissing + , case reqMissing of [] -> Right (reqHave <> optHave) xs -> Left xs - ) + ) --- | Like 'partitionOptReq'. --- --- Will throw an 'IOError in the case of missing things. Details on missing --- things will be reported in stderr. --- --- This is useful in dealing with layers and extensions. +{- | Like 'partitionOptReq'. + +Will throw an 'IOError in the case of missing things. Details on missing +things will be reported in stderr. + +This is useful in dealing with layers and extensions. +-} partitionOptReqIO :: (Show a, Eq a, MonadIO m) => String @@ -53,50 +60,54 @@ -- ^ Optional desired elements -> [a] -- ^ Required desired elements - -> m ([a],[a]) - -- ^ All the required elements and as many optional elements as possible, - -- as well as the missing optional elements. + -> m ([a], [a]) + {- ^ All the required elements and as many optional elements as possible, + as well as the missing optional elements. + -} partitionOptReqIO type' available optional required = liftIO $ do let (optMissing, exts) = partitionOptReq available optional required - for_ optMissing - $ \o -> sayErr $ "Missing optional " <> type' <> ": " <> show o + for_ optMissing $ + \o -> sayErr $ "Missing optional " <> type' <> ": " <> show o case exts of Left reqMissing -> do - for_ reqMissing - $ \r -> sayErr $ "Missing required " <> type' <> ": " <> show r + for_ reqMissing $ + \r -> sayErr $ "Missing required " <> type' <> ": " <> show r noSuchThing $ "Don't have all required " <> type' <> "s" Right xs -> pure (xs, optMissing) ---------------------------------------------------------------- + -- * Bit utils + ---------------------------------------------------------------- --- | Show valies as a union of their individual bits --- --- >>> showBits @Int 5 --- "1 .|. 4" --- --- >>> showBits @Int 0 --- "zeroBits" --- --- >>> import Vulkan.Core10.Enums.QueueFlagBits --- >>> showBits (QUEUE_COMPUTE_BIT .|. QUEUE_GRAPHICS_BIT) --- "QUEUE_GRAPHICS_BIT .|. QUEUE_COMPUTE_BIT" -showBits :: forall a . (Show a, FiniteBits a) => a -> String -showBits a = if a == zeroBits - then "zeroBits" - else intercalate " .|. " $ fmap show (setBits a) +{- | Show valies as a union of their individual bits --- | The list of bits which are set -setBits :: FiniteBits a => a -> [a] +>>> showBits @Int 5 +"1 .|. 4" + +>>> showBits @Int 0 +"zeroBits" + +>>> import Vulkan.Core10.Enums.QueueFlagBits +>>> showBits (QUEUE_COMPUTE_BIT .|. QUEUE_GRAPHICS_BIT) +"QUEUE_GRAPHICS_BIT .|. QUEUE_COMPUTE_BIT" +-} +showBits :: forall a. (Show a, FiniteBits a) => a -> String +showBits a = + if a == zeroBits + then "zeroBits" + else intercalate " .|. " $ fmap show (setBits a) + +setBits :: (FiniteBits a) => a -> [a] setBits a = [ b | -- lol, is this really necessary - p <- [countTrailingZeros a .. finiteBitSize a - countLeadingZeros a - 1] + p <- [countTrailingZeros a .. finiteBitSize a - countLeadingZeros a - 1] , let b = bit p , a .&&. b ] -- | Check if the intersection of bits is non-zero -(.&&.) :: Bits a => a -> a -> Bool +(.&&.) :: (Bits a) => a -> a -> Bool x .&&. y = (x .&. y) /= zeroBits diff --git a/src/Vulkan/Utils/Pipeline.hs b/src/Vulkan/Utils/Pipeline.hs new file mode 100644 --- /dev/null +++ b/src/Vulkan/Utils/Pipeline.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE NoFieldSelectors #-} + +{-| A pipeline bundled with everything needed to drive it. + +'Layout' keeps, next to the created handles, the inputs they were created from: +the per-set 'Vk.DescriptorSetLayoutCreateInfo's and the push-constant ranges. +Descriptor-set allocation and push recording need exactly those — 'allocateSet' +sizes its pool from the kept set info and 'push' takes its stage flags and byte +count from the kept range — so neither is hand-counted at call sites, where it +drifts from the shaders. The infos can be hand written or reflected from SPIR-V +("Vulkan.Utils.SpirV.Pipeline" in @vulkan-utils-spirv@ produces these types). + +Designed for qualified import: + +@ +import Vulkan.Utils.Pipeline (Pipeline) +import qualified Vulkan.Utils.Pipeline as Pipeline + +Pipeline.bind cb pl +Pipeline.push cb pl params +set <- Pipeline.allocateSet dev pl 0 +Pipeline.bindSet cb pl 0 set +@ +-} +module Vulkan.Utils.Pipeline + ( Pipeline (..) + , allocateSet + , bind + , bindSet + , push + , Layout (..) + , allocateLayout + , set + , Set (..) + , allocateSetLayout + , allocateDescriptorSet + , allocateDescriptorSets + ) where + +import Control.Monad (guard, unless) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Trans.Resource (MonadResource, ReleaseKey, allocate) +import qualified Data.Vector as V +import Data.Word (Word32) +import Foreign.Marshal.Utils (with) +import Foreign.Ptr (castPtr) +import Foreign.Storable (Storable, sizeOf) +import qualified Vulkan.Core10 as Vk +import Vulkan.Zero (zero) + +-- | A pipeline with its bind point and 'Layout', ready to bind, push and feed sets. +data Pipeline = Pipeline + { pipeline :: Vk.Pipeline + , bindPoint :: Vk.PipelineBindPoint + , layout :: Layout + } + +bind :: (MonadIO m) => Vk.CommandBuffer -> Pipeline -> m () +bind cb pl = Vk.cmdBindPipeline cb pl.bindPoint pl.pipeline + +-- | Bind one descriptor set at @setNo@, via the pipeline's bind point and layout. +bindSet :: (MonadIO m) => Vk.CommandBuffer -> Pipeline -> Word32 -> Vk.DescriptorSet -> m () +bindSet cb pl setNo s = + Vk.cmdBindDescriptorSets cb pl.bindPoint pl.layout.pipelineLayout setNo (V.singleton s) V.empty + +{- | Push @a@ as the layout's single push-constant range: its stage flags, its size. + +The range's size is what the layout accepts — often less than @a@'s 'Foreign.Storable.sizeOf' +(std430 blocks trailing-pad) — so exactly that many of @a@'s leading bytes are +pushed; a value too small to cover the range is an error, not an out-of-bounds +read. Layouts with several ranges (or a range off 0) need 'Vk.cmdPushConstants' +directly. +-} +push :: (Storable a, MonadIO m) => Vk.CommandBuffer -> Pipeline -> a -> m () +push cb pl x = case pl.layout.pushRanges of + [r] + | r.offset == 0 + , fromIntegral r.size <= sizeOf x -> + liftIO $ with x $ \p -> + Vk.cmdPushConstants cb pl.layout.pipelineLayout r.stageFlags 0 r.size (castPtr p) + | r.offset == 0 -> + error ("Pipeline.push: the value's " <> show (sizeOf x) <> " bytes don't cover the " <> show r.size <> "-byte range") + rs -> error ("Pipeline.push: expected a single range at offset 0, got " <> show rs) + +-- | A descriptor set layout, kept with the info it was created from. +data Set = Set + { layout :: Vk.DescriptorSetLayout + , info :: Vk.DescriptorSetLayoutCreateInfo '[] + } + +-- | Create the set layout, keeping its info for 'allocateDescriptorSet' pool sizing. +allocateSetLayout :: (MonadResource m) => Vk.Device -> Vk.DescriptorSetLayoutCreateInfo '[] -> m Set +allocateSetLayout dev info = do + (_, layout) <- Vk.withDescriptorSetLayout dev info Nothing allocate + pure Set{layout, info} + +{- | One descriptor set of the layout, from its own throwaway pool. + +The pool is provisioned from the kept info's bindings, so it tracks whatever the +layout holds. It owns just this set and is released with @m@'s +'Control.Monad.Trans.Resource.ResourceT'. +-} +allocateDescriptorSet :: (MonadResource m) => Vk.Device -> Set -> m Vk.DescriptorSet +allocateDescriptorSet dev s = V.head . snd <$> allocateDescriptorSets dev s 1 + +{- | @count@ descriptor sets of the layout, from one throwaway pool. + +The key releases the pool and with it every set — for sets bound to recreated +resources (a swapchain's image views). +-} +allocateDescriptorSets :: (MonadResource m) => Vk.Device -> Set -> Int -> m (ReleaseKey, V.Vector Vk.DescriptorSet) +allocateDescriptorSets dev s count = do + (key, pool) <- Vk.withDescriptorPool dev zero{Vk.maxSets = fromIntegral count, Vk.poolSizes = poolSizes} Nothing allocate + sets <- Vk.allocateDescriptorSets dev zero{Vk.descriptorPool = pool, Vk.setLayouts = V.replicate count s.layout} + pure (key, sets) + where + -- Runtime-sized bindings reflect as count 0, and a zero pool size is invalid; + -- variable-count allocation is out of scope here, so skip them. + poolSizes = do + b <- s.info.bindings + guard (b.descriptorCount > 0) + pure $ Vk.DescriptorPoolSize b.descriptorType (b.descriptorCount * fromIntegral count) + +-- | A pipeline layout, kept with its sets (by set number) and push-constant ranges. +data Layout = Layout + { pipelineLayout :: Vk.PipelineLayout + , sets :: [(Word32, Set)] + , pushRanges :: [Vk.PushConstantRange] + } + +{- | Create the pipeline layout over the sets' layouts and the ranges. + +Sharing a 'Set' between layouts keeps them set-compatible on that number. Set +numbers must be contiguous from 0 (pad gaps with empty sets) — 'bindSet' +addresses sets by number, which has to agree with the layout's slot order — and +anything else 'fail's here rather than misbinding at record time. +-} +allocateLayout :: (MonadResource m, MonadFail m) => Vk.Device -> [(Word32, Set)] -> [Vk.PushConstantRange] -> m Layout +allocateLayout dev sets pushRanges = do + unless (map fst sets == take (length sets) [0 ..]) $ + fail ("Pipeline.allocateLayout: set numbers must be contiguous from 0, got " <> show (map fst sets)) + (_, pipelineLayout) <- + Vk.withPipelineLayout + dev + zero + { Vk.setLayouts = V.fromList [s.layout | (_, s) <- sets] + , Vk.pushConstantRanges = V.fromList pushRanges + } + Nothing + allocate + pure Layout{pipelineLayout, sets, pushRanges} + +-- | The layout's set at @setNo@; 'fail's if there is none. +set :: (MonadFail m) => Layout -> Word32 -> m Set +set l setNo = case lookup setNo l.sets of + Just s -> pure s + Nothing -> fail ("Pipeline.set: no set " <> show setNo <> " in layout (sets: " <> show (map fst l.sets) <> ")") + +-- | 'allocateDescriptorSet' for the pipeline's set @setNo@. +allocateSet :: (MonadResource m, MonadFail m) => Vk.Device -> Pipeline -> Word32 -> m Vk.DescriptorSet +allocateSet dev pl setNo = set pl.layout setNo >>= allocateDescriptorSet dev diff --git a/src/Vulkan/Utils/Pipeline/Internal.hs b/src/Vulkan/Utils/Pipeline/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Vulkan/Utils/Pipeline/Internal.hs @@ -0,0 +1,185 @@ +{-# LANGUAGE OverloadedLists #-} + +{-| Shared graphics-pipeline construction behind the two rendering paths, +"Vulkan.Utils.RenderPass" and "Vulkan.Utils.DynamicRendering". Not meant for +direct use — import one of those modules instead. + +The only difference between the paths is whether the pipeline references a +'Vk.RenderPass' or carries a @PipelineRenderingCreateInfo@ in its pNext chain, +so everything else (the vanilla rasterizer/blend/dynamic-state config, the +transient empty layout, the shader-module lifetime) lives here once. +-} +module Vulkan.Utils.Pipeline.Internal + ( basePipelineCreateInfo + , buildColorPipeline + , withCompiledStages + ) where + +import Control.Monad.IO.Unlift (MonadUnliftIO) +import Control.Monad.Trans.Resource (MonadResource, ReleaseKey, allocate, release) +import Data.Bits ((.|.)) +import Data.ByteString (ByteString) +import Data.Foldable (traverse_) +import Data.Maybe (fromMaybe) +import Data.Vector (Vector) +import qualified Data.Vector as V +import Vulkan.CStruct.Extends (SomeStruct (..)) +import qualified Vulkan.Core10 as Vk +import Vulkan.Utils.Pipeline.Specialization (Specialization, withSpecialization) +import Vulkan.Utils.Shader (shaderModuleStage) +import Vulkan.Zero (zero) + +{- | The shared body of the vanilla graphics pipeline: the given @dynamicStates@, +@colorAttachmentCount@ identical non-blended color attachments, an optional +depth-stencil state, and empty vertex input. The static values left in the +create-info (cull mode, topology, …) are the baked defaults for any state not +listed dynamic; states that are listed dynamic ignore them, so callers MUST emit +the matching @cmdSet*@ before drawing. + +The colour and depth shape MUST match the attachments the pipeline renders to — +the render pass (render-pass path) or the @PipelineRenderingCreateInfo@ formats +(dynamic-rendering path): + + * @colorAttachmentCount == 0@ omits @colorBlendState@ entirely (a depth-only + pipeline); otherwise one RGBA, non-blended attachment per colour target. + * @depth@ adds a zeroed @depthStencilState@ — present (non-NULL) is required + whenever a depth attachment is used; the actual test config is dynamic, so a + zeroed struct is correct. + +Pass @Just@ the target render pass (render-pass path), or @Nothing@ and attach +a @PipelineRenderingCreateInfo@ to the returned struct's pNext chain +(dynamic-rendering path). +-} +basePipelineCreateInfo + :: Vk.PipelineLayout + -> Maybe Vk.RenderPass + -> Int + -- ^ Colour attachment count (blend attachments); @0@ for depth-only. + -> Bool + -- ^ Whether a depth attachment is present. + -> Vk.PipelineVertexInputStateCreateInfo '[] + -- ^ Vertex input (bindings + attributes); @zero@ for none. + -> Vector Vk.DynamicState + -> Vector (SomeStruct Vk.PipelineShaderStageCreateInfo) + -> Vk.GraphicsPipelineCreateInfo '[] +basePipelineCreateInfo pipelineLayout renderPass colorAttachmentCount depth vertexInput dynamicStates' stages = + zero + { Vk.stages = stages + , Vk.vertexInputState = Just (SomeStruct vertexInput) + , Vk.inputAssemblyState = + Just + zero + { Vk.topology = Vk.PRIMITIVE_TOPOLOGY_TRIANGLE_LIST + , Vk.primitiveRestartEnable = False + } + , Vk.viewportState = + Just $ + SomeStruct + zero + { -- The counts MUST be zero when the matching @*_WITH_COUNT@ state + -- is dynamic (set then via @cmdSetViewportWithCount@); otherwise + -- the static count stands (plain @VIEWPORT@/@SCISSOR@ only swap + -- the values). VUID-VkGraphicsPipelineCreateInfo-pDynamicStates-03379/03380. + Vk.viewportCount = + if Vk.DYNAMIC_STATE_VIEWPORT_WITH_COUNT `V.elem` dynamicStates' then 0 else 1 + , Vk.scissorCount = + if Vk.DYNAMIC_STATE_SCISSOR_WITH_COUNT `V.elem` dynamicStates' then 0 else 1 + } + , Vk.rasterizationState = + Just $ + SomeStruct + zero + { Vk.depthClampEnable = False + , Vk.rasterizerDiscardEnable = False + , Vk.lineWidth = 1 + , Vk.polygonMode = Vk.POLYGON_MODE_FILL + , Vk.cullMode = Vk.CULL_MODE_NONE + , Vk.frontFace = Vk.FRONT_FACE_COUNTER_CLOCKWISE + , Vk.depthBiasEnable = False + } + , Vk.multisampleState = + Just $ + SomeStruct + zero + { Vk.sampleShadingEnable = False + , Vk.rasterizationSamples = Vk.SAMPLE_COUNT_1_BIT + , Vk.minSampleShading = 1 + , Vk.sampleMask = [maxBound] + } + , Vk.depthStencilState = + if depth then Just zero else Nothing + , Vk.colorBlendState = + if colorAttachmentCount == 0 + then Nothing + else + Just $ + SomeStruct + zero + { Vk.logicOpEnable = False + , Vk.attachments = V.replicate colorAttachmentCount colorBlendAttachment + } + , Vk.dynamicState = Just zero{Vk.dynamicStates = dynamicStates'} + , Vk.layout = pipelineLayout + , Vk.renderPass = fromMaybe Vk.NULL_HANDLE renderPass + , Vk.subpass = 0 + , Vk.basePipelineHandle = zero + } + where + colorBlendAttachment :: Vk.PipelineColorBlendAttachmentState + colorBlendAttachment = + zero + { Vk.colorWriteMask = + Vk.COLOR_COMPONENT_R_BIT + .|. Vk.COLOR_COMPONENT_G_BIT + .|. Vk.COLOR_COMPONENT_B_BIT + .|. Vk.COLOR_COMPONENT_A_BIT + , Vk.blendEnable = False + } + +{- | Build a single graphics pipeline from the given create-info builder. With +'Nothing', a transient empty pipeline layout is allocated and freed after the +build (the historical behaviour: no descriptor sets, no push constants); with +@Just layout@, the caller's layout is used and remains owned (and kept alive) +by the caller. The returned 'ReleaseKey' frees the pipeline. +-} +buildColorPipeline + :: (MonadResource m, MonadFail m) + => Vk.Device + -> Maybe Vk.PipelineLayout + -> (Vk.PipelineLayout -> SomeStruct Vk.GraphicsPipelineCreateInfo) + -> m (ReleaseKey, Vk.Pipeline) +buildColorPipeline dev layout mkCreateInfo = case layout of + Just pipelineLayout -> build pipelineLayout + Nothing -> do + (layoutKey, pipelineLayout) <- Vk.withPipelineLayout dev zero Nothing allocate + built <- build pipelineLayout + release layoutKey + pure built + where + build pipelineLayout = do + (key, (_, [pipeline])) <- + Vk.withGraphicsPipelines dev zero [mkCreateInfo pipelineLayout] Nothing allocate + pure (key, pipeline) + +{- | Compile each @(stage, SPIR-V)@ pair into a shader module, run the +continuation with the resulting stages, then release the now-redundant +module handles. Shader modules are only needed during pipeline creation, so +the continuation typically returns the built pipeline. +-} +withCompiledStages + :: (MonadResource m, MonadUnliftIO m, Specialization spec) + => Vk.Device + -> spec + -> [(Vk.ShaderStageFlagBits, ByteString)] + -> (Vector (SomeStruct Vk.PipelineShaderStageCreateInfo) -> m a) + -> m a +withCompiledStages dev spec shaders k = + withSpecialization spec $ \specializationInfo -> do + compiled <- + traverse + (\(stage, code) -> shaderModuleStage dev stage specializationInfo code) + shaders + let (keys, stages) = unzip compiled + result <- k (V.fromList stages) + traverse_ release keys + pure result diff --git a/src/Vulkan/Utils/Pipeline/Specialization.hs b/src/Vulkan/Utils/Pipeline/Specialization.hs new file mode 100644 --- /dev/null +++ b/src/Vulkan/Utils/Pipeline/Specialization.hs @@ -0,0 +1,234 @@ +{-| +Specialization constants, normalized to stacks of 32-bit units. + + +@ +data MySpec = MySpec { width :: Word32, height :: Word32, scale :: Float } +instance Specialization MySpec where -- ... pack the fields + +withSpecialization sp \\mSpec -> + -- build a 'Vulkan.Core10.PipelineShaderStageCreateInfo' with + -- specializationInfo = mSpec + ... +@ +-} +module Vulkan.Utils.Pipeline.Specialization + ( withSpecialization + , allocateSpecialization + , Specialization (..) + , SpecializationConst (..) + ) where + +import Control.Monad.IO.Class (liftIO) +import Control.Monad.IO.Unlift (MonadUnliftIO, withRunInIO) +import Control.Monad.Trans.Resource (MonadResource, allocate) +import Data.Bool (bool) +import Data.Int (Int32) +import Data.Vector (Vector) +import qualified Data.Vector as Vector +import qualified Data.Vector.Storable as Storable +import Data.Word (Word32) +import Foreign.Marshal.Alloc (free) +import Foreign.Marshal.Array (mallocArray, pokeArray) +import Foreign.Ptr (castPtr) +import GHC.Float (castFloatToWord32) +import qualified Vulkan.Core10 as Vk + +{- | Provide a 'Vk.SpecializationInfo' describing @spec@ to the callback. + +The info (and the buffer its @data'@ pointer references) is valid only for the +duration of the callback, which is exactly the window in which it needs to live: +pipeline creation copies the constant values out. Build and create the pipeline +inside the continuation. + +An empty specialization (e.g. @()@ or an empty list) yields 'Nothing', so the +shader stage's @specializationInfo@ stays unset. +-} +withSpecialization + :: (Specialization spec, MonadUnliftIO m) + => spec + -> (Maybe Vk.SpecializationInfo -> m a) + -> m a +withSpecialization spec action = + if Storable.null specData + then + action Nothing + else withRunInIO $ \run -> + Storable.unsafeWith specData $ \specPtr -> + run . action $ + Just + Vk.SpecializationInfo + { Vk.mapEntries = mapEntries + , Vk.dataSize = fromIntegral $ Storable.length specData * 4 + , Vk.data' = castPtr specPtr + } + where + specData :: Storable.Vector Word32 + specData = Storable.fromList (specializationData spec) + + mapEntries :: Vector Vk.SpecializationMapEntry + mapEntries = specializationMapEntries (Storable.length specData) + +{- | Pack a specialization into a buffer tied to the current resource scope, +yielding the 'Vk.SpecializationInfo' to embed in a shader stage's +@specializationInfo@. + +Unlike 'withSpecialization' this is not continuation-scoped: the backing buffer +lives until the surrounding 'Control.Monad.Trans.Resource.ResourceT' block ends, +so it survives a later pipeline creation. An empty specialization (e.g. @()@) +yields 'Nothing'. +-} +allocateSpecialization + :: (Specialization spec, MonadResource m) + => spec + -> m (Maybe Vk.SpecializationInfo) +allocateSpecialization spec = + case specializationData spec of + [] -> + pure Nothing + ws -> do + let n = length ws + -- A C-malloc'd buffer is pointer-stable and freed at scope end; the + -- pointer must stay valid until pipeline creation copies the values. + (_key, ptr) <- allocate (mallocArray n) free + liftIO $ pokeArray ptr ws + pure $ + Just + Vk.SpecializationInfo + { Vk.mapEntries = specializationMapEntries n + , Vk.dataSize = fromIntegral (n * 4) + , Vk.data' = castPtr ptr + } + +-- | One 32-bit @constantID = offset/4@ entry per slot, counting from zero. +specializationMapEntries :: Int -> Vector Vk.SpecializationMapEntry +specializationMapEntries n = + Vector.generate n $ \ix -> + Vk.SpecializationMapEntry + { Vk.constantID = fromIntegral ix + , Vk.offset = fromIntegral (ix * 4) + , Vk.size = 4 + } + +{- | A value that flattens to a stack of 32-bit specialization constants, in +@constant_id@ order starting from zero. +-} +class Specialization a where + specializationData :: a -> [Word32] + +instance Specialization () where + specializationData _ = [] + +-- | Pre-packed constants, used as-is. +instance Specialization [Word32] where + specializationData = id + +instance Specialization Word32 where + specializationData x = [packConstData x] + +instance Specialization Int32 where + specializationData x = [packConstData x] + +instance Specialization Float where + specializationData x = [packConstData x] + +instance Specialization Bool where + specializationData x = [packConstData x] + +{- | A single scalar specialization constant, reinterpreted into its 32-bit +representation. + +Per the @GL_KHR_vulkan_glsl@ spec a @constant_id@ may only decorate a scalar +@int@, @float@ or @bool@; @uint@ works in practice too. All of these are 32 bits +wide. +-} +class SpecializationConst a where + packConstData :: a -> Word32 + +instance SpecializationConst Word32 where + packConstData = id + +-- | Two's-complement bit pattern, preserved by 'fromIntegral' at the same width. +instance SpecializationConst Int32 where + packConstData = fromIntegral + +instance SpecializationConst Float where + packConstData = castFloatToWord32 + +instance SpecializationConst Bool where + packConstData = bool 0 1 + +instance + ( SpecializationConst a + , SpecializationConst b + ) + => Specialization (a, b) + where + specializationData (a, b) = + [ packConstData a + , packConstData b + ] + +instance + ( SpecializationConst a + , SpecializationConst b + , SpecializationConst c + ) + => Specialization (a, b, c) + where + specializationData (a, b, c) = + [ packConstData a + , packConstData b + , packConstData c + ] + +instance + ( SpecializationConst a + , SpecializationConst b + , SpecializationConst c + , SpecializationConst d + ) + => Specialization (a, b, c, d) + where + specializationData (a, b, c, d) = + [ packConstData a + , packConstData b + , packConstData c + , packConstData d + ] + +instance + ( SpecializationConst a + , SpecializationConst b + , SpecializationConst c + , SpecializationConst d + , SpecializationConst e + ) + => Specialization (a, b, c, d, e) + where + specializationData (a, b, c, d, e) = + [ packConstData a + , packConstData b + , packConstData c + , packConstData d + , packConstData e + ] + +instance + ( SpecializationConst a + , SpecializationConst b + , SpecializationConst c + , SpecializationConst d + , SpecializationConst e + , SpecializationConst f + ) + => Specialization (a, b, c, d, e, f) + where + specializationData (a, b, c, d, e, f) = + [ packConstData a + , packConstData b + , packConstData c + , packConstData d + , packConstData e + , packConstData f + ] diff --git a/src/Vulkan/Utils/PipelineLayout.hs b/src/Vulkan/Utils/PipelineLayout.hs new file mode 100644 --- /dev/null +++ b/src/Vulkan/Utils/PipelineLayout.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE NoFieldSelectors #-} + +{-| Assemble a pipeline's descriptor-set-layout bindings and push-constant ranges +from the per-stage contributions of several shaders. + +A binding (or push-constant range) declared by more than one stage must become a +single entry whose 'Vk.stageFlags' is the OR of the contributing stages — that is +what a pipeline layout shared between, say, a vertex and a fragment shader needs. +'mergeDescriptorSetLayoutBindings' and 'mergePushConstantRanges' do that merge on +plain Vulkan values, independent of where the per-stage bindings came from (hand +written, or reflected — see @vulkan-utils-spirv@). +-} +module Vulkan.Utils.PipelineLayout + ( mergeDescriptorSetLayoutBindings + , mergePushConstantRanges + , DescriptorBindingConflict (..) + ) where + +import Control.Monad (foldM) +import Data.Bits ((.|.)) +import Data.Foldable (foldl') +import qualified Data.Map.Strict as Map +import Data.Word (Word32) +import qualified Vulkan.Core10 as Vk +import Vulkan.Zero (zero) + +{- | Two stages declared the same binding number with different descriptor types, +which cannot be reconciled into one binding. +-} +data DescriptorBindingConflict = DescriptorBindingConflict + { binding :: Word32 + -- ^ The binding number the stages disagree on. + , types :: (Vk.DescriptorType, Vk.DescriptorType) + -- ^ The two differing descriptor types. + } + deriving (Eq, Show) + +{- | Merge the descriptor-set-layout bindings contributed by several stages for a +single descriptor set. Bindings sharing a binding number are combined: their +'Vk.stageFlags' are OR-ed and their 'Vk.descriptorCount's maxed. A +'Vk.descriptorType' disagreement is a 'Left'. The result is ascending by +binding number. + +Each input binding should carry the one stage that declares it (its +'Vk.stageFlags' set to that stage); the merge turns the per-stage bindings +into one multi-stage binding per binding number. +-} +mergeDescriptorSetLayoutBindings + :: (Foldable f) + => f Vk.DescriptorSetLayoutBinding + -> Either DescriptorBindingConflict [Vk.DescriptorSetLayoutBinding] +mergeDescriptorSetLayoutBindings bindings = + fmap (fmap snd . Map.toAscList) (foldM step Map.empty bindings) + where + step acc b = case Map.lookup b.binding acc of + Nothing -> Right (Map.insert b.binding b acc) + Just b0 -> (\b' -> Map.insert b.binding b' acc) <$> combine b0 b + + combine b0 b1 + | t0 /= t1 = Left (DescriptorBindingConflict b0.binding (t0, t1)) + | otherwise = + Right + ( b0 + { Vk.stageFlags = b0.stageFlags .|. b1.stageFlags + , Vk.descriptorCount = max b0.descriptorCount b1.descriptorCount + } + ) + where + t0 = b0.descriptorType + t1 = b1.descriptorType + +{- | Merge the push-constant ranges contributed by several stages: ranges sharing +the same @(offset, size)@ have their 'Vk.stageFlags' OR-ed. The result is +ascending by offset. +-} +mergePushConstantRanges + :: (Foldable f) => f Vk.PushConstantRange -> [Vk.PushConstantRange] +mergePushConstantRanges ranges = + [ zero{Vk.stageFlags = stage, Vk.offset = off, Vk.size = sz} + | ((off, sz), stage) <- Map.toAscList byRange + ] + where + byRange = foldl' add Map.empty ranges + add m r = Map.insertWith (.|.) (r.offset, r.size) r.stageFlags m diff --git a/src/Vulkan/Utils/QueueAssignment.hs b/src/Vulkan/Utils/QueueAssignment.hs --- a/src/Vulkan/Utils/QueueAssignment.hs +++ b/src/Vulkan/Utils/QueueAssignment.hs @@ -1,9 +1,10 @@ module Vulkan.Utils.QueueAssignment ( assignQueues - , QueueSpec(..) - , QueueFamilyIndex(..) - , QueueIndex(..) - -- * Queue Family Predicates + , QueueSpec (..) + , QueueFamilyIndex (..) + , QueueIndex (..) + + -- * Queue Family Predicates , isComputeQueueFamily , isGraphicsQueueFamily , isTransferQueueFamily @@ -11,89 +12,91 @@ , isPresentQueueFamily ) where -import Control.Applicative -import Control.Category ( (>>>) ) -import Control.Monad ( filterM ) -import Control.Monad.IO.Class -import Control.Monad.Trans.Class ( MonadTrans(lift) ) -import Control.Monad.Trans.Maybe -import Control.Monad.Trans.State.Strict - ( evalState - , evalStateT - , get - , put - ) -import Data.Bits -import Data.Foldable -import Data.Functor ( (<&>) ) -import Data.Traversable -import qualified Data.Vector as V -import Data.Vector ( Vector ) -import Data.Word -import GHC.Stack ( HasCallStack ) -import Vulkan.Core10 -import Vulkan.Extensions.VK_KHR_surface - ( SurfaceKHR - , getPhysicalDeviceSurfaceSupportKHR - ) -import Vulkan.Utils.Misc -import Vulkan.Zero +import Control.Applicative +import Control.Category ((>>>)) +import Control.Monad (filterM) +import Control.Monad.IO.Class +import Control.Monad.Trans.Class (MonadTrans (lift)) +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.State.Strict + ( evalState + , evalStateT + , get + , put + ) +import Data.Bits +import Data.Foldable +import Data.Functor ((<&>)) +import Data.Traversable +import Data.Vector (Vector) +import qualified Data.Vector as V +import Data.Word +import GHC.Stack (HasCallStack) +import Vulkan.Core10 +import Vulkan.Extensions.VK_KHR_surface + ( SurfaceKHR + , getPhysicalDeviceSurfaceSupportKHR + ) +import Vulkan.Utils.Misc +import Vulkan.Zero ---------------------------------------------------------------- -- Device Queue creation ---------------------------------------------------------------- --- | Requirements for a 'Queue' to be assigned a family by 'assignQueues'. --- --- To assign to a specific queue family index @f@: --- --- @ --- queueSpecFamilyPredicate = \i _ -> i == f --- @ --- --- To assign to any queue family which supports compute operations: --- --- @ --- let isComputeQueue q = QUEUE_COMPUTE_BIT .&&. queueFlags q --- in QueueSpec priority (\_index q -> pure (isComputeQueue q)) --- @ +{- | Requirements for a 'Queue' to be assigned a family by 'assignQueues'. + +To assign to a specific queue family index @f@: + +@ +queueSpecFamilyPredicate = \i _ -> i == f +@ + +To assign to any queue family which supports compute operations: + +@ +let isComputeQueue q = QUEUE_COMPUTE_BIT .&&. queueFlags q +in QueueSpec priority (\_index q -> pure (isComputeQueue q)) +@ +-} data QueueSpec m = QueueSpec { queueSpecQueuePriority :: Float , queueSpecFamilyPredicate :: QueueFamilyIndex -> QueueFamilyProperties -> m Bool } -newtype QueueFamilyIndex = QueueFamilyIndex { unQueueFamilyIndex :: Word32 } +newtype QueueFamilyIndex = QueueFamilyIndex {unQueueFamilyIndex :: Word32} deriving (Eq, Ord, Enum, Show) -newtype QueueIndex = QueueIndex { unQueueIndex :: Word32 } +newtype QueueIndex = QueueIndex {unQueueIndex :: Word32} deriving (Eq, Ord, Enum, Show) --- | Given a 'PhysicalDevice' and a set of requirements for queues, calculate an --- assignment of queues to queue families and return information with which to --- create a 'Device' and also a function to extract the requested 'Queue's from --- the device. --- --- You may want to create a custom type with a 'Traversable' instance to store --- your queues like: --- --- @ --- data MyQueues q = MyQueues --- { computeQueue :: q --- , graphicsAndPresentQueue :: q --- , transferQueue :: q --- } --- --- myQueueSpecs :: MyQueues QueueSpec --- myQueueSpecs = MyQueues --- { computeQueue = QueueSpec 0.5 isComputeQueueFamily --- , graphicsAndPresentQueue = QueueSpec 1 isPresentQueueFamily --- , transferQueue = QueueSpec 1 isTransferOnlyQueueFamily --- } --- @ --- --- Note, this doesn't permit differentiating queue family assignment based on --- whether or not the queue is protected. +{- | Given a 'PhysicalDevice' and a set of requirements for queues, calculate an +assignment of queues to queue families and return information with which to +create a 'Device' and also a function to extract the requested 'Queue's from +the device. + +You may want to create a custom type with a 'Traversable' instance to store +your queues like: + +@ +data MyQueues q = MyQueues + { computeQueue :: q + , graphicsAndPresentQueue :: q + , transferQueue :: q + } + +myQueueSpecs :: MyQueues QueueSpec +myQueueSpecs = MyQueues + { computeQueue = QueueSpec 0.5 isComputeQueueFamily + , graphicsAndPresentQueue = QueueSpec 1 isPresentQueueFamily + , transferQueue = QueueSpec 1 isTransferOnlyQueueFamily + } +@ + +Note, this doesn't permit differentiating queue family assignment based on +whether or not the queue is protected. +-} assignQueues :: forall f m n . (Traversable f, MonadIO m, MonadIO n) @@ -106,84 +109,92 @@ , Device -> n (f (QueueFamilyIndex, Queue)) ) ) - -- ^ - -- - A set of 'DeviceQueueCreateInfo's to pass to 'createDevice' - -- - A function to extract the requested 'Queue's from the 'Device' created - -- with the 'DeviceQueueCreateInfo's - -- - -- 'Nothing' if it wasn't possible to satisfy all the 'QueueSpec's + {- ^ + - A set of 'DeviceQueueCreateInfo's to pass to 'createDevice' + - A function to extract the requested 'Queue's from the 'Device' created + with the 'DeviceQueueCreateInfo's + + 'Nothing' if it wasn't possible to satisfy all the 'QueueSpec's + -} assignQueues phys specs = runMaybeT $ do queueFamilyProperties <- zip [QueueFamilyIndex 0 ..] - . V.toList - <$> getPhysicalDeviceQueueFamilyProperties phys + . V.toList + <$> getPhysicalDeviceQueueFamilyProperties phys -- For each QueueSpec find the list of applicable families specsWithFamilies <- for specs $ \spec -> do - families <- filterM (lift . uncurry (queueSpecFamilyPredicate spec)) - queueFamilyProperties + families <- + filterM + (lift . uncurry (queueSpecFamilyPredicate spec)) + queueFamilyProperties pure (spec, fst <$> families) - let -- Get the number of available queues for each family - familiesWithCapacities :: [(QueueFamilyIndex, Word32)] - familiesWithCapacities = - [ (i, queueCount) - | (i, QueueFamilyProperties {..}) <- queueFamilyProperties - ] + let + -- Get the number of available queues for each family + familiesWithCapacities :: [(QueueFamilyIndex, Word32)] + familiesWithCapacities = + [ (i, queueCount) + | (i, QueueFamilyProperties{..}) <- queueFamilyProperties + ] -- Assign each QueueSpec to a queue family - specsWithFamily :: f (QueueSpec m, QueueFamilyIndex) <- headMay - (assign - familiesWithCapacities - (specsWithFamilies <&> \(spec, indices) index -> - if index `elem` indices then Just (spec, index) else Nothing + specsWithFamily :: f (QueueSpec m, QueueFamilyIndex) <- + headMay + ( assign + familiesWithCapacities + ( specsWithFamilies <&> \(spec, indices) index -> + if index `elem` indices then Just (spec, index) else Nothing + ) ) - ) - let maxFamilyIndex :: Maybe QueueFamilyIndex - maxFamilyIndex = maximumMay (snd <$> toList specsWithFamily) + let + maxFamilyIndex :: Maybe QueueFamilyIndex + maxFamilyIndex = maximumMay (snd <$> toList specsWithFamily) - -- Assign each QueueSpec an index within its queue family - specsWithQueueIndex :: f (QueueSpec m, QueueFamilyIndex, QueueIndex) - specsWithQueueIndex = - flip evalState (repeat (QueueIndex 0)) - $ for specsWithFamily - $ \(spec, familyIndex) -> do - indices <- get - let (index, indices') = - incrementAt (unQueueFamilyIndex familyIndex) indices - put indices' - pure (spec, familyIndex, index) + -- Assign each QueueSpec an index within its queue family + specsWithQueueIndex :: f (QueueSpec m, QueueFamilyIndex, QueueIndex) + specsWithQueueIndex = + flip evalState (repeat (QueueIndex 0)) $ + for specsWithFamily $ + \(spec, familyIndex) -> do + indices <- get + let (index, indices') = + incrementAt (unQueueFamilyIndex familyIndex) indices + put indices' + pure (spec, familyIndex, index) - -- Gather the priorities for each queue in each queue family - queuePriorities :: [[Float]] - queuePriorities = foldr - (\(QueueSpec {..}, QueueFamilyIndex i) ps -> - prependAt i queueSpecQueuePriority ps + -- Gather the priorities for each queue in each queue family + queuePriorities :: [[Float]] + queuePriorities = + foldr + ( \(QueueSpec{..}, QueueFamilyIndex i) ps -> + prependAt i queueSpecQueuePriority ps ) - (replicate - (maybe 0 (fromIntegral . unQueueFamilyIndex . succ) maxFamilyIndex) - [] + ( replicate + (maybe 0 (fromIntegral . unQueueFamilyIndex . succ) maxFamilyIndex) + [] ) specsWithFamily - -- Make 'DeviceQueueCreateInfo's for the required queue families and - -- priorities. - queueCreateInfos :: Vector (DeviceQueueCreateInfo '[]) - queueCreateInfos = V.fromList - [ zero { queueFamilyIndex = familyIndex - , queuePriorities = V.fromList ps - } + -- Make 'DeviceQueueCreateInfo's for the required queue families and + -- priorities. + queueCreateInfos :: Vector (DeviceQueueCreateInfo '[]) + queueCreateInfos = + V.fromList + [ zero + { queueFamilyIndex = familyIndex + , queuePriorities = V.fromList ps + } | (familyIndex, ps) <- zip [0 ..] queuePriorities , not (null ps) ] - -- Get - extractQueues :: Device -> n (f (QueueFamilyIndex, Queue)) - extractQueues dev = - for specsWithQueueIndex - $ \(_, i@(QueueFamilyIndex familyIndex), QueueIndex index) -> - (i, ) <$> getDeviceQueue dev familyIndex index + extractQueues :: Device -> n (f (QueueFamilyIndex, Queue)) + extractQueues dev = + for specsWithQueueIndex $ + \(_, i@(QueueFamilyIndex familyIndex), QueueIndex index) -> + (i,) <$> getDeviceQueue dev familyIndex index pure (queueCreateInfos, extractQueues) @@ -200,18 +211,19 @@ isTransferQueueFamily :: QueueFamilyProperties -> Bool isTransferQueueFamily q = QUEUE_TRANSFER_BIT .&&. queueFlags q --- | Does this queue have 'QUEUE_TRANSFER_BIT' set and not 'QUEUE_COMPUTE_BIT' --- or 'QUEUE_GRAPHICS_BIT' +{- | Does this queue have 'QUEUE_TRANSFER_BIT' set and not 'QUEUE_COMPUTE_BIT' +or 'QUEUE_GRAPHICS_BIT' +-} isTransferOnlyQueueFamily :: QueueFamilyProperties -> Bool isTransferOnlyQueueFamily q = - ( queueFlags q - .&. (QUEUE_TRANSFER_BIT .|. QUEUE_GRAPHICS_BIT .|. QUEUE_COMPUTE_BIT) - ) + ( queueFlags q + .&. (QUEUE_TRANSFER_BIT .|. QUEUE_GRAPHICS_BIT .|. QUEUE_COMPUTE_BIT) + ) == QUEUE_TRANSFER_BIT -- | Can this queue family present to this surface on this device isPresentQueueFamily - :: MonadIO m => PhysicalDevice -> SurfaceKHR -> QueueFamilyIndex -> m Bool + :: (MonadIO m) => PhysicalDevice -> SurfaceKHR -> QueueFamilyIndex -> m Bool isPresentQueueFamily phys surf (QueueFamilyIndex i) = getPhysicalDeviceSurfaceSupportKHR phys i surf @@ -219,54 +231,61 @@ -- Helpers ---------------------------------------------------------------- --- | Find all possible valid assignments for elements of a 'Traversable' with --- some limited resources. --- --- >>> assign @[] @_ @() [("a", 1)] [] --- [[]] --- --- >>> assign @[] [("hi", 1), ("foo", 3)] [Just, Just . reverse, Just . take 1 ] --- [["hi","oof","f"],["foo","ih","f"],["foo","oof","h"],["foo","oof","f"]] --- --- >>> assign @[] [("a", 1), ("b", 2)] [\case {"a" -> Just 1; "b" -> Just 2; _ -> Nothing}, \case {"b" -> Just 3; _ -> Nothing}, \case {"a" -> Just 4; _ -> Nothing}] --- [[2,3,4]] +{- | Find all possible valid assignments for elements of a 'Traversable' with +some limited resources. + +>>> assign @[] @_ @() [("a", 1)] [] +[[]] + +>>> assign @[] [("hi", 1), ("foo", 3)] [Just, Just . reverse, Just . take 1 ] +[["hi","oof","f"],["foo","ih","f"],["foo","oof","h"],["foo","oof","f"]] + +>>> assign @[] [("a", 1), ("b", 2)] [\case {"a" -> Just 1; "b" -> Just 2; _ -> Nothing}, \case {"b" -> Just 3; _ -> Nothing}, \case {"a" -> Just 4; _ -> Nothing}] +[[2,3,4]] +-} assign :: forall f a b - . Traversable f + . (Traversable f) => [(a, Word32)] -- ^ How many of each 'a' are available -> f (a -> Maybe b) -- ^ Which 'a's can each element use -> [f b] - -- ^ A list of assignments, each element in this list has the length of the - -- requirements list -assign capacities = flip evalStateT capacities . traverse - (\p -> do - cs <- get - (choice, cs') <- lift (select p cs) - put cs' - pure choice - ) + {- ^ A list of assignments, each element in this list has the length of the + requirements list + -} +assign capacities = + flip evalStateT capacities + . traverse + ( \p -> do + cs <- get + (choice, cs') <- lift (select p cs) + put cs' + pure choice + ) --- | Select an element from the list according to some predicate, and return --- that element along with the decremented list. +{- | Select an element from the list according to some predicate, and return +that element along with the decremented list. +-} select :: (a -> Maybe b) -> [(a, Word32)] -> [(b, [(a, Word32)])] select p = \case [] -> [] x : xs -> - let hit b = (b, if snd x == 1 then xs else (pred <$> x) : xs) - miss = do - (selected, xs') <- select p xs - pure (selected, x : xs') - in if snd x == 0 - then miss - else case p (fst x) of - Nothing -> miss - Just b -> hit b : miss + let + hit b = (b, if snd x == 1 then xs else (pred <$> x) : xs) + miss = do + (selected, xs') <- select p xs + pure (selected, x : xs') + in + if snd x == 0 + then miss + else case p (fst x) of + Nothing -> miss + Just b -> hit b : miss -headMay :: Alternative f => [a] -> f a +headMay :: (Alternative f) => [a] -> f a headMay = \case - [] -> empty + [] -> empty x : _ -> pure x maximumMay :: (Foldable f, Ord a) => f a -> Maybe a @@ -275,10 +294,11 @@ incrementAt :: (HasCallStack, Enum a) => Word32 -> [a] -> (a, [a]) incrementAt index = modAt index succ -prependAt :: HasCallStack => Word32 -> a -> [[a]] -> [[a]] +prependAt :: (HasCallStack) => Word32 -> a -> [[a]] -> [[a]] prependAt index p = snd . modAt index (p :) -modAt :: HasCallStack => Word32 -> (a -> a) -> [a] -> (a, [a]) -modAt index f = splitAt (fromIntegral index) >>> \case - (_ , [] ) -> error "modAt, out of bounds" - (xs, y : ys) -> (y, xs <> (f y : ys)) +modAt :: (HasCallStack) => Word32 -> (a -> a) -> [a] -> (a, [a]) +modAt index f = + splitAt (fromIntegral index) >>> \case + (_, []) -> error "modAt, out of bounds" + (xs, y : ys) -> (y, xs <> (f y : ys)) diff --git a/src/Vulkan/Utils/Queues.hs b/src/Vulkan/Utils/Queues.hs new file mode 100644 --- /dev/null +++ b/src/Vulkan/Utils/Queues.hs @@ -0,0 +1,253 @@ +{-| A common physical-device + logical-device boot recipe: pick a device +that exposes a graphics/compute/transfer queue triple (with the graphics +family also presenting, when a surface is supplied), then create a logical +device with one 'Queue' allocated per slot. + +This is the wheel every "draw a thing in Vulkan" application reinvents. +The recipe here is opinionated: + +- The graphics slot doubles as the present queue. +- The compute slot prefers a compute-only queue family (async compute); + falls back to aliasing the graphics family. +- The transfer slot prefers a transfer-only queue family (DMA-only + hardware queue); falls back to aliasing the compute family. +- Priorities are 1.0 / 0.5 / 0.2 for graphics / compute / transfer. + +When two slots target the same family, two distinct 'Queue' handles are +still allocated within that shared family with the requested priorities. + +If you need a different shape (compute-only, multiple graphics queues, +custom priorities, …) reach for the lower-level +'Vulkan.Utils.QueueAssignment.assignQueues' directly. +-} +module Vulkan.Utils.Queues + ( Queues (..) + , allocateDevice + ) where + +import Control.Monad.IO.Class +import Control.Monad.Trans.Resource +import Data.Foldable (foldl', toList) +import Data.List (sortOn) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Traversable (mapAccumL) +import qualified Data.Vector as V +import Data.Word (Word32, Word64) +import Vulkan.CStruct.Extends (SomeStruct (..)) +import qualified Vulkan.Core10 as Vk +import qualified Vulkan.Core10.DeviceInitialization as DI +import Vulkan.Extensions.VK_KHR_surface (SurfaceKHR) +import Vulkan.Requirement (DeviceRequirement) +import Vulkan.Utils.Initialization (allocateDeviceFromRequirements, pickPhysicalDevice) +import Vulkan.Utils.QueueAssignment (QueueFamilyIndex (..), QueueSpec (..), assignQueues, isComputeQueueFamily, isGraphicsQueueFamily, isPresentQueueFamily, isTransferOnlyQueueFamily) +import Vulkan.Zero (zero) + +{- | The G/C/T queue kit. Parametric in the slot contents so the same +shape can carry priorities ('Float'), family indices ('QueueFamilyIndex'), +queue specs ('QueueSpec'), or fully-resolved @(QueueFamilyIndex, Queue)@ +pairs. +-} +data Queues a = Queues + { qGraphics :: a + -- ^ graphics + present, priority 1.0 + , qCompute :: a + -- ^ compute (prefers compute-only family), priority 0.5 + , qTransfer :: a + -- ^ transfer (prefers transfer-only family), priority 0.2 + } + deriving (Show, Functor, Foldable, Traversable) + +-- | Elementwise zip — handy for combining priorities with family predicates. +instance Applicative Queues where + pure x = Queues x x x + Queues f g h <*> Queues x y z = Queues (f x) (g y) (h z) + +{- | Pick a physical device that has the queue families needed for the +caller, then create a logical device exposing one queue per G/C/T slot. +Devices are scored by total memory. + +Pass @'Just' surface@ for windowed callers — the graphics family must also +support presentation. Pass 'Nothing' for headless callers — any graphics +family will do. + +Pass any extra device requirements (extensions, features, API version) in +the third argument; they are forwarded to 'allocateDeviceFromRequirements'. + +Fails (via 'MonadFail') when no physical device satisfies the family +requirements. +-} +allocateDevice + :: (MonadResource m, MonadFail m) + => Vk.Instance + -> Maybe SurfaceKHR + -> [DeviceRequirement] + -> m (Vk.PhysicalDevice, Vk.Device, Queues (QueueFamilyIndex, Vk.Queue)) +allocateDevice inst mSurface extraReqs = do + mPd <- + pickPhysicalDevice + inst + (discoverFamilies mSurface) + (snd :: (Queues QueueFamilyIndex, Word64) -> Word64) + ((qFams, _score), phys) <- case mPd of + Just x -> pure x + Nothing -> fail "No physical device with the required G/C/T queue families" + + let + prios = Queues 1.0 0.5 0.2 + mkSpec target prio = QueueSpec prio (\i _ -> pure (i == target)) + specs = mkSpec <$> qFams <*> prios + + -- Prefer 'assignQueues', which hands each slot its own queue for maximum + -- parallelism. When the hardware can't supply that many distinct queues + -- (e.g. a lone graphics+compute family exposing a single queue, as some + -- mobile and translation-layer drivers do) fall back to sharing rather than + -- failing: the triple still works, just with serialized submission. + (qInfos, getQs) <- + assignQueues phys specs >>= \case + Just qs -> pure qs + Nothing -> shareQueues phys ((,) <$> qFams <*> prios) + + dev <- + allocateDeviceFromRequirements + extraReqs + [] + phys + zero{Vk.queueCreateInfos = SomeStruct <$> qInfos} + qs <- liftIO (getQs dev) + pure (phys, dev, qs) + +discoverFamilies + :: (MonadIO m) + => Maybe SurfaceKHR + -> Vk.PhysicalDevice + -> m (Maybe (Queues QueueFamilyIndex, Word64)) +discoverFamilies mSurf phys = do + qProps <- Vk.getPhysicalDeviceQueueFamilyProperties phys + let + withIndex = V.toList (V.indexed qProps) + asQfi i = QueueFamilyIndex (fromIntegral i) + + graphicsFamilies = + [asQfi i | (i, q) <- withIndex, isGraphicsQueueFamily q] + asyncCompute = + [ asQfi i + | (i, q) <- withIndex + , isComputeQueueFamily q && not (isGraphicsQueueFamily q) + ] + anyCompute = + [asQfi i | (i, q) <- withIndex, isComputeQueueFamily q] + dedicatedTransfer = + [asQfi i | (i, q) <- withIndex, isTransferOnlyQueueFamily q] + + mGp <- case mSurf of + Just surf -> do + presentResults <- + mapM + (\qfi -> (qfi,) <$> isPresentQueueFamily phys surf qfi) + graphicsFamilies + pure $ case [qfi | (qfi, True) <- presentResults] of + qfi : _ -> Just qfi + [] -> Nothing + Nothing -> + pure $ case graphicsFamilies of + qfi : _ -> Just qfi + [] -> Nothing + + let mCp = case asyncCompute of + qfi : _ -> Just qfi + [] -> case anyCompute of + qfi : _ -> Just qfi + [] -> Nothing + + case (mGp, mCp) of + (Just gp, Just cp) -> do + let tf = case dedicatedTransfer of + qfi : _ -> qfi + [] -> cp + heaps <- Vk.memoryHeaps <$> Vk.getPhysicalDeviceMemoryProperties phys + let score = sum (DI.size <$> heaps) :: Word64 + pure (Just (Queues gp cp tf, score)) + _ -> pure Nothing + +{- | Robust fallback for 'allocateDevice' when 'assignQueues' can't give every +slot its own queue. Allocates as many distinct queues per family as the +hardware exposes, then aliases the surplus slots onto them round-robin, so it +always succeeds. + +A shared queue keeps every capability it was selected for — a graphics+compute +family also handles transfer — so the result is correct, just less concurrent. +Two slots that resolve to the same 'Vk.Queue' compare equal, so a caller who +cares can detect aliasing. Callers submitting from multiple threads must +externally synchronize a shared queue themselves; see +'Vulkan.Utils.QueueAssignment'. +-} +shareQueues + :: (MonadIO m) + => Vk.PhysicalDevice + -> Queues (QueueFamilyIndex, Float) + -- ^ The resolved family and queue priority for each slot. + -> m + ( V.Vector (Vk.DeviceQueueCreateInfo '[]) + , Vk.Device -> IO (Queues (QueueFamilyIndex, Vk.Queue)) + ) +shareQueues phys famPrios = do + capacities <- familyCapacities phys + let + capOf fam = Map.findWithDefault 0 fam capacities + + -- Hand each slot a queue index within its family, wrapping at the family's + -- capacity so surplus slots reuse (alias) earlier queues. + step counts (fam, prio) = + let + used = Map.findWithDefault 0 fam counts + idx = used `mod` max 1 (capOf fam) + in + (Map.insert fam (used + 1) counts, (fam, prio, idx)) + + slots :: Queues (QueueFamilyIndex, Float, Word32) + slots = snd (mapAccumL step Map.empty famPrios) + + -- The highest requested priority wins for a queue shared by several slots. + priorityAt :: Map (QueueFamilyIndex, Word32) Float + priorityAt = + foldl' + (\acc (fam, prio, idx) -> Map.insertWith max (fam, idx) prio acc) + Map.empty + (toList slots) + + -- One create-info per family, priorities ordered by queue index. + perFamily :: Map QueueFamilyIndex [(Word32, Float)] + perFamily = + Map.fromListWith + (<>) + [(fam, [(idx, prio)]) | ((fam, idx), prio) <- Map.toList priorityAt] + + createInfos = + V.fromList + [ zero + { Vk.queueFamilyIndex = unQueueFamilyIndex fam + , Vk.queuePriorities = V.fromList (snd <$> sortOn fst idxPrios) + } + | (fam, idxPrios) <- Map.toList perFamily + ] + + getQueues dev = + traverse + ( \(fam, _, idx) -> + (fam,) <$> Vk.getDeviceQueue dev (unQueueFamilyIndex fam) idx + ) + slots + + pure (createInfos, getQueues) + +-- | The number of queues each queue family of a 'Vk.PhysicalDevice' exposes. +familyCapacities + :: (MonadIO m) => Vk.PhysicalDevice -> m (Map QueueFamilyIndex Word32) +familyCapacities phys = do + props <- Vk.getPhysicalDeviceQueueFamilyProperties phys + pure $ + Map.fromList + [ (QueueFamilyIndex (fromIntegral i), Vk.queueCount qfp) + | (i, qfp) <- zip [0 :: Int ..] (V.toList props) + ] diff --git a/src/Vulkan/Utils/RefCounted.hs b/src/Vulkan/Utils/RefCounted.hs new file mode 100644 --- /dev/null +++ b/src/Vulkan/Utils/RefCounted.hs @@ -0,0 +1,60 @@ +{-| Lightweight reference counter that runs a release action when the count +hits zero. Useful for keeping a Vulkan object alive across an unknown number +of in-flight frames — bump the count when a frame starts using it, drop the +count when the frame retires, and the object is destroyed promptly after the +last frame finishes. +-} +module Vulkan.Utils.RefCounted + ( RefCounted + , newRefCounted + , releaseRefCounted + , takeRefCounted + , resourceTRefCount + ) where + +import Control.Exception (mask, throwIO) +import Control.Monad +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.Trans.Resource (MonadResource, allocate_) +import Data.IORef +import GHC.IO.Exception (IOErrorType (UserError), IOException (IOError)) + +-- | A 'RefCounted' will perform the specified action when the count reaches 0 +data RefCounted = RefCounted + { rcCount :: IORef Int + , rcAction :: IO () + } + +-- | Create a counter with a value of 1 +newRefCounted :: (MonadIO m) => IO () -> m RefCounted +newRefCounted rcAction = do + rcCount <- liftIO $ newIORef 1 + pure RefCounted{..} + +{- | Decrement the value, the action will be run promptly and in +this thread if the counter reached 0. +-} +releaseRefCounted :: (MonadIO m) => RefCounted -> m () +releaseRefCounted RefCounted{..} = liftIO $ mask $ \_ -> + atomicModifyIORef' rcCount (\c -> (pred c, pred c)) >>= \case + 0 -> rcAction + n + | n < 0 -> + liftIO . throwIO $ + IOError + Nothing + UserError + "" + "Ref counted value decremented below 0" + Nothing + Nothing + _ -> pure () + +-- | Increment the counter by 1 +takeRefCounted :: (MonadIO m) => RefCounted -> m () +takeRefCounted RefCounted{..} = + liftIO $ atomicModifyIORef' rcCount (\c -> (succ c, ())) + +-- | Hold a reference for the duration of the 'MonadResource' action +resourceTRefCount :: (MonadResource f) => RefCounted -> f () +resourceTRefCount r = void $ allocate_ (takeRefCounted r) (releaseRefCounted r) diff --git a/src/Vulkan/Utils/RenderPass.hs b/src/Vulkan/Utils/RenderPass.hs new file mode 100644 --- /dev/null +++ b/src/Vulkan/Utils/RenderPass.hs @@ -0,0 +1,245 @@ +{-# LANGUAGE OverloadedLists #-} + +{-| The classic render-pass drawing path: a 'Vk.RenderPass' over one or more +colour attachments (and an optional depth attachment), framebuffers over the +swapchain image views, and a vanilla pipeline that targets the render pass. + +This is one of two self-contained alternatives — see +"Vulkan.Utils.DynamicRendering" for the @VK_KHR_dynamic_rendering@ path, which +needs neither a render pass nor framebuffers. Pick one and import only it. +-} +module Vulkan.Utils.RenderPass + ( -- * Render pass + allocateRenderPass + , allocateColorRenderPass + + -- * Pipeline + , PipelineConfig (..) + , allocatePipeline + , allocatePipelineFromShaders + ) where + +import Control.Monad.IO.Unlift (MonadUnliftIO) +import Control.Monad.Trans.Resource (MonadResource, ReleaseKey, allocate) +import Data.Bits ((.|.)) +import Data.ByteString (ByteString) +import Data.Maybe (fromMaybe, isJust) +import Data.Vector (Vector) +import qualified Data.Vector as V +import Vulkan.CStruct.Extends (SomeStruct (..)) +import qualified Vulkan.Core10 as Vk +import Vulkan.Utils.DynamicState (defaultDynamicStatesFor) +import Vulkan.Utils.Pipeline.Internal (basePipelineCreateInfo, buildColorPipeline, withCompiledStages) +import Vulkan.Utils.Pipeline.Specialization (Specialization) +import Vulkan.Zero (Zero (..)) + +{- | A render pass with @colors@ colour attachments (each @(format, finalLayout)@) +and an optional depth attachment, all cleared on load and stored on completion, in +a single graphics subpass. Attachment indices are the colours @0..N-1@ then the +depth attachment at @N@ — the colour-then-depth order the framebuffer's +@attachments@ must follow. The external +dependency synchronizes colour output and, when present, the +depth fragment tests. +-} +allocateRenderPass + :: (MonadResource m) + => Vk.Device + -> Vector (Vk.Format, Vk.ImageLayout) + -- ^ Colour attachments: @(format, finalLayout)@. + -> Maybe Vk.Format + -- ^ Optional depth attachment format. + -> m (ReleaseKey, Vk.RenderPass) +allocateRenderPass dev colors depth = + Vk.withRenderPass + dev + zero + { Vk.attachments = colorDescriptions <> depthDescriptions + , Vk.subpasses = [subpass] + , Vk.dependencies = [subpassDependency] + } + Nothing + allocate + where + colorCount = V.length colors + hasColor = colorCount > 0 + hasDepth = isJust depth + + colorDescriptions :: Vector Vk.AttachmentDescription + colorDescriptions = fmap (uncurry colorAttachmentDescription) colors + + depthDescriptions :: Vector Vk.AttachmentDescription + depthDescriptions = maybe [] (V.singleton . depthAttachmentDescription) depth + + colorReferences :: Vector Vk.AttachmentReference + colorReferences = + V.imap + ( \i _ -> + zero + { Vk.attachment = fromIntegral i + , Vk.layout = Vk.IMAGE_LAYOUT_COLOR_ATTACHMENT_OPTIMAL + } + ) + colors + + depthReference :: Maybe Vk.AttachmentReference + depthReference + | hasDepth = + Just + zero + { Vk.attachment = fromIntegral colorCount + , Vk.layout = Vk.IMAGE_LAYOUT_DEPTH_ATTACHMENT_OPTIMAL + } + | otherwise = Nothing + + subpass :: Vk.SubpassDescription + subpass = + zero + { Vk.pipelineBindPoint = Vk.PIPELINE_BIND_POINT_GRAPHICS + , Vk.colorAttachments = colorReferences + , Vk.depthStencilAttachment = depthReference + } + + subpassDependency :: Vk.SubpassDependency + subpassDependency = + zero + { Vk.srcSubpass = Vk.SUBPASS_EXTERNAL + , Vk.dstSubpass = 0 + , Vk.srcStageMask = stageMask + , Vk.srcAccessMask = zero + , Vk.dstStageMask = stageMask + , Vk.dstAccessMask = accessMask + } + + stageMask = + (if hasColor then Vk.PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT else zero) + .|. ( if hasDepth + then + Vk.PIPELINE_STAGE_EARLY_FRAGMENT_TESTS_BIT + .|. Vk.PIPELINE_STAGE_LATE_FRAGMENT_TESTS_BIT + else zero + ) + accessMask = + ( if hasColor + then Vk.ACCESS_COLOR_ATTACHMENT_READ_BIT .|. Vk.ACCESS_COLOR_ATTACHMENT_WRITE_BIT + else zero + ) + .|. (if hasDepth then Vk.ACCESS_DEPTH_STENCIL_ATTACHMENT_WRITE_BIT else zero) + +colorAttachmentDescription :: Vk.Format -> Vk.ImageLayout -> Vk.AttachmentDescription +colorAttachmentDescription imageFormat finalLayout = + zero + { Vk.format = imageFormat + , Vk.samples = Vk.SAMPLE_COUNT_1_BIT + , Vk.loadOp = Vk.ATTACHMENT_LOAD_OP_CLEAR + , Vk.storeOp = Vk.ATTACHMENT_STORE_OP_STORE + , Vk.stencilLoadOp = Vk.ATTACHMENT_LOAD_OP_DONT_CARE + , Vk.stencilStoreOp = Vk.ATTACHMENT_STORE_OP_DONT_CARE + , Vk.initialLayout = Vk.IMAGE_LAYOUT_UNDEFINED + , Vk.finalLayout = finalLayout + } + +depthAttachmentDescription :: Vk.Format -> Vk.AttachmentDescription +depthAttachmentDescription imageFormat = + zero + { Vk.format = imageFormat + , Vk.samples = Vk.SAMPLE_COUNT_1_BIT + , Vk.loadOp = Vk.ATTACHMENT_LOAD_OP_CLEAR + , Vk.storeOp = Vk.ATTACHMENT_STORE_OP_STORE + , Vk.stencilLoadOp = Vk.ATTACHMENT_LOAD_OP_DONT_CARE + , Vk.stencilStoreOp = Vk.ATTACHMENT_STORE_OP_DONT_CARE + , Vk.initialLayout = Vk.IMAGE_LAYOUT_UNDEFINED + , Vk.finalLayout = Vk.IMAGE_LAYOUT_DEPTH_ATTACHMENT_OPTIMAL + } + +{- | The single-colour render pass: one attachment cleared on load and stored, +ending in @finalLayout@ (e.g. @PRESENT_SRC_KHR@ for swapchains, +@TRANSFER_SRC_OPTIMAL@ for offscreen images). The common special case of +'allocateRenderPass'. +-} +allocateColorRenderPass + :: (MonadResource m) + => Vk.Device + -> Vk.Format + -- ^ Color attachment format. + -> Vk.ImageLayout + -- ^ Final layout. + -> m (ReleaseKey, Vk.RenderPass) +allocateColorRenderPass dev imageFormat finalLayout = + allocateRenderPass dev [(imageFormat, finalLayout)] Nothing + +{- | Attachment + fixed-function knobs for a render-pass pipeline. + +Construct with 'zero' and override what differs, e.g. +@zero { RenderPass.colorFormats = [fmt], RenderPass.depthFormat = Just d }@. The +attachment shape — 'colorFormats' count and whether 'depthFormat' is present — MUST +match the render pass; the formats themselves live in the render pass, so only the +count and depth presence are read here. +-} +data PipelineConfig = PipelineConfig + { colorFormats :: [Vk.Format] + -- ^ Colour attachment formats; only the count is read (must match the render pass). + , depthFormat :: Maybe Vk.Format + -- ^ Optional depth attachment; only its presence is read (must match the render pass). + , vertexInput :: Vk.PipelineVertexInputStateCreateInfo '[] + -- ^ Vertex input (bindings + attributes); 'zero' for none. + , dynamicStates :: Maybe (Vector Vk.DynamicState) + -- ^ Dynamic states; 'Nothing' defaults layout-aware (see "Vulkan.Utils.DynamicState"). + , layout :: Maybe Vk.PipelineLayout + {- ^ Pipeline layout for descriptor sets \/ push constants; 'Nothing' uses a + transient empty layout (shaders take no resources). A supplied layout stays + owned by the caller, who must keep it alive for the pipeline's lifetime. + -} + } + +instance Zero PipelineConfig where + zero = + PipelineConfig + { colorFormats = [] + , depthFormat = Nothing + , vertexInput = zero + , dynamicStates = Nothing + , layout = Nothing + } + +{- | A vanilla vertex+fragment pipeline targeting @renderPass@ (subpass 0). The +'PipelineConfig' attachment shape MUST match @renderPass@. Whatever dynamic state +is selected MUST be set before drawing. Intended to be used qualified, e.g. +@RenderPass.allocatePipeline@. +-} +allocatePipeline + :: (MonadResource m, MonadFail m) + => Vk.Device + -> Vk.RenderPass + -> PipelineConfig + -> Vector (SomeStruct Vk.PipelineShaderStageCreateInfo) + -> m (ReleaseKey, Vk.Pipeline) +allocatePipeline dev renderPass PipelineConfig{..} stages = + buildColorPipeline dev layout $ \resolvedLayout -> + SomeStruct + ( basePipelineCreateInfo + resolvedLayout + (Just renderPass) + (length colorFormats) + (isJust depthFormat) + vertexInput + (fromMaybe (defaultDynamicStatesFor (not (null colorFormats))) dynamicStates) + stages + ) + +{- | 'allocatePipeline' from @(stage, SPIR-V)@ pairs: compile each into a shader +module, build the pipeline, then release the now-redundant module handles. + +@spec@ is one specialization shared by every stage (see +'Vulkan.Utils.Pipeline.Specialization'); pass @()@ for none. +-} +allocatePipelineFromShaders + :: (MonadResource m, MonadUnliftIO m, MonadFail m, Specialization spec) + => Vk.Device + -> Vk.RenderPass + -> PipelineConfig + -> spec + -- ^ Specialization shared by every stage; @()@ for none. + -> [(Vk.ShaderStageFlagBits, ByteString)] + -> m (ReleaseKey, Vk.Pipeline) +allocatePipelineFromShaders dev renderPass config spec shaders = + withCompiledStages dev spec shaders (allocatePipeline dev renderPass config) diff --git a/src/Vulkan/Utils/Requirements.hs b/src/Vulkan/Utils/Requirements.hs --- a/src/Vulkan/Utils/Requirements.hs +++ b/src/Vulkan/Utils/Requirements.hs @@ -1,80 +1,89 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE UndecidableSuperClasses #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} module Vulkan.Utils.Requirements ( -- * Instance requirements checkInstanceRequirements - , -- * Device requirements - checkDeviceRequirements - , -- * Results - RequirementResult(..) - , Unsatisfied(..) + + -- * Device requirements + , checkDeviceRequirements + + -- * Results + , RequirementResult (..) + , Unsatisfied (..) , requirementReport , prettyRequirementResult ) where -import Control.Arrow ( Arrow((***)) ) -import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Trans.State -import Data.Bifunctor -import Data.ByteString ( ByteString ) -import qualified Data.Dependent.Map as DMap -import Data.Dependent.Map ( DMap ) -import Data.Dependent.Sum ( DSum((:=>)) ) -import Data.Foldable -import Data.Functor.Product ( Product(..) ) -import qualified Data.HashMap.Strict as Map -import Data.Kind ( Type ) -import Data.List ( intercalate, intersect ) -import Data.List.Extra ( nubOrd ) -import Data.Proxy -import Data.Semigroup ( Endo(..) ) -import Data.Traversable -import Data.Typeable ( eqT ) -import qualified Data.Vector as V -import Data.Vector ( Vector ) -import Data.Word -import Foreign.Ptr ( FunPtr - , Ptr - , nullFunPtr - ) -import GHC.Base ( Proxy# ) -import GHC.Exts ( proxy# ) -import Type.Reflection -import Vulkan.CStruct ( FromCStruct - , ToCStruct - ) -import Vulkan.CStruct.Extends -import Vulkan.Core10 -import qualified Vulkan.Core10 as Device - ( DeviceCreateInfo(..) ) -import qualified Vulkan.Core10 as Extension - ( ExtensionProperties(..) ) -import qualified Vulkan.Core10 as Instance - ( InstanceCreateInfo(..) ) -import qualified Vulkan.Core10 as PhysicalDevice - ( PhysicalDeviceProperties(..) - , PhysicalDevice(instanceCmds) ) -import Vulkan.Core11.DeviceInitialization -import Vulkan.Core11.Promoted_From_VK_KHR_get_physical_device_properties2 -import qualified Vulkan.Core11.Promoted_From_VK_KHR_get_physical_device_properties2 - as PhysicalDevice - ( PhysicalDeviceProperties2(..) - , features ) -import Vulkan.Dynamic ( InstanceCmds - ( pVkGetPhysicalDeviceFeatures2 - , pVkGetPhysicalDeviceProperties2 - ) - ) -import Vulkan.NamedType -import Vulkan.Requirement -import Vulkan.Version -import Vulkan.Zero ( Zero(..) ) +import Control.Arrow (Arrow ((***))) +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.State +import Data.Bifunctor +import Data.ByteString (ByteString) +import Data.Foldable +import Data.Functor.Product (Product (..)) +import qualified Data.HashMap.Strict as Map +import Data.Kind (Type) +import Data.List (intercalate, intersect) +import Data.List.Extra (nubOrd) +import qualified Data.Map.Strict as TRMap +import Data.Proxy +import Data.Semigroup (Endo (..)) +import Data.Traversable +import Data.Typeable (eqT) +import Data.Vector (Vector) +import qualified Data.Vector as V +import Data.Word +import Foreign.Ptr + ( FunPtr + , Ptr + , nullFunPtr + ) +import GHC.Base (Proxy#) +import GHC.Exts (proxy#) +import Type.Reflection +import Vulkan.CStruct + ( FromCStruct + , ToCStruct + ) +import Vulkan.CStruct.Extends +import Vulkan.Core10 +import qualified Vulkan.Core10 as Device + ( DeviceCreateInfo (..) + ) +import qualified Vulkan.Core10 as Extension + ( ExtensionProperties (..) + ) +import qualified Vulkan.Core10 as Instance + ( InstanceCreateInfo (..) + ) +import qualified Vulkan.Core10 as PhysicalDevice + ( PhysicalDevice (instanceCmds) + , PhysicalDeviceProperties (..) + ) +import Vulkan.Core11.DeviceInitialization +import Vulkan.Core11.Promoted_From_VK_KHR_get_physical_device_properties2 +import qualified Vulkan.Core11.Promoted_From_VK_KHR_get_physical_device_properties2 as PhysicalDevice + ( PhysicalDeviceProperties2 (..) + , features + ) +import Vulkan.Dynamic + ( InstanceCmds + ( pVkGetPhysicalDeviceFeatures2 + , pVkGetPhysicalDeviceProperties2 + ) + ) +import Vulkan.NamedType +import Vulkan.Requirement +import Vulkan.Version +import Vulkan.Zero (Zero (..)) ---------------------------------------------------------------- + -- * Instance Creation + ---------------------------------------------------------------- checkInstanceRequirements @@ -85,24 +94,27 @@ -> o InstanceRequirement -- ^ Optional requests -> InstanceCreateInfo es - -- ^ An 'InstanceCreateInfo', this will be returned appropriately modified by - -- the requirements + {- ^ An 'InstanceCreateInfo', this will be returned appropriately modified by + the requirements + -} -> m ( Maybe (InstanceCreateInfo es) , r RequirementResult , o RequirementResult ) checkInstanceRequirements required optional baseCreateInfo = do - let requiredList = toList required - allAsList = requiredList <> toList optional - foundVersion <- enumerateInstanceVersion + let + requiredList = toList required + allAsList = requiredList <> toList optional + foundVersion <- enumerateInstanceVersion (_, layerProps) <- enumerateInstanceLayerProperties - lookupExtension <- getLookupExtension - layerProps - Nothing - [ instanceExtensionLayerName - | RequireInstanceExtension { instanceExtensionLayerName } <- allAsList - ] + lookupExtension <- + getLookupExtension + layerProps + Nothing + [ instanceExtensionLayerName + | RequireInstanceExtension{instanceExtensionLayerName} <- allAsList + ] (r, continue) <- flip runStateT True $ for required $ \r -> case checkInstanceRequest foundVersion layerProps lookupExtension r of @@ -118,12 +130,15 @@ let ici = do guard continue - pure $ makeInstanceCreateInfo (requiredList <> goodOptions) - baseCreateInfo + pure $ + makeInstanceCreateInfo + (requiredList <> goodOptions) + baseCreateInfo pure (ici, r, o) --- | Insert the settings of the requirements in to the provided instance create --- info +{- | Insert the settings of the requirements in to the provided instance create +info +-} makeInstanceCreateInfo :: forall es . [InstanceRequirement] @@ -131,58 +146,62 @@ -> InstanceCreateInfo es makeInstanceCreateInfo reqs baseCreateInfo = let - layers = [ instanceLayerName | RequireInstanceLayer {..} <- reqs ] + layers = [instanceLayerName | RequireInstanceLayer{..} <- reqs] extensions = - [ instanceExtensionName | RequireInstanceExtension {..} <- reqs ] + [instanceExtensionName | RequireInstanceExtension{..} <- reqs] in baseCreateInfo - { Instance.enabledLayerNames = - Instance.enabledLayerNames baseCreateInfo - <> V.fromList layers + { Instance.enabledLayerNames = + Instance.enabledLayerNames baseCreateInfo + <> V.fromList layers , Instance.enabledExtensionNames = - Instance.enabledExtensionNames baseCreateInfo - <> V.fromList extensions + Instance.enabledExtensionNames baseCreateInfo + <> V.fromList extensions } checkInstanceRequest :: ("apiVersion" ::: Word32) -> ("properties" ::: Vector LayerProperties) - -> ( ("layerName" ::: Maybe ByteString) - -> ByteString - -> Maybe ExtensionProperties + -> ( ("layerName" ::: Maybe ByteString) + -> ByteString + -> Maybe ExtensionProperties ) -> InstanceRequirement -> RequirementResult checkInstanceRequest foundVersion layerProps lookupExtension = \case - RequireInstanceVersion minVersion -> if foundVersion >= minVersion - then Satisfied - else UnsatisfiedInstanceVersion (Unsatisfied minVersion foundVersion) - - RequireInstanceLayer { instanceLayerName, instanceLayerMinVersion } - | Just props <- find ((== instanceLayerName) . layerName) layerProps - , foundLayerVersion <- implementationVersion props - -> if foundVersion >= instanceLayerMinVersion + RequireInstanceVersion minVersion -> + if foundVersion >= minVersion then Satisfied - else UnsatisfiedLayerVersion - instanceLayerName - (Unsatisfied instanceLayerMinVersion foundLayerVersion) - | otherwise - -> MissingLayer instanceLayerName - - RequireInstanceExtension { instanceExtensionLayerName, instanceExtensionName, instanceExtensionMinVersion } - | Just eProps <- lookupExtension instanceExtensionLayerName - instanceExtensionName - -> let foundInstanceExtensionVersion = - Extension.specVersion eProps - in if foundInstanceExtensionVersion >= instanceExtensionMinVersion + else UnsatisfiedInstanceVersion (Unsatisfied minVersion foundVersion) + RequireInstanceLayer{instanceLayerName, instanceLayerMinVersion} + | Just props <- find ((== instanceLayerName) . layerName) layerProps + , foundLayerVersion <- implementationVersion props -> + if foundVersion >= instanceLayerMinVersion + then Satisfied + else + UnsatisfiedLayerVersion + instanceLayerName + (Unsatisfied instanceLayerMinVersion foundLayerVersion) + | otherwise -> + MissingLayer instanceLayerName + RequireInstanceExtension{instanceExtensionLayerName, instanceExtensionName, instanceExtensionMinVersion} + | Just eProps <- + lookupExtension + instanceExtensionLayerName + instanceExtensionName -> + let foundInstanceExtensionVersion = + Extension.specVersion eProps + in if foundInstanceExtensionVersion >= instanceExtensionMinVersion then Satisfied - else UnsatisfiedInstanceExtensionVersion - instanceExtensionName - (Unsatisfied instanceExtensionMinVersion - foundInstanceExtensionVersion - ) - | otherwise - -> UnsatisfiedInstanceExtension instanceExtensionName + else + UnsatisfiedInstanceExtensionVersion + instanceExtensionName + ( Unsatisfied + instanceExtensionMinVersion + foundInstanceExtensionVersion + ) + | otherwise -> + UnsatisfiedInstanceExtension instanceExtensionName ---------------------------------------------------------------- -- Device @@ -197,17 +216,19 @@ -- ^ Optional requests -> PhysicalDevice -> DeviceCreateInfo '[] - -- ^ A deviceCreateInfo with no extensions. If you need elements in the - -- struct chain you can add them later with - -- 'Vulkan.CStruct.Extends.extendSomeStruct' + {- ^ A deviceCreateInfo with no extensions. If you need elements in the + struct chain you can add them later with + 'Vulkan.CStruct.Extends.extendSomeStruct' + -} -> m ( Maybe (SomeStruct DeviceCreateInfo) , r RequirementResult , o RequirementResult ) checkDeviceRequirements required optional phys baseCreateInfo = do - let requiredList = toList required - allAsList = requiredList <> toList optional + let + requiredList = toList required + allAsList = requiredList <> toList optional -- -- First collect the types and properties that we'll need to query using @@ -218,15 +239,16 @@ -- -- Fetch everything -- - feats <- getPhysicalDeviceFeaturesMaybe @fs phys - props <- getPhysicalDevicePropertiesMaybe @ps phys + feats <- getPhysicalDeviceFeaturesMaybe @fs phys + props <- getPhysicalDevicePropertiesMaybe @ps phys (_, layerProps) <- enumerateDeviceLayerProperties phys - lookupExtension <- getLookupExtension - layerProps - (Just phys) - [ deviceExtensionLayerName - | RequireDeviceExtension { deviceExtensionLayerName } <- allAsList - ] + lookupExtension <- + getLookupExtension + layerProps + (Just phys) + [ deviceExtensionLayerName + | RequireDeviceExtension{deviceExtensionLayerName} <- allAsList + ] (r, continue) <- flip runStateT True $ for required $ \r -> case checkDeviceRequest feats props lookupExtension r of @@ -245,56 +267,63 @@ -- let dci = do guard continue - pure $ makeDeviceCreateInfo (requiredList <> goodOptions) - baseCreateInfo + pure $ + makeDeviceCreateInfo + (requiredList <> goodOptions) + baseCreateInfo pure (dci, r, o) {-# ANN makeDeviceCreateInfo ("HLint: ignore Move guards forward" :: String) #-} --- | Generate 'DeviceCreateInfo' from some requirements. --- --- The returned struct chain will enable all required features and extensions. + +{- | Generate 'DeviceCreateInfo' from some requirements. + +The returned struct chain will enable all required features and extensions. +-} makeDeviceCreateInfo :: [DeviceRequirement] -> DeviceCreateInfo '[] -> SomeStruct DeviceCreateInfo makeDeviceCreateInfo allReqs baseCreateInfo = let - featureSetters :: DMap TypeRep (Product (Has KnownFeatureStruct) Endo) - featureSetters = DMap.fromListWithKey - (\_ l r -> catProducts l r) - [ typeRep :=> Pair Has (Endo enableFeature) - | RequireDeviceFeature { enableFeature } <- allReqs - ] + featureSetters :: DMap (Product (Has KnownFeatureStruct) Endo) + featureSetters = + dmapFromListWith + catProducts + [ typeRep :=> Pair Has (Endo enableFeature) + | RequireDeviceFeature{enableFeature} <- allReqs + ] makeZeroFeatureExts :: [Endo (SomeStruct DeviceCreateInfo)] makeZeroFeatureExts = [ Endo (extendSomeStruct s) - | _ :=> Pair Has (f :: Endo s) <- DMap.toList featureSetters - , ExtendedFeatureStruct <- pure $ sFeatureStruct @s + | _ :=> Pair Has (f :: Endo s) <- dmapToList featureSetters + , ExtendedFeatureStruct <- pure $ sFeatureStruct @s , let s = appEndo f zero ] addBasicFeatures :: Endo (SomeStruct DeviceCreateInfo) addBasicFeatures = - case DMap.lookup (typeRep @PhysicalDeviceFeatures) featureSetters of - Nothing -> mempty - Just (Pair _ s) -> Endo - (extendSomeStruct - ((zero :: PhysicalDeviceFeatures2 '[]) { features = appEndo s zero } + case dmapLookup (typeRep @PhysicalDeviceFeatures) featureSetters of + Nothing -> mempty + Just (Pair _ s) -> + Endo + ( extendSomeStruct + ((zero :: PhysicalDeviceFeatures2 '[]){features = appEndo s zero}) ) - ) extensionNames :: [ByteString] extensionNames = [ deviceExtensionName - | RequireDeviceExtension { deviceExtensionName } <- allReqs + | RequireDeviceExtension{deviceExtensionName} <- allReqs ] newFeatures :: SomeStruct DeviceCreateInfo - newFeatures = appEndo - (fold (addBasicFeatures : makeZeroFeatureExts)) - (SomeStruct (baseCreateInfo :: DeviceCreateInfo '[]) - { Device.enabledExtensionNames = V.fromList extensionNames - } - ) + newFeatures = + appEndo + (fold (addBasicFeatures : makeZeroFeatureExts)) + ( SomeStruct + (baseCreateInfo :: DeviceCreateInfo '[]) + { Device.enabledExtensionNames = V.fromList extensionNames + } + ) in newFeatures @@ -303,53 +332,50 @@ . (KnownChain fs, KnownChain ps) => Maybe (PhysicalDeviceFeatures2 fs) -> Maybe (PhysicalDeviceProperties2 ps) - -> ( ("layerName" ::: Maybe ByteString) - -> ("extensionName" ::: ByteString) - -> Maybe ExtensionProperties + -> ( ("layerName" ::: Maybe ByteString) + -> ("extensionName" ::: ByteString) + -> Maybe ExtensionProperties ) -- ^ Lookup an extension -> DeviceRequirement - -- ^ The requirement to test -> RequirementResult - -- ^ The result checkDeviceRequest mbFeats mbProps lookupExtension = \case RequireDeviceVersion minVersion | Just props <- mbProps - , foundVersion <- PhysicalDevice.apiVersion (PhysicalDevice.properties props) - -> if foundVersion >= minVersion - then Satisfied - else UnsatisfiedDeviceVersion (Unsatisfied minVersion foundVersion) - | otherwise - -> UnattemptedProperties "apiVersion" - - RequireDeviceFeature { featureName, checkFeature } + , foundVersion <- PhysicalDevice.apiVersion (PhysicalDevice.properties props) -> + if foundVersion >= minVersion + then Satisfied + else UnsatisfiedDeviceVersion (Unsatisfied minVersion foundVersion) + | otherwise -> + UnattemptedProperties "apiVersion" + RequireDeviceFeature{featureName, checkFeature} | Just feats <- mbFeats -> case getFeatureStruct feats of - Nothing -> - error "Impossible: didn't find requested feature in struct chain" - Just s -> - if checkFeature s then Satisfied else UnsatisfiedFeature featureName + Nothing -> + error "Impossible: didn't find requested feature in struct chain" + Just s -> + if checkFeature s then Satisfied else UnsatisfiedFeature featureName | otherwise -> UnattemptedFeatures featureName - - RequireDeviceProperty { propertyName, checkProperty } + RequireDeviceProperty{propertyName, checkProperty} | Just props <- mbProps -> case getPropertyStruct props of - Nothing -> - error "Impossible: didn't find requested property in struct chain" - Just s -> - if checkProperty s then Satisfied else UnsatisfiedProperty propertyName + Nothing -> + error "Impossible: didn't find requested property in struct chain" + Just s -> + if checkProperty s then Satisfied else UnsatisfiedProperty propertyName | otherwise -> UnattemptedProperties propertyName - - RequireDeviceExtension { deviceExtensionLayerName, deviceExtensionName, deviceExtensionMinVersion } - | Just eProps <- lookupExtension deviceExtensionLayerName - deviceExtensionName - -> let foundVersion = Extension.specVersion eProps - in if foundVersion >= deviceExtensionMinVersion + RequireDeviceExtension{deviceExtensionLayerName, deviceExtensionName, deviceExtensionMinVersion} + | Just eProps <- + lookupExtension + deviceExtensionLayerName + deviceExtensionName -> + let foundVersion = Extension.specVersion eProps + in if foundVersion >= deviceExtensionMinVersion then Satisfied - else UnsatisfiedDeviceExtensionVersion - deviceExtensionName - (Unsatisfied deviceExtensionMinVersion foundVersion) - | otherwise - -> UnsatisfiedDeviceExtension deviceExtensionName - + else + UnsatisfiedDeviceExtensionVersion + deviceExtensionName + (Unsatisfied deviceExtensionMinVersion foundVersion) + | otherwise -> + UnsatisfiedDeviceExtension deviceExtensionName ---------------------------------------------------------------- -- Results @@ -358,62 +384,67 @@ -- TODO, better version reporting for extensions -- TODO, better reporting for properties data RequirementResult - = Satisfied - -- ^ All the requirements were met - | UnattemptedProperties ByteString - -- ^ Didn't attempt this check because it required - -- getPhysicalDeviceProperties2 which wasn't loaded - | UnattemptedFeatures ByteString - -- ^ Didn't attempt this check because it required - -- getPhysicalDeviceFeatures2 which wasn't loaded - | MissingLayer ByteString - -- ^ A Layer was not found - | UnsatisfiedDeviceVersion (Unsatisfied Word32) - -- ^ A device version didn't meet the minimum requested - | UnsatisfiedInstanceVersion (Unsatisfied Word32) - -- ^ The instance version didn't meet the minimum requested - | UnsatisfiedLayerVersion ByteString (Unsatisfied Word32) - -- ^ A layer version didn't meet the minimum requested - | UnsatisfiedFeature ByteString - -- ^ A feature was missing - | UnsatisfiedProperty ByteString - -- ^ A propery was not an appropriate value - | UnsatisfiedDeviceExtension ByteString - -- ^ A device extension was missing - | UnsatisfiedDeviceExtensionVersion ByteString (Unsatisfied Word32) - -- ^ A device extension was found but the version didn't meet requirements - | UnsatisfiedInstanceExtension ByteString - -- ^ An instance extension was missing - | UnsatisfiedInstanceExtensionVersion ByteString (Unsatisfied Word32) - -- ^ An instance extension was found but the version didn't meet requirements + = -- | All the requirements were met + Satisfied + | {- | Didn't attempt this check because it required + getPhysicalDeviceProperties2 which wasn't loaded + -} + UnattemptedProperties ByteString + | {- | Didn't attempt this check because it required + getPhysicalDeviceFeatures2 which wasn't loaded + -} + UnattemptedFeatures ByteString + | -- | A Layer was not found + MissingLayer ByteString + | -- | A device version didn't meet the minimum requested + UnsatisfiedDeviceVersion (Unsatisfied Word32) + | -- | The instance version didn't meet the minimum requested + UnsatisfiedInstanceVersion (Unsatisfied Word32) + | -- | A layer version didn't meet the minimum requested + UnsatisfiedLayerVersion ByteString (Unsatisfied Word32) + | -- | A feature was missing + UnsatisfiedFeature ByteString + | -- | A propery was not an appropriate value + UnsatisfiedProperty ByteString + | -- | A device extension was missing + UnsatisfiedDeviceExtension ByteString + | -- | A device extension was found but the version didn't meet requirements + UnsatisfiedDeviceExtensionVersion ByteString (Unsatisfied Word32) + | -- | An instance extension was missing + UnsatisfiedInstanceExtension ByteString + | -- | An instance extension was found but the version didn't meet requirements + UnsatisfiedInstanceExtensionVersion ByteString (Unsatisfied Word32) deriving (Eq, Ord) data Unsatisfied a = Unsatisfied { unsatisfiedMinimum :: a - -- ^ The minimum value to be accepted - , unsatisfiedActual :: a - -- ^ The value we got, less than 'unsatisfiedMinumum' + -- ^ The minimum value to be accepted + , unsatisfiedActual :: a + -- ^ The value we got, less than 'unsatisfiedMinumum' } deriving (Eq, Ord) --- | Generate a string describing which requirements were not met, if --- everything was satisfied return 'Nothing'. +{- | Generate a string describing which requirements were not met, if +everything was satisfied return 'Nothing'. +-} requirementReport :: (Foldable r, Foldable o) => r RequirementResult -> o RequirementResult -> Maybe String requirementReport required optional = - let pList xs = - nubOrd [ prettyRequirementResult r | r <- toList xs, r /= Satisfied ] - reqStrings = pList required - optStrings = pList optional - withHeader s = \case - [] -> [] - xs -> (s <> " requirements not met:") : ((" " <>) <$> xs) - reportLines = - withHeader "Required" reqStrings <> withHeader "Optional" optStrings - in if null reportLines then Nothing else Just $ unlines reportLines + let + pList xs = + nubOrd [prettyRequirementResult r | r <- toList xs, r /= Satisfied] + reqStrings = pList required + optStrings = pList optional + withHeader s = \case + [] -> [] + xs -> (s <> " requirements not met:") : ((" " <>) <$> xs) + reportLines = + withHeader "Required" reqStrings <> withHeader "Optional" optStrings + in + if null reportLines then Nothing else Just $ unlines reportLines prettyRequirementResult :: RequirementResult -> String prettyRequirementResult = \case @@ -426,12 +457,12 @@ "Did not attempt to check " <> show n <> " because the 'getPhysicalDeviceFeatures' function was not loaded" - MissingLayer n -> "Couldn't find layer: " <> show n + MissingLayer n -> "Couldn't find layer: " <> show n UnsatisfiedInstanceVersion u -> "Unsatisfied Instance version: " <> p u - UnsatisfiedDeviceVersion u -> "Unsatisfied Device version: " <> p u + UnsatisfiedDeviceVersion u -> "Unsatisfied Device version: " <> p u UnsatisfiedLayerVersion n u -> "Unsatisfied layer version for " <> show n <> ": " <> p u - UnsatisfiedFeature n -> "Missing feature: " <> show n + UnsatisfiedFeature n -> "Missing feature: " <> show n UnsatisfiedProperty n -> "Unsatisfied property: " <> show n UnsatisfiedInstanceExtension n -> "Couldn't find instance extension: " <> show n @@ -440,11 +471,12 @@ UnsatisfiedDeviceExtension n -> "Couldn't find device extension: " <> show n UnsatisfiedDeviceExtensionVersion n u -> "Unsatisfied Device extension version " <> show n <> " " <> p u - where p = prettyUnsatisfied showVersion + where + p = prettyUnsatisfied showVersion -- How I'm feeling after writing all this type level nonsense prettyUnsatisfied :: (t -> String) -> Unsatisfied t -> String -prettyUnsatisfied s Unsatisfied {..} = +prettyUnsatisfied s Unsatisfied{..} = "Wanted minimum of " <> s unsatisfiedMinimum <> ", got: " @@ -456,9 +488,11 @@ -- | Enough information to focus on any structure within a Vulkan structure chain. class (PeekChain xs, PokeChain xs) => KnownChain (xs :: [Type]) where - -- | If the given structure can be found within a chain, return a lens to it. - -- Otherwise, return 'Nothing'. - has :: forall a. Typeable a => Proxy# a -> Maybe (Chain xs -> a, (a -> a) -> (Chain xs -> Chain xs)) + {- | If the given structure can be found within a chain, return a lens to it. + Otherwise, return 'Nothing'. + -} + has :: forall a. (Typeable a) => Proxy# a -> Maybe (Chain xs -> a, (a -> a) -> (Chain xs -> Chain xs)) + -- | Is this chain empty? knownChainNull :: Maybe (xs :~: '[]) @@ -467,8 +501,9 @@ knownChainNull = Just Refl instance (Typeable x, ToCStruct x, FromCStruct x, KnownChain xs) => KnownChain (x ': xs) where - has (px :: Proxy# a) | Just Refl <- eqT @a @x = Just (fst, first) - | otherwise = ((. snd) *** (second .)) <$> has px + has (px :: Proxy# a) + | Just Refl <- eqT @a @x = Just (fst, first) + | otherwise = ((. snd) *** (second .)) <$> has px knownChainNull = Nothing getPropertyStruct @@ -478,7 +513,7 @@ -> Maybe s getPropertyStruct c = case eqT @PhysicalDeviceProperties @s of Just Refl -> Just $ PhysicalDevice.properties c - Nothing -> getStruct c + Nothing -> getStruct c getFeatureStruct :: forall s es @@ -487,7 +522,7 @@ -> Maybe s getFeatureStruct c = case eqT @PhysicalDeviceFeatures @s of Just Refl -> Just $ PhysicalDevice.features c - Nothing -> getStruct c + Nothing -> getStruct c getStruct :: forall s h es @@ -500,26 +535,31 @@ -- Helpers for 'Device' and 'Instance' extensions ---------------------------------------------------------------- --- | Make a lookup function for extensions in layers. Ignores layers not --- present in the instance/device +{- | Make a lookup function for extensions in layers. Ignores layers not +present in the instance/device +-} getLookupExtension - :: MonadIO m + :: (MonadIO m) => Vector LayerProperties -> Maybe PhysicalDevice - -- ^ Pass 'Nothing' for 'Instance' extensions, pass a PhysicalDevice for - -- 'Device' extensions. + {- ^ Pass 'Nothing' for 'Instance' extensions, pass a PhysicalDevice for + 'Device' extensions. + -} -> ["layerName" ::: Maybe ByteString] -> m - ( ("layerName" ::: Maybe ByteString) - -> ByteString - -> Maybe ExtensionProperties + ( ("layerName" ::: Maybe ByteString) + -> ByteString + -> Maybe ExtensionProperties ) getLookupExtension layerProps mbPhys extensionLayers = do - let enumerate = maybe enumerateInstanceExtensionProperties - enumerateDeviceExtensionProperties - mbPhys - availableLayers = Nothing : ((Just . layerName) <$> V.toList layerProps) - searchedLayers = availableLayers `intersect` extensionLayers + let + enumerate = + maybe + enumerateInstanceExtensionProperties + enumerateDeviceExtensionProperties + mbPhys + availableLayers = Nothing : ((Just . layerName) <$> V.toList layerProps) + searchedLayers = availableLayers `intersect` extensionLayers extensions <- for searchedLayers $ \layer -> do (_, props) <- enumerate layer pure (layer, props) @@ -533,58 +573,58 @@ ---------------------------------------------------------------- withDevicePropertyStructs - :: forall a . [DeviceRequirement] -> ChainCont DevicePropertyChain a -> a + :: forall a. [DeviceRequirement] -> ChainCont DevicePropertyChain a -> a withDevicePropertyStructs = go @'[] [] - where - go - :: forall (fs :: [Type]) - . DevicePropertyChain fs - => [SomeTypeRep] - -> [DeviceRequirement] - -> ChainCont DevicePropertyChain a - -> a - go seen reqs f = case reqs of - -- We've been through all the reqs, call the continuation with the types - [] -> f (Proxy @fs) - -- This is a device property, add it to the list if we've not seen it before - (RequireDeviceProperty _ (_ :: s -> Bool)) : rs - | ExtendedPropertyStruct <- sPropertyStruct @s - , sRep <- SomeTypeRep (typeRep @s) - , sRep `notElem` seen - -> go @(s:fs) (sRep : seen) rs f - -- Otherwise skip - _ : rs -> go @fs seen rs f + where + go + :: forall (fs :: [Type]) + . (DevicePropertyChain fs) + => [SomeTypeRep] + -> [DeviceRequirement] + -> ChainCont DevicePropertyChain a + -> a + go seen reqs f = case reqs of + -- We've been through all the reqs, call the continuation with the types + [] -> f (Proxy @fs) + -- This is a device property, add it to the list if we've not seen it before + (RequireDeviceProperty _ (_ :: s -> Bool)) : rs + | ExtendedPropertyStruct <- sPropertyStruct @s + , sRep <- SomeTypeRep (typeRep @s) + , sRep `notElem` seen -> + go @(s : fs) (sRep : seen) rs f + -- Otherwise skip + _ : rs -> go @fs seen rs f withDeviceFeatureStructs - :: forall a . [DeviceRequirement] -> ChainCont DeviceFeatureChain a -> a + :: forall a. [DeviceRequirement] -> ChainCont DeviceFeatureChain a -> a withDeviceFeatureStructs = go @'[] [] - where - go - :: forall (fs :: [Type]) - . DeviceFeatureChain fs - => [SomeTypeRep] - -> [DeviceRequirement] - -> ChainCont DeviceFeatureChain a - -> a - go seen reqs f = case reqs of - -- We've been through all the reqs, call the continuation with the types - [] -> f (Proxy @fs) - -- This is a device feature, add it to the list if we've not seen it before - (RequireDeviceFeature _ _ (_ :: s -> s)) : rs - | ExtendedFeatureStruct <- sFeatureStruct @s - , sRep <- SomeTypeRep (typeRep @s) - , sRep `notElem` seen - -> go @(s:fs) (sRep : seen) rs f - -- Otherwise skip - _ : rs -> go @fs seen rs f + where + go + :: forall (fs :: [Type]) + . (DeviceFeatureChain fs) + => [SomeTypeRep] + -> [DeviceRequirement] + -> ChainCont DeviceFeatureChain a + -> a + go seen reqs f = case reqs of + -- We've been through all the reqs, call the continuation with the types + [] -> f (Proxy @fs) + -- This is a device feature, add it to the list if we've not seen it before + (RequireDeviceFeature _ _ (_ :: s -> s)) : rs + | ExtendedFeatureStruct <- sFeatureStruct @s + , sRep <- SomeTypeRep (typeRep @s) + , sRep `notElem` seen -> + go @(s : fs) (sRep : seen) rs f + -- Otherwise skip + _ : rs -> go @fs seen rs f -class (KnownChain es, Extendss PhysicalDeviceFeatures2 es, Show (Chain es)) => DeviceFeatureChain es where -instance (KnownChain es, Extendss PhysicalDeviceFeatures2 es, Show (Chain es)) => DeviceFeatureChain es where +class (KnownChain es, Extendss PhysicalDeviceFeatures2 es, Show (Chain es)) => DeviceFeatureChain es +instance (KnownChain es, Extendss PhysicalDeviceFeatures2 es, Show (Chain es)) => DeviceFeatureChain es -class (KnownChain es, Extendss PhysicalDeviceProperties2 es) => DevicePropertyChain es where -instance (KnownChain es, Extendss PhysicalDeviceProperties2 es) => DevicePropertyChain es where +class (KnownChain es, Extendss PhysicalDeviceProperties2 es) => DevicePropertyChain es +instance (KnownChain es, Extendss PhysicalDeviceProperties2 es) => DevicePropertyChain es -type ChainCont c a = forall (es :: [Type]) . (c es) => Proxy es -> a +type ChainCont c a = forall (es :: [Type]). (c es) => Proxy es -> a ---------------------------------------------------------------- -- Helpers for getting features and properties without using the extended @@ -596,26 +636,30 @@ . (MonadIO m, KnownChain fs, Extendss PhysicalDeviceFeatures2 fs) => PhysicalDevice -> m (Maybe (PhysicalDeviceFeatures2 fs)) -getPhysicalDeviceFeaturesMaybe = getMaybe pVkGetPhysicalDeviceFeatures2 - (PhysicalDeviceFeatures2 ()) - getPhysicalDeviceFeatures - getPhysicalDeviceFeatures2 +getPhysicalDeviceFeaturesMaybe = + getMaybe + pVkGetPhysicalDeviceFeatures2 + (PhysicalDeviceFeatures2 ()) + getPhysicalDeviceFeatures + getPhysicalDeviceFeatures2 getPhysicalDevicePropertiesMaybe :: forall fs m . (MonadIO m, KnownChain fs, Extendss PhysicalDeviceProperties2 fs) => PhysicalDevice -> m (Maybe (PhysicalDeviceProperties2 fs)) -getPhysicalDevicePropertiesMaybe = getMaybe pVkGetPhysicalDeviceProperties2 - (PhysicalDeviceProperties2 ()) - getPhysicalDeviceProperties - getPhysicalDeviceProperties2 +getPhysicalDevicePropertiesMaybe = + getMaybe + pVkGetPhysicalDeviceProperties2 + (PhysicalDeviceProperties2 ()) + getPhysicalDeviceProperties + getPhysicalDeviceProperties2 getMaybe :: forall fs s1 s2 m . (MonadIO m, KnownChain fs, Extendss s2 fs) - => ( InstanceCmds - -> FunPtr (Ptr PhysicalDevice_T -> Ptr (SomeStruct s2) -> IO ()) + => ( InstanceCmds + -> FunPtr (Ptr PhysicalDevice_T -> Ptr (SomeStruct s2) -> IO ()) ) -> (s1 -> s2 '[]) -> (PhysicalDevice -> m s1) @@ -624,9 +668,9 @@ -> m (Maybe (s2 fs)) getMaybe funPtr wrapper2 get1 get2 phys = let hasFunPtr = funPtr (PhysicalDevice.instanceCmds phys) /= nullFunPtr - in case knownChainNull @fs of - Just Refl -> Just . wrapper2 <$> get1 phys - Nothing -> if hasFunPtr then Just <$> get2 phys else pure Nothing + in case knownChainNull @fs of + Just Refl -> Just . wrapper2 <$> get1 phys + Nothing -> if hasFunPtr then Just <$> get2 phys else pure Nothing ---------------------------------------------------------------- -- Utils @@ -634,10 +678,11 @@ showVersion :: Word32 -> String showVersion ver = intercalate "." [show ma, show mi, show pa] - where MAKE_API_VERSION ma mi pa = ver + where + MAKE_API_VERSION ma mi pa = ver data Has c a where - Has ::c a => Has c a + Has :: (c a) => Has c a instance Semigroup (Has c a) where Has <> _ = Has @@ -649,3 +694,52 @@ -> Product f g a -> Product f g a catProducts (Pair a1 b1) (Pair a2 b2) = Pair (a1 <> a2) (b1 <> b2) + +---------------------------------------------------------------- +-- A minimal dependent map keyed by 'TypeRep' +-- +-- This is just enough to replace the uses of @dependent-map@ and +-- @dependent-sum@ in 'makeDeviceCreateInfo': +-- group the per-feature-struct setters by their +-- (existentially quantified) struct type, recovering that type +-- later to extend the chain. +---------------------------------------------------------------- + +{- | A dependent pair: a 'TypeRep' tag together with a value whose type is +determined by the tag. +-} +data DSum f = forall a. (TypeRep a) :=> (f a) + +infixr 1 :=> + +{- | A map from a type (witnessed by its 'TypeRep') to a value whose type +depends on that key. +-} +newtype DMap f = DMap (TRMap.Map SomeTypeRep (DSum f)) + +{- | Build a 'DMap' from a list of dependent pairs, combining the values of +any entries that share a key. +-} +dmapFromListWith :: (forall a. f a -> f a -> f a) -> [DSum f] -> DMap f +dmapFromListWith combine = + DMap + . TRMap.fromListWith merge + . map (\d@(tr :=> _) -> (SomeTypeRep tr, d)) + where + -- Both entries are stored under the same 'SomeTypeRep', so their tags + -- necessarily witness the same type; 'eqTypeRep' recovers that equality + -- so the values can be combined. The 'Nothing' case is unreachable. + merge (trNew :=> vNew) (trOld :=> vOld) = case eqTypeRep trNew trOld of + Just HRefl -> trNew :=> combine vNew vOld + Nothing -> trNew :=> vNew + +-- | The contents of a 'DMap', as dependent pairs. +dmapToList :: DMap f -> [DSum f] +dmapToList (DMap m) = TRMap.elems m + +-- | Look up the value stored under a given type. +dmapLookup :: forall a f. TypeRep a -> DMap f -> Maybe (f a) +dmapLookup tr (DMap m) = do + (trStored :=> v) <- TRMap.lookup (SomeTypeRep tr) m + HRefl <- eqTypeRep tr trStored + pure v diff --git a/src/Vulkan/Utils/Requirements/TH.hs b/src/Vulkan/Utils/Requirements/TH.hs --- a/src/Vulkan/Utils/Requirements/TH.hs +++ b/src/Vulkan/Utils/Requirements/TH.hs @@ -14,7 +14,7 @@ import Data.Either (lefts) import Data.Foldable import Data.Functor ((<&>)) -import Data.List ( intercalate, isPrefixOf, dropWhileEnd ) +import Data.List (dropWhileEnd, intercalate, isPrefixOf) import Data.List.Extra (nubOrd) import Data.Maybe import Data.String @@ -33,76 +33,79 @@ import Vulkan.Version (pattern MAKE_API_VERSION) import Prelude hiding (GT) --- $setup --- >>> import Vulkan.Core11.Promoted_From_VK_KHR_multiview --- >>> import Vulkan.Core12 --- >>> import Vulkan.Extensions.VK_KHR_ray_tracing_pipeline --- >>> import Vulkan.Zero +{- $setup +>>> import Vulkan.Core11.Promoted_From_VK_KHR_multiview +>>> import Vulkan.Core12 +>>> import Vulkan.Extensions.VK_KHR_ray_tracing_pipeline +>>> import Vulkan.Zero +-} --- | Parse a requirement and produce an appropriate 'DeviceRequirement' --- --- 'DeviceVersionRequirement's are specified by in the form --- @.[.]@ --- --- 'DeviceFeatureRequirement's are specified in the form @.@ and produce a 'RequireDeviceFeature' which checks and sets this --- feature. --- --- 'DevicePropertyRequirement's are specified like feature requirements except --- with an additional description of the constraint. This may be any of --- --- - @myFunctionName@: To check with an in-scope function taking the property --- type and returning 'Bool' --- - @> 123@: To indicate a minimum bound on a integral property --- - @>= 123@: To indicate an inclusive minimum bound on a integral property --- - @& SOMETHING_BIT@: To indicate that the specified bit must be present in --- the bitmask value --- --- 'DeviceExtensionRequirement's are specified in the form @ --- @. @@ must start with @VK_@. The version --- will be compared against the 'specVersion' field of the --- 'ExtensionProperties' record. --- --- - Names may be qualified. --- - The separator between the type and member can be any of @.@ @::@ @:@ @->@ --- or any amount of space --- --- >>> let r = [req|PhysicalDeviceRayTracingPipelineFeaturesKHR.rayTracingPipeline|] --- >>> featureName r --- "PhysicalDeviceRayTracingPipelineFeaturesKHR.rayTracingPipeline" --- --- >>> let r = [req|PhysicalDeviceVulkan11Features.multiview|] --- >>> featureName r --- "PhysicalDeviceVulkan11Features.multiview" --- --- >>> let r = [reqs| PhysicalDeviceTimelineSemaphoreFeatures.timelineSemaphore |] --- >>> featureName <$> r --- ["PhysicalDeviceTimelineSemaphoreFeatures.timelineSemaphore"] --- --- >>> let r = [req|PhysicalDeviceMultiviewFeatures.doesn'tExist|] --- ... --- • Couldn't find member "doesn'tExist" in Vulkan.Core11.Promoted_From_VK_KHR_multiview.PhysicalDeviceMultiviewFeatures --- ... --- --- >>> let r = [req|Doesn'tExist.multiview|] --- ... --- • Couldn't find type name "Doesn'tExist" --- ... --- --- >>> let r = [req|Either.multiview|] --- ... --- • Data.Either.Either doesn't seem to be the type of a record constructor --- ... +{- | Parse a requirement and produce an appropriate 'DeviceRequirement' + +'DeviceVersionRequirement's are specified by in the form +@.[.]@ + +'DeviceFeatureRequirement's are specified in the form @.@ and produce a 'RequireDeviceFeature' which checks and sets this +feature. + +'DevicePropertyRequirement's are specified like feature requirements except +with an additional description of the constraint. This may be any of + +- @myFunctionName@: To check with an in-scope function taking the property + type and returning 'Bool' +- @> 123@: To indicate a minimum bound on a integral property +- @>= 123@: To indicate an inclusive minimum bound on a integral property +- @& SOMETHING_BIT@: To indicate that the specified bit must be present in + the bitmask value + +'DeviceExtensionRequirement's are specified in the form @ +@. @@ must start with @VK_@. The version +will be compared against the 'specVersion' field of the +'ExtensionProperties' record. + +- Names may be qualified. +- The separator between the type and member can be any of @.@ @::@ @:@ @->@ + or any amount of space + +>>> let r = [req|PhysicalDeviceRayTracingPipelineFeaturesKHR.rayTracingPipeline|] +>>> featureName r +"PhysicalDeviceRayTracingPipelineFeaturesKHR.rayTracingPipeline" + +>>> let r = [req|PhysicalDeviceVulkan11Features.multiview|] +>>> featureName r +"PhysicalDeviceVulkan11Features.multiview" + +>>> let r = [reqs| PhysicalDeviceTimelineSemaphoreFeatures.timelineSemaphore |] +>>> featureName <$> r +["PhysicalDeviceTimelineSemaphoreFeatures.timelineSemaphore"] + +>>> let r = [req|PhysicalDeviceMultiviewFeatures.doesn'tExist|] +... + • Couldn't find member "doesn'tExist" in Vulkan.Core11.Promoted_From_VK_KHR_multiview.PhysicalDeviceMultiviewFeatures +... + +>>> let r = [req|Doesn'tExist.multiview|] +... + • Couldn't find type name "Doesn'tExist" +... + +>>> let r = [req|Either.multiview|] +... + • Data.Either.Either doesn't seem to be the type of a record constructor +... +-} req :: QuasiQuoter req = (badQQ "req"){quoteExp = reqExp} --- | Like 'reqs' except that this parses a list of newline separated --- requirements --- --- It ignores --- --- - Blank lines --- - Lines beginning with @--@ or @#@ +{- | Like 'reqs' except that this parses a list of newline separated +requirements + +It ignores + +- Blank lines +- Lines beginning with @--@ or @#@ +-} reqs :: QuasiQuoter reqs = (badQQ "req"){quoteExp = exps reqExp . filterComments} @@ -117,38 +120,48 @@ renderRequest :: String -> Request Name Name -> ExpQ renderRequest input = \case Feature s m -> - let check = explicitRecordGet s m (ConT ''Bool) - enable = explicitRecordSet s m (ConT ''Bool) [|True|] - in do - [| - let featureName = fromString $(lift input) - checkFeature = $(check) - enableFeature = $(enable) - in RequireDeviceFeature featureName checkFeature enableFeature - |] - Property s m c -> - let t = conT s - getProp = [|\str -> $(varE m) (str :: $t)|] - checker = case c of - GTE v -> [|(>= $(litE (IntegerL v)))|] - GT v -> [|(> $(litE (IntegerL v)))|] - AndBit b -> [|(.&&. $(conE b))|] - Fun f -> [|$(varE f)|] - check = [|$checker . $getProp|] - in [| - let propertyName = fromString $(lift input) - checkProperty = $(check) - in RequireDeviceProperty propertyName checkProperty + let + check = explicitRecordGet s m (ConT ''Bool) + enable = explicitRecordSet s m (ConT ''Bool) [|True|] + in + do + [| + let + featureName = fromString $(lift input) + checkFeature = $(check) + enableFeature = $(enable) + in + RequireDeviceFeature featureName checkFeature enableFeature |] + Property s m c -> + let + t = conT s + getProp = [|\str -> $(varE m) (str :: $t)|] + checker = case c of + GTE v -> [|(>= $(litE (IntegerL v)))|] + GT v -> [|(> $(litE (IntegerL v)))|] + AndBit b -> [|(.&&. $(conE b))|] + Fun f -> [|$(varE f)|] + check = [|$checker . $getProp|] + in + [| + let + propertyName = fromString $(lift input) + checkProperty = $(check) + in + RequireDeviceProperty propertyName checkProperty + |] Extension s v -> [| - let deviceExtensionLayerName = Nothing - deviceExtensionName = fromString $(lift s) - deviceExtensionMinVersion = $(lift (fromMaybe minBound v)) - in RequireDeviceExtension - deviceExtensionLayerName - deviceExtensionName - deviceExtensionMinVersion + let + deviceExtensionLayerName = Nothing + deviceExtensionName = fromString $(lift s) + deviceExtensionMinVersion = $(lift (fromMaybe minBound v)) + in + RequireDeviceExtension + deviceExtensionLayerName + deviceExtensionName + deviceExtensionMinVersion |] Version v -> [|RequireDeviceVersion $(lift v)|] @@ -165,15 +178,15 @@ pure $ Property sName mName c' Extension s v -> pure $ Extension s v Version v -> pure $ Version v - where - getQualTyName n = do - let q = intercalate "." n - maybe (fail $ "Couldn't find type name " <> show q) pure - =<< lookupTypeName q - getQualValueName n = do - let q = intercalate "." n - maybe (fail $ "Couldn't find value name " <> show q) pure - =<< lookupValueName q + where + getQualTyName n = do + let q = intercalate "." n + maybe (fail $ "Couldn't find type name " <> show q) pure + =<< lookupTypeName q + getQualValueName n = do + let q = intercalate "." n + maybe (fail $ "Couldn't find value name " <> show q) pure + =<< lookupValueName q data Request qual unqual = Version Word32 @@ -189,104 +202,107 @@ | Fun qual deriving (Show, Functor, Foldable, Traversable) --- | --- >>> parse "" --- Nothing --- --- >>> parse "Foo->bar" --- Just (Feature ["Foo"] "bar") --- --- >>> parse "V.Foo.bar" --- Just (Feature ["V","Foo"] "bar") --- --- >>> parse "V.E.Foo bar" --- Just (Feature ["V","E","Foo"] "bar") --- --- >>> parse "1.2" --- Just (Version 4202496) --- --- >>> parse "1 2 1" --- Just (Version 4202497) --- --- >>> parse "Foo.bar >= 10" --- Just (Property ["Foo"] "bar" (GTE 10)) --- --- >>> parse "V.Foo.bar & A.B.C_BIT" --- Just (Property ["V","Foo"] "bar" (AndBit ["A","B","C_BIT"])) --- --- >>> parse "V.Foo.bar even" --- Just (Property ["V","Foo"] "bar" (Fun ["even"])) --- --- >>> parse "V.Foo.bar Prelude.even" --- Just (Property ["V","Foo"] "bar" (Fun ["Prelude","even"])) +{- | +>>> parse "" +Nothing + +>>> parse "Foo->bar" +Just (Feature ["Foo"] "bar") + +>>> parse "V.Foo.bar" +Just (Feature ["V","Foo"] "bar") + +>>> parse "V.E.Foo bar" +Just (Feature ["V","E","Foo"] "bar") + +>>> parse "1.2" +Just (Version 4202496) + +>>> parse "1 2 1" +Just (Version 4202497) + +>>> parse "Foo.bar >= 10" +Just (Property ["Foo"] "bar" (GTE 10)) + +>>> parse "V.Foo.bar & A.B.C_BIT" +Just (Property ["V","Foo"] "bar" (AndBit ["A","B","C_BIT"])) + +>>> parse "V.Foo.bar even" +Just (Property ["V","Foo"] "bar" (Fun ["even"])) + +>>> parse "V.Foo.bar Prelude.even" +Just (Property ["V","Foo"] "bar" (Fun ["Prelude","even"])) +-} parse :: String -> Maybe (Request [String] String) parse = - let varRemChars = munch (isAlphaNum <||> (== '\'') <||> (== '_')) - var = (:) <$> satisfy (isLower <||> (== '_')) <*> varRemChars - con = (:) <$> satisfy isUpper <*> varRemChars - mod' = con - qual :: ReadP String -> ReadP [String] - qual x = (pure <$> x) <|> ((:) <$> (mod' <* char '.') <*> qual x) - separator = asum (skipSpaces : (void . string <$> [".", "->", "::", ":"])) + let + varRemChars = munch (isAlphaNum <||> (== '\'') <||> (== '_')) + var = (:) <$> satisfy (isLower <||> (== '_')) <*> varRemChars + con = (:) <$> satisfy isUpper <*> varRemChars + mod' = con + qual :: ReadP String -> ReadP [String] + qual x = (pure <$> x) <|> ((:) <$> (mod' <* char '.') <*> qual x) + separator = asum (skipSpaces : (void . string <$> [".", "->", "::", ":"])) - digits = munch1 isDigit - integer = readS_to_P (reads @Integer) - word = do - Just w <- readMaybe <$> digits - pure w + digits = munch1 isDigit + integer = readS_to_P (reads @Integer) + word = do + Just w <- readMaybe <$> digits + pure w - comp = do - c <- (GT <$ string ">") <|> (GTE <$ string ">=") - skipSpaces - w <- integer - pure $ c w - andBit = do - _ <- string "&" - skipSpaces - q <- qual con - pure $ AndBit q - fun = Fun <$> qual var - constraint = comp <|> andBit <|> fun + comp = do + c <- (GT <$ string ">") <|> (GTE <$ string ">=") + skipSpaces + w <- integer + pure $ c w + andBit = do + _ <- string "&" + skipSpaces + q <- qual con + pure $ AndBit q + fun = Fun <$> qual var + constraint = comp <|> andBit <|> fun - version = do - ma <- word - separator - mi <- word - pa <- fromMaybe 0 <$> (separator *> optional word) - pure $ Version (MAKE_API_VERSION ma mi pa) + version = do + ma <- word + separator + mi <- word + pa <- fromMaybe 0 <$> (separator *> optional word) + pure $ Version (MAKE_API_VERSION ma mi pa) - feature = do - s <- qual con - _ <- separator - m <- var - pure $ Feature s m + feature = do + s <- qual con + _ <- separator + m <- var + pure $ Feature s m - property = do - s <- qual con - _ <- separator - m <- var - skipSpaces - c <- constraint - pure $ Property s m c + property = do + s <- qual con + _ <- separator + m <- var + skipSpaces + c <- constraint + pure $ Property s m c - extension = do - let prefix = "VK_" - _ <- string prefix - e <- (prefix <>) <$> munch (isAlphaNum <||> (== '_')) - skipSpaces - v <- optional word - pure $ Extension e v + extension = do + let prefix = "VK_" + _ <- string prefix + e <- (prefix <>) <$> munch (isAlphaNum <||> (== '_')) + skipSpaces + v <- optional word + pure $ Extension e v - request = do - skipSpaces - asum - [ p <* skipSpaces <* eof - | p <- [version, feature, property, extension] - ] - in readP_to_S request >>> \case - -- xs -> pure $ Feature [] (show xs) - [(r, "")] -> pure r - _ -> Nothing + request = do + skipSpaces + asum + [ p <* skipSpaces <* eof + | p <- [version, feature, property, extension] + ] + in + readP_to_S request >>> \case + -- xs -> pure $ Feature [] (show xs) + [(r, "")] -> pure r + _ -> Nothing {-# ANN parse ("HLint: ignore Use <$>" :: String) #-} ---------------------------------------------------------------- @@ -297,7 +313,7 @@ filterComments :: String -> [String] filterComments = let bad = (("--" `isPrefixOf`) <||> ("#" `isPrefixOf`) <||> null) - in nubOrd . filter (not . bad) . fmap strip . lines + in nubOrd . filter (not . bad) . fmap strip . lines strip :: String -> String strip = dropWhile isSpace . dropWhileEnd isSpace @@ -305,7 +321,7 @@ exps :: (String -> ExpQ) -> [String] -> ExpQ exps f = listE . fmap f -(<||>) :: Applicative f => f Bool -> f Bool -> f Bool +(<||>) :: (Applicative f) => f Bool -> f Bool -> f Bool (<||>) = liftA2 (||) ---------------------------------------------------------------- @@ -354,31 +370,34 @@ -- ^ (Constructor, [Left var name, Right selected member type]) overRecord s (nameBase -> m) t = do reify s >>= \case - TyConI (DataD _ _ _ _ [c] _) | RecC con vs <- c -> - let ns = vs <&> \case - (nameBase -> n, _bang, t') | n == m -> Left t' - | otherwise -> Right n - in case lefts ns of - [] -> fail $ "Couldn't find member " <> show m <> " in " <> show s - [t'] - | t == t' - -> pure (con, ns) - | otherwise - -> fail - $ "Member " - <> show m - <> " of " - <> show s - <> " has type " - <> show t' - <> " but we expected " - <> show t - _ -> - fail - $ "Found multiple members called" - <> show m - <> " in " - <> show s - <> " ...what?" + TyConI (DataD _ _ _ _ [c] _) + | RecC con vs <- c -> + let ns = + vs <&> \case + (nameBase -> n, _bang, t') + | n == m -> Left t' + | otherwise -> Right n + in case lefts ns of + [] -> fail $ "Couldn't find member " <> show m <> " in " <> show s + [t'] + | t == t' -> + pure (con, ns) + | otherwise -> + fail $ + "Member " + <> show m + <> " of " + <> show s + <> " has type " + <> show t' + <> " but we expected " + <> show t + _ -> + fail $ + "Found multiple members called" + <> show m + <> " in " + <> show s + <> " ...what?" _ -> fail $ show s <> " doesn't seem to be the type of a record constructor" diff --git a/src/Vulkan/Utils/Shader.hs b/src/Vulkan/Utils/Shader.hs new file mode 100644 --- /dev/null +++ b/src/Vulkan/Utils/Shader.hs @@ -0,0 +1,55 @@ +module Vulkan.Utils.Shader + ( shaderStage + , shaderModuleStage + ) where + +import Control.Monad.Trans.Resource (MonadResource, ReleaseKey, allocate) +import Data.ByteString (ByteString) +import Vulkan.CStruct.Extends (SomeStruct (..)) +import qualified Vulkan.Core10 as Vk +import Vulkan.Utils.Pipeline.Specialization (Specialization, allocateSpecialization) +import Vulkan.Zero (zero) + +{- | Build a 'PipelineShaderStageCreateInfo' for a single SPIR-V module with +entry point @main@. The returned 'ReleaseKey' frees the module — release it +once the pipeline is built. + +The @spec@ argument supplies specialization constants (see +'Vulkan.Utils.Pipeline.Specialization'); pass @()@ for none. +-} +shaderStage + :: (MonadResource m, Specialization spec) + => Vk.Device + -> Vk.ShaderStageFlagBits + -> spec + -> ByteString + -> m (ReleaseKey, SomeStruct Vk.PipelineShaderStageCreateInfo) +shaderStage dev stage spec code = do + specializationInfo <- allocateSpecialization spec + shaderModuleStage dev stage specializationInfo code + +{- | Lower-level companion to 'shaderStage' taking an already-built +'Vk.SpecializationInfo' (or 'Nothing'). Useful when one specialization is shared +across several stages — build it once with +'Vulkan.Utils.Pipeline.Specialization.withSpecialization' and pass it to each +stage rather than re-packing per stage. +-} +shaderModuleStage + :: (MonadResource m) + => Vk.Device + -> Vk.ShaderStageFlagBits + -> Maybe Vk.SpecializationInfo + -> ByteString + -> m (ReleaseKey, SomeStruct Vk.PipelineShaderStageCreateInfo) +shaderModuleStage dev stage specializationInfo code = do + (key, module') <- Vk.withShaderModule dev zero{Vk.code = code} Nothing allocate + pure + ( key + , SomeStruct + zero + { Vk.stage + , Vk.module' + , Vk.name = "main" + , Vk.specializationInfo + } + ) diff --git a/src/Vulkan/Utils/ShaderQQ/Backend/Glslang.hs b/src/Vulkan/Utils/ShaderQQ/Backend/Glslang.hs --- a/src/Vulkan/Utils/ShaderQQ/Backend/Glslang.hs +++ b/src/Vulkan/Utils/ShaderQQ/Backend/Glslang.hs @@ -4,9 +4,9 @@ , processGlslangMessages ) where -import qualified Data.ByteString.Lazy.Char8 as BSL -import Data.List.Extra -import System.FilePath +import qualified Data.ByteString.Lazy.Char8 as BSL +import Data.List.Extra +import System.FilePath type GlslangError = String type GlslangWarning = String @@ -14,10 +14,12 @@ processGlslangMessages :: BSL.ByteString -> ([GlslangWarning], [GlslangError]) processGlslangMessages = foldr grep ([], []) . filter (not . null) . lines . BSL.unpack - where - grep line (ws, es) | "WARNING: " `isPrefixOf` line = (cut line : ws, es) - | "ERROR: " `isPrefixOf` line = (ws, cut line : es) - | otherwise = (ws, es) + where + grep line (ws, es) + | "WARNING: " `isPrefixOf` line = (cut line : ws, es) + | "ERROR: " `isPrefixOf` line = (ws, cut line : es) + | otherwise = (ws, es) - cut line = takeFileName path <> msg - where (path, msg) = break (== ':') . drop 1 $ dropWhile (/= ' ') line + cut line = takeFileName path <> msg + where + (path, msg) = break (== ':') . drop 1 $ dropWhile (/= ' ') line diff --git a/src/Vulkan/Utils/ShaderQQ/Backend/Glslang/Internal.hs b/src/Vulkan/Utils/ShaderQQ/Backend/Glslang/Internal.hs --- a/src/Vulkan/Utils/ShaderQQ/Backend/Glslang/Internal.hs +++ b/src/Vulkan/Utils/ShaderQQ/Backend/Glslang/Internal.hs @@ -3,30 +3,30 @@ , compileShader ) where -import Control.Monad.IO.Class -import Data.ByteString ( ByteString ) -import qualified Data.ByteString as BS -import Data.FileEmbed -import Language.Haskell.TH -import System.Exit -import System.IO.Temp -import System.Process.Typed -import Vulkan.Utils.ShaderQQ.ShaderType -import qualified Vulkan.Utils.ShaderQQ.GLSL as GLSL -import qualified Vulkan.Utils.ShaderQQ.HLSL as HLSL -import Vulkan.Utils.ShaderQQ.Backend.Glslang -import Vulkan.Utils.ShaderQQ.Backend.Internal +import Control.Monad.IO.Class +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.FileEmbed +import Language.Haskell.TH +import System.Exit +import System.IO.Temp +import System.Process.Typed +import Vulkan.Utils.ShaderQQ.Backend.Glslang +import Vulkan.Utils.ShaderQQ.Backend.Internal +import qualified Vulkan.Utils.ShaderQQ.GLSL as GLSL +import qualified Vulkan.Utils.ShaderQQ.HLSL as HLSL +import Vulkan.Utils.ShaderQQ.ShaderType -- * Utilities --- | Compile a GLSL/HLSL shader to spir-v using glslangValidator. --- --- Messages are converted to GHC warnings or errors depending on compilation success. +{- | Compile a GLSL/HLSL shader to spir-v using glslangValidator. + +Messages are converted to GHC warnings or errors depending on compilation success. +-} compileShaderQ :: Maybe String -- ^ Argument to pass to `--target-env` -> ShaderType - -- ^ Argument to specify between glsl/hlsl shader -> String -- ^ stage -> Maybe String @@ -36,20 +36,19 @@ -> Q Exp -- ^ Spir-V bytecode compileShaderQ targetEnv shaderType stage entryPoint code = do - loc <- location + loc <- location (warnings, result) <- compileShader (Just loc) targetEnv shaderType stage entryPoint code bs <- messageProcess "glslangValidator" reportWarning fail (warnings, result) bsToExp bs -- | Compile a GLSL/HLSL shader to spir-v using glslangValidator compileShader - :: MonadIO m + :: (MonadIO m) => Maybe Loc -- ^ Source location -> Maybe String -- ^ Argument to pass to `--target-env` -> ShaderType - -- ^ Argument to specify between glsl/hlsl shader -> String -- ^ stage -> Maybe String @@ -60,27 +59,33 @@ -- ^ Spir-V bytecode with warnings or errors compileShader loc targetEnv shaderType stage entryPoint code = liftIO $ withSystemTempDirectory "th-shader" $ \dir -> do - let codeWithLineDirective = maybe code (case shaderType of - GLSL -> GLSL.insertLineDirective code - HLSL -> HLSL.insertLineDirective code - ) loc - let shader = dir <> "/shader." <> stage - spirv = dir <> "/shader.spv" + let codeWithLineDirective = + maybe + code + ( case shaderType of + GLSL -> GLSL.insertLineDirective code + HLSL -> HLSL.insertLineDirective code + ) + loc + let + shader = dir <> "/shader." <> stage + spirv = dir <> "/shader.spv" writeFile shader codeWithLineDirective - let targetArgs = case targetEnv of - Nothing -> [] - Just t -> ["--target-env", t] - shaderTypeArgs = case shaderType of - GLSL -> [] - HLSL -> ["-D"] - -- https://github.com/KhronosGroup/glslang/issues/1045#issuecomment-328707953 - entryPointArgs = case entryPoint of - Nothing -> [] - Just name -> case shaderType of - GLSL -> ["-e", name, "--source-entry-point", "main"] - HLSL -> ["-e", name] - args = targetArgs ++ shaderTypeArgs ++ entryPointArgs ++ ["-S", stage, "-V", shader, "-o", spirv] + let + targetArgs = case targetEnv of + Nothing -> [] + Just t -> ["--target-env", t] + shaderTypeArgs = case shaderType of + GLSL -> [] + HLSL -> ["-D"] + -- https://github.com/KhronosGroup/glslang/issues/1045#issuecomment-328707953 + entryPointArgs = case entryPoint of + Nothing -> [] + Just name -> case shaderType of + GLSL -> ["-e", name, "--source-entry-point", "main"] + HLSL -> ["-e", name] + args = targetArgs ++ shaderTypeArgs ++ entryPointArgs ++ ["-S", stage, "-V", shader, "-o", spirv] (rc, out, err) <- readProcess $ proc "glslangValidator" args let (warnings, errors) = processGlslangMessages (out <> err) case rc of diff --git a/src/Vulkan/Utils/ShaderQQ/Backend/Internal.hs b/src/Vulkan/Utils/ShaderQQ/Backend/Internal.hs --- a/src/Vulkan/Utils/ShaderQQ/Backend/Internal.hs +++ b/src/Vulkan/Utils/ShaderQQ/Backend/Internal.hs @@ -2,8 +2,8 @@ ( messageProcess ) where -import Data.ByteString ( ByteString ) -import Data.List.Extra +import Data.ByteString (ByteString) +import Data.List.Extra messageProcess :: (Applicative m, Monad m) @@ -19,10 +19,10 @@ -- ^ Spir-V bytecode messageProcess tool warn err (warnings, result) = do case warnings of - [] -> pure () + [] -> pure () _some -> warn $ prepare warnings case result of - Left [] -> err $ tool ++ " failed with no errors" + Left [] -> err $ tool ++ " failed with no errors" Left errors -> do _ <- err $ prepare errors pure mempty diff --git a/src/Vulkan/Utils/ShaderQQ/Backend/Shaderc.hs b/src/Vulkan/Utils/ShaderQQ/Backend/Shaderc.hs --- a/src/Vulkan/Utils/ShaderQQ/Backend/Shaderc.hs +++ b/src/Vulkan/Utils/ShaderQQ/Backend/Shaderc.hs @@ -4,10 +4,10 @@ , processShadercMessages ) where -import Control.Monad ( void ) -import qualified Data.ByteString.Lazy.Char8 as BSL -import Data.Foldable ( asum ) -import Text.ParserCombinators.ReadP +import Control.Monad (void) +import qualified Data.ByteString.Lazy.Char8 as BSL +import Data.Foldable (asum) +import Text.ParserCombinators.ReadP type ShadercError = String type ShadercWarning = String @@ -39,59 +39,61 @@ -- >>> parseMsg "foo: foo(1): error at column 3, HLSL parsing failed." -- ([],["foo:1: error at column 3, HLSL parsing failed."]) parseMsg :: String -> ([ShadercWarning], [ShadercError]) -parseMsg = runParser $ foldl1 - (<++) - [ do - f <- filename - line <- between colon colon number - skipSpaces - t <- msgType - msg <- manyTill get eof - pure $ formatMsg t f line msg - , do - f <- filename - colon *> skipSpaces - t <- msgType - _ <- string f - line <- between (char ':') (char ':') number - skipSpaces - msg <- manyTill get eof - pure $ formatMsg t f line msg - , do - f <- filename - colon *> skipSpaces - _ <- string f - line <- between (char '(') (char ')') number - colon *> skipSpaces - let t x = ([], [x]) - msg <- manyTill get eof - pure $ formatMsg t f line msg - , do - _ <- number - skipSpaces - _ <- string "errors generated" - eof - pure ([], []) - , do - -- Unknown format - msg <- manyTill get eof - eof - pure ([], [msg]) - ] - where - formatMsg t f line msg = t (f <> ":" <> show line <> ": " <> msg) - filename = many1 get - number = readS_to_P (reads @Integer) - colon = void $ char ':' - msgType = - asum +parseMsg = + runParser $ + foldl1 + (<++) + [ do + f <- filename + line <- between colon colon number + skipSpaces + t <- msgType + msg <- manyTill get eof + pure $ formatMsg t f line msg + , do + f <- filename + colon *> skipSpaces + t <- msgType + _ <- string f + line <- between (char ':') (char ':') number + skipSpaces + msg <- manyTill get eof + pure $ formatMsg t f line msg + , do + f <- filename + colon *> skipSpaces + _ <- string f + line <- between (char '(') (char ')') number + colon *> skipSpaces + let t x = ([], [x]) + msg <- manyTill get eof + pure $ formatMsg t f line msg + , do + _ <- number + skipSpaces + _ <- string "errors generated" + eof + pure ([], []) + , do + -- Unknown format + msg <- manyTill get eof + eof + pure ([], [msg]) + ] + where + formatMsg t f line msg = t (f <> ":" <> show line <> ": " <> msg) + filename = many1 get + number = readS_to_P (reads @Integer) + colon = void $ char ':' + msgType = + asum [ (\x -> ([], [x])) <$ string "error" , (\x -> ([x], [])) <$ string "warning" ] - <* colon - <* skipSpaces + <* colon + <* skipSpaces -runParser :: Monoid p => ReadP p -> String -> p +runParser :: (Monoid p) => ReadP p -> String -> p runParser p s = case readP_to_S p s of [(r, "")] -> r - _ -> mempty + _ -> mempty diff --git a/src/Vulkan/Utils/ShaderQQ/Backend/Shaderc/Internal.hs b/src/Vulkan/Utils/ShaderQQ/Backend/Shaderc/Internal.hs --- a/src/Vulkan/Utils/ShaderQQ/Backend/Shaderc/Internal.hs +++ b/src/Vulkan/Utils/ShaderQQ/Backend/Shaderc/Internal.hs @@ -3,30 +3,30 @@ , compileShader ) where -import Control.Monad.IO.Class -import Data.ByteString ( ByteString ) -import qualified Data.ByteString as BS -import Data.FileEmbed -import Language.Haskell.TH -import System.Exit -import System.IO.Temp -import System.Process.Typed -import Vulkan.Utils.ShaderQQ.ShaderType -import qualified Vulkan.Utils.ShaderQQ.GLSL as GLSL -import qualified Vulkan.Utils.ShaderQQ.HLSL as HLSL -import Vulkan.Utils.ShaderQQ.Backend.Shaderc -import Vulkan.Utils.ShaderQQ.Backend.Internal +import Control.Monad.IO.Class +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.FileEmbed +import Language.Haskell.TH +import System.Exit +import System.IO.Temp +import System.Process.Typed +import Vulkan.Utils.ShaderQQ.Backend.Internal +import Vulkan.Utils.ShaderQQ.Backend.Shaderc +import qualified Vulkan.Utils.ShaderQQ.GLSL as GLSL +import qualified Vulkan.Utils.ShaderQQ.HLSL as HLSL +import Vulkan.Utils.ShaderQQ.ShaderType -- * Utilities --- | Compile a GLSL/HLSL shader to SPIR-V using glslc (from the shaderc project) --- --- Messages are converted to GHC warnings or errors depending on compilation success. +{- | Compile a GLSL/HLSL shader to SPIR-V using glslc (from the shaderc project) + +Messages are converted to GHC warnings or errors depending on compilation success. +-} compileShaderQ :: Maybe String -- ^ Argument to pass to `--target-spv` -> ShaderType - -- ^ Argument to specify between glsl/hlsl shader -> String -- ^ stage -> Maybe String @@ -36,20 +36,19 @@ -> Q Exp -- ^ Spir-V bytecode compileShaderQ targetSpv shaderType stage entryPoint code = do - loc <- location + loc <- location (warnings, result) <- compileShader (Just loc) targetSpv shaderType stage entryPoint code bs <- messageProcess "glslc" reportWarning fail (warnings, result) bsToExp bs -- | Compile a GLSL/HLSL shader to spir-v using glslc compileShader - :: MonadIO m + :: (MonadIO m) => Maybe Loc -- ^ Source location -> Maybe String -- ^ Argument to pass to `--target-spv` -> ShaderType - -- ^ Argument to specify between glsl/hlsl shader -> String -- ^ stage -> Maybe String @@ -60,24 +59,30 @@ -- ^ Spir-V bytecode with warnings or errors compileShader loc targetSpv shaderType stage entryPoint code = liftIO $ withSystemTempDirectory "th-shader" $ \dir -> do - let codeWithLineDirective = maybe code (case shaderType of - GLSL -> GLSL.insertLineDirective code - HLSL -> HLSL.insertLineDirective code - ) loc - let shader = dir <> "/shader." <> stage - spirv = dir <> "/shader.spv" + let codeWithLineDirective = + maybe + code + ( case shaderType of + GLSL -> GLSL.insertLineDirective code + HLSL -> HLSL.insertLineDirective code + ) + loc + let + shader = dir <> "/shader." <> stage + spirv = dir <> "/shader.spv" writeFile shader codeWithLineDirective - let targetArgs = case targetSpv of - Nothing -> [] - Just t -> ["--target-spv=" <> t] - -- https://github.com/google/shaderc/blob/01dd72d6079ebdc0f96859365ba7abb1b62758bf/glslc/src/main.cc#L64 - entryPointArgs = case entryPoint of - Nothing -> [] - Just name -> case shaderType of - GLSL -> [] - HLSL -> ["-fentry-point=" <> name] - args = targetArgs ++ entryPointArgs ++ ["-fshader-stage=" <> stage, "-x", show shaderType, shader, "-o", spirv] + let + targetArgs = case targetSpv of + Nothing -> [] + Just t -> ["--target-spv=" <> t] + -- https://github.com/google/shaderc/blob/01dd72d6079ebdc0f96859365ba7abb1b62758bf/glslc/src/main.cc#L64 + entryPointArgs = case entryPoint of + Nothing -> [] + Just name -> case shaderType of + GLSL -> [] + HLSL -> ["-fentry-point=" <> name] + args = targetArgs ++ entryPointArgs ++ ["-fshader-stage=" <> stage, "-x", show shaderType, shader, "-o", spirv] (rc, out, err) <- readProcess $ proc "glslc" args let (warnings, errors) = processShadercMessages (out <> err) case rc of diff --git a/src/Vulkan/Utils/ShaderQQ/GLSL.hs b/src/Vulkan/Utils/ShaderQQ/GLSL.hs --- a/src/Vulkan/Utils/ShaderQQ/GLSL.hs +++ b/src/Vulkan/Utils/ShaderQQ/GLSL.hs @@ -3,57 +3,62 @@ , insertLineDirective ) where -import Language.Haskell.TH -import Language.Haskell.TH.Quote -import Vulkan.Utils.Internal ( badQQ ) -import Vulkan.Utils.ShaderQQ.Interpolate -import Data.Char -import Data.List.Extra +import Data.Char +import Data.List.Extra +import Language.Haskell.TH +import Language.Haskell.TH.Quote +import Vulkan.Utils.Internal (badQQ) +import Vulkan.Utils.ShaderQQ.Interpolate --- $setup --- >>> :set -XQuasiQuotes +{- $setup +>>> :set -XQuasiQuotes +-} --- | 'glsl' is a QuasiQuoter which produces GLSL source code with @#line@ --- directives inserted so that error locations point to the correct location in --- the Haskell source file. It also permits basic string interpolation. --- --- - Interpolated variables are prefixed with @$@ --- - They can optionally be surrounded with braces like @${foo}@ --- - Interpolated variables are converted to strings with 'show' --- - To escape a @$@ use @\\$@ --- --- An explicit example (@@ is from doctest): --- --- >>> let version = 450 :: Int in [glsl|#version $version|] --- "#version 450\n#extension GL_GOOGLE_cpp_style_line_directive : enable\n#line ... \"\"\n" --- --- Note that line number will be thrown off if any of the interpolated --- variables contain newlines. +{- | 'glsl' is a QuasiQuoter which produces GLSL source code with @#line@ +directives inserted so that error locations point to the correct location in +the Haskell source file. It also permits basic string interpolation. + +- Interpolated variables are prefixed with @$@ +- They can optionally be surrounded with braces like @${foo}@ +- Interpolated variables are converted to strings with 'show' +- To escape a @$@ use @\\$@ + +An explicit example (@@ is from doctest): + +>>> let version = 450 :: Int in [glsl|#version $version|] +"#version 450\n#extension GL_GOOGLE_cpp_style_line_directive : enable\n#line ... \"\"\n" + +Note that line number will be thrown off if any of the interpolated +variables contain newlines. +-} glsl :: QuasiQuoter -glsl = (badQQ "glsl") - { quoteExp = \s -> do - loc <- location - -- Insert the directive here, `compileShaderQ` will insert - -- another one, but it's before this one, so who cares. - let codeWithLineDirective = insertLineDirective s loc - interpExp codeWithLineDirective - } +glsl = + (badQQ "glsl") + { quoteExp = \s -> do + loc <- location + -- Insert the directive here, `compileShaderQ` will insert + -- another one, but it's before this one, so who cares. + let codeWithLineDirective = insertLineDirective s loc + interpExp codeWithLineDirective + } -- If possible, insert a #line directive after the #version directive (as well -- as the extension which allows filenames in line directives. insertLineDirective :: String -> Loc -> String -insertLineDirective code Loc {..} = - let isVersionDirective = ("#version" `isPrefixOf`) . dropWhile isSpace - codeLines = lines code - (beforeVersion, afterVersion) = break isVersionDirective codeLines - lineDirective = - [ "#extension GL_GOOGLE_cpp_style_line_directive : enable" - , "#line " +insertLineDirective code Loc{..} = + let + isVersionDirective = ("#version" `isPrefixOf`) . dropWhile isSpace + codeLines = lines code + (beforeVersion, afterVersion) = break isVersionDirective codeLines + lineDirective = + [ "#extension GL_GOOGLE_cpp_style_line_directive : enable" + , "#line " <> show (fst loc_start + length beforeVersion + 1) <> " \"" <> loc_filename <> "\"" - ] - in case afterVersion of - [] -> code - v : xs -> unlines $ beforeVersion <> [v] <> lineDirective <> xs + ] + in + case afterVersion of + [] -> code + v : xs -> unlines $ beforeVersion <> [v] <> lineDirective <> xs diff --git a/src/Vulkan/Utils/ShaderQQ/GLSL/Glslang.hs b/src/Vulkan/Utils/ShaderQQ/GLSL/Glslang.hs --- a/src/Vulkan/Utils/ShaderQQ/GLSL/Glslang.hs +++ b/src/Vulkan/Utils/ShaderQQ/GLSL/Glslang.hs @@ -18,159 +18,176 @@ , compileShader ) where -import Control.Monad.IO.Class -import Data.ByteString ( ByteString ) -import Language.Haskell.TH -import Language.Haskell.TH.Quote -import Vulkan.Utils.Internal ( badQQ ) -import Vulkan.Utils.ShaderQQ.ShaderType -import Vulkan.Utils.ShaderQQ.Backend.Glslang ( GlslangError, GlslangWarning ) +import Control.Monad.IO.Class +import Data.ByteString (ByteString) +import Language.Haskell.TH +import Language.Haskell.TH.Quote +import Vulkan.Utils.Internal (badQQ) +import Vulkan.Utils.ShaderQQ.Backend.Glslang (GlslangError, GlslangWarning) import qualified Vulkan.Utils.ShaderQQ.Backend.Glslang.Internal as Glslang -import qualified Vulkan.Utils.ShaderQQ.GLSL as GLSL +import qualified Vulkan.Utils.ShaderQQ.GLSL as GLSL +import Vulkan.Utils.ShaderQQ.ShaderType --- $setup --- >>> :set -XQuasiQuotes +{- $setup +>>> :set -XQuasiQuotes +-} --- | 'glsl' is a QuasiQuoter which produces GLSL source code with @#line@ --- directives inserted so that error locations point to the correct location in --- the Haskell source file. It also permits basic string interpolation. --- --- - Interpolated variables are prefixed with @$@ --- - They can optionally be surrounded with braces like @${foo}@ --- - Interpolated variables are converted to strings with 'show' --- - To escape a @$@ use @\\$@ --- --- It is intended to be used in concert with 'compileShaderQ' like so --- --- @ --- myConstant = 3.141 -- Note that this will have to be in a different module --- myFragmentShader = $(compileShaderQ Nothing "frag" Nothing [glsl| --- #version 450 --- const float myConstant = ${myConstant}; --- main (){ --- } --- |]) --- @ --- --- An explicit example (@@ is from doctest): --- --- >>> let version = 450 :: Int in [glsl|#version $version|] --- "#version 450\n#extension GL_GOOGLE_cpp_style_line_directive : enable\n#line ... \"\"\n" --- --- Note that line number will be thrown off if any of the interpolated --- variables contain newlines. +{- | 'glsl' is a QuasiQuoter which produces GLSL source code with @#line@ +directives inserted so that error locations point to the correct location in +the Haskell source file. It also permits basic string interpolation. + +- Interpolated variables are prefixed with @$@ +- They can optionally be surrounded with braces like @${foo}@ +- Interpolated variables are converted to strings with 'show' +- To escape a @$@ use @\\$@ + +It is intended to be used in concert with 'compileShaderQ' like so + +@ +myConstant = 3.141 -- Note that this will have to be in a different module +myFragmentShader = $(compileShaderQ Nothing "frag" Nothing [glsl| + #version 450 + const float myConstant = ${myConstant}; + main (){ + } +|]) +@ + +An explicit example (@@ is from doctest): + +>>> let version = 450 :: Int in [glsl|#version $version|] +"#version 450\n#extension GL_GOOGLE_cpp_style_line_directive : enable\n#line ... \"\"\n" + +Note that line number will be thrown off if any of the interpolated +variables contain newlines. +-} glsl :: QuasiQuoter glsl = GLSL.glsl --- | QuasiQuoter for creating a compute shader. --- --- Equivalent to calling @$(compileShaderQ Nothing "comp" Nothing [glsl|...|])@ without --- interpolation support. +{- | QuasiQuoter for creating a compute shader. + +Equivalent to calling @$(compileShaderQ Nothing "comp" Nothing [glsl|...|])@ without +interpolation support. +-} comp :: QuasiQuoter comp = shaderQQ "comp" --- | QuasiQuoter for creating a fragment shader. --- --- Equivalent to calling @$(compileShaderQ Nothing "frag" Nothing [glsl|...|])@ without --- interpolation support. +{- | QuasiQuoter for creating a fragment shader. + +Equivalent to calling @$(compileShaderQ Nothing "frag" Nothing [glsl|...|])@ without +interpolation support. +-} frag :: QuasiQuoter frag = shaderQQ "frag" --- | QuasiQuoter for creating a geometry shader. --- --- Equivalent to calling @$(compileShaderQ Nothing "geom" Nothing [glsl|...|])@ without --- interpolation support. +{- | QuasiQuoter for creating a geometry shader. + +Equivalent to calling @$(compileShaderQ Nothing "geom" Nothing [glsl|...|])@ without +interpolation support. +-} geom :: QuasiQuoter geom = shaderQQ "geom" --- | QuasiQuoter for creating a tessellation control shader. --- --- Equivalent to calling @$(compileShaderQ Nothing "tesc" Nothing [glsl|...|])@ without --- interpolation support. +{- | QuasiQuoter for creating a tessellation control shader. + +Equivalent to calling @$(compileShaderQ Nothing "tesc" Nothing [glsl|...|])@ without +interpolation support. +-} tesc :: QuasiQuoter tesc = shaderQQ "tesc" --- | QuasiQuoter for creating a tessellation evaluation shader. --- --- Equivalent to calling @$(compileShaderQ Nothing "tese" Nothing [glsl|...|])@ without --- interpolation support. +{- | QuasiQuoter for creating a tessellation evaluation shader. + +Equivalent to calling @$(compileShaderQ Nothing "tese" Nothing [glsl|...|])@ without +interpolation support. +-} tese :: QuasiQuoter tese = shaderQQ "tese" --- | QuasiQuoter for creating a vertex shader. --- --- Equivalent to calling @$(compileShaderQ Nothing "vert" Nothing [glsl|...|])@ without --- interpolation support. +{- | QuasiQuoter for creating a vertex shader. + +Equivalent to calling @$(compileShaderQ Nothing "vert" Nothing [glsl|...|])@ without +interpolation support. +-} vert :: QuasiQuoter vert = shaderQQ "vert" --- | QuasiQuoter for creating a ray generation shader. --- --- Equivalent to calling @$(compileShaderQ (Just "spirv1.4") "rgen" Nothing [glsl|...|])@ without --- interpolation support. +{- | QuasiQuoter for creating a ray generation shader. + +Equivalent to calling @$(compileShaderQ (Just "spirv1.4") "rgen" Nothing [glsl|...|])@ without +interpolation support. +-} rgen :: QuasiQuoter rgen = rayShaderQQ "rgen" --- | QuasiQuoter for creating an intersection shader. --- --- Equivalent to calling @$(compileShaderQ (Just "spirv1.4") "rint" Nothing [glsl|...|])@ without --- interpolation support. +{- | QuasiQuoter for creating an intersection shader. + +Equivalent to calling @$(compileShaderQ (Just "spirv1.4") "rint" Nothing [glsl|...|])@ without +interpolation support. +-} rint :: QuasiQuoter rint = rayShaderQQ "rint" --- | QuasiQuoter for creating an any-hit shader. --- --- Equivalent to calling @$(compileShaderQ (Just "spirv1.4") "rahit" Nothing [glsl|...|])@ without --- interpolation support. +{- | QuasiQuoter for creating an any-hit shader. + +Equivalent to calling @$(compileShaderQ (Just "spirv1.4") "rahit" Nothing [glsl|...|])@ without +interpolation support. +-} rahit :: QuasiQuoter rahit = rayShaderQQ "rahit" --- | QuasiQuoter for creating a closest hit shader. --- --- Equivalent to calling @$(compileShaderQ (Just "spirv1.4") "rchit" Nothing [glsl|...|])@ without --- interpolation support. +{- | QuasiQuoter for creating a closest hit shader. + +Equivalent to calling @$(compileShaderQ (Just "spirv1.4") "rchit" Nothing [glsl|...|])@ without +interpolation support. +-} rchit :: QuasiQuoter rchit = rayShaderQQ "rchit" --- | QuasiQuoter for creating a miss shader. --- --- Equivalent to calling @$(compileShaderQ (Just "spirv1.4") "rmiss" Nothing [glsl|...|])@ without --- interpolation support. +{- | QuasiQuoter for creating a miss shader. + +Equivalent to calling @$(compileShaderQ (Just "spirv1.4") "rmiss" Nothing [glsl|...|])@ without +interpolation support. +-} rmiss :: QuasiQuoter rmiss = rayShaderQQ "rmiss" --- | QuasiQuoter for creating a callable shader. --- --- Equivalent to calling @$(compileShaderQ (Just "spirv1.4") "rcall" Nothing [glsl|...|])@ without --- interpolation support. +{- | QuasiQuoter for creating a callable shader. + +Equivalent to calling @$(compileShaderQ (Just "spirv1.4") "rcall" Nothing [glsl|...|])@ without +interpolation support. +-} rcall :: QuasiQuoter rcall = rayShaderQQ "rcall" --- | QuasiQuoter for creating a task shader. --- --- Equivalent to calling @$(compileShaderQ Nothing "task" Nothing [glsl|...|])@ without --- interpolation support. +{- | QuasiQuoter for creating a task shader. + +Equivalent to calling @$(compileShaderQ Nothing "task" Nothing [glsl|...|])@ without +interpolation support. +-} task :: QuasiQuoter task = shaderQQ "task" --- | QuasiQuoter for creating a mesh shader. --- --- Equivalent to calling @$(compileShaderQ Nothing "mesh" Nothing [glsl|...|])@ without --- interpolation support. +{- | QuasiQuoter for creating a mesh shader. + +Equivalent to calling @$(compileShaderQ Nothing "mesh" Nothing [glsl|...|])@ without +interpolation support. +-} mesh :: QuasiQuoter mesh = shaderQQ "mesh" shaderQQ :: String -> QuasiQuoter -shaderQQ stage = (badQQ stage) { quoteExp = compileShaderQ Nothing stage Nothing } +shaderQQ stage = (badQQ stage){quoteExp = compileShaderQ Nothing stage Nothing} rayShaderQQ :: String -> QuasiQuoter -rayShaderQQ stage = (badQQ stage) { quoteExp = compileShaderQ (Just "spirv1.4") stage Nothing } +rayShaderQQ stage = (badQQ stage){quoteExp = compileShaderQ (Just "spirv1.4") stage Nothing} -- * Utilities --- | Compile a GLSL shader to spir-v using glslangValidator. --- --- Messages are converted to GHC warnings or errors depending on compilation success. +{- | Compile a GLSL shader to spir-v using glslangValidator. + +Messages are converted to GHC warnings or errors depending on compilation success. +-} compileShaderQ :: Maybe String -- ^ Argument to pass to `--target-env` @@ -186,7 +203,7 @@ -- | Compile a GLSL shader to spir-v using glslangValidator. compileShader - :: MonadIO m + :: (MonadIO m) => Maybe Loc -- ^ Source location -> Maybe String diff --git a/src/Vulkan/Utils/ShaderQQ/GLSL/Shaderc.hs b/src/Vulkan/Utils/ShaderQQ/GLSL/Shaderc.hs --- a/src/Vulkan/Utils/ShaderQQ/GLSL/Shaderc.hs +++ b/src/Vulkan/Utils/ShaderQQ/GLSL/Shaderc.hs @@ -18,159 +18,176 @@ , compileShader ) where -import Control.Monad.IO.Class -import Data.ByteString ( ByteString ) -import Language.Haskell.TH -import Language.Haskell.TH.Quote -import Vulkan.Utils.Internal ( badQQ ) -import Vulkan.Utils.ShaderQQ.ShaderType -import Vulkan.Utils.ShaderQQ.Backend.Shaderc ( ShadercError, ShadercWarning ) +import Control.Monad.IO.Class +import Data.ByteString (ByteString) +import Language.Haskell.TH +import Language.Haskell.TH.Quote +import Vulkan.Utils.Internal (badQQ) +import Vulkan.Utils.ShaderQQ.Backend.Shaderc (ShadercError, ShadercWarning) import qualified Vulkan.Utils.ShaderQQ.Backend.Shaderc.Internal as Shaderc -import qualified Vulkan.Utils.ShaderQQ.GLSL as GLSL +import qualified Vulkan.Utils.ShaderQQ.GLSL as GLSL +import Vulkan.Utils.ShaderQQ.ShaderType --- $setup --- >>> :set -XQuasiQuotes +{- $setup +>>> :set -XQuasiQuotes +-} --- | 'glsl' is a QuasiQuoter which produces GLSL source code with @#line@ --- directives inserted so that error locations point to the correct location in --- the Haskell source file. It also permits basic string interpolation. --- --- - Interpolated variables are prefixed with @$@ --- - They can optionally be surrounded with braces like @${foo}@ --- - Interpolated variables are converted to strings with 'show' --- - To escape a @$@ use @\\$@ --- --- It is intended to be used in concert with 'compileShaderQ' like so --- --- @ --- myConstant = 3.141 -- Note that this will have to be in a different module --- myFragmentShader = $(compileShaderQ Nothing "frag" [glsl| --- #version 450 --- const float myConstant = ${myConstant}; --- main (){ --- } --- |]) --- @ --- --- An explicit example (@@ is from doctest): --- --- >>> let version = 450 :: Int in [glsl|#version $version|] --- "#version 450\n#extension GL_GOOGLE_cpp_style_line_directive : enable\n#line ... \"\"\n" --- --- Note that line number will be thrown off if any of the interpolated --- variables contain newlines. +{- | 'glsl' is a QuasiQuoter which produces GLSL source code with @#line@ +directives inserted so that error locations point to the correct location in +the Haskell source file. It also permits basic string interpolation. + +- Interpolated variables are prefixed with @$@ +- They can optionally be surrounded with braces like @${foo}@ +- Interpolated variables are converted to strings with 'show' +- To escape a @$@ use @\\$@ + +It is intended to be used in concert with 'compileShaderQ' like so + +@ +myConstant = 3.141 -- Note that this will have to be in a different module +myFragmentShader = $(compileShaderQ Nothing "frag" [glsl| + #version 450 + const float myConstant = ${myConstant}; + main (){ + } +|]) +@ + +An explicit example (@@ is from doctest): + +>>> let version = 450 :: Int in [glsl|#version $version|] +"#version 450\n#extension GL_GOOGLE_cpp_style_line_directive : enable\n#line ... \"\"\n" + +Note that line number will be thrown off if any of the interpolated +variables contain newlines. +-} glsl :: QuasiQuoter glsl = GLSL.glsl --- | QuasiQuoter for creating a compute shader. --- --- Equivalent to calling @$(compileShaderQ Nothing "comp" [glsl|...|])@ without --- interpolation support. +{- | QuasiQuoter for creating a compute shader. + +Equivalent to calling @$(compileShaderQ Nothing "comp" [glsl|...|])@ without +interpolation support. +-} comp :: QuasiQuoter comp = shaderQQ "comp" --- | QuasiQuoter for creating a fragment shader. --- --- Equivalent to calling @$(compileShaderQ Nothing "frag" [glsl|...|])@ without --- interpolation support. +{- | QuasiQuoter for creating a fragment shader. + +Equivalent to calling @$(compileShaderQ Nothing "frag" [glsl|...|])@ without +interpolation support. +-} frag :: QuasiQuoter frag = shaderQQ "frag" --- | QuasiQuoter for creating a geometry shader. --- --- Equivalent to calling @$(compileShaderQ Nothing "geom" [glsl|...|])@ without --- interpolation support. +{- | QuasiQuoter for creating a geometry shader. + +Equivalent to calling @$(compileShaderQ Nothing "geom" [glsl|...|])@ without +interpolation support. +-} geom :: QuasiQuoter geom = shaderQQ "geom" --- | QuasiQuoter for creating a tessellation control shader. --- --- Equivalent to calling @$(compileShaderQ Nothing "tesc" [glsl|...|])@ without --- interpolation support. +{- | QuasiQuoter for creating a tessellation control shader. + +Equivalent to calling @$(compileShaderQ Nothing "tesc" [glsl|...|])@ without +interpolation support. +-} tesc :: QuasiQuoter tesc = shaderQQ "tesc" --- | QuasiQuoter for creating a tessellation evaluation shader. --- --- Equivalent to calling @$(compileShaderQ Nothing "tese" [glsl|...|])@ without --- interpolation support. +{- | QuasiQuoter for creating a tessellation evaluation shader. + +Equivalent to calling @$(compileShaderQ Nothing "tese" [glsl|...|])@ without +interpolation support. +-} tese :: QuasiQuoter tese = shaderQQ "tese" --- | QuasiQuoter for creating a vertex shader. --- --- Equivalent to calling @$(compileShaderQ Nothing "vert" [glsl|...|])@ without --- interpolation support. +{- | QuasiQuoter for creating a vertex shader. + +Equivalent to calling @$(compileShaderQ Nothing "vert" [glsl|...|])@ without +interpolation support. +-} vert :: QuasiQuoter vert = shaderQQ "vert" --- | QuasiQuoter for creating a ray generation shader. --- --- Equivalent to calling @$(compileShaderQ (Just "spv1.4") "rgen" [glsl|...|])@ without --- interpolation support. +{- | QuasiQuoter for creating a ray generation shader. + +Equivalent to calling @$(compileShaderQ (Just "spv1.4") "rgen" [glsl|...|])@ without +interpolation support. +-} rgen :: QuasiQuoter rgen = rayShaderQQ "rgen" --- | QuasiQuoter for creating an intersection shader. --- --- Equivalent to calling @$(compileShaderQ (Just "spv1.4") "rint" [glsl|...|])@ without --- interpolation support. +{- | QuasiQuoter for creating an intersection shader. + +Equivalent to calling @$(compileShaderQ (Just "spv1.4") "rint" [glsl|...|])@ without +interpolation support. +-} rint :: QuasiQuoter rint = rayShaderQQ "rint" --- | QuasiQuoter for creating an any-hit shader. --- --- Equivalent to calling @$(compileShaderQ (Just "spv1.4") "rahit" [glsl|...|])@ without --- interpolation support. +{- | QuasiQuoter for creating an any-hit shader. + +Equivalent to calling @$(compileShaderQ (Just "spv1.4") "rahit" [glsl|...|])@ without +interpolation support. +-} rahit :: QuasiQuoter rahit = rayShaderQQ "rahit" --- | QuasiQuoter for creating a closest hit shader. --- --- Equivalent to calling @$(compileShaderQ (Just "spv1.4") "rchit" [glsl|...|])@ without --- interpolation support. +{- | QuasiQuoter for creating a closest hit shader. + +Equivalent to calling @$(compileShaderQ (Just "spv1.4") "rchit" [glsl|...|])@ without +interpolation support. +-} rchit :: QuasiQuoter rchit = rayShaderQQ "rchit" --- | QuasiQuoter for creating a miss shader. --- --- Equivalent to calling @$(compileShaderQ (Just "spv1.4") "rmiss" [glsl|...|])@ without --- interpolation support. +{- | QuasiQuoter for creating a miss shader. + +Equivalent to calling @$(compileShaderQ (Just "spv1.4") "rmiss" [glsl|...|])@ without +interpolation support. +-} rmiss :: QuasiQuoter rmiss = rayShaderQQ "rmiss" --- | QuasiQuoter for creating a callable shader. --- --- Equivalent to calling @$(compileShaderQ (Just "spv1.4") "rcall" [glsl|...|])@ without --- interpolation support. +{- | QuasiQuoter for creating a callable shader. + +Equivalent to calling @$(compileShaderQ (Just "spv1.4") "rcall" [glsl|...|])@ without +interpolation support. +-} rcall :: QuasiQuoter rcall = rayShaderQQ "rcall" --- | QuasiQuoter for creating a task shader. --- --- Equivalent to calling @$(compileShaderQ Nothing "task" [glsl|...|])@ without --- interpolation support. +{- | QuasiQuoter for creating a task shader. + +Equivalent to calling @$(compileShaderQ Nothing "task" [glsl|...|])@ without +interpolation support. +-} task :: QuasiQuoter task = shaderQQ "task" --- | QuasiQuoter for creating a mesh shader. --- --- Equivalent to calling @$(compileShaderQ Nothing "mesh" [glsl|...|])@ without --- interpolation support. +{- | QuasiQuoter for creating a mesh shader. + +Equivalent to calling @$(compileShaderQ Nothing "mesh" [glsl|...|])@ without +interpolation support. +-} mesh :: QuasiQuoter mesh = shaderQQ "mesh" shaderQQ :: String -> QuasiQuoter -shaderQQ stage = (badQQ stage) { quoteExp = compileShaderQ Nothing stage } +shaderQQ stage = (badQQ stage){quoteExp = compileShaderQ Nothing stage} rayShaderQQ :: String -> QuasiQuoter -rayShaderQQ stage = (badQQ stage) { quoteExp = compileShaderQ (Just "spv1.4") stage } +rayShaderQQ stage = (badQQ stage){quoteExp = compileShaderQ (Just "spv1.4") stage} -- * Utilities --- | Compile a GLSL shader to spir-v using glslc. --- --- Messages are converted to GHC warnings or errors depending on compilation success. +{- | Compile a GLSL shader to spir-v using glslc. + +Messages are converted to GHC warnings or errors depending on compilation success. +-} compileShaderQ :: Maybe String -- ^ Argument to pass to `--target-env` @@ -184,7 +201,7 @@ -- | Compile a GLSL shader to spir-v using glslc. compileShader - :: MonadIO m + :: (MonadIO m) => Maybe Loc -- ^ Source location -> Maybe String diff --git a/src/Vulkan/Utils/ShaderQQ/HLSL.hs b/src/Vulkan/Utils/ShaderQQ/HLSL.hs --- a/src/Vulkan/Utils/ShaderQQ/HLSL.hs +++ b/src/Vulkan/Utils/ShaderQQ/HLSL.hs @@ -3,40 +3,42 @@ , insertLineDirective ) where -import Language.Haskell.TH -import Language.Haskell.TH.Quote -import Vulkan.Utils.Internal ( badQQ ) -import Vulkan.Utils.ShaderQQ.Interpolate +import Language.Haskell.TH +import Language.Haskell.TH.Quote +import Vulkan.Utils.Internal (badQQ) +import Vulkan.Utils.ShaderQQ.Interpolate --- | 'hlsl' is a QuasiQuoter which produces HLSL source code with a @#line@ --- directive inserted so that error locations point to the correct location in --- the Haskell source file. It also permits basic string interpolation. --- --- - Interpolated variables are prefixed with @$@ --- - They can optionally be surrounded with braces like @${foo}@ --- - Interpolated variables are converted to strings with 'show' --- - To escape a @$@ use @\\$@ --- --- An explicit example (@@ is from doctest): --- --- >>> let foo = 450 :: Int in [hlsl|const float foo = $foo|] --- "#line ... \"\"\nconst float foo = 450" --- --- Note that line number will be thrown off if any of the interpolated --- variables contain newlines. +{- | 'hlsl' is a QuasiQuoter which produces HLSL source code with a @#line@ +directive inserted so that error locations point to the correct location in +the Haskell source file. It also permits basic string interpolation. + +- Interpolated variables are prefixed with @$@ +- They can optionally be surrounded with braces like @${foo}@ +- Interpolated variables are converted to strings with 'show' +- To escape a @$@ use @\\$@ + +An explicit example (@@ is from doctest): + +>>> let foo = 450 :: Int in [hlsl|const float foo = $foo|] +"#line ... \"\"\nconst float foo = 450" + +Note that line number will be thrown off if any of the interpolated +variables contain newlines. +-} hlsl :: QuasiQuoter -hlsl = (badQQ "hlsl") - { quoteExp = \s -> do - loc <- location - -- Insert the directive here, `compileShaderQ` will insert - -- another one, but it's before this one, so who cares. - let codeWithLineDirective = insertLineDirective s loc - interpExp codeWithLineDirective - } +hlsl = + (badQQ "hlsl") + { quoteExp = \s -> do + loc <- location + -- Insert the directive here, `compileShaderQ` will insert + -- another one, but it's before this one, so who cares. + let codeWithLineDirective = insertLineDirective s loc + interpExp codeWithLineDirective + } -- Insert a #line directive with the specified location at the top of the file insertLineDirective :: String -> Loc -> String -insertLineDirective code Loc {..} = +insertLineDirective code Loc{..} = let lineDirective = "#line " <> show (fst loc_start) <> " \"" <> loc_filename <> "\"" - in lineDirective <> "\n" <> code + in lineDirective <> "\n" <> code diff --git a/src/Vulkan/Utils/ShaderQQ/HLSL/Glslang.hs b/src/Vulkan/Utils/ShaderQQ/HLSL/Glslang.hs --- a/src/Vulkan/Utils/ShaderQQ/HLSL/Glslang.hs +++ b/src/Vulkan/Utils/ShaderQQ/HLSL/Glslang.hs @@ -18,156 +18,172 @@ , compileShader ) where -import Control.Monad.IO.Class -import Data.ByteString ( ByteString ) -import Language.Haskell.TH -import Language.Haskell.TH.Quote -import Vulkan.Utils.Internal ( badQQ ) -import Vulkan.Utils.ShaderQQ.ShaderType -import Vulkan.Utils.ShaderQQ.Backend.Glslang ( GlslangError, GlslangWarning ) +import Control.Monad.IO.Class +import Data.ByteString (ByteString) +import Language.Haskell.TH +import Language.Haskell.TH.Quote +import Vulkan.Utils.Internal (badQQ) +import Vulkan.Utils.ShaderQQ.Backend.Glslang (GlslangError, GlslangWarning) import qualified Vulkan.Utils.ShaderQQ.Backend.Glslang.Internal as Glslang -import qualified Vulkan.Utils.ShaderQQ.HLSL as HLSL +import qualified Vulkan.Utils.ShaderQQ.HLSL as HLSL +import Vulkan.Utils.ShaderQQ.ShaderType --- | 'hlsl' is a QuasiQuoter which produces HLSL source code with a @#line@ --- directive inserted so that error locations point to the correct location in --- the Haskell source file. It also permits basic string interpolation. --- --- - Interpolated variables are prefixed with @$@ --- - They can optionally be surrounded with braces like @${foo}@ --- - Interpolated variables are converted to strings with 'show' --- - To escape a @$@ use @\\$@ --- --- It is intended to be used in concert with 'compileShaderQ' like so --- --- @ --- myConstant = 3.141 -- Note that this will have to be in a different module --- myFragmentShader = $(compileShaderQ Nothing "frag" (Just "main") [hlsl| --- static const float myConstant = ${myConstant}; --- float main (){ --- return myConstant; --- } --- |]) --- @ --- --- An explicit example (@@ is from doctest): --- --- >>> let foo = 450 :: Int in [hlsl|const float foo = $foo|] --- "#line ... \"\"\nconst float foo = 450" --- --- Note that line number will be thrown off if any of the interpolated --- variables contain newlines. +{- | 'hlsl' is a QuasiQuoter which produces HLSL source code with a @#line@ +directive inserted so that error locations point to the correct location in +the Haskell source file. It also permits basic string interpolation. + +- Interpolated variables are prefixed with @$@ +- They can optionally be surrounded with braces like @${foo}@ +- Interpolated variables are converted to strings with 'show' +- To escape a @$@ use @\\$@ + +It is intended to be used in concert with 'compileShaderQ' like so + +@ +myConstant = 3.141 -- Note that this will have to be in a different module +myFragmentShader = $(compileShaderQ Nothing "frag" (Just "main") [hlsl| + static const float myConstant = ${myConstant}; + float main (){ + return myConstant; + } +|]) +@ + +An explicit example (@@ is from doctest): + +>>> let foo = 450 :: Int in [hlsl|const float foo = $foo|] +"#line ... \"\"\nconst float foo = 450" + +Note that line number will be thrown off if any of the interpolated +variables contain newlines. +-} hlsl :: QuasiQuoter hlsl = HLSL.hlsl --- | QuasiQuoter for creating a compute shader. --- --- Equivalent to calling @$(compileShaderQ Nothing "comp" (Just "main") [hlsl|...|])@ without --- interpolation support. +{- | QuasiQuoter for creating a compute shader. + +Equivalent to calling @$(compileShaderQ Nothing "comp" (Just "main") [hlsl|...|])@ without +interpolation support. +-} comp :: QuasiQuoter comp = shaderQQ "comp" --- | QuasiQuoter for creating a fragment shader. --- --- Equivalent to calling @$(compileShaderQ Nothing "frag" (Just "main") [hlsl|...|])@ without --- interpolation support. +{- | QuasiQuoter for creating a fragment shader. + +Equivalent to calling @$(compileShaderQ Nothing "frag" (Just "main") [hlsl|...|])@ without +interpolation support. +-} frag :: QuasiQuoter frag = shaderQQ "frag" --- | QuasiQuoter for creating a geometry shader. --- --- Equivalent to calling @$(compileShaderQ Nothing "geom" (Just "main") [hlsl|...|])@ without --- interpolation support. +{- | QuasiQuoter for creating a geometry shader. + +Equivalent to calling @$(compileShaderQ Nothing "geom" (Just "main") [hlsl|...|])@ without +interpolation support. +-} geom :: QuasiQuoter geom = shaderQQ "geom" --- | QuasiQuoter for creating a tessellation control shader. --- --- Equivalent to calling @$(compileShaderQ Nothing "tesc" (Just "main") [hlsl|...|])@ without --- interpolation support. +{- | QuasiQuoter for creating a tessellation control shader. + +Equivalent to calling @$(compileShaderQ Nothing "tesc" (Just "main") [hlsl|...|])@ without +interpolation support. +-} tesc :: QuasiQuoter tesc = shaderQQ "tesc" --- | QuasiQuoter for creating a tessellation evaluation shader. --- --- Equivalent to calling @$(compileShaderQ Nothing "tese" (Just "main") [hlsl|...|])@ without --- interpolation support. +{- | QuasiQuoter for creating a tessellation evaluation shader. + +Equivalent to calling @$(compileShaderQ Nothing "tese" (Just "main") [hlsl|...|])@ without +interpolation support. +-} tese :: QuasiQuoter tese = shaderQQ "tese" --- | QuasiQuoter for creating a vertex shader. --- --- Equivalent to calling @$(compileShaderQ Nothing "vert" (Just "main") [hlsl|...|])@ without --- interpolation support. +{- | QuasiQuoter for creating a vertex shader. + +Equivalent to calling @$(compileShaderQ Nothing "vert" (Just "main") [hlsl|...|])@ without +interpolation support. +-} vert :: QuasiQuoter vert = shaderQQ "vert" --- | QuasiQuoter for creating a ray generation shader. --- --- Equivalent to calling @$(compileShaderQ (Just "spirv1.4") "rgen" (Just "main") [hlsl|...|])@ without --- interpolation support. +{- | QuasiQuoter for creating a ray generation shader. + +Equivalent to calling @$(compileShaderQ (Just "spirv1.4") "rgen" (Just "main") [hlsl|...|])@ without +interpolation support. +-} rgen :: QuasiQuoter rgen = rayShaderQQ "rgen" --- | QuasiQuoter for creating an intersection shader. --- --- Equivalent to calling @$(compileShaderQ (Just "spirv1.4") "rint" (Just "main") [hlsl|...|])@ without --- interpolation support. +{- | QuasiQuoter for creating an intersection shader. + +Equivalent to calling @$(compileShaderQ (Just "spirv1.4") "rint" (Just "main") [hlsl|...|])@ without +interpolation support. +-} rint :: QuasiQuoter rint = rayShaderQQ "rint" --- | QuasiQuoter for creating an any-hit shader. --- --- Equivalent to calling @$(compileShaderQ (Just "spirv1.4") "rahit" (Just "main") [hlsl|...|])@ without --- interpolation support. +{- | QuasiQuoter for creating an any-hit shader. + +Equivalent to calling @$(compileShaderQ (Just "spirv1.4") "rahit" (Just "main") [hlsl|...|])@ without +interpolation support. +-} rahit :: QuasiQuoter rahit = rayShaderQQ "rahit" --- | QuasiQuoter for creating a closest hit shader. --- --- Equivalent to calling @$(compileShaderQ (Just "spirv1.4") "rchit" (Just "main") [hlsl|...|])@ without --- interpolation support. +{- | QuasiQuoter for creating a closest hit shader. + +Equivalent to calling @$(compileShaderQ (Just "spirv1.4") "rchit" (Just "main") [hlsl|...|])@ without +interpolation support. +-} rchit :: QuasiQuoter rchit = rayShaderQQ "rchit" --- | QuasiQuoter for creating a miss shader. --- --- Equivalent to calling @$(compileShaderQ (Just "spirv1.4") "rmiss" (Just "main") [hlsl|...|])@ without --- interpolation support. +{- | QuasiQuoter for creating a miss shader. + +Equivalent to calling @$(compileShaderQ (Just "spirv1.4") "rmiss" (Just "main") [hlsl|...|])@ without +interpolation support. +-} rmiss :: QuasiQuoter rmiss = rayShaderQQ "rmiss" --- | QuasiQuoter for creating a callable shader. --- --- Equivalent to calling @$(compileShaderQ (Just "spirv1.4") "rcall" (Just "main") [hlsl|...|])@ without --- interpolation support. +{- | QuasiQuoter for creating a callable shader. + +Equivalent to calling @$(compileShaderQ (Just "spirv1.4") "rcall" (Just "main") [hlsl|...|])@ without +interpolation support. +-} rcall :: QuasiQuoter rcall = rayShaderQQ "rcall" --- | QuasiQuoter for creating a task shader. --- --- Equivalent to calling @$(compileShaderQ Nothing "task" (Just "main") [hlsl|...|])@ without --- interpolation support. +{- | QuasiQuoter for creating a task shader. + +Equivalent to calling @$(compileShaderQ Nothing "task" (Just "main") [hlsl|...|])@ without +interpolation support. +-} task :: QuasiQuoter task = shaderQQ "task" --- | QuasiQuoter for creating a mesh shader. --- --- Equivalent to calling @$(compileShaderQ Nothing "mesh" (Just "main") [hlsl|...|])@ without --- interpolation support. +{- | QuasiQuoter for creating a mesh shader. + +Equivalent to calling @$(compileShaderQ Nothing "mesh" (Just "main") [hlsl|...|])@ without +interpolation support. +-} mesh :: QuasiQuoter mesh = shaderQQ "mesh" shaderQQ :: String -> QuasiQuoter -shaderQQ stage = (badQQ stage) { quoteExp = compileShaderQ Nothing stage (Just "main") } +shaderQQ stage = (badQQ stage){quoteExp = compileShaderQ Nothing stage (Just "main")} rayShaderQQ :: String -> QuasiQuoter -rayShaderQQ stage = (badQQ stage) { quoteExp = compileShaderQ (Just "spirv1.4") stage (Just "main") } +rayShaderQQ stage = (badQQ stage){quoteExp = compileShaderQ (Just "spirv1.4") stage (Just "main")} -- * Utilities --- | Compile a HLSL shader to spir-v using glslangValidator. --- --- Messages are converted to GHC warnings or errors depending on compilation success. +{- | Compile a HLSL shader to spir-v using glslangValidator. + +Messages are converted to GHC warnings or errors depending on compilation success. +-} compileShaderQ :: Maybe String -- ^ Argument to pass to `--target-env` @@ -183,7 +199,7 @@ -- | Compile a HLSL shader to spir-v using glslangValidator. compileShader - :: MonadIO m + :: (MonadIO m) => Maybe Loc -- ^ Source location -> Maybe String diff --git a/src/Vulkan/Utils/ShaderQQ/HLSL/Shaderc.hs b/src/Vulkan/Utils/ShaderQQ/HLSL/Shaderc.hs --- a/src/Vulkan/Utils/ShaderQQ/HLSL/Shaderc.hs +++ b/src/Vulkan/Utils/ShaderQQ/HLSL/Shaderc.hs @@ -18,156 +18,172 @@ , compileShader ) where -import Control.Monad.IO.Class -import Data.ByteString ( ByteString ) -import Language.Haskell.TH -import Language.Haskell.TH.Quote -import Vulkan.Utils.Internal ( badQQ ) -import Vulkan.Utils.ShaderQQ.ShaderType -import Vulkan.Utils.ShaderQQ.Backend.Shaderc ( ShadercError, ShadercWarning ) +import Control.Monad.IO.Class +import Data.ByteString (ByteString) +import Language.Haskell.TH +import Language.Haskell.TH.Quote +import Vulkan.Utils.Internal (badQQ) +import Vulkan.Utils.ShaderQQ.Backend.Shaderc (ShadercError, ShadercWarning) import qualified Vulkan.Utils.ShaderQQ.Backend.Shaderc.Internal as Shaderc -import qualified Vulkan.Utils.ShaderQQ.HLSL as HLSL +import qualified Vulkan.Utils.ShaderQQ.HLSL as HLSL +import Vulkan.Utils.ShaderQQ.ShaderType --- | 'hlsl' is a QuasiQuoter which produces HLSL source code with a @#line@ --- directive inserted so that error locations point to the correct location in --- the Haskell source file. It also permits basic string interpolation. --- --- - Interpolated variables are prefixed with @$@ --- - They can optionally be surrounded with braces like @${foo}@ --- - Interpolated variables are converted to strings with 'show' --- - To escape a @$@ use @\\$@ --- --- It is intended to be used in concert with 'compileShaderQ' like so --- --- @ --- myConstant = 3.141 -- Note that this will have to be in a different module --- myFragmentShader = $(compileShaderQ Nothing "frag" Nothing [hlsl| --- static const float myConstant = ${myConstant}; --- float main (){ --- return myConstant; --- } --- |]) --- @ --- --- An explicit example (@@ is from doctest): --- --- >>> let foo = 450 :: Int in [hlsl|const float foo = $foo|] --- "#line ... \"\"\nconst float foo = 450" --- --- Note that line number will be thrown off if any of the interpolated --- variables contain newlines. +{- | 'hlsl' is a QuasiQuoter which produces HLSL source code with a @#line@ +directive inserted so that error locations point to the correct location in +the Haskell source file. It also permits basic string interpolation. + +- Interpolated variables are prefixed with @$@ +- They can optionally be surrounded with braces like @${foo}@ +- Interpolated variables are converted to strings with 'show' +- To escape a @$@ use @\\$@ + +It is intended to be used in concert with 'compileShaderQ' like so + +@ +myConstant = 3.141 -- Note that this will have to be in a different module +myFragmentShader = $(compileShaderQ Nothing "frag" Nothing [hlsl| + static const float myConstant = ${myConstant}; + float main (){ + return myConstant; + } +|]) +@ + +An explicit example (@@ is from doctest): + +>>> let foo = 450 :: Int in [hlsl|const float foo = $foo|] +"#line ... \"\"\nconst float foo = 450" + +Note that line number will be thrown off if any of the interpolated +variables contain newlines. +-} hlsl :: QuasiQuoter hlsl = HLSL.hlsl --- | QuasiQuoter for creating a compute shader. --- --- Equivalent to calling @$(compileShaderQ Nothing "comp" Nothing [hlsl|...|])@ without --- interpolation support. +{- | QuasiQuoter for creating a compute shader. + +Equivalent to calling @$(compileShaderQ Nothing "comp" Nothing [hlsl|...|])@ without +interpolation support. +-} comp :: QuasiQuoter comp = shaderQQ "comp" --- | QuasiQuoter for creating a fragment shader. --- --- Equivalent to calling @$(compileShaderQ Nothing "frag" Nothing [hlsl|...|])@ without --- interpolation support. +{- | QuasiQuoter for creating a fragment shader. + +Equivalent to calling @$(compileShaderQ Nothing "frag" Nothing [hlsl|...|])@ without +interpolation support. +-} frag :: QuasiQuoter frag = shaderQQ "frag" --- | QuasiQuoter for creating a geometry shader. --- --- Equivalent to calling @$(compileShaderQ Nothing "geom" Nothing [hlsl|...|])@ without --- interpolation support. +{- | QuasiQuoter for creating a geometry shader. + +Equivalent to calling @$(compileShaderQ Nothing "geom" Nothing [hlsl|...|])@ without +interpolation support. +-} geom :: QuasiQuoter geom = shaderQQ "geom" --- | QuasiQuoter for creating a tessellation control shader. --- --- Equivalent to calling @$(compileShaderQ Nothing "tesc" Nothing [hlsl|...|])@ without --- interpolation support. +{- | QuasiQuoter for creating a tessellation control shader. + +Equivalent to calling @$(compileShaderQ Nothing "tesc" Nothing [hlsl|...|])@ without +interpolation support. +-} tesc :: QuasiQuoter tesc = shaderQQ "tesc" --- | QuasiQuoter for creating a tessellation evaluation shader. --- --- Equivalent to calling @$(compileShaderQ Nothing "tese" Nothing [hlsl|...|])@ without --- interpolation support. +{- | QuasiQuoter for creating a tessellation evaluation shader. + +Equivalent to calling @$(compileShaderQ Nothing "tese" Nothing [hlsl|...|])@ without +interpolation support. +-} tese :: QuasiQuoter tese = shaderQQ "tese" --- | QuasiQuoter for creating a vertex shader. --- --- Equivalent to calling @$(compileShaderQ Nothing "vert" Nothing [hlsl|...|])@ without --- interpolation support. +{- | QuasiQuoter for creating a vertex shader. + +Equivalent to calling @$(compileShaderQ Nothing "vert" Nothing [hlsl|...|])@ without +interpolation support. +-} vert :: QuasiQuoter vert = shaderQQ "vert" --- | QuasiQuoter for creating a ray generation shader. --- --- Equivalent to calling @$(compileShaderQ (Just "spv1.4") "rgen" Nothing [hlsl|...|])@ without --- interpolation support. +{- | QuasiQuoter for creating a ray generation shader. + +Equivalent to calling @$(compileShaderQ (Just "spv1.4") "rgen" Nothing [hlsl|...|])@ without +interpolation support. +-} rgen :: QuasiQuoter rgen = rayShaderQQ "rgen" --- | QuasiQuoter for creating an intersection shader. --- --- Equivalent to calling @$(compileShaderQ (Just "spv1.4") "rint" Nothing [hlsl|...|])@ without --- interpolation support. +{- | QuasiQuoter for creating an intersection shader. + +Equivalent to calling @$(compileShaderQ (Just "spv1.4") "rint" Nothing [hlsl|...|])@ without +interpolation support. +-} rint :: QuasiQuoter rint = rayShaderQQ "rint" --- | QuasiQuoter for creating an any-hit shader. --- --- Equivalent to calling @$(compileShaderQ (Just "spv1.4") "rahit" Nothing [hlsl|...|])@ without --- interpolation support. +{- | QuasiQuoter for creating an any-hit shader. + +Equivalent to calling @$(compileShaderQ (Just "spv1.4") "rahit" Nothing [hlsl|...|])@ without +interpolation support. +-} rahit :: QuasiQuoter rahit = rayShaderQQ "rahit" --- | QuasiQuoter for creating a closest hit shader. --- --- Equivalent to calling @$(compileShaderQ (Just "spv1.4") "rchit" Nothing [hlsl|...|])@ without --- interpolation support. +{- | QuasiQuoter for creating a closest hit shader. + +Equivalent to calling @$(compileShaderQ (Just "spv1.4") "rchit" Nothing [hlsl|...|])@ without +interpolation support. +-} rchit :: QuasiQuoter rchit = rayShaderQQ "rchit" --- | QuasiQuoter for creating a miss shader. --- --- Equivalent to calling @$(compileShaderQ (Just "spv1.4") "rmiss" Nothing [hlsl|...|])@ without --- interpolation support. +{- | QuasiQuoter for creating a miss shader. + +Equivalent to calling @$(compileShaderQ (Just "spv1.4") "rmiss" Nothing [hlsl|...|])@ without +interpolation support. +-} rmiss :: QuasiQuoter rmiss = rayShaderQQ "rmiss" --- | QuasiQuoter for creating a callable shader. --- --- Equivalent to calling @$(compileShaderQ (Just "spv1.4") "rcall" Nothing [hlsl|...|])@ without --- interpolation support. +{- | QuasiQuoter for creating a callable shader. + +Equivalent to calling @$(compileShaderQ (Just "spv1.4") "rcall" Nothing [hlsl|...|])@ without +interpolation support. +-} rcall :: QuasiQuoter rcall = rayShaderQQ "rcall" --- | QuasiQuoter for creating a task shader. --- --- Equivalent to calling @$(compileShaderQ Nothing "task" Nothing [hlsl|...|])@ without --- interpolation support. +{- | QuasiQuoter for creating a task shader. + +Equivalent to calling @$(compileShaderQ Nothing "task" Nothing [hlsl|...|])@ without +interpolation support. +-} task :: QuasiQuoter task = shaderQQ "task" --- | QuasiQuoter for creating a mesh shader. --- --- Equivalent to calling @$(compileShaderQ Nothing "mesh" Nothing [hlsl|...|])@ without --- interpolation support. +{- | QuasiQuoter for creating a mesh shader. + +Equivalent to calling @$(compileShaderQ Nothing "mesh" Nothing [hlsl|...|])@ without +interpolation support. +-} mesh :: QuasiQuoter mesh = shaderQQ "mesh" shaderQQ :: String -> QuasiQuoter -shaderQQ stage = (badQQ stage) { quoteExp = compileShaderQ Nothing stage Nothing } +shaderQQ stage = (badQQ stage){quoteExp = compileShaderQ Nothing stage Nothing} rayShaderQQ :: String -> QuasiQuoter -rayShaderQQ stage = (badQQ stage) { quoteExp = compileShaderQ (Just "spv1.4") stage Nothing } +rayShaderQQ stage = (badQQ stage){quoteExp = compileShaderQ (Just "spv1.4") stage Nothing} -- * Utilities --- | Compile a HLSL shader to spir-v using glslc. --- --- Messages are converted to GHC warnings or errors depending on compilation success. +{- | Compile a HLSL shader to spir-v using glslc. + +Messages are converted to GHC warnings or errors depending on compilation success. +-} compileShaderQ :: Maybe String -- ^ Argument to pass to `--target-env` @@ -183,7 +199,7 @@ -- | Compile a HLSL shader to spir-v using glslc. compileShader - :: MonadIO m + :: (MonadIO m) => Maybe Loc -- ^ Source location -> Maybe String diff --git a/src/Vulkan/Utils/ShaderQQ/Interpolate.hs b/src/Vulkan/Utils/ShaderQQ/Interpolate.hs --- a/src/Vulkan/Utils/ShaderQQ/Interpolate.hs +++ b/src/Vulkan/Utils/ShaderQQ/Interpolate.hs @@ -1,44 +1,47 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE QuasiQuotes #-} module Vulkan.Utils.ShaderQQ.Interpolate ( interpExp ) where -import Control.Applicative ( liftA2 ) -import Data.Char -import Language.Haskell.TH -import Text.ParserCombinators.ReadP +import Control.Applicative (liftA2) +import Data.Char +import Language.Haskell.TH +import Text.ParserCombinators.ReadP --- $setup --- >>> :set -XTemplateHaskell --- >>> import Data.Proxy +{- $setup +>>> :set -XTemplateHaskell +>>> import Data.Proxy +-} --- | 'interpExp' performs very simple interpolation of Haskell --- values into 'String's. --- --- - Interpolated variables are prefixed with @$@ --- - They can optionally be surrounded with braces like @${foo}@ --- - Interpolated variables are converted to strings with 'show' --- - To escape a @$@ use @\\$@ --- --- >>> let foo = 123 in $(interpExp "hello, $foo") --- "hello, 123" --- --- >>> let foo = "world" in $(interpExp "hello, \\$foo") --- "hello, $foo" --- --- >>> let foo = "world" in $(interpExp "hello\r\n\rworld") --- "hello\r\n\rworld" +{- | 'interpExp' performs very simple interpolation of Haskell +values into 'String's. + +- Interpolated variables are prefixed with @$@ +- They can optionally be surrounded with braces like @${foo}@ +- Interpolated variables are converted to strings with 'show' +- To escape a @$@ use @\\$@ + +>>> let foo = 123 in $(interpExp "hello, $foo") +"hello, 123" + +>>> let foo = "world" in $(interpExp "hello, \\$foo") +"hello, $foo" + +>>> let foo = "world" in $(interpExp "hello\r\n\rworld") +"hello\r\n\rworld" +-} interpExp :: String -> Q Exp interpExp = - foldEither (litE (stringL "")) - (appE (varE 'show) . varOrConE) - (litE . stringL) - (\e1 e2 -> [|$e1 <> $e2|]) + foldEither + (litE (stringL "")) + (appE (varE 'show) . varOrConE) + (litE . stringL) + (\e1 e2 -> [|$e1 <> $e2|]) . parse ---------------------------------------------------------------- @@ -47,72 +50,77 @@ type Var = String --- | Extract variables and literals from string to be interpolated --- --- >>> parse "" --- [] --- --- >>> parse "hello $world" --- [Right "hello ",Left "world"] --- --- >>> parse "$hello$world" --- [Left "hello",Left "world"] --- --- >>> parse "$" --- [Right "$"] --- --- >>> parse "hi" --- [Right "hi"] --- --- >>> parse "h$hi" --- [Right "h",Left "hi"] --- --- >>> parse "$$hi" --- [Right "$",Left "hi"] --- --- >>> parse "$1" --- [Right "$1"] --- --- >>> parse "$$$" --- [Right "$$$"] --- --- >>> parse "\\" --- [Right "\\"] --- --- >>> parse "\\$" --- [Right "$"] --- --- >>> parse "\\$hi" --- [Right "$hi"] --- --- >>> parse "\\\\$hi" --- [Right "\\$hi"] --- --- >>> parse "\\hi" --- [Right "\\hi"] --- --- >>> parse "$hi\\$foo" --- [Left "hi",Right "$foo"] --- --- >>> parse "hello, \\$foo" --- [Right "hello, $foo"] --- --- >>> parse "${fo'o}bar" --- [Left "fo'o",Right "bar"] --- --- >>> parse "\\" --- [Right "\\"] --- --- >>> parse "\\\\$" --- [Right "\\$"] --- --- >>> parse "$" --- [Right "$"] +{- | Extract variables and literals from string to be interpolated + +>>> parse "" +[] + +>>> parse "hello $world" +[Right "hello ",Left "world"] + +>>> parse "$hello$world" +[Left "hello",Left "world"] + +>>> parse "$" +[Right "$"] + +>>> parse "hi" +[Right "hi"] + +>>> parse "h$hi" +[Right "h",Left "hi"] + +>>> parse "$$hi" +[Right "$",Left "hi"] + +>>> parse "$1" +[Right "$1"] + +>>> parse "$$$" +[Right "$$$"] + +>>> parse "\\" +[Right "\\"] + +>>> parse "\\$" +[Right "$"] + +>>> parse "\\$hi" +[Right "$hi"] + +>>> parse "\\\\$hi" +[Right "\\$hi"] + +>>> parse "\\hi" +[Right "\\hi"] + +>>> parse "$hi\\$foo" +[Left "hi",Right "$foo"] + +>>> parse "hello, \\$foo" +[Right "hello, $foo"] + +>>> parse "${fo'o}bar" +[Left "fo'o",Right "bar"] + +>>> parse "\\" +[Right "\\"] + +>>> parse "\\\\$" +[Right "\\$"] + +>>> parse "$" +[Right "$"] +-} parse :: String -> [Either Var String] parse s = - let -- A haskell var or con - ident = (:) <$> satisfy (isLower <||> isUpper <||> (== '_')) <*> munch - (isAlphaNum <||> (== '\'') <||> (== '_')) + let + -- A haskell var or con + ident = + (:) + <$> satisfy (isLower <||> isUpper <||> (== '_')) + <*> munch + (isAlphaNum <||> (== '\'') <||> (== '_')) braces = between (char '{') (char '}') -- parse a var, a '$' followed by an ident var = @@ -125,21 +133,21 @@ -- - Check escaped '$' first -- - variables, starting with $ -- - normal string - one = normal +++ var +++ escape + one = normal +++ var +++ escape parser = many one <* eof in case readP_to_S parser s of [(r, "")] -> foldr mergeRights [] r - _ -> error "Failed to parse string" + _ -> error "Failed to parse string" mergeRights :: Either Var String -> [Either Var String] -> [Either Var String] mergeRights = \case - Left v -> (Left v :) + Left v -> (Left v :) Right n -> \case (Right m : xs) -> Right (n <> m) : xs - xs -> Right n : xs + xs -> Right n : xs -(<&&>), (<||>) :: Applicative f => f Bool -> f Bool -> f Bool +(<&&>), (<||>) :: (Applicative f) => f Bool -> f Bool -> f Bool (<||>) = liftA2 (||) (<&&>) = liftA2 (&&) diff --git a/src/Vulkan/Utils/ShaderQQ/ShaderType.hs b/src/Vulkan/Utils/ShaderQQ/ShaderType.hs --- a/src/Vulkan/Utils/ShaderQQ/ShaderType.hs +++ b/src/Vulkan/Utils/ShaderQQ/ShaderType.hs @@ -2,7 +2,7 @@ ( ShaderType (..) ) where -import Data.String (IsString (..)) +import Data.String (IsString (..)) data ShaderType = GLSL diff --git a/src/Vulkan/Utils/Swapchain.hs b/src/Vulkan/Utils/Swapchain.hs new file mode 100644 --- /dev/null +++ b/src/Vulkan/Utils/Swapchain.hs @@ -0,0 +1,359 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# OPTIONS_GHC -Wno-missing-signatures #-} + +{-| Swapchain creation, recreation, and the small helper for catching +swapchain-out-of-date exceptions thrown elsewhere. + +Opinionated choices (storage-image usage, FIFO_RELAXED preference, surface +format selection) are exposed via 'SwapchainConfig'. 'defaultSwapchainConfig' +gives a color-attachment-only swapchain prefering FIFO_RELAXED then FIFO; +compute-shader callers add @IMAGE_USAGE_STORAGE_BIT@ etc. +-} +module Vulkan.Utils.Swapchain + ( Swapchain (..) + , SwapchainConfig (..) + , defaultSwapchainConfig + , srgbEncoding + , unormEncoding + , allocateSwapchain + , recreateSwapchain + , threwSwapchainError + ) where + +import Control.Exception (throwIO, tryJust) +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Resource +import Data.Bits +import Data.Either (isLeft) +import Data.Foldable (for_, traverse_) +import Data.Vector (Vector) +import qualified Data.Vector as V +import GHC.Generics (Generic) +import Vulkan.CStruct.Extends (pattern (:&), pattern (::&)) +import qualified Vulkan.Core10 as Vk +import Vulkan.Core12.Promoted_From_VK_KHR_timeline_semaphore (SemaphoreTypeCreateInfo (..), pattern SEMAPHORE_TYPE_BINARY) +import Vulkan.Exception (VulkanException (..)) +import Vulkan.Extensions.VK_KHR_surface as SurfaceCapabilitiesKHR (SurfaceCapabilitiesKHR (..)) +import Vulkan.Extensions.VK_KHR_surface as SurfaceFormatKHR (SurfaceFormatKHR (..)) +import qualified Vulkan.Extensions.VK_KHR_surface as KHR +import qualified Vulkan.Extensions.VK_KHR_swapchain as KHR +import Vulkan.Utils.Misc ((.&&.)) +import Vulkan.Utils.RefCounted (RefCounted, newRefCounted, releaseRefCounted) +import Vulkan.Zero (zero) + +---------------------------------------------------------------- +-- Config +---------------------------------------------------------------- + +{- | Opinionated knobs for swapchain creation. Use 'defaultSwapchainConfig' as +a starting point and override the bits you care about. +-} +data SwapchainConfig = SwapchainConfig + { scRequiredUsageFlags :: [Vk.ImageUsageFlagBits] + {- ^ Image usages every swapchain image must support. Default: + @[IMAGE_USAGE_COLOR_ATTACHMENT_BIT]@. Compute-shader callers add + @IMAGE_USAGE_STORAGE_BIT@. + -} + , scRequiredFormatFeatures :: [Vk.FormatFeatureFlagBits] + {- ^ Format-feature flags the chosen surface format's optimal tiling + must satisfy. Default: @[]@. Set @FORMAT_FEATURE_STORAGE_IMAGE_BIT@ if + using @IMAGE_USAGE_STORAGE_BIT@ — SRGB formats typically omit it. + -} + , scDesiredPresentModes :: [KHR.PresentModeKHR] + {- ^ Present-mode preference, best first. Default: + @[FIFO_RELAXED, FIFO]@. The driver-guaranteed @FIFO@ is the safe + fallback. Add @IMMEDIATE@ or @MAILBOX@ if your scheduler can tolerate + them. + -} + , scSurfaceFormatPreferences :: [KHR.SurfaceFormatKHR -> Bool] + {- ^ Surface-format preference predicates, best first. For each predicate + in order, the first format that matches both the predicate AND the + feature requirements wins. If no preference matches, falls back to the + first feature-satisfying format, then to the head. Default: @[]@. + -} + } + deriving (Generic) + +defaultSwapchainConfig :: SwapchainConfig +defaultSwapchainConfig = + SwapchainConfig + { scRequiredUsageFlags = [Vk.IMAGE_USAGE_COLOR_ATTACHMENT_BIT] + , scRequiredFormatFeatures = [] + , scDesiredPresentModes = + [ KHR.PRESENT_MODE_FIFO_RELAXED_KHR + , KHR.PRESENT_MODE_FIFO_KHR + ] + , scSurfaceFormatPreferences = [] + } + +{- | Does presenting through this surface format sRGB-encode written linear values? + +'selectSurfaceFormat' is first-fit and the platforms disagree — Mesa's surface +list leads with sRGB formats, MoltenVK's with UNORM — so unpinned output is +only correct on the platform whose pick matches what the app writes. Pin via +'scSurfaceFormatPreferences': 'srgbEncoding' when passes produce linear colour +(the hardware encodes on write), 'unormEncoding' when they produce +display-referred (already-encoded) colour that must pass through untouched. +A preference is best-effort — a surface offering no match falls back — so +callers that can adapt should check the picked 'sFormat'. +-} +srgbEncoding :: KHR.SurfaceFormatKHR -> Bool +srgbEncoding = + encodedAs + [ Vk.FORMAT_B8G8R8A8_SRGB + , Vk.FORMAT_R8G8B8A8_SRGB + , Vk.FORMAT_A8B8G8R8_SRGB_PACK32 + ] + +-- | The pass-through counterpart of 'srgbEncoding': written values reach the display verbatim. +unormEncoding :: KHR.SurfaceFormatKHR -> Bool +unormEncoding = + encodedAs + [ Vk.FORMAT_B8G8R8A8_UNORM + , Vk.FORMAT_R8G8B8A8_UNORM + , Vk.FORMAT_A8B8G8R8_UNORM_PACK32 + ] + +-- | One of the given formats, in the (non-HDR) sRGB colour space. +encodedAs :: [Vk.Format] -> KHR.SurfaceFormatKHR -> Bool +encodedAs formats sf = + SurfaceFormatKHR.format sf `elem` formats + && SurfaceFormatKHR.colorSpace sf == KHR.COLOR_SPACE_SRGB_NONLINEAR_KHR + +---------------------------------------------------------------- +-- Swapchain +---------------------------------------------------------------- + +data Swapchain = Swapchain + { sSwapchain :: KHR.SwapchainKHR + , sSurface :: KHR.SurfaceKHR + , sFormat :: KHR.SurfaceFormatKHR + , sExtent :: Vk.Extent2D + , sPresentMode :: KHR.PresentModeKHR + , sImages :: Vector Vk.Image + , sImageViews :: Vector Vk.ImageView + , sRenderFinished :: Vector Vk.Semaphore + {- ^ Per-image present-wait binary semaphore, indexed by the acquired image + index (@length == length sImages@). A frame's submit signals + @sRenderFinished ! imageIndex@ and the present waits on it; reusing it is + safe only once that image is re-acquired, which is why it lives here (per + image) rather than in the per-frame 'RecycledResources'. Freed by 'sRelease'. + -} + , sRelease :: RefCounted + -- ^ Held until no in-flight frame still uses this swapchain. + , sConfig :: SwapchainConfig + -- ^ Retained so 'recreateSwapchain' can re-apply the same knobs. + } + deriving (Generic) + +---------------------------------------------------------------- +-- Allocate / recreate +---------------------------------------------------------------- + +-- | Allocate a new swapchain plus its image views. +allocateSwapchain + :: (MonadResource m) + => Vk.PhysicalDevice + -> Vk.Device + -> SwapchainConfig + -> KHR.SwapchainKHR + -- ^ Previous swapchain ('NULL_HANDLE' for first) + -> Vk.Extent2D + -- ^ Fallback size when the surface lets us pick + -> KHR.SurfaceKHR + -> m Swapchain +allocateSwapchain phys dev cfg oldSwapchain windowSize surface = do + (sSwapchain, sFormat, sExtent, sPresentMode, swapchainKey) <- + allocateSwapchainEx phys dev cfg oldSwapchain windowSize surface + + (_, sImages) <- KHR.getSwapchainImagesKHR dev sSwapchain + (imageViewKeys, sImageViews) <- + fmap V.unzip . V.forM sImages $ \image -> + allocateImageView dev (SurfaceFormatKHR.format sFormat) image + + -- One present-wait binary semaphore per swapchain image, indexed by the + -- acquired image index (see 'sRenderFinished'). + (renderFinishedKeys, sRenderFinished) <- + fmap V.unzip . V.forM sImages $ \_image -> + Vk.withSemaphore + dev + (zero ::& SemaphoreTypeCreateInfo SEMAPHORE_TYPE_BINARY 0 :& ()) + Nothing + allocate + + -- Released by the next 'recreateSwapchain' (when frames stop using it). + sRelease <- newRefCounted $ do + traverse_ release renderFinishedKeys + traverse_ release imageViewKeys + release swapchainKey + + pure Swapchain{sSurface = surface, sConfig = cfg, ..} + +{- | Build a new swapchain at a new size, dropping the reference to the old +one so its resources can be released once in-flight frames complete. +-} +recreateSwapchain + :: (MonadResource m) + => Vk.PhysicalDevice + -> Vk.Device + -> Vk.Extent2D + -- ^ New window size + -> Swapchain + -> m Swapchain +recreateSwapchain phys dev newSize old = do + fresh <- allocateSwapchain phys dev (sConfig old) (sSwapchain old) newSize (sSurface old) + releaseRefCounted (sRelease old) + pure fresh + +---------------------------------------------------------------- +-- Internals +---------------------------------------------------------------- + +allocateSwapchainEx + :: (MonadResource m) + => Vk.PhysicalDevice + -> Vk.Device + -> SwapchainConfig + -> KHR.SwapchainKHR + -> Vk.Extent2D + -> KHR.SurfaceKHR + -> m (KHR.SwapchainKHR, SurfaceFormatKHR, Vk.Extent2D, KHR.PresentModeKHR, ReleaseKey) +allocateSwapchainEx phys dev cfg oldSwapchain explicitSize surf = do + surfaceCaps <- KHR.getPhysicalDeviceSurfaceCapabilitiesKHR phys surf + + -- Sanity-check that the surface advertises the usages we need. + for_ (scRequiredUsageFlags cfg) $ \f -> + unless (supportedUsageFlags surfaceCaps .&&. f) $ + liftIO . throwIO . userError $ + "Surface images do not support " <> show f + + -- Pick a present mode in our preference order. + (_, availablePresentModes) <- KHR.getPhysicalDeviceSurfacePresentModesKHR phys surf + presentMode <- + case filter (`V.elem` availablePresentModes) (scDesiredPresentModes cfg) of + [] -> liftIO . throwIO . userError $ "Unable to find a suitable present mode for swapchain" + x : _ -> pure x + + -- Pick a surface format. Vulkan guarantees at least one. + (_, availableFormats) <- KHR.getPhysicalDeviceSurfaceFormatsKHR phys surf + surfaceFormat <- selectSurfaceFormat phys cfg availableFormats + + -- Use the surface's reported extent unless it tells us we can pick. + let imageExtent = + case currentExtent (surfaceCaps :: SurfaceCapabilitiesKHR) of + Vk.Extent2D w h | w == maxBound, h == maxBound -> explicitSize + e -> e + + let imageCount = + let + limit = case maxImageCount (surfaceCaps :: SurfaceCapabilitiesKHR) of + 0 -> maxBound + n -> n + buffer = 1 -- request one extra to avoid waiting on the driver + desired = buffer + SurfaceCapabilitiesKHR.minImageCount surfaceCaps + in + min limit desired + + compositeAlphaMode <- + if KHR.COMPOSITE_ALPHA_OPAQUE_BIT_KHR .&&. supportedCompositeAlpha surfaceCaps + then pure KHR.COMPOSITE_ALPHA_OPAQUE_BIT_KHR + else liftIO . throwIO . userError $ "Surface doesn't support COMPOSITE_ALPHA_OPAQUE_BIT_KHR" + + let swapchainCreateInfo = + KHR.SwapchainCreateInfoKHR + { surface = surf + , next = () + , flags = zero + , queueFamilyIndices = mempty + , minImageCount = imageCount + , imageFormat = SurfaceFormatKHR.format surfaceFormat + , imageColorSpace = colorSpace surfaceFormat + , imageExtent = imageExtent + , imageArrayLayers = 1 + , imageUsage = foldr (.|.) zero (scRequiredUsageFlags cfg) + , imageSharingMode = Vk.SHARING_MODE_EXCLUSIVE + , preTransform = SurfaceCapabilitiesKHR.currentTransform surfaceCaps + , compositeAlpha = compositeAlphaMode + , presentMode = presentMode + , clipped = True + , oldSwapchain = oldSwapchain + } + + (key, swapchain) <- KHR.withSwapchainKHR dev swapchainCreateInfo Nothing allocate + + pure (swapchain, surfaceFormat, imageExtent, presentMode, key) + +-- | 2D color image view covering the whole image. +allocateImageView + :: (MonadResource m) + => Vk.Device + -> Vk.Format + -> Vk.Image + -> m (ReleaseKey, Vk.ImageView) +allocateImageView dev format image = + Vk.withImageView dev imageViewCreateInfo Nothing allocate + where + imageViewCreateInfo = + zero + { Vk.image = image + , Vk.viewType = Vk.IMAGE_VIEW_TYPE_2D + , Vk.format = format + , Vk.components = + zero + { Vk.r = Vk.COMPONENT_SWIZZLE_IDENTITY + , Vk.g = Vk.COMPONENT_SWIZZLE_IDENTITY + , Vk.b = Vk.COMPONENT_SWIZZLE_IDENTITY + , Vk.a = Vk.COMPONENT_SWIZZLE_IDENTITY + } + , Vk.subresourceRange = + zero + { Vk.aspectMask = Vk.IMAGE_ASPECT_COLOR_BIT + , Vk.baseMipLevel = 0 + , Vk.levelCount = 1 + , Vk.baseArrayLayer = 0 + , Vk.layerCount = 1 + } + } + +---------------------------------------------------------------- +-- Format selection +---------------------------------------------------------------- + +{- | Prefer formats whose 'optimalTilingFeatures' satisfy +'scRequiredFormatFeatures' and additionally match one of +'scSurfaceFormatPreferences' (best preference first). Falls back to the +first feature-satisfying format, then to the head if all else fails. +-} +selectSurfaceFormat + :: (MonadIO m) + => Vk.PhysicalDevice + -> SwapchainConfig + -> Vector SurfaceFormatKHR + -> m SurfaceFormatKHR +selectSurfaceFormat phys cfg fmts = do + good <- V.filterM featuresOK fmts + let fallback = if V.null good then V.head fmts else V.head good + pure $ pickPreference (scSurfaceFormatPreferences cfg) good fallback + where + featuresOK f = do + props <- Vk.getPhysicalDeviceFormatProperties phys (SurfaceFormatKHR.format f) + pure $ all (Vk.optimalTilingFeatures props .&&.) (scRequiredFormatFeatures cfg) + + pickPreference [] _ fallback = fallback + pickPreference (p : ps) good fallback = + case V.find p good of + Just f -> f + Nothing -> pickPreference ps good fallback + +---------------------------------------------------------------- +-- Specifications +---------------------------------------------------------------- + +-- | Catch an 'ERROR_OUT_OF_DATE_KHR' exception and return 'True' when caught. +threwSwapchainError :: IO b -> IO Bool +threwSwapchainError = fmap isLeft . tryJust swapchainError + where + swapchainError = \case + VulkanException e@Vk.ERROR_OUT_OF_DATE_KHR -> Just e + VulkanException _ -> Nothing diff --git a/src/Vulkan/Utils/VulkanContext.hs b/src/Vulkan/Utils/VulkanContext.hs new file mode 100644 --- /dev/null +++ b/src/Vulkan/Utils/VulkanContext.hs @@ -0,0 +1,76 @@ +{-| Application-static Vulkan handles plus the recycle channel ends used by +the recycling 'Vulkan.Utils.Frame.Frame' machinery. + +Constructed once at boot, never modified. Sub-systems (swapchain, frame loop, +window loop) accept a 'VulkanContext' so they don't need their own copies of +device/queues plumbing. +-} +module Vulkan.Utils.VulkanContext + ( VulkanContext (..) + , RecycledResources (..) + , mkVulkanContext + ) where + +import Control.Concurrent.Chan.Unagi +import qualified Vulkan.Core10 as Vk +import Vulkan.Utils.QueueAssignment (QueueFamilyIndex) +import Vulkan.Utils.Queues (Queues (..)) + +{- | A bunch of long-lived handles that the application carries around. The +recycle channel ends carry per-frame 'RecycledResources' between the frame +loop and the wait-and-recycle thread. +-} +data VulkanContext rr = VulkanContext + { vcInstance :: Vk.Instance + , vcPhysicalDevice :: Vk.PhysicalDevice + , vcDevice :: Vk.Device + , vcQueues :: Queues (QueueFamilyIndex, Vk.Queue) + , vcRecycleBin :: (RecycledResources rr) -> IO () + {- ^ Drop a frame's reusable bits back into the pool. Called from the + per-frame wait thread once the GPU is done with the frame. + -} + , vcRecycleNib :: IO (Either (IO (RecycledResources rr)) (RecycledResources rr)) + {- ^ Pull a frame's reusable bits out. 'Right' if available immediately; + 'Left' is a blocking read. + -} + } + +{- | The bits of state recycled between frames: a binary image-available +semaphore (signalled by image acquisition, waited on by the frame's submit) +and the command pool the frame's commands are recorded into. + +The render-finished / present-wait semaphore is /not/ here — it is per +swapchain image (see 'Vulkan.Utils.Swapchain.sRenderFinished'), because a +present-wait semaphore is only safe to reuse once its image is re-acquired, +not when the frame's render completes. +-} +data RecycledResources a = RecycledResources + { rrImageAvailable :: Vk.Semaphore + , rrCommandPools :: Queues Vk.CommandPool + {- ^ One command pool per queue role, reset when the frame retires. Roles + sharing a queue family share the pool handle, so a frame holds one pool + per distinct family — pools are expensive to create and cheap to reset, + which is the whole point of recycling them. + -} + , rrData :: a + -- ^ Double-buffered data of the application to ping-pong around updating and rendering. + } + +{- | Assemble a 'VulkanContext' from already-constructed handles. Builds the +recycle channel internally; the channel starts empty and is populated by +'Vulkan.Utils.Frame.initialFrame'. +-} +mkVulkanContext + :: Vk.Instance + -> Vk.PhysicalDevice + -> Vk.Device + -> Queues (QueueFamilyIndex, Vk.Queue) + -> IO (VulkanContext rr) +mkVulkanContext vcInstance vcPhysicalDevice vcDevice vcQueues = do + (binW, binR) <- newChan + let + vcRecycleBin = writeChan binW + vcRecycleNib = do + (try, block) <- tryReadChan binR + maybe (Left block) Right <$> tryRead try + pure VulkanContext{..} diff --git a/src/Vulkan/Utils/WindowAdapter.hs b/src/Vulkan/Utils/WindowAdapter.hs new file mode 100644 --- /dev/null +++ b/src/Vulkan/Utils/WindowAdapter.hs @@ -0,0 +1,30 @@ +{-| Bridge between a boot sequence and a particular window-library +backend. A boot helper written against 'WindowAdapter' stays oblivious +to which library is in use; the window packages each provide a +constructor for their own window type — @glfwAdapter@ in +"Vulkan.Utils.Init.GLFW.Window" (@vulkan-init-glfw@) and @sdl2Adapter@ +in "Vulkan.Utils.Init.SDL2.Window" (@vulkan-init-sdl2@). +-} +module Vulkan.Utils.WindowAdapter + ( WindowAdapter (..) + ) where + +import qualified Vulkan.Core10 as Vk +import Vulkan.Extensions.VK_KHR_surface (SurfaceKHR) +import Vulkan.Requirement (InstanceRequirement) + +-- | The window-library operations a boot sequence needs. +data WindowAdapter m = WindowAdapter + { waAllocateInstance + :: Maybe Vk.ApplicationInfo + -> [InstanceRequirement] + -> [InstanceRequirement] + -> m Vk.Instance + {- ^ Create an instance satisfying the window library's requirements + plus the given required and optional ones. + -} + , waAllocateSurface :: Vk.Instance -> m SurfaceKHR + -- ^ Create a surface for the window, destroyed with the resource scope. + , waDrawableSize :: m Vk.Extent2D + -- ^ The window's current drawable size, for the swapchain extent. + } diff --git a/src/Vulkan/Utils/WindowLoop.hs b/src/Vulkan/Utils/WindowLoop.hs new file mode 100644 --- /dev/null +++ b/src/Vulkan/Utils/WindowLoop.hs @@ -0,0 +1,135 @@ +{-| Per-frame window loop shared by windowed applications. + +The skeleton — read swapchain, run a frame inside @runFrame@, recreate on +'Vulkan.Utils.Swapchain.threwSwapchainError', advance — is the same for any +windowed Vulkan app. Each consumer only varies in: + +* the per-swapchain state it holds (framebuffers, descriptor sets, …), +* the per-frame render action, and +* the "what to do on exit / per-frame metric" hooks. + +'runWindowLoop' takes those four points as fields of a 'WindowLoop' record. +-} +module Vulkan.Utils.WindowLoop + ( WindowLoop (..) + , runWindowLoop + , noWindowState + , noRecycledResources + , noOnFrame + , noOnExit + ) where + +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Resource + ( ReleaseKey + , ResourceT + , register + , release + ) +import Data.IORef +import Data.Word (Word64) +import GHC.Clock (getMonotonicTimeNSec) +import qualified Vulkan.Core10 as Vk +import Vulkan.Utils.Frame (Frame (..), InitRecycledResources, advanceFrame, drainFrames, initialFrame, runFrame) +import Vulkan.Utils.Swapchain (Swapchain, recreateSwapchain, threwSwapchainError) +import Vulkan.Utils.VulkanContext (VulkanContext (..)) + +data WindowLoop s rr = WindowLoop + { wlMkState :: Swapchain -> ResourceT IO (s, ReleaseKey) + {- ^ Build per-swapchain state. The release key is fired when the + swapchain is recreated and a fresh state replaces this one. + -} + , wlMkRecycled :: InitRecycledResources (ResourceT IO) rr + , wlRender :: s -> Frame rr -> ResourceT IO () + -- ^ Per-frame render action; runs inside @runFrame@. + , wlOnFrame :: Word64 -> Word64 -> ResourceT IO () + {- ^ Optional metric hook with start/end nanoseconds around 'runFrame'. + Use 'noOnFrame' if you don't care. + -} + , wlOnExit :: Frame rr -> ResourceT IO () + -- ^ Fired once when the window closes. Use 'noOnExit' if you don't care. + } + +runWindowLoop + :: VulkanContext rr + -> Swapchain + -> IO Vk.Extent2D + -- ^ Get current drawable size (called on resize) + -> IO Bool + -- ^ Per-frame poller; 'True' means quit + -> WindowLoop s rr + -> ResourceT IO () +runWindowLoop vc initialSC getSize shouldQuit WindowLoop{..} = do + initialState <- wlMkState initialSC + scRef <- liftIO $ newIORef initialSC + stRef <- liftIO $ newIORef initialState + initial <- initialFrame vc initialSC wlMkRecycled + let + perFrame f = do + currentSC <- liftIO $ readIORef scRef + (st, _) <- liftIO $ readIORef stRef + let f' = f{fSwapchain = currentSC} + startNs <- liftIO getMonotonicTimeNSec + needsNew <- + liftIO . threwSwapchainError $ + runFrame vc f' (wlRender st f') + endNs <- liftIO getMonotonicTimeNSec + wlOnFrame startNs endNs + sc' <- + if needsNew + then do + newSize <- liftIO getSize + -- A swapchain recreation retires the old swapchain. Drain the + -- graphics/present queue first so the old swapchain's pending + -- presents — and this frame's GPU work behind the old + -- per-swapchain state — all complete before we free the old + -- per-image present-wait semaphores, the old swapchain, and the + -- old state. A present-wait semaphore cannot otherwise be known + -- idle (its present has no host-visible completion without + -- VK_KHR_swapchain_maintenance1). Recreation is rare, so this + -- one-shot wait is cheap. + Vk.deviceWaitIdle (vcDevice vc) + sc' <- recreateSwapchain (vcPhysicalDevice vc) (vcDevice vc) newSize currentSC + -- Free the old state before building its replacement: recreation + -- already retired the old swapchain's images, so the new state may + -- be handed their recycled handles — any bookkeeping the old state + -- keys on them must be gone before wlMkState re-wraps. + (_, oldKey) <- liftIO $ readIORef stRef + release oldKey + (newSt, newKey) <- wlMkState sc' + liftIO $ writeIORef scRef sc' + liftIO $ writeIORef stRef (newSt, newKey) + pure sc' + else pure currentSC + advanceFrame vc sc' f' + + loop f = + liftIO shouldQuit >>= \case + True -> do + Vk.deviceWaitIdle (vcDevice vc) + wlOnExit f + liftIO $ drainFrames vc f + pure Nothing + False -> Just <$> perFrame f + loopJust loop initial + +-- | 'wlMkState' for callers that have no per-swapchain state. +noWindowState :: Swapchain -> ResourceT IO ((), ReleaseKey) +noWindowState _ = do + key <- register (pure ()) + pure ((), key) + +noRecycledResources :: (Applicative m) => InitRecycledResources m () +noRecycledResources _vc _dbIx _pools = pure () + +noOnFrame :: Word64 -> Word64 -> ResourceT IO () +noOnFrame _ _ = pure () + +noOnExit :: Frame rr -> ResourceT IO () +noOnExit _ = pure () + +loopJust :: (Monad m) => (a -> m (Maybe a)) -> a -> m () +loopJust f x = + f x >>= \case + Nothing -> pure () + Just x' -> loopJust f x' diff --git a/test/doctest/Doctests.hs b/test/doctest/Doctests.hs --- a/test/doctest/Doctests.hs +++ b/test/doctest/Doctests.hs @@ -1,10 +1,11 @@ module Main where -import Build_doctests ( flags - , module_sources - , pkgs - ) -import Test.DocTest ( doctest ) +import Build_doctests + ( flags + , module_sources + , pkgs + ) +import Test.DocTest (doctest) main :: IO () main = doctest $ flags ++ pkgs ++ module_sources diff --git a/vulkan-utils.cabal b/vulkan-utils.cabal --- a/vulkan-utils.cabal +++ b/vulkan-utils.cabal @@ -1,16 +1,16 @@ cabal-version: 1.24 --- This file has been generated from package.yaml by hpack version 0.34.5. +-- This file has been generated from package.yaml by hpack version 0.39.6. -- -- see: https://github.com/sol/hpack name: vulkan-utils -version: 0.5.10.6 +version: 0.5.11.0 synopsis: Utils for the vulkan package category: Graphics -homepage: https://github.com/expipiplus1/vulkan#readme -bug-reports: https://github.com/expipiplus1/vulkan/issues -maintainer: Ellie Hermaszewska +homepage: https://github.com/haskell-game/vulkan#readme +bug-reports: https://github.com/haskell-game/vulkan/issues +maintainer: IC Rainbow , Ellie Hermaszewska license: BSD3 license-file: LICENSE build-type: Custom @@ -22,7 +22,7 @@ source-repository head type: git - location: https://github.com/expipiplus1/vulkan + location: https://github.com/haskell-game/vulkan custom-setup setup-depends: @@ -32,14 +32,29 @@ library exposed-modules: + Vulkan.Utils.Barrier Vulkan.Utils.CommandCheck Vulkan.Utils.Debug + Vulkan.Utils.Descriptors + Vulkan.Utils.DynamicRendering + Vulkan.Utils.DynamicState + Vulkan.Utils.Frame + Vulkan.Utils.Framebuffer Vulkan.Utils.FromGL + Vulkan.Utils.Init.Headless Vulkan.Utils.Initialization Vulkan.Utils.Misc + Vulkan.Utils.Pipeline + Vulkan.Utils.Pipeline.Internal + Vulkan.Utils.Pipeline.Specialization + Vulkan.Utils.PipelineLayout Vulkan.Utils.QueueAssignment + Vulkan.Utils.Queues + Vulkan.Utils.RefCounted + Vulkan.Utils.RenderPass Vulkan.Utils.Requirements Vulkan.Utils.Requirements.TH + Vulkan.Utils.Shader Vulkan.Utils.ShaderQQ.Backend.Glslang Vulkan.Utils.ShaderQQ.Backend.Shaderc Vulkan.Utils.ShaderQQ.GLSL.Glslang @@ -47,6 +62,10 @@ Vulkan.Utils.ShaderQQ.HLSL.Glslang Vulkan.Utils.ShaderQQ.HLSL.Shaderc Vulkan.Utils.ShaderQQ.Interpolate + Vulkan.Utils.Swapchain + Vulkan.Utils.VulkanContext + Vulkan.Utils.WindowAdapter + Vulkan.Utils.WindowLoop other-modules: Vulkan.Utils.Internal Vulkan.Utils.ShaderQQ.ShaderType @@ -76,6 +95,7 @@ MagicHash NamedFieldPuns NoMonomorphismRestriction + OverloadedRecordDot OverloadedStrings PartialTypeSignatures PatternSynonyms @@ -97,11 +117,9 @@ c-sources: cbits/DebugCallback.c build-depends: - base <5 + base >=4.16 && <5 , bytestring , containers - , dependent-map - , dependent-sum , extra , file-embed , filepath @@ -111,9 +129,11 @@ , text , transformers , typed-process + , unagi-chan + , unliftio-core , unordered-containers , vector - , vulkan >=3.6.14 && <3.27 + , vulkan ==3.27.* default-language: Haskell2010 test-suite doctests @@ -142,6 +162,7 @@ MagicHash NamedFieldPuns NoMonomorphismRestriction + OverloadedRecordDot OverloadedStrings PartialTypeSignatures PatternSynonyms