diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index cc7a0baba..95ca305fe 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -263,6 +263,7 @@ jobs: - run: nix-build --arg compiler '${{ matrix.ghc }}' -A vulkan - run: nix-build --arg compiler '${{ matrix.ghc }}' -A VulkanMemoryAllocator - run: nix-build --arg compiler '${{ matrix.ghc }}' -A vulkan-utils + - run: nix-build --arg compiler '${{ matrix.ghc }}' -A vulkan-utils-spirv - run: nix-build --arg compiler '${{ matrix.ghc }}' -A openxr - run: nix-build --arg compiler '${{ matrix.ghc }}' ./nix/haskell-packages.nix --arg openxrNoVulkan true -A openxr - run: nix-build --arg compiler '${{ matrix.ghc }}' -A vulkan-examples @@ -328,7 +329,8 @@ jobs: sudo apt-get install fd-find - name: Check scripts with shellcheck run: | - fdfind .sh$ . \ + fdfind '\.sh$' . \ + --type f \ --exclude VulkanMemoryAllocator/VulkanMemoryAllocator \ --exclude generate-new/Vulkan-Docs \ --exclude generate-new/OpenXR-Docs \ diff --git a/cabal.project b/cabal.project index dee63d1c1..52f23f0cb 100644 --- a/cabal.project +++ b/cabal.project @@ -3,6 +3,7 @@ packages: ./openxr ./VulkanMemoryAllocator ./utils + ./utils-spirv ./utils-init/vulkan-init-sdl2 ./utils-init/vulkan-init-glfw ./examples diff --git a/default.nix b/default.nix index 0f25677ac..b51d90032 100644 --- a/default.nix +++ b/default.nix @@ -21,7 +21,7 @@ let (pkgs.haskell.lib.dontCheck vulkan) (pkgs.haskell.lib.dontCheck VulkanMemoryAllocator) ] else - [ vulkan vulkan-utils vulkan-init-sdl2 vulkan-init-glfw VulkanMemoryAllocator vulkan-examples openxr ] + [ vulkan vulkan-utils vulkan-utils-spirv vulkan-init-sdl2 vulkan-init-glfw VulkanMemoryAllocator vulkan-examples openxr ] ++ pkgs.lib.optional (p.ghc.version == generator-ghc-version) generate-new; in if forShell then diff --git a/examples/compute-reflect/Julia.hs b/examples/compute-reflect/Julia.hs new file mode 100644 index 000000000..8457a7250 --- /dev/null +++ b/examples/compute-reflect/Julia.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +{-| Julia-set compute pipeline, its interface reflected from 'Julia.Shader.code': + + * 'reflectShaderTypesBytes' generates the 'Params' push-constant record (with + a gl-block std430 'Storable'); + * 'singleDescriptorSetLayoutInfo' builds the descriptor set layout for the + output SSBO; + * 'pushConstantRanges' builds the pipeline layout's push-constant range; and + * 'allocateSpecializationInfo' builds the pipeline's specialization info + (@maxIterations@, @escapeRadius@) from the reflected constant ids. + +Compare with the @compute@ example, which hand-writes all of this. +-} +module Julia + ( Params (..) + , Pipeline (..) + , allocatePipeline + , workgroup + ) where + +import Control.Monad.Trans.Resource (ResourceT, allocate) +import qualified Data.Vector as V +import Data.Word (Word32) +import qualified Geomancy +import Graphics.Gl.Block (Std430 (..)) +import Vulkan.CStruct.Extends (SomeStruct (..)) +import qualified Vulkan.Core10 as PipelineLayoutCreateInfo (PipelineLayoutCreateInfo (..)) +import qualified Vulkan.Core10 as Vk +import Vulkan.Utils.Shader (shaderModuleStage) +import Vulkan.Utils.SpirV.Descriptors (pushConstantRanges, singleDescriptorSetLayoutInfo) +import Vulkan.Utils.SpirV.Reflect (reflectBytes) +import Vulkan.Utils.SpirV.Specialization (allocateSpecializationInfo) +import Vulkan.Utils.SpirV.TH (reflectShaderTypesBytes) +import Vulkan.Zero (zero) + +import qualified Julia.Shader as Shader + +-- Generate the @Params@ push-constant record (and its std430 'Storable') from +-- the same SPIR-V the runtime loads. +reflectShaderTypesBytes Shader.code + +-- | Workgroup size on each axis (matches @local_size_x/y@ in the shader). +workgroup :: Int +workgroup = 16 + +data Pipeline = Pipeline + { pipeline :: Vk.Pipeline + , pipelineLayout :: Vk.PipelineLayout + , descriptorSetLayout :: Vk.DescriptorSetLayout + } + +{- | The pipeline, specialized to the given iteration cap and escape radius. + +Descriptor set layout, push-constant range and specialization info all come +from reflecting 'Shader.code'. +-} +allocatePipeline :: Vk.Device -> Word32 -> Float -> ResourceT IO Pipeline +allocatePipeline dev maxIterations escapeRadius = do + -- Reflect the embedded module once; reuse it for the descriptor set layout, + -- the push-constant range and the specialization info. + reflected <- reflectBytes Shader.code + + setLayoutInfo <- either fail pure (singleDescriptorSetLayoutInfo reflected) + (_, descriptorSetLayout) <- Vk.withDescriptorSetLayout dev setLayoutInfo Nothing allocate + + mSpec <- allocateSpecializationInfo reflected (maxIterations, escapeRadius) + (_, shader) <- shaderModuleStage dev Vk.SHADER_STAGE_COMPUTE_BIT mSpec Shader.code + (_, pipelineLayout) <- + Vk.withPipelineLayout + dev + zero + { PipelineLayoutCreateInfo.setLayouts = [descriptorSetLayout] + , PipelineLayoutCreateInfo.pushConstantRanges = + V.fromList (pushConstantRanges reflected) + } + Nothing + allocate + let + pipelineCreateInfo :: Vk.ComputePipelineCreateInfo '[] + pipelineCreateInfo = + zero + { Vk.layout = pipelineLayout + , Vk.stage = shader + , Vk.basePipelineHandle = zero + } + (_, (_, [computePipeline])) <- + Vk.withComputePipelines dev zero [SomeStruct pipelineCreateInfo] Nothing allocate + pure + Pipeline + { pipeline = computePipeline + , pipelineLayout = pipelineLayout + , descriptorSetLayout = descriptorSetLayout + } diff --git a/examples/compute-reflect/Julia/Shader.hs b/examples/compute-reflect/Julia/Shader.hs new file mode 100644 index 000000000..6e3945749 --- /dev/null +++ b/examples/compute-reflect/Julia/Shader.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE QuasiQuotes #-} + +{-| The Julia-set compute shader, compiled to SPIR-V at build time. + +Its interface is reflected by vulkan-utils-spirv in the "Julia" module: +the @Params@ push-constant block, the output SSBO's descriptor set layout, +and the specialization constants. +-} +module Julia.Shader + ( code + ) where + +import Data.ByteString (ByteString) +import Vulkan.Utils.ShaderQQ.GLSL.Glslang (comp) + +code :: ByteString +code = + [comp| + #version 450 + #extension GL_ARB_separate_shader_objects : enable + + layout(local_size_x = 16, local_size_y = 16, local_size_z = 1) in; + + // Specialized at pipeline-creation time (see Vulkan.Utils.SpirV.Specialization). + layout(constant_id = 0) const uint maxIterations = 1000u; + layout(constant_id = 1) const float escapeRadius = 2.0; + + // Fields are ordered by non-increasing alignment (vec2/uvec2 = 8) so gl-block's + // Generic std430 layout matches the shader; see the guardrail in + // Vulkan.Utils.SpirV.Block. + layout(push_constant, std430) uniform Params { + vec2 center; // c in the Julia iteration + uvec2 resolution; // output size in pixels + } params; + + layout(set = 0, binding = 0, std430) buffer OutputBuffer { + vec4 pixels[]; + }; + + // From https://iquilezles.org/articles/palettes/ + vec3 palette(float t) { + const vec3 a = vec3(0.5); + const vec3 b = vec3(0.5); + const vec3 c = vec3(1.0); + const vec3 d = vec3(0.0, 0.10, 0.20); + return a + b * cos(6.28318530718 * (c * t + d)); + } + + void main() { + uvec2 gid = gl_GlobalInvocationID.xy; + if (gid.x >= params.resolution.x || gid.y >= params.resolution.y) { + return; + } + + vec2 uv = + ( vec2(gid) / vec2(params.resolution) * 2.0 - 1.0 ) * escapeRadius; + + vec2 z = uv; + int i = 0; + for (; i < int(maxIterations); ++i) { + vec2 z2 = vec2(z.x * z.x - z.y * z.y, 2.0 * z.x * z.y); + z = z2 + params.center; + if (dot(z, z) > escapeRadius * escapeRadius) { + break; + } + } + + uint idx = gid.y * params.resolution.x + gid.x; + if (i == int(maxIterations)) { + pixels[idx] = vec4(0.0, 0.0, 0.0, 1.0); + } else { + pixels[idx] = vec4(palette(float(i) / float(maxIterations)), 1.0); + } + } + |] diff --git a/examples/compute-reflect/Main.hs b/examples/compute-reflect/Main.hs new file mode 100644 index 000000000..1e5c351fb --- /dev/null +++ b/examples/compute-reflect/Main.hs @@ -0,0 +1,34 @@ +{-| A compute example whose shader interface is derived from the quasiquoted +shader in "Julia.Shader" at build time by @vulkan-utils-spirv@ β€” see "Julia" +for the reflected pipeline and "Render" for the frame. +-} +module Main + ( main + ) +where + +import Control.Monad.Trans.Resource (runResourceT) +import HeadlessBoot (HeadlessConfig (..), HeadlessVk (..), withHeadlessVk) +import ImageReadback (savePng) +import qualified Vulkan.Core10 as Vk +import Vulkan.Utils.QueueAssignment (QueueFamilyIndex (..)) +import Vulkan.Utils.Queues (Queues (..)) +import Vulkan.Zero (zero) + +import qualified Render + +main :: IO () +main = runResourceT $ do + HeadlessVk{..} <- + withHeadlessVk + HeadlessConfig + { appName = "Haskell Vulkan compute-reflect example" + , instanceReqs = [] + , deviceReqs = [] + , vmaFlags = zero + } + let QueueFamilyIndex computeQueueFamilyIndex = fst (qCompute queues) + + image <- Render.render allocator device computeQueueFamilyIndex + Vk.deviceWaitIdle device + savePng "julia-reflect.png" image diff --git a/examples/compute-reflect/Render.hs b/examples/compute-reflect/Render.hs new file mode 100644 index 000000000..c1f6b6574 --- /dev/null +++ b/examples/compute-reflect/Render.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedRecordDot #-} + +-- | The single headless frame: dispatch the Julia pipeline and read the image back. +module Render + ( render + ) where + +import qualified Codec.Picture as JP +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Resource (ResourceT, allocate) +import Data.Word (Word32) +import Foreign.Marshal.Array (peekArray) +import Foreign.Marshal.Utils (with) +import Foreign.Ptr (Ptr, castPtr, plusPtr) +import Foreign.Storable (sizeOf) +import Geomancy.UVec2 (uvec2) +import Geomancy.Vec2 (vec2) +import HeadlessBoot (submitAndWait) +import ImageReadback (captureImageRGBA8) +import Vulkan.CStruct.Utils (FixedArray, lowerArrayPtr) +import qualified Vulkan.Core10 as CommandBufferBeginInfo (CommandBufferBeginInfo (..)) +import qualified Vulkan.Core10 as CommandPoolCreateInfo (CommandPoolCreateInfo (..)) +import qualified Vulkan.Core10 as Vk +import Vulkan.Utils.Descriptors (bufferWrite) +import Vulkan.Zero (zero) +import qualified VulkanMemoryAllocator as VMA + +import Julia (Params (..)) +import qualified Julia + +render + :: VMA.Allocator + -> Vk.Device + -> Word32 + -> ResourceT IO (JP.Image JP.PixelRGBA8) +render allocator dev computeQueueFamilyIndex = do + let + width, height :: Int + width = 512 + height = width + + -- Push-constant block (reflected as 'Params'). + params :: Params + params = + Params + { center = vec2 (-0.8) 0.156 + , resolution = uvec2 (fromIntegral width) (fromIntegral height) + } + + -- Specialization constants, in ascending constant_id order: + -- id 0 = maxIterations (uint), id 1 = escapeRadius (float). + maxIterations :: Word32 + maxIterations = 1000 + escapeRadius :: Float + escapeRadius = 2.0 + + -- Output storage buffer: one RGBA32F texel per pixel, mapped GPU_TO_CPU. + (_, (outBuffer, outAllocation, outInfo)) <- + VMA.withBuffer + allocator + zero + { Vk.size = fromIntegral $ width * height * 4 * sizeOf (0 :: Float) + , Vk.usage = Vk.BUFFER_USAGE_STORAGE_BUFFER_BIT + } + zero + { VMA.flags = VMA.ALLOCATION_CREATE_MAPPED_BIT + , VMA.usage = VMA.MEMORY_USAGE_GPU_TO_CPU + } + allocate + + julia <- Julia.allocatePipeline dev maxIterations escapeRadius + + (_, descriptorPool) <- + Vk.withDescriptorPool + dev + zero + { Vk.maxSets = 1 + , Vk.poolSizes = + [ Vk.DescriptorPoolSize Vk.DESCRIPTOR_TYPE_STORAGE_BUFFER 1 + ] + } + Nothing + allocate + [descriptorSet] <- + Vk.allocateDescriptorSets + dev + zero + { Vk.descriptorPool = descriptorPool + , Vk.setLayouts = [julia.descriptorSetLayout] + } + + Vk.updateDescriptorSets + dev + [ bufferWrite descriptorSet 0 Vk.DESCRIPTOR_TYPE_STORAGE_BUFFER outBuffer + ] + [] + + (_, commandPool) <- + Vk.withCommandPool dev zero{CommandPoolCreateInfo.queueFamilyIndex = computeQueueFamilyIndex} Nothing allocate + (_, [cb]) <- + Vk.withCommandBuffers + dev + zero + { Vk.commandPool = commandPool + , 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} do + Vk.cmdBindPipeline cb Vk.PIPELINE_BIND_POINT_COMPUTE julia.pipeline + Vk.cmdBindDescriptorSets cb Vk.PIPELINE_BIND_POINT_COMPUTE julia.pipelineLayout 0 [descriptorSet] [] + -- Push the reflected 'Params' (std430) for this dispatch. + liftIO $ with params $ \pParams -> + Vk.cmdPushConstants + cb + julia.pipelineLayout + Vk.SHADER_STAGE_COMPUTE_BIT + 0 + (fromIntegral (sizeOf params)) + (castPtr pParams) + Vk.cmdDispatch + cb + (ceiling (realToFrac width / realToFrac @_ @Float Julia.workgroup)) + (ceiling (realToFrac height / realToFrac @_ @Float Julia.workgroup)) + 1 + + computeQueue <- Vk.getDeviceQueue dev computeQueueFamilyIndex 0 + submitAndWait dev computeQueue cb "Timed out waiting for compute" + + let + pixelAddr :: Int -> Int -> Ptr (FixedArray 4 Float) + pixelAddr x y = + plusPtr + (VMA.mappedData outInfo) + (((y * width) + x) * 4 * sizeOf (0 :: Float)) + captureImageRGBA8 allocator outAllocation width height $ \x y -> do + let ptr = pixelAddr x y + [r, g, b, a] <- fmap (\f -> round (f * 255)) <$> peekArray 4 (lowerArrayPtr ptr) + pure $ JP.PixelRGBA8 r g b a diff --git a/examples/compute/Main.hs b/examples/compute/Main.hs index df85ae6b7..c02c4384e 100644 --- a/examples/compute/Main.hs +++ b/examples/compute/Main.hs @@ -34,14 +34,15 @@ main = runResourceT $ do HeadlessVk{..} <- withHeadlessVk HeadlessConfig - { hcAppName = "Haskell Vulkan compute example" - , hcInstanceReqs = [] - , hcDeviceReqs = [] + { appName = "Haskell Vulkan compute example" + , instanceReqs = [] + , deviceReqs = [] + , vmaFlags = zero } - let QueueFamilyIndex computeQueueFamilyIndex = fst (qCompute hvQueues) + let QueueFamilyIndex computeQueueFamilyIndex = fst (qCompute queues) - image <- render hvAllocator hvDevice computeQueueFamilyIndex - Vk.deviceWaitIdle hvDevice + image <- render allocator device computeQueueFamilyIndex + Vk.deviceWaitIdle device savePng "julia.png" image -- | Render the Julia set diff --git a/examples/depth-headless/Main.hs b/examples/depth-headless/Main.hs index 57eef6162..65bc363da 100644 --- a/examples/depth-headless/Main.hs +++ b/examples/depth-headless/Main.hs @@ -107,17 +107,18 @@ main = runResourceT $ do HeadlessVk{..} <- withHeadlessVk HeadlessConfig - { hcAppName = "Haskell Vulkan depth + vertex-buffer (headless) test" - , hcInstanceReqs = [] - , hcDeviceReqs = + { appName = "Haskell Vulkan depth + vertex-buffer (headless) test" + , instanceReqs = [] + , deviceReqs = [U.reqs| VK_KHR_dynamic_rendering PhysicalDeviceDynamicRenderingFeatures.dynamicRendering |] + , vmaFlags = zero } - let QueueFamilyIndex graphicsQueueFamilyIndex = fst (qGraphics hvQueues) - results <- render hvAllocator hvDevice graphicsQueueFamilyIndex - Vk.deviceWaitIdle hvDevice + let QueueFamilyIndex graphicsQueueFamilyIndex = fst (qGraphics queues) + results <- render allocator device graphicsQueueFamilyIndex + Vk.deviceWaitIdle device centres <- forM results $ \(name, image) -> do savePng ("depth-headless-" <> name <> ".png") image @@ -192,7 +193,7 @@ render allocator dev graphicsQueueFamilyIndex = do , Dynamic.depthFormat = Just depthFormat , Dynamic.vertexInput = vertexInput } - () -- no specialization constants + () [(Vk.SHADER_STAGE_VERTEX_BIT, vertCode), (Vk.SHADER_STAGE_FRAGMENT_BIT, fragCode)] let poolCreateInfo = zero{CommandPoolCreateInfo.queueFamilyIndex = graphicsQueueFamilyIndex} diff --git a/examples/hlsl/Main.hs b/examples/hlsl/Main.hs index 7e637a18b..01f8a78c3 100644 --- a/examples/hlsl/Main.hs +++ b/examples/hlsl/Main.hs @@ -32,11 +32,11 @@ main = runResourceT $ do (vc, _vma, initialSC) <- withWindowedVk WindowedConfig - { wcAppName = "Vulkan πŸš€ Haskell" - , wcInstanceReqs = [] - , wcDeviceReqs = [] - , wcVmaFlags = zero - , wcSwapchainConfig = defaultSwapchainConfig + { appName = "Vulkan πŸš€ Haskell" + , instanceReqs = [] + , deviceReqs = [] + , vmaFlags = zero + , swapchainConfig = defaultSwapchainConfig } (sdl2Adapter win) let dev = vcDevice vc diff --git a/examples/lib/HeadlessBoot.hs b/examples/lib/HeadlessBoot.hs index 41f45ad7e..e8a9002e3 100644 --- a/examples/lib/HeadlessBoot.hs +++ b/examples/lib/HeadlessBoot.hs @@ -1,27 +1,30 @@ {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoFieldSelectors #-} -{-| Shared boot prelude for the headless examples (compute, triangle-headless). +{-| Shared boot prelude for the headless examples. Mirrors 'WindowedBoot.withWindowedVk' but with no surface, no swapchain β€” just an instance, a logical device with the standard 'Queues' triple, and a VMA allocator. -Headless callers project the queue they actually need from 'hvQueues' -(@qCompute@ for compute, @qGraphics@ for triangle-headless) β€” there's no -per-example queue-family configuration. +Headless callers project the queue they actually need from 'queues' +(@qCompute@ for compute examples, @qGraphics@ for graphics examples) β€” there's +no per-example queue-family configuration. -} module HeadlessBoot ( HeadlessConfig (..) , HeadlessVk (..) , withHeadlessVk , submitAndWait + , submitAndWaitFor ) where import Control.Exception.Safe (MonadThrow, throwString) import Control.Monad.IO.Class (liftIO) -import Control.Monad.Trans.Resource (MonadResource, allocate) +import Control.Monad.Trans.Resource (MonadResource, allocate, release) import Data.Text (Text) import qualified Data.Text.Encoding as Text +import Data.Word (Word64) import Say (sayErr) import Vulkan.CStruct.Extends (SomeStruct (..)) import qualified Vulkan.Core10 as Vk @@ -41,18 +44,20 @@ import WindowedBoot (debugMessengerCreateInfo) the helper always provisions the standard G/C/T 'Queues' triple. -} data HeadlessConfig = HeadlessConfig - { hcAppName :: Text - , hcInstanceReqs :: [InstanceRequirement] - , hcDeviceReqs :: [DeviceRequirement] + { appName :: Text + , instanceReqs :: [InstanceRequirement] + , deviceReqs :: [DeviceRequirement] + , vmaFlags :: VMA.AllocatorCreateFlags + -- ^ VMA flags (e.g. @ALLOCATOR_CREATE_BUFFER_DEVICE_ADDRESS_BIT@ for BDA). } -- | Long-lived handles produced by 'withHeadlessVk'. data HeadlessVk = HeadlessVk - { hvInstance :: Vk.Instance - , hvPhysicalDevice :: Vk.PhysicalDevice - , hvDevice :: Vk.Device - , hvAllocator :: VMA.Allocator - , hvQueues :: Queues (QueueFamilyIndex, Vk.Queue) + { inst :: Vk.Instance + , physicalDevice :: Vk.PhysicalDevice + , device :: Vk.Device + , allocator :: VMA.Allocator + , queues :: Queues (QueueFamilyIndex, Vk.Queue) } {- | Open a Vulkan instance + headless device + VMA allocator. Logs the @@ -67,30 +72,31 @@ withHeadlessVk HeadlessConfig{..} = do Init.allocateInstance ( Just zero - { Vk.applicationName = Just (Text.encodeUtf8 hcAppName) + { Vk.applicationName = Just (Text.encodeUtf8 appName) , Vk.apiVersion = API_VERSION_1_3 } ) ( RequireInstanceExtension Nothing EXT_DEBUG_UTILS_EXTENSION_NAME minBound - : hcInstanceReqs + : instanceReqs ) [RequireInstanceLayer "VK_LAYER_KHRONOS_validation" minBound] _ <- withDebugUtilsMessengerEXT inst debugMessengerCreateInfo Nothing allocate - (phys, dev, qs) <- allocateDevice inst Nothing hcDeviceReqs + (phys, dev, qs) <- allocateDevice inst Nothing deviceReqs (_, vma) <- - VMA.withAllocator (allocatorCreateInfo zero API_VERSION_1_3 inst phys dev) allocate + VMA.withAllocator (allocatorCreateInfo vmaFlags API_VERSION_1_3 inst phys dev) allocate sayErr . ("Using device: " <>) =<< physicalDeviceName phys pure HeadlessVk - { hvInstance = inst - , hvPhysicalDevice = phys - , hvDevice = dev - , hvAllocator = vma - , hvQueues = qs + { inst + , physicalDevice = phys + , device = dev + , allocator = vma + , queues = qs } {- | Submit a single command buffer to the queue, wait up to a second on a -fresh fence for it to complete, throw on timeout. +fresh fence for it to complete, throw on timeout. For longer-running work (e.g. +a heavy compute dispatch) use 'submitAndWaitFor' with an explicit budget. -} submitAndWait :: (MonadResource m, MonadThrow m) @@ -99,12 +105,26 @@ submitAndWait -> Vk.CommandBuffer -> String -> m () -submitAndWait dev queue commandBuffer timeoutMessage = do - (_, fence) <- Vk.withFence dev zero Nothing allocate +submitAndWait = submitAndWaitFor (1 * 1000 * 1000 * 1000) -- 1 second + +-- | As 'submitAndWait', but with a caller-supplied timeout in nanoseconds. +submitAndWaitFor + :: (MonadResource m, MonadThrow m) + => Word64 + -- ^ Timeout in nanoseconds. + -> Vk.Device + -> Vk.Queue + -> Vk.CommandBuffer + -> String + -- ^ Message to throw if the wait times out. + -> m () +submitAndWaitFor fenceTimeout dev queue commandBuffer timeoutMessage = do + (fenceKey, fence) <- Vk.withFence dev zero Nothing allocate let submitInfo = - zero{Vk.commandBuffers = [Vk.commandBufferHandle commandBuffer]} + zero + { Vk.commandBuffers = [Vk.commandBufferHandle commandBuffer] + } Vk.queueSubmit queue [SomeStruct submitInfo] fence - let fenceTimeout = 1e9 -- 1 second liftIO (Vk.waitForFences dev [fence] True fenceTimeout) >>= \case Vk.TIMEOUT -> throwString timeoutMessage - _ -> pure () + _ -> release fenceKey diff --git a/examples/lib/Triangle.hs b/examples/lib/Triangle.hs index 71a28a71d..684ad4646 100644 --- a/examples/lib/Triangle.hs +++ b/examples/lib/Triangle.hs @@ -117,7 +117,7 @@ createGraphicsPipeline dev renderPass colorFormat = renderPass zero { RenderPass.colorFormats = [colorFormat] - , RenderPass.dynamicStates = Just minimalDynamicStates -- just viewport+scissor; set below with cmdSetViewport/Scissor + , RenderPass.dynamicStates = Just minimalDynamicStates -- just viewport+scissor; set with cmdSetViewport/Scissor } () -- no specialization constants [ (Vk.SHADER_STAGE_VERTEX_BIT, vertCode) diff --git a/examples/lib/WindowedBoot.hs b/examples/lib/WindowedBoot.hs index 49954ed43..9c28196b2 100644 --- a/examples/lib/WindowedBoot.hs +++ b/examples/lib/WindowedBoot.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoFieldSelectors #-} {-| Shared boot prelude for the windowed examples. Drives the standard @allocateInstance \/ allocateSurface \/ allocateDevice \/ withAllocator \/ allocateSwapchain@ @@ -39,15 +40,15 @@ import VulkanMemoryAllocator.Utils (allocatorCreateInfo) -- | Per-example knobs the helper can't infer. data WindowedConfig = WindowedConfig - { wcAppName :: Text + { appName :: Text -- ^ Shows up in the application info; also used as the window title. - , wcInstanceReqs :: [InstanceRequirement] + , instanceReqs :: [InstanceRequirement] -- ^ Extra instance requirements (frame's defaults are added automatically). - , wcDeviceReqs :: [DeviceRequirement] + , deviceReqs :: [DeviceRequirement] -- ^ Extra device requirements (frame's defaults are added automatically). - , wcVmaFlags :: VMA.AllocatorCreateFlags + , vmaFlags :: VMA.AllocatorCreateFlags -- ^ VMA flags (e.g. @ALLOCATOR_CREATE_BUFFER_DEVICE_ADDRESS_BIT@ for rays). - , wcSwapchainConfig :: SwapchainConfig + , swapchainConfig :: SwapchainConfig {- ^ Knobs for the initial swapchain. Pass 'defaultSwapchainConfig' for the common case; compute-shader callers (e.g. @resize@) tweak the storage bits. -} @@ -66,30 +67,29 @@ withWindowedVk WindowedConfig{..} WindowAdapter{..} = do waAllocateInstance ( Just zero - { Vk.applicationName = Just (Text.encodeUtf8 wcAppName) + { Vk.applicationName = Just (Text.encodeUtf8 appName) , Vk.apiVersion = API_VERSION_1_3 } ) ( RequireInstanceExtension Nothing EXT_DEBUG_UTILS_EXTENSION_NAME minBound : frameInstanceRequirements - ++ wcInstanceReqs + ++ instanceReqs ) [RequireInstanceLayer "VK_LAYER_KHRONOS_validation" minBound] _ <- withDebugUtilsMessengerEXT inst debugMessengerCreateInfo Nothing allocate surf <- waAllocateSurface inst (phys, dev, qs) <- - allocateDevice inst (Just surf) (frameDeviceRequirements ++ wcDeviceReqs) + allocateDevice inst (Just surf) (frameDeviceRequirements ++ deviceReqs) (_, vma) <- VMA.withAllocator - (allocatorCreateInfo wcVmaFlags API_VERSION_1_3 inst phys dev) + (allocatorCreateInfo vmaFlags API_VERSION_1_3 inst phys dev) allocate props <- Vk.getPhysicalDeviceProperties phys sayErr $ "Using device: " <> decodeUtf8 (Vk.deviceName props) vc <- liftIO $ mkVulkanContext inst phys dev qs initialSize <- waDrawableSize - initialSC <- - allocateSwapchain phys dev wcSwapchainConfig Vk.NULL_HANDLE initialSize surf + initialSC <- allocateSwapchain phys dev swapchainConfig Vk.NULL_HANDLE initialSize surf pure (vc, vma, initialSC) {- | Standard validation/perf debug messenger create info, shared with diff --git a/examples/mesh-reflect/Main.hs b/examples/mesh-reflect/Main.hs new file mode 100644 index 000000000..428710f76 --- /dev/null +++ b/examples/mesh-reflect/Main.hs @@ -0,0 +1,83 @@ +{-| Headless demonstration of type-verified pipeline assembly from reflected +SPIR-V β€” see "Mesh" for the pipeline family (and the compile-time composition +check), "Mesh.Shader" for the quasiquoted shaders, and "Render" for the frame: + + * a __depth-only__ pipeline (vertex stage alone, no colour attachment) β€” a + z-prepass whose depth buffer is read back and checked (near depth written at + the centre, the cleared far value at the corner). + + * a __depth+colour__ pipeline (vertex + fragment) β€” the fragment stage shades + the surface with a Lambert (NΒ·L) light from the shared @Scene@ UBO, producing + a top-bright/bottom-dark gradient that is read back and checked. + +Exits non-zero on mismatch. +-} +module Main where + +import qualified Codec.Picture as JP +import Control.Monad (unless) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Resource (runResourceT) +import HeadlessBoot (HeadlessConfig (..), HeadlessVk (..), withHeadlessVk) +import ImageReadback (savePng) +import System.Exit (exitFailure) +import qualified Vulkan.Core10 as Vk +import qualified Vulkan.Utils.DynamicRendering as Dynamic +import Vulkan.Utils.QueueAssignment (QueueFamilyIndex (..)) +import Vulkan.Utils.Queues (Queues (..)) +import Vulkan.Zero (zero) + +import qualified Mesh +import Render (height, width) +import qualified Render + +main :: IO () +main = runResourceT $ do + HeadlessVk{..} <- + withHeadlessVk + HeadlessConfig + { appName = "Haskell Vulkan type-verified pipeline assembly (headless)" + , instanceReqs = [] + , deviceReqs = Dynamic.dynamicRenderingRequirements + , vmaFlags = zero + } + liftIO $ putStrLn $ "vertex+fragment pipeline composes (compile-time): " <> show Mesh.pipelineComposes + let QueueFamilyIndex graphicsQueueFamilyIndex = fst (qGraphics queues) + + (depthCentre, depthCorner, colorImage) <- + Render.render allocator device graphicsQueueFamilyIndex + Vk.deviceWaitIdle device + + savePng "mesh-reflect-color.png" colorImage + let + pixel x y = JP.pixelAt colorImage x y + lum (JP.PixelRGBA8 r g b _) = fromIntegral r + fromIntegral g + fromIntegral b :: Int + cx = fromIntegral width `div` 2 + upper = lum (pixel cx (fromIntegral height `div` 4)) -- near the lit apex + lower = lum (pixel cx (3 * fromIntegral height `div` 4)) -- near the dark base + centre = lum (pixel cx (fromIntegral height `div` 2)) + corner = lum (pixel 4 4) -- background + liftIO $ do + putStrLn $ "depth-only: centre=" <> show depthCentre <> " corner=" <> show depthCorner + putStrLn $ + "depth+color: luminance upper=" + <> show upper + <> " lower=" + <> show lower + <> " centre=" + <> show centre + <> " corner=" + <> show corner + + let + checks :: [(String, Bool)] + checks = + [ ("depth-only wrote near depth at the centre", depthCentre < 0.9) + , ("depth-only left the corner at the far plane", depthCorner > 0.99) + , ("depth+color lit the geometry above the background", centre > corner + 60) + , ("Lambert shading is brighter near the light (top) than away (bottom)", upper > lower + 60) + ] + liftIO $ do + mapM_ (\(label, ok) -> putStrLn $ "[" <> (if ok then "PASS" else "FAIL") <> "] " <> label) checks + unless (all snd checks) exitFailure + putStrLn "All type-verified pipeline-assembly checks passed." diff --git a/examples/mesh-reflect/Mesh.hs b/examples/mesh-reflect/Mesh.hs new file mode 100644 index 000000000..48b1733c6 --- /dev/null +++ b/examples/mesh-reflect/Mesh.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +{-| The mesh pipeline family: one vertex shader, two pipelines. + +Reflection of 'Shader.vertCode' \/ 'Shader.fragCode' provides the @Scene@ UBO +record, the @Vertex@ SSBO element record, and a stage signature for each +shader. The fragment stage's compatibility with the vertex stage β€” matching +@out@\/@in@ interface and shared use of the @Scene@ descriptor β€” is verified +__at compile time__ by 'MatchInterface' \/ 'CompatibleResources' (see +'pipelineComposes'); the merged pipeline layout (Scene visible to both stages, +the Mesh SSBO to the vertex stage) and each pipeline come from +'allocateReflectedLayout' \/ 'allocateGraphicsPipeline'. +-} +module Mesh + ( Scene (..) + , Vertex (..) + , pipelineComposes + , Pipelines (..) + , allocatePipelines + ) where + +import Control.Monad.Trans.Resource (ResourceT) +import qualified Geomancy +import Graphics.Gl.Block (Std140 (..), Std430 (..)) +import qualified Vulkan.Core10 as Vk +import qualified Vulkan.Utils.DynamicRendering as Dynamic +import Vulkan.Zero (zero) + +import Data.SpirV.Reflect.FFI (loadBytes) +import Vulkan.Utils.SpirV.Pipeline (ReflectedLayout, allocateGraphicsPipeline, allocateReflectedLayout) +import Vulkan.Utils.SpirV.Stage (CompatibleResources, MatchInterface, reflectStageSigBytes) +import Vulkan.Utils.SpirV.TH (reflectShaderTypesBytes) + +import qualified Mesh.Shader as Shader + +-- Reflection at compile time: the @Scene@ UBO record and the @Vertex@ SSBO +-- element record, plus a stage signature for each shader. +reflectShaderTypesBytes Shader.vertCode +reflectStageSigBytes "VertSig" Shader.vertCode +reflectStageSigBytes "FragSig" Shader.fragCode + +-- Compile-time proof that the fragment stage composes with the vertex stage: +-- matching interface and compatible shared resources. Evaluating it forces GHC to +-- discharge those constraints. +pipelineComposes :: (MatchInterface VertSig FragSig, CompatibleResources VertSig FragSig) => Bool +pipelineComposes = True + +data Pipelines = Pipelines + { layout :: ReflectedLayout + , depthOnly :: Vk.Pipeline + , depthColor :: Vk.Pipeline + } + +{- | Two pipelines from the same vertex shader and the same reflected layout: +depth-only (no colour attachment) and depth+colour. Vertex input is empty β€” +geometry comes from the SSBO via @gl_VertexIndex@. +-} +allocatePipelines :: Vk.Device -> Vk.Format -> Vk.Format -> ResourceT IO Pipelines +allocatePipelines dev colorFormat depthFormat = do + vertModule <- loadBytes Shader.vertCode + fragModule <- loadBytes Shader.fragCode + + -- Descriptor set layouts + pipeline layout from reflection, merged across both + -- stages: Scene visible to vertex AND fragment (stage-flag union), the Mesh SSBO + -- to the vertex stage. One layout, shared by both pipelines. + (_, layout) <- allocateReflectedLayout dev [vertModule, fragModule] + + (_, depthOnly) <- + allocateGraphicsPipeline + dev + layout + zero{Dynamic.depthFormat = Just depthFormat} + () + [(vertModule, Shader.vertCode)] + (_, depthColor) <- + allocateGraphicsPipeline + dev + layout + zero + { Dynamic.colorFormats = [colorFormat] + , Dynamic.depthFormat = Just depthFormat + } + () + [(vertModule, Shader.vertCode), (fragModule, Shader.fragCode)] + + pure Pipelines{layout = layout, depthOnly = depthOnly, depthColor = depthColor} diff --git a/examples/mesh-reflect/Mesh/Shader.hs b/examples/mesh-reflect/Mesh/Shader.hs new file mode 100644 index 000000000..5dc86d655 --- /dev/null +++ b/examples/mesh-reflect/Mesh/Shader.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE QuasiQuotes #-} + +{-| The mesh vertex/fragment shaders, compiled to SPIR-V at build time. + +Reflected in "Mesh": the @Scene@ UBO and @Vertex@ SSBO-element records, the +per-stage signatures the compile-time composition check runs on, and the +merged pipeline layout. +-} +module Mesh.Shader + ( vertCode + , fragCode + ) where + +import Data.ByteString (ByteString) +import Vulkan.Utils.ShaderQQ.GLSL.Glslang (frag, vert) + +{- | Vertex stage shared by both pipelines (depth-only z-prepass and +depth+color). The geometry is pulled from the @Mesh@ SSBO (set 0, binding 1) +indexed by @gl_VertexIndex@ β€” no vertex buffer. The Camera\/Scene UBO (set 0, +binding 0) is shared with the fragment stage: the vertex stage uses +@transform@, the fragment stage uses the light fields. +-} +vertCode :: ByteString +vertCode = + [vert| + #version 450 + + struct Vertex { + vec3 position; + vec3 normal; + vec3 color; + }; + + layout(set = 0, binding = 1, std430) readonly buffer Mesh { + Vertex verts[]; + }; + + layout(set = 0, binding = 0, std140) uniform Scene { + mat4 transform; + vec4 lightDir; + vec4 lightColor; + } scene; + + layout(location = 0) out vec3 outNormal; + layout(location = 1) out vec3 outColor; + + void main() { + Vertex v = verts[gl_VertexIndex]; + gl_Position = scene.transform * vec4(v.position, 1.0); + outNormal = v.normal; + outColor = v.color; + } + |] + +{- | Fragment stage of the depth+color pipeline. Its inputs (normal @loc 0@, +color @loc 1@) must match the vertex stage's outputs, and it shares the Scene +UBO (using the light fields the vertex stage ignores) β€” both checked at +compile time by 'Vulkan.Utils.SpirV.Stage.MatchInterface' \/ +'Vulkan.Utils.SpirV.Stage.CompatibleResources'. Shades the surface with a +simple Lambert (NΒ·L) term plus ambient. +-} +fragCode :: ByteString +fragCode = + [frag| + #version 450 + + layout(location = 0) in vec3 inNormal; + layout(location = 1) in vec3 inColor; + + layout(set = 0, binding = 0, std140) uniform Scene { + mat4 transform; + vec4 lightDir; + vec4 lightColor; + } scene; + + layout(location = 0) out vec4 outColor; + + void main() { + float lambert = max(dot(normalize(inNormal), normalize(scene.lightDir.xyz)), 0.0); + float shade = 0.15 + 0.85 * lambert; + outColor = vec4(inColor * scene.lightColor.rgb * shade, 1.0); + } + |] diff --git a/examples/mesh-reflect/Render.hs b/examples/mesh-reflect/Render.hs new file mode 100644 index 000000000..01d53c4fe --- /dev/null +++ b/examples/mesh-reflect/Render.hs @@ -0,0 +1,309 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE TypeFamilies #-} + +{-| The headless frame: a depth-only z-prepass whose depth buffer is read back, +then a depth+colour pass whose image is read back. +-} +module Render + ( render + , width + , height + ) where + +import qualified Codec.Picture as JP +import Control.Monad (zipWithM_) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Resource (ResourceT, allocate) +import Data.Bits ((.|.)) +import Data.Proxy (Proxy (..)) +import qualified Data.Vector as V +import Data.Word (Word32) +import Foreign.Ptr (castPtr) +import Foreign.Storable (peekElemOff, poke, sizeOf) +import qualified Geomancy.Mat4 as Mat4 +import Geomancy.Vec3 (vec3) +import Geomancy.Vec4 (vec4) +import HeadlessBoot (submitAndWait) +import ImageReadback (copyImageToHost, makeReadbackImage) +import RenderTarget (createColorTarget) +import qualified Vulkan.Core10 as CommandBufferBeginInfo (CommandBufferBeginInfo (..)) +import qualified Vulkan.Core10 as CommandPoolCreateInfo (CommandPoolCreateInfo (..)) +import qualified Vulkan.Core10 as Vk +import qualified Vulkan.Core13 as Vk +import Vulkan.Utils.Barrier (imageBarrier, transitionColorAttachment, transitionDepthAttachment) +import Vulkan.Utils.Descriptors (bufferWrite) +import qualified Vulkan.Utils.DynamicRendering as Dynamic +import Vulkan.Utils.DynamicState (DynamicState (..), allDynamicStates, applyDynamicStates, depthOnlyDynamicStates, dynamicStateFor, fullScissor) +import Vulkan.Zero (zero) +import qualified VulkanMemoryAllocator as AllocationCreateInfo (AllocationCreateInfo (..)) +import qualified VulkanMemoryAllocator as VMA + +import qualified Vulkan.Utils.SpirV.Array as Array +import Vulkan.Utils.SpirV.Buffer (Buffer, unsafeAsBufferPtr, writeBufferElem) +import qualified Vulkan.Utils.SpirV.Pipeline +import Vulkan.Utils.SpirV.Signature (ArrayOf, Sig) + +import Mesh (Scene (..), Vertex (..)) +import qualified Mesh + +width, height :: Word32 +width = 256 +height = 256 + +colorFormat :: Vk.Format +colorFormat = Vk.FORMAT_R8G8B8A8_UNORM + +depthFormat :: Vk.Format +depthFormat = Vk.FORMAT_D32_SFLOAT + +floatSize :: Int +floatSize = sizeOf (0 :: Float) + +{- | The triangle, stored in the SSBO. Apex at the top (Vulkan clip space is +Y +down), facing the light; the base faces away β€” so Lambert shading gives a +top-bright/bottom-dark gradient. Vertices are white; the colour comes from the +light. +-} +meshVertices :: [Vertex] +meshVertices = + [ Vertex{position = vec3 0.0 (-0.7) 0.5, normal = vec3 0.0 (-1.0) 0.6, color = vec3 1 1 1} + , Vertex{position = vec3 (-0.7) 0.6 0.5, normal = vec3 0.0 1.0 0.6, color = vec3 1 1 1} + , Vertex{position = vec3 0.7 0.6 0.5, normal = vec3 0.0 1.0 0.6, color = vec3 1 1 1} + ] + +vertexCount :: Word32 +vertexCount = 3 + +-- | Identity transform, a light from the top-front, and a warm light colour. +sceneValue :: Scene +sceneValue = + Scene + { transform = Mat4.identity + , lightDir = vec4 0.0 (-1.0) 0.6 0.0 + , lightColor = vec4 1.0 0.85 0.6 1.0 + } + +render + :: VMA.Allocator + -> Vk.Device + -> Word32 + -> ResourceT IO (Float, Float, JP.Image JP.PixelRGBA8) +render allocator dev graphicsQueueFamilyIndex = do + let extent = Vk.Extent2D width height + + (_, (image, imageView)) <- createColorTarget allocator dev colorFormat extent + -- Depth target with TRANSFER_SRC so the prepass result can be read back. + (depthImage, depthView) <- createReadableDepthTarget allocator dev depthFormat extent + (cpuImage, readback) <- makeReadbackImage allocator dev colorFormat extent + + -- Geometry SSBO (host-visible, mapped). The mapped pointer is tagged as a typed + -- runtime array of the reflected @Vertex@ element β€” @'ArrayOf' ('Sig' Vertex)@ β€” + -- and each vertex is written with 'writeBufferElem', which is gated by + -- 'Vulkan.Utils.SpirV.Signature.FitsTail': a wrong element layout (or indexing a + -- non-array buffer) is a compile error, and the element stride comes from the + -- signature, not a hand-computed offset. + (_, (meshBuffer, _, meshInfo)) <- + VMA.withBuffer + allocator + zero + { Vk.size = fromIntegral (length meshVertices * Array.std430Stride (Proxy @Vertex)) + , Vk.usage = Vk.BUFFER_USAGE_STORAGE_BUFFER_BIT + } + mappedAlloc + allocate + meshBuf <- unsafeAsBufferPtr (VMA.mappedData meshInfo) :: ResourceT IO (Buffer (ArrayOf (Sig Vertex))) + zipWithM_ (writeBufferElem meshBuf) [0 ..] meshVertices + + -- Scene UBO (host-visible, mapped). + (_, (sceneBuffer, _, sceneInfo)) <- + VMA.withBuffer + allocator + zero + { Vk.size = fromIntegral (sizeOf sceneValue) + , Vk.usage = Vk.BUFFER_USAGE_UNIFORM_BUFFER_BIT + } + mappedAlloc + allocate + liftIO $ poke (castPtr (VMA.mappedData sceneInfo)) sceneValue + + pipelines <- Mesh.allocatePipelines dev colorFormat depthFormat + let layout = pipelines.layout + + -- One descriptor set: binding 0 -> Scene UBO, binding 1 -> Mesh SSBO. + (_, descriptorPool) <- + Vk.withDescriptorPool + dev + zero + { Vk.maxSets = 1 + , Vk.poolSizes = + [ Vk.DescriptorPoolSize Vk.DESCRIPTOR_TYPE_UNIFORM_BUFFER 1 + , Vk.DescriptorPoolSize Vk.DESCRIPTOR_TYPE_STORAGE_BUFFER 1 + ] + } + Nothing + allocate + descriptorSets <- + Vk.allocateDescriptorSets + dev + zero + { Vk.descriptorPool = descriptorPool + , Vk.setLayouts = V.fromList (map snd layout.setLayouts) + } + let descriptorSet = V.head descriptorSets + Vk.updateDescriptorSets + dev + [ bufferWrite descriptorSet 0 Vk.DESCRIPTOR_TYPE_UNIFORM_BUFFER sceneBuffer + , bufferWrite descriptorSet 1 Vk.DESCRIPTOR_TYPE_STORAGE_BUFFER meshBuffer + ] + [] + + (_, commandPool) <- + Vk.withCommandPool dev zero{CommandPoolCreateInfo.queueFamilyIndex = graphicsQueueFamilyIndex} Nothing allocate + graphicsQueue <- Vk.getDeviceQueue dev graphicsQueueFamilyIndex 0 + + -- Depth buffer readback target (host-visible buffer of width*height floats). + (_, (depthBuffer, depthAllocation, depthBufInfo)) <- + VMA.withBuffer + allocator + zero + { Vk.size = fromIntegral (fromIntegral width * fromIntegral height * floatSize) + , Vk.usage = Vk.BUFFER_USAGE_TRANSFER_DST_BIT + } + readbackAlloc + allocate + + let + oneShot = zero{CommandBufferBeginInfo.flags = Vk.COMMAND_BUFFER_USAGE_ONE_TIME_SUBMIT_BIT} + -- Apply only the dynamic states the bound pipeline declares (the depth-only + -- pipeline has no colour-blend state). + bindCommon dynStates cb pipeline = do + Vk.cmdBindPipeline cb Vk.PIPELINE_BIND_POINT_GRAPHICS pipeline + applyDynamicStates + dynStates + cb + (dynamicStateFor extent){depthTest = True, depthWrite = True, depthCompareOp = Vk.COMPARE_OP_LESS} + Vk.cmdBindDescriptorSets cb Vk.PIPELINE_BIND_POINT_GRAPHICS layout.pipelineLayout 0 [descriptorSet] [] + Vk.cmdDraw cb vertexCount 1 0 0 + + -- Pass 1: depth-only z-prepass, then copy the depth image to the host buffer. + cb1 <- oneCommandBuffer dev commandPool + Vk.useCommandBuffer cb1 oneShot do + transitionDepthAttachment cb1 depthImage + Vk.cmdUseRendering cb1 (Dynamic.renderingInfo (fullScissor extent) [] (Just (depthView, 1))) $ + bindCommon depthOnlyDynamicStates cb1 pipelines.depthOnly + depthToTransferSrc cb1 depthImage + Vk.cmdCopyImageToBuffer cb1 depthImage Vk.IMAGE_LAYOUT_TRANSFER_SRC_OPTIMAL depthBuffer [depthCopyRegion extent] + submitAndWait dev graphicsQueue cb1 "Timed out in the depth-only prepass" + VMA.invalidateAllocation allocator depthAllocation 0 Vk.WHOLE_SIZE + let depthPtr = castPtr (VMA.mappedData depthBufInfo) + depthCentre <- liftIO $ peekElemOff depthPtr (fromIntegral (height `div` 2) * fromIntegral width + fromIntegral (width `div` 2)) + depthCorner <- liftIO $ peekElemOff depthPtr 0 + + -- Pass 2: depth+colour, then copy the colour image to the host image. + cb2 <- oneCommandBuffer dev commandPool + Vk.useCommandBuffer cb2 oneShot do + transitionColorAttachment cb2 image + transitionDepthAttachment cb2 depthImage + Vk.cmdUseRendering + cb2 + (Dynamic.renderingInfo (fullScissor extent) [(imageView, Vk.Float32 0.05 0.05 0.05 1)] (Just (depthView, 1))) + $ bindCommon allDynamicStates cb2 pipelines.depthColor + copyImageToHost cb2 extent image cpuImage + submitAndWait dev graphicsQueue cb2 "Timed out in the colour pass" + colorImage <- readback + + pure (depthCentre, depthCorner, colorImage) + +mappedAlloc :: VMA.AllocationCreateInfo +mappedAlloc = + zero + { AllocationCreateInfo.flags = VMA.ALLOCATION_CREATE_MAPPED_BIT + , AllocationCreateInfo.usage = VMA.MEMORY_USAGE_CPU_TO_GPU + , AllocationCreateInfo.requiredFlags = Vk.MEMORY_PROPERTY_HOST_VISIBLE_BIT + } + +readbackAlloc :: VMA.AllocationCreateInfo +readbackAlloc = + zero + { AllocationCreateInfo.flags = VMA.ALLOCATION_CREATE_MAPPED_BIT + , AllocationCreateInfo.usage = VMA.MEMORY_USAGE_GPU_TO_CPU + } + +oneCommandBuffer :: Vk.Device -> Vk.CommandPool -> ResourceT IO Vk.CommandBuffer +oneCommandBuffer dev pool = do + (_, cbs) <- + Vk.withCommandBuffers + dev + zero + { Vk.commandPool = pool + , Vk.level = Vk.COMMAND_BUFFER_LEVEL_PRIMARY + , Vk.commandBufferCount = 1 + } + allocate + pure (V.head cbs) + +depthCopyRegion :: Vk.Extent2D -> Vk.BufferImageCopy +depthCopyRegion (Vk.Extent2D w h) = + Vk.BufferImageCopy + { Vk.bufferOffset = 0 + , Vk.bufferRowLength = 0 + , Vk.bufferImageHeight = 0 + , Vk.imageSubresource = Vk.ImageSubresourceLayers Vk.IMAGE_ASPECT_DEPTH_BIT 0 0 1 + , Vk.imageOffset = Vk.Offset3D 0 0 0 + , Vk.imageExtent = Vk.Extent3D w h 1 + } + +{- | A GPU-only depth attachment that can also be a transfer source (so the +prepass depth can be copied back). Like 'RenderTarget.createDepthTarget' but +with the extra usage flag. +-} +createReadableDepthTarget + :: VMA.Allocator -> Vk.Device -> Vk.Format -> Vk.Extent2D -> ResourceT IO (Vk.Image, Vk.ImageView) +createReadableDepthTarget allocator dev format (Vk.Extent2D w h) = do + (_, (image, _, _)) <- VMA.withImage allocator imageCreateInfo gpuAlloc allocate + (_, view) <- Vk.withImageView dev (viewCreateInfo image) Nothing allocate + pure (image, view) + where + gpuAlloc = zero{AllocationCreateInfo.usage = VMA.MEMORY_USAGE_GPU_ONLY} + imageCreateInfo = + zero + { Vk.imageType = Vk.IMAGE_TYPE_2D + , Vk.format = format + , Vk.extent = Vk.Extent3D w h 1 + , Vk.mipLevels = 1 + , Vk.arrayLayers = 1 + , Vk.samples = Vk.SAMPLE_COUNT_1_BIT + , Vk.tiling = Vk.IMAGE_TILING_OPTIMAL + , Vk.usage = Vk.IMAGE_USAGE_DEPTH_STENCIL_ATTACHMENT_BIT .|. Vk.IMAGE_USAGE_TRANSFER_SRC_BIT + , Vk.initialLayout = Vk.IMAGE_LAYOUT_UNDEFINED + } + viewCreateInfo image = + zero + { Vk.image = image + , Vk.viewType = Vk.IMAGE_VIEW_TYPE_2D + , Vk.format = format + , Vk.subresourceRange = Vk.ImageSubresourceRange Vk.IMAGE_ASPECT_DEPTH_BIT 0 1 0 1 + } + +{- | Barrier the depth image from a depth attachment (after the prepass) to a +transfer source, so it can be copied out. +-} +depthToTransferSrc :: Vk.CommandBuffer -> Vk.Image -> ResourceT IO () +depthToTransferSrc cb img = + Vk.cmdPipelineBarrier + cb + Vk.PIPELINE_STAGE_LATE_FRAGMENT_TESTS_BIT + Vk.PIPELINE_STAGE_TRANSFER_BIT + zero + [] + [] + [ imageBarrier + Vk.IMAGE_ASPECT_DEPTH_BIT + Vk.ACCESS_DEPTH_STENCIL_ATTACHMENT_WRITE_BIT + Vk.ACCESS_TRANSFER_READ_BIT + Vk.IMAGE_LAYOUT_DEPTH_ATTACHMENT_OPTIMAL + Vk.IMAGE_LAYOUT_TRANSFER_SRC_OPTIMAL + img + ] diff --git a/examples/package.yaml b/examples/package.yaml index 00a1d820b..5e30fa6bd 100644 --- a/examples/package.yaml +++ b/examples/package.yaml @@ -131,6 +131,83 @@ executables: - vulkan - vulkan-utils + compute-reflect: + main: Main.hs + source-dirs: compute-reflect + dependencies: + - JuicyPixels + - VulkanMemoryAllocator + - vulkan-examples + - base <5 + - bytestring + - geomancy + - gl-block + - resourcet + - safe-exceptions + - say + - text + - transformers + - vector + - vulkan + - vulkan-utils + - vulkan-utils-spirv + + pathtrace-reflect: + main: Main.hs + source-dirs: pathtrace-reflect + dependencies: + - JuicyPixels + - VulkanMemoryAllocator + - vulkan-examples + - base <5 + - bytestring + - geomancy + - gl-block + - optparse-applicative + - random + - resourcet + - transformers + - vector + - vulkan + - vulkan-utils + - vulkan-utils-spirv + + mesh-reflect: + main: Main.hs + source-dirs: mesh-reflect + dependencies: + - JuicyPixels + - VulkanMemoryAllocator + - vulkan-examples + - base <5 + - bytestring + - geomancy + - gl-block + - resourcet + - say + - spirv-reflect-ffi + - vector + - vulkan + - vulkan-utils + - vulkan-utils-spirv + + texture-reflect: + main: Main.hs + source-dirs: texture-reflect + dependencies: + - JuicyPixels + - VulkanMemoryAllocator + - vulkan-examples + - base <5 + - bytestring + - gl-block + - resourcet + - spirv-reflect-ffi + - vector + - vulkan + - vulkan-utils + - vulkan-utils-spirv + resize: main: Main.hs source-dirs: resize diff --git a/examples/pathtrace-reflect.png b/examples/pathtrace-reflect.png new file mode 100644 index 000000000..cec6141e8 Binary files /dev/null and b/examples/pathtrace-reflect.png differ diff --git a/examples/pathtrace-reflect/Main.hs b/examples/pathtrace-reflect/Main.hs new file mode 100644 index 000000000..80c8e6501 --- /dev/null +++ b/examples/pathtrace-reflect/Main.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE OverloadedRecordDot #-} + +{-| A single-frame, procedural compute path tracer whose /entire/ shader +interface is derived from the quasiquoted shader at build time by +@vulkan-utils-spirv@ β€” see "Pathtracer" for the reflected pipeline, +"Pathtracer.Shader" for the shader, "Scene" for the host-built scene and BVH, +and "Render" for the banded dispatch. + +The scene (a "Ray Tracing in One Weekend" arrangement) is generated on the +host from a command-line seed: the spheres go into the @Scene@ buffer and a +BVH over them into a separate device-address-linked node buffer. +-} +module Main + ( main + ) +where + +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Resource (runResourceT) +import HeadlessBoot (HeadlessConfig (..), HeadlessVk (..), withHeadlessVk) +import ImageReadback (savePng) +import Options.Applicative +import qualified Vulkan.Core10 as Vk +import Vulkan.Utils.QueueAssignment (QueueFamilyIndex (..)) +import Vulkan.Utils.Queues (Queues (..)) +import qualified VulkanMemoryAllocator as VMA + +import qualified Pathtracer +import Render (Options (..)) +import qualified Render + +main :: IO () +main = do + opts <- execParser optionsInfo + runResourceT $ do + HeadlessVk{..} <- + withHeadlessVk + HeadlessConfig + { appName = "Haskell Vulkan pathtrace-reflect example" + , instanceReqs = [] + , deviceReqs = Pathtracer.deviceRequirements + , -- the BVH node buffer is reached by device address + vmaFlags = VMA.ALLOCATOR_CREATE_BUFFER_DEVICE_ADDRESS_BIT + } + let QueueFamilyIndex computeQueueFamilyIndex = fst (qCompute queues) + + image <- Render.render allocator device computeQueueFamilyIndex opts + Vk.deviceWaitIdle device + liftIO $ savePng opts.output image + liftIO $ putStrLn ("Wrote " <> opts.output) + +optionsInfo :: ParserInfo Options +optionsInfo = + info + (optionsParser <**> helper) + ( fullDesc + <> header "pathtrace-reflect - reflection-driven compute path tracer" + <> progDesc + "Render one frame of a procedural sphere scene with a compute path \ + \tracer whose entire interface is derived from SPIR-V reflection." + ) + +optionsParser :: Parser Options +optionsParser = + Options + <$> option auto (long "width" <> metavar "N" <> value 600 <> showDefault <> help "Image width") + <*> option auto (long "height" <> metavar "N" <> value 400 <> showDefault <> help "Image height") + <*> option auto (long "samples" <> metavar "N" <> value 32 <> showDefault <> help "Samples per pixel (spec constant)") + <*> option auto (long "bounces" <> metavar "N" <> value 12 <> showDefault <> help "Max ray bounces (spec constant)") + <*> option auto (long "spheres" <> metavar "N" <> value 64 <> showDefault <> help "Random spheres in the scene") + <*> option auto (long "seed" <> metavar "N" <> value 1 <> showDefault <> help "Scene and sampling seed") + <*> option auto (long "fov" <> metavar "DEG" <> value 20 <> showDefault <> help "Vertical field of view") + <*> option auto (long "timeout" <> metavar "SEC" <> value 60 <> showDefault <> help "GPU wait budget in seconds") + <*> strOption (long "output" <> metavar "FILE" <> value "pathtrace-reflect.png" <> showDefault <> help "Output PNG path") diff --git a/examples/pathtrace-reflect/Pathtracer.hs b/examples/pathtrace-reflect/Pathtracer.hs new file mode 100644 index 000000000..b584f2212 --- /dev/null +++ b/examples/pathtrace-reflect/Pathtracer.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +{-| The path-tracing compute pipeline, its /entire/ interface derived from +'Shader.code' β€” exercising every reflected resource kind at once: + + * the @Camera@ uniform block -> a generated record (std140); + * the @Scene@ input storage buffer -> a descriptor binding holding the leaf + sphere geometry; its element record 'Sphere' is generated from the SSBO's + array element type; + * the @Image@ output storage buffer -> a descriptor binding; + * the @BvhNode@ @buffer_reference@ type -> a generated record whose children + are @DeviceAddress BvhNode@; + * the @Frame@ push-constant block -> a generated record + range, carrying + the root node's device address; and + * the @SAMPLES@ \/ @MAX_BOUNCES@ specialization constants -> the pipeline's + 'Vk.SpecializationInfo'. +-} +module Pathtracer + ( Camera (..) + , Frame (..) + , Sphere (..) + , BvhNode (..) + , deviceRequirements + , Pipeline (..) + , allocatePipeline + ) where + +import Control.Monad.Trans.Resource (ResourceT, allocate) +import qualified Data.Vector as V +import Data.Word (Word32) +import qualified Geomancy +import Graphics.Gl.Block (Std140 (..), Std430 (..)) +import Vulkan.CStruct.Extends (SomeStruct (..)) +import qualified Vulkan.Core10 as PipelineLayoutCreateInfo (PipelineLayoutCreateInfo (..)) +import qualified Vulkan.Core10 as Vk +import Vulkan.Core12.Promoted_From_VK_KHR_buffer_device_address (PhysicalDeviceBufferDeviceAddressFeatures (..)) +import Vulkan.Requirement (DeviceRequirement) +import Vulkan.Utils.Requirements.TH (reqs) +import Vulkan.Utils.Shader (shaderModuleStage) +import Vulkan.Utils.SpirV.Descriptors (pushConstantRanges, singleDescriptorSetLayoutInfo) +import Vulkan.Utils.SpirV.Reflect (reflectBytes) +import Vulkan.Utils.SpirV.Specialization (allocateSpecializationInfo) +import Vulkan.Utils.SpirV.TH (reflectShaderTypesBytes) +import Vulkan.Zero (zero) + +import qualified Pathtracer.Shader as Shader + +-- Generate the records from the same SPIR-V the runtime loads: +-- * @Camera@ (std140 UBO); +-- * @Frame@ (std430 push constant); +-- * @Sphere@ (std430), the element type of the @Scene@ SSBO's @Sphere[]@ β€” +-- generated even though the runtime-array @Scene@/@Image@ blocks themselves +-- aren't (they're @[Sphere]@ / raw @vec4@ texels on the host); and +-- * @BvhNode@ (std430 buffer_reference) with @DeviceAddress BvhNode@ children. +reflectShaderTypesBytes Shader.code + +{- | Enable buffer device addresses so the BVH nodes can be linked on the host +and traversed by 'DeviceAddress' on the GPU. +-} +deviceRequirements :: [DeviceRequirement] +deviceRequirements = + [reqs| PhysicalDeviceBufferDeviceAddressFeatures.bufferDeviceAddress |] + +data Pipeline = Pipeline + { pipeline :: Vk.Pipeline + , pipelineLayout :: Vk.PipelineLayout + , descriptorSetLayout :: Vk.DescriptorSetLayout + } + +{- | The pipeline, specialized to the given samples-per-pixel and bounce cap. + +Descriptor set layout (UBO + 2 SSBOs), push-constant range and specialization +info all come from reflecting 'Shader.code'. +-} +allocatePipeline :: Vk.Device -> Word32 -> Word32 -> ResourceT IO Pipeline +allocatePipeline dev samples bounces = do + -- Reflect the embedded module once; reuse it for the descriptor set layout, + -- the push-constant range and the specialization info. + reflected <- reflectBytes Shader.code + + setLayoutInfo <- either fail pure (singleDescriptorSetLayoutInfo reflected) + (_, descriptorSetLayout) <- Vk.withDescriptorSetLayout dev setLayoutInfo Nothing allocate + + mSpec <- allocateSpecializationInfo reflected (samples, bounces) + (_, shader) <- shaderModuleStage dev Vk.SHADER_STAGE_COMPUTE_BIT mSpec Shader.code + (_, pipelineLayout) <- + Vk.withPipelineLayout + dev + zero + { PipelineLayoutCreateInfo.setLayouts = [descriptorSetLayout] + , PipelineLayoutCreateInfo.pushConstantRanges = + V.fromList (pushConstantRanges reflected) + } + Nothing + allocate + let + pipelineCreateInfo :: Vk.ComputePipelineCreateInfo '[] + pipelineCreateInfo = + zero + { Vk.layout = pipelineLayout + , Vk.stage = shader + , Vk.basePipelineHandle = zero + } + (_, (_, [computePipeline])) <- + Vk.withComputePipelines dev zero [SomeStruct pipelineCreateInfo] Nothing allocate + pure + Pipeline + { pipeline = computePipeline + , pipelineLayout = pipelineLayout + , descriptorSetLayout = descriptorSetLayout + } diff --git a/examples/pathtrace-reflect/Pathtracer/Shader.hs b/examples/pathtrace-reflect/Pathtracer/Shader.hs new file mode 100644 index 000000000..40365f9b3 --- /dev/null +++ b/examples/pathtrace-reflect/Pathtracer/Shader.hs @@ -0,0 +1,282 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} + +{-| The path-tracing compute shader, compiled to SPIR-V at build time. + +@buffer_reference@ needs SPIR-V 1.3+, so this is compiled with +@--target-env vulkan1.2@ ('compileShaderQ' rather than the plain @comp@ +quasiquoter). The whole interface is reflected in "Pathtracer". +-} +module Pathtracer.Shader + ( code + ) where + +import Data.ByteString (ByteString) +import Vulkan.Utils.ShaderQQ.GLSL.Glslang (compileShaderQ, glsl) + +{- | Scene intersection walks a BVH whose nodes are linked by 64-bit +@buffer_reference@ device addresses (BDA): + + * @Camera@ UBO (std140) -> generated Haskell record (Geomancy.Vec3); + * @Scene@ input SSBO (binding 1, readonly) -> leaf sphere geometry, indexed + by a BVH leaf's @sphereIndex@; + * @Image@ output SSBO (binding 2, writeonly) -> descriptor set layout; + * @BvhNode@ (buffer_reference) -> generated record with DeviceAddress children; + * @Frame@ push constants (std430) carry the root BvhNode device address; + * @SAMPLES@ \/ @MAX_BOUNCES@ spec constants -> the pipeline's SpecializationInfo. +-} +code :: ByteString +code = + $( compileShaderQ + (Just "vulkan1.2") + "comp" + Nothing + [glsl| + #version 460 + #extension GL_EXT_buffer_reference : require + + layout(local_size_x = 16, local_size_y = 16) in; + + // Compile-time tunables, specialized at pipeline creation. + layout(constant_id = 0) const uint SAMPLES = 16u; + layout(constant_id = 1) const uint MAX_BOUNCES = 8u; + + // All members are vec3, so they share std140 base alignment 16 (the gl-block + // layout guardrail wants non-increasing alignments). + layout(set = 0, binding = 0, std140) uniform Camera { + vec3 origin; + vec3 lowerLeft; + vec3 horizontal; + vec3 vertical; + vec3 skyTop; + vec3 skyBottom; + } cam; + + struct Sphere { + vec4 centerRadius; // xyz: center, w: radius + vec4 albedo; // rgb: albedo + vec4 material; // x: type (0 lambertian, 1 metal, 2 dielectric), y: fuzz, z: ior + }; + + layout(set = 0, binding = 1, std430) readonly buffer Scene { + Sphere spheres[]; + }; + + layout(set = 0, binding = 2, std430) writeonly buffer Image { + vec4 pixels[]; + }; + + // A BVH node reached by device address. Internal nodes have child addresses and + // sphereIndex < 0; leaves have sphereIndex >= 0 (into the Scene buffer) and null + // children. Fields are ordered by non-increasing alignment (16,16,8,8,4). + layout(buffer_reference) buffer BvhNode; // fwd decl enables self-reference + layout(buffer_reference, std430) buffer BvhNode { + vec4 boundsMin; // xyz AABB min + vec4 boundsMax; // xyz AABB max + BvhNode left; // child device address (null for a leaf) + BvhNode right; // child device address (null for a leaf) + int sphereIndex; // >= 0: leaf sphere index; < 0: internal node + }; + + layout(push_constant, std430) uniform Frame { + BvhNode root; // entry address into the BVH + uvec2 resolution; // image size in pixels + uint seed; // varies sampling between runs + uint rowOffset; // first image row this dispatch (band) covers + } frame; + + struct Ray { + vec3 o; + vec3 d; + }; + + struct Hit { + float t; + vec3 p; + vec3 n; + bool front; + vec4 albedo; + vec4 material; + }; + + // PCG hash RNG, advanced in place. + uint pcg(inout uint s) { + s = s * 747796405u + 2891336453u; + uint w = ((s >> ((s >> 28u) + 4u)) ^ s) * 277803737u; + return (w >> 22u) ^ w; + } + + float rnd(inout uint s) { + return float(pcg(s)) * (1.0 / 4294967296.0); + } + + // Uniformly distributed point on the unit sphere. + vec3 rndUnit(inout uint s) { + float z = rnd(s) * 2.0 - 1.0; + float a = rnd(s) * 6.28318530718; + float r = sqrt(max(0.0, 1.0 - z * z)); + return vec3(r * cos(a), r * sin(a), z); + } + + bool hitSphere(Sphere sp, Ray ray, float tmin, float tmax, inout Hit h) { + vec3 center = sp.centerRadius.xyz; + float radius = sp.centerRadius.w; + vec3 oc = ray.o - center; + float a = dot(ray.d, ray.d); + float halfB = dot(oc, ray.d); + float c = dot(oc, oc) - radius * radius; + float disc = halfB * halfB - a * c; + if (disc < 0.0) { + return false; + } + float sq = sqrt(disc); + float t = (-halfB - sq) / a; + if (t < tmin || t > tmax) { + t = (-halfB + sq) / a; + if (t < tmin || t > tmax) { + return false; + } + } + h.t = t; + h.p = ray.o + t * ray.d; + vec3 outwardN = (h.p - center) / radius; + h.front = dot(ray.d, outwardN) < 0.0; + h.n = h.front ? outwardN : -outwardN; + h.albedo = sp.albedo; + h.material = sp.material; + return true; + } + + // Ray vs AABB slab test, gated to [tmin, tmax]. + bool aabbHit(vec3 bmin, vec3 bmax, Ray ray, float tmin, float tmax) { + vec3 inv = 1.0 / ray.d; + vec3 t0 = (bmin - ray.o) * inv; + vec3 t1 = (bmax - ray.o) * inv; + vec3 tsmall = min(t0, t1); + vec3 tbig = max(t0, t1); + float lo = max(max(tsmall.x, tsmall.y), max(tsmall.z, tmin)); + float hi = min(min(tbig.x, tbig.y), min(tbig.z, tmax)); + return hi >= lo; + } + + // Max BVH traversal depth. A balanced median-split BVH of N leaves is ~log2(N) + // deep, so this covers far more spheres than the host will ever generate; the + // bound guards against a pathologically deep tree (a subtree is skipped rather + // than overflowing the stack). + const int BVH_STACK = 64; + + // Walk the BVH from the root device address, hopping pointers to find the + // closest sphere hit. An explicit stack stands in for recursion. + bool worldHit(Ray ray, float tmin, float tmax, out Hit h) { + bool hitAny = false; + float closest = tmax; + + BvhNode stack[BVH_STACK]; + int sp = 0; + stack[sp++] = frame.root; + + while (sp > 0) { + BvhNode node = stack[--sp]; + if (!aabbHit(node.boundsMin.xyz, node.boundsMax.xyz, ray, tmin, closest)) { + continue; + } + if (node.sphereIndex >= 0) { + Hit tmp; + if (hitSphere(spheres[node.sphereIndex], ray, tmin, closest, tmp)) { + hitAny = true; + closest = tmp.t; + h = tmp; + } + } else if (sp + 2 <= BVH_STACK) { + stack[sp++] = node.left; + stack[sp++] = node.right; + } + } + return hitAny; + } + + vec3 skyColor(vec3 dir) { + float t = 0.5 * (normalize(dir).y + 1.0); + return mix(cam.skyBottom, cam.skyTop, t); + } + + float schlick(float cosine, float ref) { + float r0 = (1.0 - ref) / (1.0 + ref); + r0 = r0 * r0; + return r0 + (1.0 - r0) * pow(1.0 - cosine, 5.0); + } + + vec3 rayColor(Ray ray, inout uint s) { + vec3 attenuation = vec3(1.0); + for (uint bounce = 0u; bounce < MAX_BOUNCES; ++bounce) { + Hit h; + if (!worldHit(ray, 0.001, 1e30, h)) { + return attenuation * skyColor(ray.d); + } + + int mat = int(h.material.x + 0.5); + if (mat == 0) { + // Lambertian: scatter about the normal. + vec3 dir = h.n + rndUnit(s); + if (dot(dir, dir) < 1e-8) { + dir = h.n; + } + ray = Ray(h.p, dir); + attenuation *= h.albedo.rgb; + } else if (mat == 1) { + // Metal: reflect, perturbed by fuzz. + vec3 refl = reflect(normalize(ray.d), h.n); + vec3 dir = refl + h.material.y * rndUnit(s); + if (dot(dir, h.n) <= 0.0) { + return vec3(0.0); + } + ray = Ray(h.p, dir); + attenuation *= h.albedo.rgb; + } else { + // Dielectric: refract or reflect (Schlick). + float ior = h.material.z; + float ratio = h.front ? (1.0 / ior) : ior; + vec3 ud = normalize(ray.d); + float cosT = min(dot(-ud, h.n), 1.0); + float sinT = sqrt(max(0.0, 1.0 - cosT * cosT)); + vec3 dir; + if (ratio * sinT > 1.0 || schlick(cosT, ratio) > rnd(s)) { + dir = reflect(ud, h.n); + } else { + dir = refract(ud, h.n, ratio); + } + ray = Ray(h.p, dir); + } + } + return vec3(0.0); // exceeded the bounce budget + } + + void main() { + // gl_GlobalInvocationID.y is relative to this band; rowOffset places it into + // the full image. The host splits the render into horizontal bands so no single + // compute submission runs long enough to trip the GPU's hang-recovery watchdog. + uvec2 gid = uvec2(gl_GlobalInvocationID.x, gl_GlobalInvocationID.y + frame.rowOffset); + if (gid.x >= frame.resolution.x || gid.y >= frame.resolution.y) { + return; + } + + uint s = (gid.x * 1973u + gid.y * 9277u + frame.seed * 26699u) | 1u; + + vec3 color = vec3(0.0); + for (uint i = 0u; i < SAMPLES; ++i) { + float u = (float(gid.x) + rnd(s)) / float(frame.resolution.x); + float v = (float(gid.y) + rnd(s)) / float(frame.resolution.y); + // Image rows grow downward; flip v so the top row maps to the top of the + // viewport. + vec3 dir = + cam.lowerLeft + u * cam.horizontal + (1.0 - v) * cam.vertical - cam.origin; + color += rayColor(Ray(cam.origin, dir), s); + } + color /= float(SAMPLES); + color = sqrt(color); // gamma 2.0 + + uint idx = gid.y * frame.resolution.x + gid.x; + pixels[idx] = vec4(color, 1.0); + } + |] + ) diff --git a/examples/pathtrace-reflect/Render.hs b/examples/pathtrace-reflect/Render.hs new file mode 100644 index 000000000..669d493f7 --- /dev/null +++ b/examples/pathtrace-reflect/Render.hs @@ -0,0 +1,264 @@ +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedRecordDot #-} + +{-| The headless frame: upload the scene, camera and device-address-linked BVH, +then path-trace in horizontal bands and read the image back. +-} +module Render + ( Options (..) + , render + ) where + +import qualified Codec.Picture as JP +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Resource (ResourceT, allocate) +import Data.Bits ((.|.)) +import Data.Foldable (for_) +import Data.Proxy (Proxy (..)) +import qualified Data.Vector.Storable as VS +import Data.Word (Word32) +import Foreign.Marshal.Array (peekArray) +import Foreign.Marshal.Utils (with) +import Foreign.Ptr (Ptr, castPtr, plusPtr) +import Foreign.Storable (poke, sizeOf) +import Geomancy.UVec2 (uvec2) +import Geomancy.Vec3 (vec3) +import HeadlessBoot (submitAndWaitFor) +import ImageReadback (captureImageRGBA8) +import Vulkan.CStruct.Utils (FixedArray, lowerArrayPtr) +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_buffer_device_address (BufferDeviceAddressInfo (..), getBufferDeviceAddress) +import Vulkan.Utils.Descriptors (bufferWrite) +import Vulkan.Zero (zero) +import qualified VulkanMemoryAllocator as VMA + +import qualified Vulkan.Utils.SpirV.Array as Array +import Vulkan.Utils.SpirV.DeviceAddress (DeviceAddress (..)) + +import Pathtracer (BvhNode, Frame (..), Sphere) +import qualified Pathtracer +import qualified Scene + +data Options = Options + { width :: Int + , height :: Int + , samples :: Word32 + , bounces :: Word32 + , spheres :: Int + , seed :: Word32 + , fov :: Float + , timeout :: Double + -- ^ GPU wait budget, seconds + , output :: FilePath + } + +render + :: VMA.Allocator + -> Vk.Device + -> Word32 + -> Options + -> ResourceT IO (JP.Image JP.PixelRGBA8) +render allocator dev computeQueueFamilyIndex opts = do + let + width = opts.width + height = opts.height + workgroup = 16 :: Int + + -- The runtime-sized Scene SSBO is a std430 array of the reflected 'Sphere'; + -- the BVH bounds each sphere from its reflected centerRadius (a 'Vec4'). + spheres :: VS.Vector Sphere + spheres = VS.fromList (Scene.buildScene opts.spheres opts.seed) + sphereCount = VS.length spheres + + -- One BVH leaf per sphere, flattened to an array with the root at index 0. + bvhFlats = Scene.flattenBvh (Scene.buildBvh (zip [0 ..] (map Scene.sphereAabb (VS.toList spheres)))) + + aspect = fromIntegral width / fromIntegral height + camera = Scene.buildCamera aspect opts.fov (vec3 13 2 3) (vec3 0 0 0) (vec3 0 1 0) + + -- Output storage buffer: one RGBA32F texel per pixel, mapped GPU_TO_CPU. + (_, (outBuffer, outAllocation, outInfo)) <- + VMA.withBuffer + allocator + zero + { Vk.size = fromIntegral $ width * height * 4 * sizeOf (0 :: Float) + , Vk.usage = Vk.BUFFER_USAGE_STORAGE_BUFFER_BIT + } + zero + { VMA.flags = VMA.ALLOCATION_CREATE_MAPPED_BIT + , VMA.usage = VMA.MEMORY_USAGE_GPU_TO_CPU + } + allocate + + -- Input storage buffer: the scene's spheres, written from the host. + (_, (sceneBuffer, _sceneAllocation, sceneInfo)) <- + VMA.withBuffer + allocator + zero + { Vk.size = fromIntegral (sphereCount * Array.std430Stride (Proxy @Sphere)) + , Vk.usage = Vk.BUFFER_USAGE_STORAGE_BUFFER_BIT + } + zero + { VMA.flags = VMA.ALLOCATION_CREATE_MAPPED_BIT + , VMA.usage = VMA.MEMORY_USAGE_CPU_TO_GPU + } + allocate + liftIO $ Array.pokeStd430 (VMA.mappedData sceneInfo) spheres + + -- Uniform buffer holding the reflected 'Camera', written from the host. + (_, (camBuffer, _camAllocation, camInfo)) <- + VMA.withBuffer + allocator + zero + { Vk.size = fromIntegral (sizeOf camera) + , Vk.usage = Vk.BUFFER_USAGE_UNIFORM_BUFFER_BIT + } + zero + { VMA.flags = VMA.ALLOCATION_CREATE_MAPPED_BIT + , VMA.usage = VMA.MEMORY_USAGE_CPU_TO_GPU + } + allocate + liftIO $ poke (castPtr (VMA.mappedData camInfo)) camera + + -- BVH node buffer, reached purely by device address (not a descriptor). + -- Allocate it, learn its base address, then write each node with its + -- children linked by address β€” the generated 'BvhNode' record's + -- @DeviceAddress BvhNode@ fields carry the pointers the shader hops. + let + nodeStride = Array.std430Stride (Proxy @BvhNode) + nodeCount = length bvhFlats + (_, (nodeBuffer, _nodeAllocation, nodeInfo)) <- + VMA.withBuffer + allocator + zero + { Vk.size = fromIntegral (nodeCount * nodeStride) + , Vk.usage = + Vk.BUFFER_USAGE_STORAGE_BUFFER_BIT + .|. Vk.BUFFER_USAGE_SHADER_DEVICE_ADDRESS_BIT + } + zero + { VMA.flags = VMA.ALLOCATION_CREATE_MAPPED_BIT + , VMA.usage = VMA.MEMORY_USAGE_CPU_TO_GPU + } + allocate + bvhBase <- getBufferDeviceAddress dev zero{buffer = nodeBuffer} + liftIO $ + Array.pokeStd430 + (VMA.mappedData nodeInfo) + (VS.fromList (map (Scene.toBvhNode bvhBase nodeStride) bvhFlats)) + + -- The reflected 'Frame' push constant carries the root node's address + -- (the flattened BVH puts the root at index 0, i.e. the buffer base). + let frame = + Frame + { root = DeviceAddress bvhBase + , resolution = uvec2 (fromIntegral width) (fromIntegral height) + , seed = opts.seed + , rowOffset = 0 -- set per band below + } + + pathtracer <- Pathtracer.allocatePipeline dev opts.samples opts.bounces + + (_, descriptorPool) <- + Vk.withDescriptorPool + dev + zero + { Vk.maxSets = 1 + , Vk.poolSizes = + [ Vk.DescriptorPoolSize Vk.DESCRIPTOR_TYPE_UNIFORM_BUFFER 1 + , Vk.DescriptorPoolSize Vk.DESCRIPTOR_TYPE_STORAGE_BUFFER 2 + ] + } + Nothing + allocate + [descriptorSet] <- + Vk.allocateDescriptorSets + dev + zero + { Vk.descriptorPool = descriptorPool + , Vk.setLayouts = [pathtracer.descriptorSetLayout] + } + + Vk.updateDescriptorSets + dev + [ bufferWrite descriptorSet 0 Vk.DESCRIPTOR_TYPE_UNIFORM_BUFFER camBuffer + , bufferWrite descriptorSet 1 Vk.DESCRIPTOR_TYPE_STORAGE_BUFFER sceneBuffer + , bufferWrite descriptorSet 2 Vk.DESCRIPTOR_TYPE_STORAGE_BUFFER outBuffer + ] + [] + + -- Command buffer, reset and re-recorded per band (hence the pool's + -- RESET_COMMAND_BUFFER flag). + (_, commandPool) <- + Vk.withCommandPool + dev + zero + { CommandPoolCreateInfo.queueFamilyIndex = computeQueueFamilyIndex + , CommandPoolCreateInfo.flags = Vk.COMMAND_POOL_CREATE_RESET_COMMAND_BUFFER_BIT + } + Nothing + allocate + (_, [cb]) <- + Vk.withCommandBuffers + dev + zero + { Vk.commandPool = commandPool + , Vk.level = Vk.COMMAND_BUFFER_LEVEL_PRIMARY + , Vk.commandBufferCount = 1 + } + allocate + computeQueue <- Vk.getDeviceQueue dev computeQueueFamilyIndex 0 + let timeoutNanos = round (opts.timeout * 1e9) + + -- Split the dispatch into horizontal bands so no single compute submission runs + -- long enough to trip the GPU's hang-recovery watchdog β€” which resets the queue + -- and drops the unfinished (bottom) workgroups, corrupting that region. Each + -- band is an independent short submission; a low-cost render stays one dispatch. + let + samples = max 1 (fromIntegral opts.samples) :: Int + bounces = max 1 (fromIntegral opts.bounces) :: Int + -- A conservative per-submission budget in ray-bounces (well under what tripped + -- the watchdog here, with margin for heavier scenes). + budget = 6 * 1000 * 1000 * 1000 :: Int + bandRows = max 1 (min height (budget `div` (width * samples * bounces))) + for_ ([0, bandRows .. height - 1] :: [Int]) $ \row0 -> do + let + rowsThis = min bandRows (height - row0) + bandFrame = frame{rowOffset = fromIntegral row0} + Vk.resetCommandBuffer cb zero + Vk.useCommandBuffer cb zero{CommandBufferBeginInfo.flags = Vk.COMMAND_BUFFER_USAGE_ONE_TIME_SUBMIT_BIT} do + Vk.cmdBindPipeline cb Vk.PIPELINE_BIND_POINT_COMPUTE pathtracer.pipeline + Vk.cmdBindDescriptorSets cb Vk.PIPELINE_BIND_POINT_COMPUTE pathtracer.pipelineLayout 0 [descriptorSet] [] + -- Push the reflected 'Frame' (std430) with this band's row offset. + liftIO $ with bandFrame $ \pFrame -> + Vk.cmdPushConstants + cb + pathtracer.pipelineLayout + Vk.SHADER_STAGE_COMPUTE_BIT + 0 + (fromIntegral (sizeOf bandFrame)) + (castPtr pFrame) + Vk.cmdDispatch + cb + (ceiling (realToFrac width / realToFrac @_ @Float workgroup)) + (ceiling (realToFrac rowsThis / realToFrac @_ @Float workgroup)) + 1 + submitAndWaitFor timeoutNanos dev computeQueue cb $ + "Timed out waiting for compute band at row " + <> show row0 + <> " after " + <> show opts.timeout + <> "s (raise --timeout)" + + let + pixelAddr :: Int -> Int -> Ptr (FixedArray 4 Float) + pixelAddr x y = + plusPtr + (VMA.mappedData outInfo) + (((y * width) + x) * 4 * sizeOf (0 :: Float)) + captureImageRGBA8 allocator outAllocation width height $ \x y -> do + let ptr = pixelAddr x y + [r, g, b, a] <- fmap (\f -> round (min 1 f * 255)) <$> peekArray 4 (lowerArrayPtr ptr) + pure $ JP.PixelRGBA8 r g b a diff --git a/examples/pathtrace-reflect/Scene.hs b/examples/pathtrace-reflect/Scene.hs new file mode 100644 index 000000000..c36c6503c --- /dev/null +++ b/examples/pathtrace-reflect/Scene.hs @@ -0,0 +1,208 @@ +{-# LANGUAGE OverloadedRecordDot #-} + +{-| The procedural sphere scene (a "Ray Tracing in One Weekend" arrangement) +and the BVH built over it on the host β€” linked and traversed on the GPU by +device address. +-} +module Scene + ( buildCamera + , buildScene + , sphereAabb + , buildBvh + , flattenBvh + , toBvhNode + , BvhFlat + ) where + +import Control.Monad.Trans.State (State, evalState, runState, state) +import Data.List (sortOn) +import Data.Maybe (catMaybes) +import Data.Word (Word32, Word64) +import Geomancy.Vec3 (Vec3, emap2, vec3, pattern WithVec3) +import qualified Geomancy.Vec3 as V3 +import Geomancy.Vec4 (Vec4, fromVec3, vec4, pattern WithVec4) +import System.Random (StdGen, mkStdGen, uniformR) + +import Vulkan.Utils.SpirV.DeviceAddress (DeviceAddress (..)) + +import Pathtracer (BvhNode (..), Camera (..), Sphere (..)) + +{- | Build the reflected 'Camera' for a simple look-at camera with unit focal +length (no defocus blur). +-} +buildCamera :: Float -> Float -> Vec3 -> Vec3 -> Vec3 -> Camera +buildCamera aspect vfovDeg lookFrom lookAt vup = + Camera + { origin = lookFrom + , lowerLeft = lowerLeft + , horizontal = horizontal + , vertical = vertical + , skyTop = vec3 0.5 0.7 1.0 + , skyBottom = vec3 1.0 1.0 1.0 + } + where + theta = vfovDeg * pi / 180 + viewportH = 2 * tan (theta / 2) + viewportW = aspect * viewportH + w = V3.normalize (lookFrom - lookAt) + u = V3.normalize (V3.cross vup w) + v = V3.cross w u + horizontal = u V3.^* viewportW + vertical = v V3.^* viewportH + lowerLeft = lookFrom - (horizontal V3.^* 0.5) - (vertical V3.^* 0.5) - w + +{- | The full scene: ground, three feature spheres, and @count@ random small +ones laid out on a grid (from @seed@). +-} +buildScene :: Int -> Word32 -> [Sphere] +buildScene count seed = ground : features ++ small + where + ground = lambertian (vec3 0 (-1000) 0) 1000 (vec3 0.5 0.5 0.5) + features = + [ dielectric (vec3 0 1 0) 1 1.5 + , lambertian (vec3 (-4) 1 0) 1 (vec3 0.4 0.2 0.1) + , metal (vec3 4 1 0) 1 (vec3 0.7 0.6 0.5) 0 + ] + small = evalState (smallSpheres count) (mkStdGen (fromIntegral seed)) + +{- | Up to @n@ small spheres scattered over a grid, skipping any too close to the +feature spheres. Materials are randomly diffuse\/metal\/glass. +-} +smallSpheres :: Int -> State StdGen [Sphere] +smallSpheres n = catMaybes <$> mapM gen (take n grid) + where + -- A square field of unit cells centred on the origin, sized to hold @n@ + -- spheres so they expand toward the horizon as the count grows. (@n = 484@ + -- reproduces the classic @[-11 .. 10]^2@ "Ray Tracing in One Weekend" grid.) + side = ceiling (sqrt (fromIntegral (max 1 n) :: Double)) :: Int + lo = negate (side `div` 2) + grid = [(a, b) | a <- [lo .. lo + side - 1], b <- [lo .. lo + side - 1]] + gen (a, b) = do + rx <- rF (0, 0.9) + rz <- rF (0, 0.9) + let + center = vec3 (fromIntegral a + rx) 0.2 (fromIntegral b + rz) + d = center - vec3 4 0.2 0 + -- Skip spheres too close to the metal feature sphere (compare squared). + if V3.dot d d <= 0.9 * 0.9 + then pure Nothing + else do + choose <- rF (0, 1) + fmap Just $ + if choose < (0.8 :: Float) + then do + c1 <- rF (0, 1) + c2 <- rF (0, 1) + c3 <- rF (0, 1) + pure $ lambertian center 0.2 (vec3 (c1 * c1) (c2 * c2) (c3 * c3)) + else + if choose < 0.95 + then do + c1 <- rF (0.5, 1) + c2 <- rF (0.5, 1) + c3 <- rF (0.5, 1) + fz <- rF (0, 0.5) + pure $ metal center 0.2 (vec3 c1 c2 c3) fz + else pure $ dielectric center 0.2 1.5 + rF range = state (uniformR range) + +-- Sphere constructors (material encoding matches the shader). The center is a +-- 'Vec3' and the albedo a 'Vec3'; @centerRadius@ packs the radius into w. + +mkSphere :: Vec3 -> Float -> Vec4 -> Vec4 -> Sphere +mkSphere center r = Sphere (fromVec3 center r) + +lambertian :: Vec3 -> Float -> Vec3 -> Sphere +lambertian c r albedo = mkSphere c r (fromVec3 albedo 1) (vec4 0 0 0 0) + +metal :: Vec3 -> Float -> Vec3 -> Float -> Sphere +metal c r albedo fuzz = mkSphere c r (fromVec3 albedo 1) (vec4 1 fuzz 0 0) + +dielectric :: Vec3 -> Float -> Float -> Sphere +dielectric c r ior = mkSphere c r (vec4 1 1 1 1) (vec4 2 0 ior 0) + +-------------------------------------------------------------------------------- +-- BVH (built on the host; linked and traversed on the GPU by device address) +-------------------------------------------------------------------------------- + +-- | An axis-aligned bounding box (min, max corners). +data Aabb = Aabb !Vec3 !Vec3 + +-- | Bound a sphere from its reflected @centerRadius@ (xyz centre, w radius). +sphereAabb :: Sphere -> Aabb +sphereAabb sphere = case sphere.centerRadius of + WithVec4 cx cy cz r -> + Aabb (vec3 (cx - r) (cy - r) (cz - r)) (vec3 (cx + r) (cy + r) (cz + r)) + +aabbUnion :: Aabb -> Aabb -> Aabb +aabbUnion (Aabb amin amax) (Aabb bmin bmax) = + Aabb (emap2 min amin bmin) (emap2 max amax bmax) + +-- | A binary BVH over sphere indices; each leaf bounds one sphere. +data Bvh = BvhLeaf Int Aabb | BvhSplit Aabb Bvh Bvh + +-- | Build a BVH by recursively median-splitting the longest axis. +buildBvh :: [(Int, Aabb)] -> Bvh +buildBvh [] = error "buildBvh: empty scene" +buildBvh [(i, bb)] = BvhLeaf i bb +buildBvh xs = BvhSplit bb (buildBvh l) (buildBvh r) + where + bb = foldr1 aabbUnion (map snd xs) + Aabb lo hi = bb + axis = longestAxis (hi - lo) + (l, r) = splitAt (length xs `div` 2) (sortOn (axisKey axis . snd) xs) + +longestAxis :: Vec3 -> Int +longestAxis (WithVec3 x y z) + | x >= y && x >= z = 0 + | y >= z = 1 + | otherwise = 2 + +-- | Twice the box centre on an axis (the constant factor is irrelevant to sorting). +axisKey :: Int -> Aabb -> Float +axisKey axis (Aabb (WithVec3 mnx mny mnz) (WithVec3 mxx mxy mxz)) = case axis of + 0 -> mnx + mxx + 1 -> mny + mxy + _ -> mnz + mxz + +{- | A flattened node: bounds, child array indices (-1 if none), and the leaf's +sphere index (-1 for an internal node). +-} +data BvhFlat = BvhFlat Vec3 Vec3 Int Int Int + +{- | Flatten the tree to an array in pre-order so the root lands at index 0; +children are referenced by array index, later resolved to device addresses. +-} +flattenBvh :: Bvh -> [BvhFlat] +flattenBvh tree = map snd (sortOn fst nodes) + where + (_, (_, nodes)) = runState (go tree) (0 :: Int, []) + fresh = state (\(n, acc) -> (n, (n + 1, acc))) + emit i f = state (\(n, acc) -> ((), (n, (i, f) : acc))) + go (BvhLeaf i (Aabb mn mx)) = do + idx <- fresh + emit idx (BvhFlat mn mx (-1) (-1) i) + pure idx + go (BvhSplit (Aabb mn mx) l r) = do + idx <- fresh + li <- go l + ri <- go r + emit idx (BvhFlat mn mx li ri (-1)) + pure idx + +{- | Realise a flattened node as the reflected 'BvhNode' record, resolving child +indices to device addresses within the node buffer (base + index * stride). +-} +toBvhNode :: Word64 -> Int -> BvhFlat -> BvhNode +toBvhNode base stride (BvhFlat mn mx li ri si) = + BvhNode + { boundsMin = fromVec3 mn 0 + , boundsMax = fromVec3 mx 0 + , left = childAddr li + , right = childAddr ri + , sphereIndex = fromIntegral si + } + where + childAddr i + | i < 0 = DeviceAddress 0 + | otherwise = DeviceAddress (base + fromIntegral (i * stride)) diff --git a/examples/rays/Main.hs b/examples/rays/Main.hs index 69491212f..29d06a80c 100644 --- a/examples/rays/Main.hs +++ b/examples/rays/Main.hs @@ -31,11 +31,11 @@ main = runResourceT $ do (vc, vma, initialSC) <- withWindowedVk WindowedConfig - { wcAppName = "Vulkan ⚑ Haskell" - , wcInstanceReqs = instanceRequirements - , wcDeviceReqs = deviceRequirements - , wcVmaFlags = VMA.ALLOCATOR_CREATE_BUFFER_DEVICE_ADDRESS_BIT - , wcSwapchainConfig = defaultSwapchainConfig + { appName = "Vulkan ⚑ Haskell" + , instanceReqs = instanceRequirements + , deviceReqs = deviceRequirements + , vmaFlags = VMA.ALLOCATOR_CREATE_BUFFER_DEVICE_ADDRESS_BIT + , swapchainConfig = defaultSwapchainConfig } (sdl2Adapter win) let diff --git a/examples/resize/Main.hs b/examples/resize/Main.hs index 68dc70b59..ca1db22af 100644 --- a/examples/resize/Main.hs +++ b/examples/resize/Main.hs @@ -86,11 +86,11 @@ main = prettyError . runResourceT $ do windowConfig :: WindowedConfig windowConfig = WindowedConfig - { wcAppName = "Haskell ❀️ Vulkan" - , wcInstanceReqs = [] - , wcDeviceReqs = [] - , wcVmaFlags = zero - , wcSwapchainConfig = + { appName = "Haskell ❀️ Vulkan" + , instanceReqs = [] + , deviceReqs = [] + , vmaFlags = zero + , swapchainConfig = defaultSwapchainConfig { scRequiredUsageFlags = -- TRANSFER_DST for the blit; COLOR_ATTACHMENT so the diff --git a/examples/texture-reflect/Cube.hs b/examples/texture-reflect/Cube.hs new file mode 100644 index 000000000..cf18199a5 --- /dev/null +++ b/examples/texture-reflect/Cube.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +{-| The cube pipeline: a spinning cube sampling the offscreen image through a +@sampler2D@ at set 1, binding 0. + +Its @position@ + @uv@ vertex attributes are described from reflection +("Vulkan.Utils.SpirV.VertexInput"); the per-stage signatures prove the +vertex\/fragment composition at compile time ('composes'). The @Globals@ +record its shaders share with the offscreen pass is generated once, in "Tri". +-} +module Cube + ( composes + , Pipeline (..) + , allocatePipeline + ) where + +import Control.Monad.Trans.Resource (ResourceT, allocate) +import qualified Vulkan.Core10 as PipelineLayoutCreateInfo (PipelineLayoutCreateInfo (..)) +import qualified Vulkan.Core10 as Vk +import qualified Vulkan.Utils.DynamicRendering as Dynamic +import Vulkan.Zero (zero) + +import Data.SpirV.Reflect.FFI (loadBytes) +import Vulkan.Utils.SpirV.Stage (CompatibleResources, MatchInterface, reflectStageSigBytes) +import Vulkan.Utils.SpirV.VertexInput (vertexInputState) + +import qualified Cube.Shader as Shader + +reflectStageSigBytes "VertSig" Shader.vertCode +reflectStageSigBytes "FragSig" Shader.fragCode + +-- | This pipeline's vertex↔fragment composition, proved at compile time. +composes :: (MatchInterface VertSig FragSig, CompatibleResources VertSig FragSig) => Bool +composes = True + +data Pipeline = Pipeline + { pipeline :: Vk.Pipeline + , pipelineLayout :: Vk.PipelineLayout + } + +{- | Colour + depth, vertex attributes from reflection. Set 0 is the layout +shared with the offscreen pipeline; set 1 holds this pipeline's sampler. +-} +allocatePipeline + :: Vk.Device + -> Vk.Format + -> Vk.Format + -> Vk.DescriptorSetLayout + -> Vk.DescriptorSetLayout + -> ResourceT IO Pipeline +allocatePipeline dev colorFormat depthFormat set0Layout set1Layout = do + vertModule <- loadBytes Shader.vertCode + (_, pipelineLayout) <- + Vk.withPipelineLayout + dev + zero{PipelineLayoutCreateInfo.setLayouts = [set0Layout, set1Layout]} + Nothing + allocate + (_, pipeline) <- + Dynamic.allocatePipelineFromShaders + dev + zero + { Dynamic.colorFormats = [colorFormat] + , Dynamic.depthFormat = Just depthFormat + , Dynamic.vertexInput = vertexInputState vertModule + , Dynamic.layout = Just pipelineLayout + } + () + [(Vk.SHADER_STAGE_VERTEX_BIT, Shader.vertCode), (Vk.SHADER_STAGE_FRAGMENT_BIT, Shader.fragCode)] + pure Pipeline{pipeline = pipeline, pipelineLayout = pipelineLayout} diff --git a/examples/texture-reflect/Cube/Shader.hs b/examples/texture-reflect/Cube/Shader.hs new file mode 100644 index 000000000..da8e15a51 --- /dev/null +++ b/examples/texture-reflect/Cube/Shader.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE QuasiQuotes #-} + +{-| The cube-pass shaders: a spinning cube sampling the offscreen image, +compiled to SPIR-V at build time and reflected in "Cube". +-} +module Cube.Shader + ( vertCode + , fragCode + ) where + +import Data.ByteString (ByteString) +import Vulkan.Utils.ShaderQQ.GLSL.Glslang (frag, vert) + +{- | Geometry comes from a vertex buffer with per-vertex position + uv +attributes β€” the binding\/attribute descriptions are built from reflection +("Vulkan.Utils.SpirV.VertexInput"), not hand-written. The cube spins by +@Globals.time@ (the same shared UBO at set 0, binding 0 the offscreen pass +used). A perspective projection is built inline. +-} +vertCode :: ByteString +vertCode = + [vert| + #version 450 + + layout(set = 0, binding = 0, std140) uniform Globals { + float time; + } g; + + layout(location = 0) in vec3 position; + layout(location = 1) in vec2 uv; + + layout(location = 0) out vec2 vUv; + + mat4 rotY(float a) { + float c = cos(a), s = sin(a); + return mat4(c, 0.0, -s, 0.0, 0.0, 1.0, 0.0, 0.0, s, 0.0, c, 0.0, 0.0, 0.0, 0.0, 1.0); + } + + mat4 rotX(float a) { + float c = cos(a), s = sin(a); + return mat4(1.0, 0.0, 0.0, 0.0, 0.0, c, s, 0.0, 0.0, -s, c, 0.0, 0.0, 0.0, 0.0, 1.0); + } + + // Vulkan-clip perspective (z in [0,1], y flipped), column-major. + mat4 perspective(float fovy, float aspect, float near, float far) { + float f = 1.0 / tan(fovy * 0.5); + return mat4( + f / aspect, 0.0, 0.0, 0.0, + 0.0, -f, 0.0, 0.0, + 0.0, 0.0, far / (near - far), -1.0, + 0.0, 0.0, (near * far) / (near - far), 0.0); + } + + void main() { + // Scale the unit cube down so the framed image has padding around it. + vec4 world = rotY(g.time) * rotX(0.5) * vec4(position * 0.62, 1.0); + world.z -= 3.0; + gl_Position = perspective(radians(50.0), 1.0, 0.1, 10.0) * world; + vUv = uv; + } + |] + +{- | Samples the offscreen RGB triangle β€” produced by the "Tri" pipeline and +barriered into a shader-read layout β€” through a combined image sampler at +set 1, binding 0. The shared Globals UBO (set 0, binding 0) is read again here +for a time-based tint; it is the SAME descriptor the offscreen pass bound, +never rebound between the two draws. +-} +fragCode :: ByteString +fragCode = + [frag| + #version 450 + + layout(set = 0, binding = 0, std140) uniform Globals { + float time; + } g; + + layout(set = 1, binding = 0) uniform sampler2D offscreen; + + layout(location = 0) in vec2 vUv; + + layout(location = 0) out vec4 outColor; + + void main() { + vec3 c = texture(offscreen, vUv).rgb; + c *= 0.85 + 0.15 * sin(g.time); + outColor = vec4(c, 1.0); + } + |] diff --git a/examples/texture-reflect/Main.hs b/examples/texture-reflect/Main.hs new file mode 100644 index 000000000..5e0e4ff70 --- /dev/null +++ b/examples/texture-reflect/Main.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE BangPatterns #-} + +{-| Headless demonstration of __using a colour attachment as a texture__ +(render-to-texture), driven by reflected SPIR-V. Two pipelines run back to +back in one command buffer β€” see "Tri" (the offscreen RGB triangle), "Cube" +(the spinning cube sampling it) and "Render" (the frame and the shared-set-0 +wiring). + +Both pipelines share a @Globals@ UBO at __set 0, binding 0__ (a @time@). The +set 0 descriptor-set layout is a single object reused by both pipeline +layouts, so the layouts are /compatible for set 0/: the UBO is bound __once__ +before the offscreen pass and is never rebound β€” the cube pass only binds its +sampler at set 1. (The cross-pipeline layout match is not type-enforced here; +each pipeline's own vertex↔fragment composition still is, via +'Vulkan.Utils.SpirV.Stage.MatchInterface' \/ +'Vulkan.Utils.SpirV.Stage.CompatibleResources'.) +-} +module Main where + +import qualified Codec.Picture as JP +import Control.Monad (unless) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Resource (runResourceT) +import Data.List (foldl') +import HeadlessBoot (HeadlessConfig (..), HeadlessVk (..), withHeadlessVk) +import ImageReadback (savePng) +import System.Exit (exitFailure) +import qualified Vulkan.Core10 as Vk +import qualified Vulkan.Utils.DynamicRendering as Dynamic +import Vulkan.Utils.QueueAssignment (QueueFamilyIndex (..)) +import Vulkan.Utils.Queues (Queues (..)) +import Vulkan.Zero (zero) + +import qualified Cube +import Render (height, width) +import qualified Render +import qualified Tri + +main :: IO () +main = runResourceT $ do + HeadlessVk{..} <- + withHeadlessVk + HeadlessConfig + { appName = "Haskell Vulkan colour-attachment-as-texture (headless)" + , instanceReqs = [] + , deviceReqs = Dynamic.dynamicRenderingRequirements + , vmaFlags = zero + } + liftIO $ do + putStrLn $ "offscreen pipeline composes (compile-time): " <> show Tri.composes + putStrLn $ "cube pipeline composes (compile-time): " <> show Cube.composes + let QueueFamilyIndex graphicsQueueFamilyIndex = fst (qGraphics queues) + + colorImage <- Render.render allocator device graphicsQueueFamilyIndex + Vk.deviceWaitIdle device + + savePng "texture-reflect.png" colorImage + let + pixel x y = JP.pixelAt colorImage x y + allPixels = [pixel x y | y <- [0 .. fromIntegral height - 1], x <- [0 .. fromIntegral width - 1]] + -- Brightest sampled R/G/B across the image, in a single pass. + (maxR, maxG, maxB) = + foldl' + (\(!r, !g, !b) (JP.PixelRGBA8 pr pg pb _) -> (max r (fromIntegral pr), max g (fromIntegral pg), max b (fromIntegral pb))) + ((0, 0, 0) :: (Int, Int, Int)) + allPixels + JP.PixelRGBA8 cr cg cb _ = pixel 2 2 + cornerChannels = [fromIntegral cr, fromIntegral cg, fromIntegral cb] :: [Int] + cornerLum = sum cornerChannels + cornerSaturation = maximum cornerChannels - minimum cornerChannels + liftIO $ + putStrLn $ + "sampled max channels: R=" + <> show maxR + <> " G=" + <> show maxG + <> " B=" + <> show maxB + <> "; background corner luminance=" + <> show cornerLum + <> " saturation=" + <> show cornerSaturation + + let + checks :: [(String, Bool)] + checks = + [ ("offscreen red was sampled onto the cube", maxR > 150) + , ("offscreen green was sampled onto the cube", maxG > 150) + , ("offscreen blue was sampled onto the cube", maxB > 150) + , ("background is the neutral clear colour, not the texture", cornerLum > 80 && cornerSaturation < 40) + ] + liftIO $ do + mapM_ (\(label, ok) -> putStrLn $ "[" <> (if ok then "PASS" else "FAIL") <> "] " <> label) checks + unless (all snd checks) exitFailure + putStrLn "All render-to-texture checks passed." diff --git a/examples/texture-reflect/Render.hs b/examples/texture-reflect/Render.hs new file mode 100644 index 000000000..3e341b339 --- /dev/null +++ b/examples/texture-reflect/Render.hs @@ -0,0 +1,310 @@ +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedRecordDot #-} + +{-| The headless frame: the offscreen RGB triangle, a barrier to a sampleable +layout, then the cube pass sampling it β€” both in one command buffer. The +shared set 0 (Globals) is bound once, before the offscreen pass, and never +rebound. +-} +module Render + ( render + , width + , height + ) where + +import qualified Codec.Picture as JP +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Resource (ResourceT, allocate) +import Data.Bits ((.|.)) +import qualified Data.Vector as V +import Data.Word (Word32) +import Foreign.Marshal.Array (pokeArray) +import Foreign.Ptr (castPtr) +import Foreign.Storable (poke, sizeOf) +import HeadlessBoot (submitAndWait) +import ImageReadback (copyImageToHost, makeReadbackImage) +import RenderTarget (createColorTarget, createDepthTarget) +import System.Exit (exitFailure) +import qualified Vulkan.Core10 as CommandBufferBeginInfo (CommandBufferBeginInfo (..)) +import qualified Vulkan.Core10 as CommandPoolCreateInfo (CommandPoolCreateInfo (..)) +import qualified Vulkan.Core10 as SamplerCreateInfo (SamplerCreateInfo (..)) +import qualified Vulkan.Core10 as Vk +import qualified Vulkan.Core13 as Vk +import Vulkan.Utils.Barrier (imageBarrier, transitionColorAttachment, transitionDepthAttachment) +import Vulkan.Utils.Descriptors (bufferWrite, combinedImageSamplerWrite) +import qualified Vulkan.Utils.DynamicRendering as Dynamic +import Vulkan.Utils.DynamicState (DynamicState (..), allDynamicStates, applyDynamicStates, dynamicStateFor, fullScissor) +import Vulkan.Zero (zero) +import qualified VulkanMemoryAllocator as AllocationCreateInfo (AllocationCreateInfo (..)) +import qualified VulkanMemoryAllocator as VMA + +import Data.SpirV.Reflect.FFI (loadBytes) +import Vulkan.Utils.SpirV.Descriptors (mergedDescriptorSetLayoutInfos) + +import qualified Cube +import qualified Cube.Shader +import Tri (Globals (..)) +import qualified Tri +import qualified Tri.Shader + +width, height :: Word32 +width = 256 +height = 256 + +colorFormat :: Vk.Format +colorFormat = Vk.FORMAT_R8G8B8A8_UNORM + +depthFormat :: Vk.Format +depthFormat = Vk.FORMAT_D32_SFLOAT + +floatSize :: Int +floatSize = sizeOf (0 :: Float) + +-- | The shared uniform: a single @time@ both pipelines read. +globalsValue :: Globals +globalsValue = Globals{time = 0.7} + +{- | A unit cube centred at the origin: 6 faces Γ— 2 triangles, each vertex five +floats @px py pz u v@ (tightly packed, matching the reflected vertex input). +-} +cubeVertices :: [Float] +cubeVertices = concatMap faceVerts faces + where + h = 0.5 + add :: (Float, Float, Float) -> (Float, Float, Float) -> (Float, Float, Float) + add (a, b, c) (d, e, f) = (a + d, b + e, c + f) + -- Each face: an origin corner and two edge vectors (length 1). + faces :: [((Float, Float, Float), (Float, Float, Float), (Float, Float, Float))] + faces = + [ ((-h, -h, h), (1, 0, 0), (0, 1, 0)) -- +Z + , ((h, -h, -h), (-1, 0, 0), (0, 1, 0)) -- -Z + , ((h, -h, h), (0, 0, -1), (0, 1, 0)) -- +X + , ((-h, -h, -h), (0, 0, 1), (0, 1, 0)) -- -X + , ((-h, h, h), (1, 0, 0), (0, 0, -1)) -- +Y + , ((-h, -h, -h), (1, 0, 0), (0, 0, 1)) -- -Y + ] + faceVerts :: ((Float, Float, Float), (Float, Float, Float), (Float, Float, Float)) -> [Float] + faceVerts (o, du, dv) = + let + c00 = o + c10 = add o du + c11 = add (add o du) dv + c01 = add o dv + -- V is flipped (top edge -> v = 0): Vulkan's texture origin is top-left, + -- so v = 0 is the top row of the sampled offscreen image. + quad :: [((Float, Float, Float), (Float, Float))] + quad = [(c00, (0, 1)), (c10, (1, 1)), (c11, (1, 0)), (c00, (0, 1)), (c11, (1, 0)), (c01, (0, 0))] + in + concatMap (\((x, y, z), (u, v)) -> [x, y, z, u, v]) quad + +{- | Five floats per vertex (@px py pz u v@), so the draw count is derived from +the geometry rather than asserted separately. +-} +cubeVertexCount :: Word32 +cubeVertexCount = fromIntegral (length cubeVertices `div` 5) + +render + :: VMA.Allocator + -> Vk.Device + -> Word32 + -> ResourceT IO (JP.Image JP.PixelRGBA8) +render allocator dev graphicsQueueFamilyIndex = do + let extent = Vk.Extent2D width height + + -- Offscreen target (sampled in the cube pass), final colour target (read back), + -- depth for the cube, and the host readback image. + (offscreenImage, offscreenView) <- createSampledColorTarget allocator dev colorFormat extent + (_, (sceneImage, sceneView)) <- createColorTarget allocator dev colorFormat extent + (_, (depthImage, depthView)) <- createDepthTarget allocator dev depthFormat extent + (cpuImage, readback) <- makeReadbackImage allocator dev colorFormat extent + + -- Shared Globals UBO (host-visible, mapped). + (_, (uboBuffer, _, uboInfo)) <- + VMA.withBuffer + allocator + zero{Vk.size = fromIntegral (sizeOf globalsValue), Vk.usage = Vk.BUFFER_USAGE_UNIFORM_BUFFER_BIT} + mappedAlloc + allocate + liftIO $ poke (castPtr (VMA.mappedData uboInfo)) globalsValue + + -- Cube vertex buffer (host-visible, mapped) β€” plain floats, interpreted by the + -- reflected attribute descriptions. + (_, (cubeBuffer, _, cubeBufInfo)) <- + VMA.withBuffer + allocator + zero{Vk.size = fromIntegral (length cubeVertices * floatSize), Vk.usage = Vk.BUFFER_USAGE_VERTEX_BUFFER_BIT} + mappedAlloc + allocate + liftIO $ pokeArray (castPtr (VMA.mappedData cubeBufInfo)) cubeVertices + + (_, sampler) <- Vk.withSampler dev samplerInfo Nothing allocate + + -- ONE set 0 layout (the Globals UBO, visible to all stages that read it) and one + -- set 1 layout (the sampler), merged across all four shaders. Reusing the set 0 + -- layout object in both pipeline layouts makes them compatible for set 0. + modules <- + traverse + loadBytes + [Tri.Shader.vertCode, Tri.Shader.fragCode, Cube.Shader.vertCode, Cube.Shader.fragCode] + setInfos <- orDie (mergedDescriptorSetLayoutInfos modules) + setLayouts <- + mapM + (\(setNo, info) -> do (_, l) <- Vk.withDescriptorSetLayout dev info Nothing allocate; pure (setNo, l)) + setInfos + let + layoutFor n = maybe (error ("missing descriptor set " <> show n)) id (lookup n setLayouts) + set0Layout = layoutFor 0 + set1Layout = layoutFor 1 + + tri <- Tri.allocatePipeline dev colorFormat set0Layout + cube <- Cube.allocatePipeline dev colorFormat depthFormat set0Layout set1Layout + + -- Descriptor sets: set 0 = Globals UBO, set 1 = the offscreen image + sampler. + (_, descriptorPool) <- + Vk.withDescriptorPool + dev + zero + { Vk.maxSets = 2 + , Vk.poolSizes = + [ Vk.DescriptorPoolSize Vk.DESCRIPTOR_TYPE_UNIFORM_BUFFER 1 + , Vk.DescriptorPoolSize Vk.DESCRIPTOR_TYPE_COMBINED_IMAGE_SAMPLER 1 + ] + } + Nothing + allocate + descriptorSets <- + Vk.allocateDescriptorSets + dev + zero{Vk.descriptorPool = descriptorPool, Vk.setLayouts = [set0Layout, set1Layout]} + let + globalsSet = descriptorSets V.! 0 + samplerSet = descriptorSets V.! 1 + Vk.updateDescriptorSets + dev + [ bufferWrite globalsSet 0 Vk.DESCRIPTOR_TYPE_UNIFORM_BUFFER uboBuffer + , combinedImageSamplerWrite samplerSet 0 sampler offscreenView Vk.IMAGE_LAYOUT_SHADER_READ_ONLY_OPTIMAL + ] + [] + + (_, commandPool) <- + Vk.withCommandPool dev zero{CommandPoolCreateInfo.queueFamilyIndex = graphicsQueueFamilyIndex} Nothing allocate + graphicsQueue <- Vk.getDeviceQueue dev graphicsQueueFamilyIndex 0 + cb <- oneCommandBuffer dev commandPool + + let oneShot = zero{CommandBufferBeginInfo.flags = Vk.COMMAND_BUFFER_USAGE_ONE_TIME_SUBMIT_BIT} + Vk.useCommandBuffer cb oneShot $ do + transitionColorAttachment cb offscreenImage + transitionColorAttachment cb sceneImage + transitionDepthAttachment cb depthImage + + -- Pass 1: draw the RGB triangle into the offscreen image. The shared Globals + -- descriptor is bound here, ONCE, under the (compatible) triangle layout. + Vk.cmdUseRendering cb (Dynamic.renderingInfo (fullScissor extent) [(offscreenView, Vk.Float32 0 0 0 1)] Nothing) $ do + Vk.cmdBindPipeline cb Vk.PIPELINE_BIND_POINT_GRAPHICS tri.pipeline + applyDynamicStates allDynamicStates cb (dynamicStateFor extent) + Vk.cmdBindDescriptorSets cb Vk.PIPELINE_BIND_POINT_GRAPHICS tri.pipelineLayout 0 [globalsSet] [] + Vk.cmdDraw cb 3 1 0 0 + + -- Make the offscreen colour image readable by the cube's fragment shader. + colorToSampled cb offscreenImage + + -- Pass 2: draw the cube sampling the offscreen image. Set 0 (Globals) is still + -- bound β€” only the sampler at set 1 is bound now. + Vk.cmdUseRendering + cb + (Dynamic.renderingInfo (fullScissor extent) [(sceneView, Vk.Float32 0.30 0.32 0.38 1)] (Just (depthView, 1))) + $ do + Vk.cmdBindPipeline cb Vk.PIPELINE_BIND_POINT_GRAPHICS cube.pipeline + applyDynamicStates + allDynamicStates + cb + (dynamicStateFor extent){depthTest = True, depthWrite = True, depthCompareOp = Vk.COMPARE_OP_LESS} + Vk.cmdBindDescriptorSets cb Vk.PIPELINE_BIND_POINT_GRAPHICS cube.pipelineLayout 1 [samplerSet] [] + Vk.cmdBindVertexBuffers cb 0 [cubeBuffer] [0] + Vk.cmdDraw cb cubeVertexCount 1 0 0 + + copyImageToHost cb extent sceneImage cpuImage + submitAndWait dev graphicsQueue cb "Timed out in the render-to-texture passes" + readback + where + samplerInfo = + zero + { SamplerCreateInfo.magFilter = Vk.FILTER_LINEAR + , SamplerCreateInfo.minFilter = Vk.FILTER_LINEAR + , SamplerCreateInfo.addressModeU = Vk.SAMPLER_ADDRESS_MODE_CLAMP_TO_EDGE + , SamplerCreateInfo.addressModeV = Vk.SAMPLER_ADDRESS_MODE_CLAMP_TO_EDGE + } + +-- | Print a merged-layout conflict and exit non-zero. +orDie :: Either String a -> ResourceT IO a +orDie = either (\e -> liftIO (putStrLn ("merged layout error: " <> e) >> exitFailure)) pure + +mappedAlloc :: VMA.AllocationCreateInfo +mappedAlloc = + zero + { AllocationCreateInfo.flags = VMA.ALLOCATION_CREATE_MAPPED_BIT + , AllocationCreateInfo.usage = VMA.MEMORY_USAGE_CPU_TO_GPU + , AllocationCreateInfo.requiredFlags = Vk.MEMORY_PROPERTY_HOST_VISIBLE_BIT + } + +oneCommandBuffer :: Vk.Device -> Vk.CommandPool -> ResourceT IO Vk.CommandBuffer +oneCommandBuffer dev pool = do + (_, cbs) <- + Vk.withCommandBuffers + dev + zero{Vk.commandPool = pool, Vk.level = Vk.COMMAND_BUFFER_LEVEL_PRIMARY, Vk.commandBufferCount = 1} + allocate + pure (V.head cbs) + +{- | A GPU-only colour target that can be a colour attachment AND be sampled (the +offscreen render-to-texture target). Like 'RenderTarget.createColorTarget' but +with @SAMPLED@ instead of @TRANSFER_SRC@. +-} +createSampledColorTarget + :: VMA.Allocator -> Vk.Device -> Vk.Format -> Vk.Extent2D -> ResourceT IO (Vk.Image, Vk.ImageView) +createSampledColorTarget allocator dev format (Vk.Extent2D w h) = do + (_, (image, _, _)) <- VMA.withImage allocator imageCreateInfo gpuAlloc allocate + (_, view) <- Vk.withImageView dev (viewCreateInfo image) Nothing allocate + pure (image, view) + where + gpuAlloc = zero{AllocationCreateInfo.usage = VMA.MEMORY_USAGE_GPU_ONLY} + imageCreateInfo = + zero + { Vk.imageType = Vk.IMAGE_TYPE_2D + , Vk.format = format + , Vk.extent = Vk.Extent3D w h 1 + , Vk.mipLevels = 1 + , Vk.arrayLayers = 1 + , Vk.samples = Vk.SAMPLE_COUNT_1_BIT + , Vk.tiling = Vk.IMAGE_TILING_OPTIMAL + , Vk.usage = Vk.IMAGE_USAGE_COLOR_ATTACHMENT_BIT .|. Vk.IMAGE_USAGE_SAMPLED_BIT + , Vk.initialLayout = Vk.IMAGE_LAYOUT_UNDEFINED + } + viewCreateInfo image = + zero + { Vk.image = image + , Vk.viewType = Vk.IMAGE_VIEW_TYPE_2D + , Vk.format = format + , Vk.subresourceRange = Vk.ImageSubresourceRange Vk.IMAGE_ASPECT_COLOR_BIT 0 1 0 1 + } + +{- | Barrier a colour image from a colour attachment (after the offscreen pass) to +a shader-readable texture for the next pass's fragment sampling. +-} +colorToSampled :: Vk.CommandBuffer -> Vk.Image -> ResourceT IO () +colorToSampled cb img = + Vk.cmdPipelineBarrier + cb + Vk.PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT + Vk.PIPELINE_STAGE_FRAGMENT_SHADER_BIT + zero + [] + [] + [ imageBarrier + Vk.IMAGE_ASPECT_COLOR_BIT + Vk.ACCESS_COLOR_ATTACHMENT_WRITE_BIT + Vk.ACCESS_SHADER_READ_BIT + Vk.IMAGE_LAYOUT_COLOR_ATTACHMENT_OPTIMAL + Vk.IMAGE_LAYOUT_SHADER_READ_ONLY_OPTIMAL + img + ] diff --git a/examples/texture-reflect/Tri.hs b/examples/texture-reflect/Tri.hs new file mode 100644 index 000000000..67576c727 --- /dev/null +++ b/examples/texture-reflect/Tri.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +{-| The offscreen pipeline: the RGB triangle drawn into the image the cube +samples. + +Reflection of 'Shader.fragCode' generates the shared @Globals@ UBO record +(the cube pass references the same struct, so it is generated once, here); the +per-stage signatures prove the vertex\/fragment composition at compile time +('composes'). +-} +module Tri + ( Globals (..) + , composes + , Pipeline (..) + , allocatePipeline + ) where + +import Control.Monad.Trans.Resource (ResourceT, allocate) +import Graphics.Gl.Block (Std140 (..)) +import qualified Vulkan.Core10 as PipelineLayoutCreateInfo (PipelineLayoutCreateInfo (..)) +import qualified Vulkan.Core10 as Vk +import qualified Vulkan.Utils.DynamicRendering as Dynamic +import Vulkan.Zero (zero) + +import Vulkan.Utils.SpirV.Stage (CompatibleResources, MatchInterface, reflectStageSigBytes) +import Vulkan.Utils.SpirV.TH (reflectShaderTypesBytes) + +import qualified Tri.Shader as Shader + +-- Compile-time reflection: the shared @Globals@ UBO record and a stage +-- signature per shader. +reflectShaderTypesBytes Shader.fragCode +reflectStageSigBytes "VertSig" Shader.vertCode +reflectStageSigBytes "FragSig" Shader.fragCode + +-- | This pipeline's vertex↔fragment composition, proved at compile time. +composes :: (MatchInterface VertSig FragSig, CompatibleResources VertSig FragSig) => Bool +composes = True + +data Pipeline = Pipeline + { pipeline :: Vk.Pipeline + , pipelineLayout :: Vk.PipelineLayout + } + +{- | Colour only, no vertex input. The set 0 layout is shared with the cube +pipeline, making the two pipeline layouts compatible for set 0. +-} +allocatePipeline :: Vk.Device -> Vk.Format -> Vk.DescriptorSetLayout -> ResourceT IO Pipeline +allocatePipeline dev colorFormat set0Layout = do + (_, pipelineLayout) <- + Vk.withPipelineLayout dev zero{PipelineLayoutCreateInfo.setLayouts = [set0Layout]} Nothing allocate + (_, pipeline) <- + Dynamic.allocatePipelineFromShaders + dev + zero + { Dynamic.colorFormats = [colorFormat] + , Dynamic.layout = Just pipelineLayout + } + () + [(Vk.SHADER_STAGE_VERTEX_BIT, Shader.vertCode), (Vk.SHADER_STAGE_FRAGMENT_BIT, Shader.fragCode)] + pure Pipeline{pipeline = pipeline, pipelineLayout = pipelineLayout} diff --git a/examples/texture-reflect/Tri/Shader.hs b/examples/texture-reflect/Tri/Shader.hs new file mode 100644 index 000000000..b335c303c --- /dev/null +++ b/examples/texture-reflect/Tri/Shader.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE QuasiQuotes #-} + +{-| The offscreen-pass shaders: a screen-filling RGB triangle, compiled to +SPIR-V at build time and reflected in "Tri". +-} +module Tri.Shader + ( vertCode + , fragCode + ) where + +import Data.ByteString (ByteString) +import Vulkan.Utils.ShaderQQ.GLSL.Glslang (frag, vert) + +{- | A screen-filling triangle with saturated red \/ green \/ blue corners, so +the offscreen colour image holds the full RGB range (each primary saturated +near a vertex). That image is then sampled as a texture by the cube pass. The +geometry is generated from @gl_VertexIndex@ (no vertex buffer). The shared +Globals UBO (set 0, binding 0) is read by the fragment stage; this pipeline +and the cube pipeline keep set 0 compatible so the descriptor need not be +rebound between them. +-} +vertCode :: ByteString +vertCode = + [vert| + #version 450 + + layout(location = 0) out vec3 vColor; + + void main() { + // Vulkan clip space is +Y down: y = +1 is the bottom, y = -1 the top. + vec2 base[3] = vec2[](vec2(-1.0, 1.0), vec2(1.0, 1.0), vec2(0.0, -1.0)); + vec3 cols[3] = vec3[](vec3(1.0, 0.0, 0.0), vec3(0.0, 1.0, 0.0), vec3(0.0, 0.0, 1.0)); + gl_Position = vec4(base[gl_VertexIndex], 0.0, 1.0); + vColor = cols[gl_VertexIndex]; + } + |] + +{- | Writes the interpolated RGB gradient, pulsed by @Globals.time@ β€” the first +read of the shared UBO (set 0, binding 0). +-} +fragCode :: ByteString +fragCode = + [frag| + #version 450 + + layout(set = 0, binding = 0, std140) uniform Globals { + float time; + } g; + + layout(location = 0) in vec3 vColor; + + layout(location = 0) out vec4 outColor; + + void main() { + float pulse = 0.7 + 0.3 * abs(sin(g.time)); + outColor = vec4(vColor * pulse, 1.0); + } + |] diff --git a/examples/triangle-dynamic/Main.hs b/examples/triangle-dynamic/Main.hs index 13d73f9cd..c67ceb779 100644 --- a/examples/triangle-dynamic/Main.hs +++ b/examples/triangle-dynamic/Main.hs @@ -20,15 +20,15 @@ main = runResourceT $ do (vc, _vma, initialSC) <- withWindowedVk WindowedConfig - { wcAppName = appName - , wcInstanceReqs = [] - , wcDeviceReqs = + { appName = appName + , instanceReqs = [] + , deviceReqs = [U.reqs| VK_KHR_dynamic_rendering PhysicalDeviceDynamicRenderingFeatures.dynamicRendering |] - , wcVmaFlags = zero - , wcSwapchainConfig = defaultSwapchainConfig + , vmaFlags = zero + , swapchainConfig = defaultSwapchainConfig } (Window.glfwAdapter window) TriangleDynamic.runTriangle diff --git a/examples/triangle-dynamic/TriangleDynamic.hs b/examples/triangle-dynamic/TriangleDynamic.hs index aaebcafd9..30509109f 100644 --- a/examples/triangle-dynamic/TriangleDynamic.hs +++ b/examples/triangle-dynamic/TriangleDynamic.hs @@ -56,7 +56,7 @@ runTriangle vc initialSC getDrawableSize shouldQuit = do Dynamic.allocatePipelineFromShaders (vcDevice vc) zero{Dynamic.colorFormats = [KHR.format (sFormat initialSC)]} - () -- no specialization constants + () [ (Vk.SHADER_STAGE_VERTEX_BIT, Triangle.vertCode) , (Vk.SHADER_STAGE_FRAGMENT_BIT, Triangle.fragCode) ] diff --git a/examples/triangle-glfw/Main.hs b/examples/triangle-glfw/Main.hs index ea4580bee..fb261f77a 100644 --- a/examples/triangle-glfw/Main.hs +++ b/examples/triangle-glfw/Main.hs @@ -16,11 +16,11 @@ main = runResourceT $ do (vc, _vma, initialSC) <- withWindowedVk WindowedConfig - { wcAppName = appName - , wcInstanceReqs = [] - , wcDeviceReqs = [] - , wcVmaFlags = zero - , wcSwapchainConfig = defaultSwapchainConfig + { appName = appName + , instanceReqs = [] + , deviceReqs = [] + , vmaFlags = zero + , swapchainConfig = defaultSwapchainConfig } (Window.glfwAdapter window) Triangle.runTriangle diff --git a/examples/triangle-headless-dynamic/Main.hs b/examples/triangle-headless-dynamic/Main.hs index 63e7c180f..f6f15c31b 100644 --- a/examples/triangle-headless-dynamic/Main.hs +++ b/examples/triangle-headless-dynamic/Main.hs @@ -49,17 +49,18 @@ main = runResourceT $ do HeadlessVk{..} <- withHeadlessVk HeadlessConfig - { hcAppName = "Haskell Vulkan dynamic-state (headless) test" - , hcInstanceReqs = [] - , hcDeviceReqs = + { appName = "Haskell Vulkan dynamic-state (headless) test" + , instanceReqs = [] + , deviceReqs = [U.reqs| VK_KHR_dynamic_rendering PhysicalDeviceDynamicRenderingFeatures.dynamicRendering |] + , vmaFlags = zero } - let QueueFamilyIndex graphicsQueueFamilyIndex = fst (qGraphics hvQueues) - results <- render hvAllocator hvDevice graphicsQueueFamilyIndex - Vk.deviceWaitIdle hvDevice + let QueueFamilyIndex graphicsQueueFamilyIndex = fst (qGraphics queues) + results <- render allocator device graphicsQueueFamilyIndex + Vk.deviceWaitIdle device centres <- forM results $ \(name, image) -> do savePng ("headless-dynamic-" <> name <> ".png") image @@ -105,12 +106,12 @@ render allocator dev graphicsQueueFamilyIndex = do (cpuImage, readback) <- makeReadbackImage allocator dev imageFormat extent - -- One pipeline, full always-on dynamic state (Nothing). + -- One pipeline; dynamic states default to full always-on. (_, pipeline) <- Dynamic.allocatePipelineFromShaders dev zero{Dynamic.colorFormats = [imageFormat]} - () -- no specialization constants + () [(Vk.SHADER_STAGE_VERTEX_BIT, vertCode), (Vk.SHADER_STAGE_FRAGMENT_BIT, fragCode)] let poolCreateInfo = zero{CommandPoolCreateInfo.queueFamilyIndex = graphicsQueueFamilyIndex} diff --git a/examples/triangle-headless/Main.hs b/examples/triangle-headless/Main.hs index 5f417b0bf..aa2d5c44c 100644 --- a/examples/triangle-headless/Main.hs +++ b/examples/triangle-headless/Main.hs @@ -37,13 +37,14 @@ main = runResourceT $ do HeadlessVk{..} <- withHeadlessVk HeadlessConfig - { hcAppName = "Haskell Vulkan triangle (headless) example" - , hcInstanceReqs = [] - , hcDeviceReqs = [] + { appName = "Haskell Vulkan triangle (headless) example" + , instanceReqs = [] + , deviceReqs = [] + , vmaFlags = zero } - let QueueFamilyIndex graphicsQueueFamilyIndex = fst (qGraphics hvQueues) - image <- render hvAllocator hvDevice graphicsQueueFamilyIndex - Vk.deviceWaitIdle hvDevice + let QueueFamilyIndex graphicsQueueFamilyIndex = fst (qGraphics queues) + image <- render allocator device graphicsQueueFamilyIndex + Vk.deviceWaitIdle device savePng "triangle.png" image {- | This function renders a triangle and reads the image on the CPU @@ -177,7 +178,12 @@ render allocator dev graphicsQueueFamilyIndex = do (vertKey, vertStage) <- shaderStage dev Vk.SHADER_STAGE_VERTEX_BIT () vertCode (fragKey, fragStage) <- shaderStage dev Vk.SHADER_STAGE_FRAGMENT_BIT () fragCode - (_, graphicsPipeline) <- RenderPass.allocatePipeline dev renderPass zero{RenderPass.colorFormats = [imageFormat], RenderPass.dynamicStates = Just minimalDynamicStates} [vertStage, fragStage] + (_, graphicsPipeline) <- + RenderPass.allocatePipeline + dev + renderPass + zero{RenderPass.colorFormats = [imageFormat], RenderPass.dynamicStates = Just minimalDynamicStates} + [vertStage, fragStage] release vertKey release fragKey diff --git a/examples/triangle-sdl2/Main.hs b/examples/triangle-sdl2/Main.hs index 2e6d3c357..97ebb2b34 100644 --- a/examples/triangle-sdl2/Main.hs +++ b/examples/triangle-sdl2/Main.hs @@ -16,11 +16,11 @@ main = runResourceT $ do (vc, _vma, initialSC) <- withWindowedVk WindowedConfig - { wcAppName = appName - , wcInstanceReqs = [] - , wcDeviceReqs = [] - , wcVmaFlags = zero - , wcSwapchainConfig = defaultSwapchainConfig + { appName = appName + , instanceReqs = [] + , deviceReqs = [] + , vmaFlags = zero + , swapchainConfig = defaultSwapchainConfig } (Window.sdl2Adapter window) Triangle.runTriangle diff --git a/examples/vulkan-examples.cabal b/examples/vulkan-examples.cabal index 8a7bde774..ce261f9ae 100644 --- a/examples/vulkan-examples.cabal +++ b/examples/vulkan-examples.cabal @@ -177,6 +177,74 @@ executable compute if os(windows) ghc-options: -optl-mconsole +executable compute-reflect + main-is: Main.hs + other-modules: + Julia + Julia.Shader + Render + Paths_vulkan_examples + autogen-modules: + Paths_vulkan_examples + hs-source-dirs: + compute-reflect + default-extensions: + BlockArguments + DataKinds + DefaultSignatures + DeriveFoldable + DeriveFunctor + DeriveTraversable + DerivingStrategies + DuplicateRecordFields + FlexibleContexts + FlexibleInstances + GADTs + GeneralizedNewtypeDeriving + InstanceSigs + LambdaCase + MagicHash + NamedFieldPuns + NoMonomorphismRestriction + NumDecimals + OverloadedStrings + PatternSynonyms + PolyKinds + QuantifiedConstraints + RankNTypes + RecordWildCards + RoleAnnotations + ScopedTypeVariables + StandaloneDeriving + Strict + TupleSections + TypeApplications + TypeFamilyDependencies + TypeOperators + TypeSynonymInstances + ViewPatterns + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + build-depends: + JuicyPixels + , VulkanMemoryAllocator + , base <5 + , bytestring + , geomancy + , gl-block + , resourcet + , safe-exceptions + , say + , text + , transformers + , vector + , vulkan + , vulkan-examples + , vulkan-utils + , vulkan-utils-spirv + default-language: Haskell2010 + if os(windows) + ghc-options: -optl-mconsole + executable hlsl main-is: Main.hs other-modules: @@ -297,6 +365,140 @@ executable info if os(windows) ghc-options: -optl-mconsole +executable mesh-reflect + main-is: Main.hs + other-modules: + Mesh + Mesh.Shader + Render + Paths_vulkan_examples + autogen-modules: + Paths_vulkan_examples + hs-source-dirs: + mesh-reflect + default-extensions: + BlockArguments + DataKinds + DefaultSignatures + DeriveFoldable + DeriveFunctor + DeriveTraversable + DerivingStrategies + DuplicateRecordFields + FlexibleContexts + FlexibleInstances + GADTs + GeneralizedNewtypeDeriving + InstanceSigs + LambdaCase + MagicHash + NamedFieldPuns + NoMonomorphismRestriction + NumDecimals + OverloadedStrings + PatternSynonyms + PolyKinds + QuantifiedConstraints + RankNTypes + RecordWildCards + RoleAnnotations + ScopedTypeVariables + StandaloneDeriving + Strict + TupleSections + TypeApplications + TypeFamilyDependencies + TypeOperators + TypeSynonymInstances + ViewPatterns + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + build-depends: + JuicyPixels + , VulkanMemoryAllocator + , base <5 + , bytestring + , geomancy + , gl-block + , resourcet + , say + , spirv-reflect-ffi + , vector + , vulkan + , vulkan-examples + , vulkan-utils + , vulkan-utils-spirv + default-language: Haskell2010 + if os(windows) + ghc-options: -optl-mconsole + +executable pathtrace-reflect + main-is: Main.hs + other-modules: + Pathtracer + Pathtracer.Shader + Render + Scene + Paths_vulkan_examples + autogen-modules: + Paths_vulkan_examples + hs-source-dirs: + pathtrace-reflect + default-extensions: + BlockArguments + DataKinds + DefaultSignatures + DeriveFoldable + DeriveFunctor + DeriveTraversable + DerivingStrategies + DuplicateRecordFields + FlexibleContexts + FlexibleInstances + GADTs + GeneralizedNewtypeDeriving + InstanceSigs + LambdaCase + MagicHash + NamedFieldPuns + NoMonomorphismRestriction + NumDecimals + OverloadedStrings + PatternSynonyms + PolyKinds + QuantifiedConstraints + RankNTypes + RecordWildCards + RoleAnnotations + ScopedTypeVariables + StandaloneDeriving + Strict + TupleSections + TypeApplications + TypeFamilyDependencies + TypeOperators + TypeSynonymInstances + ViewPatterns + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + build-depends: + JuicyPixels + , VulkanMemoryAllocator + , base <5 + , bytestring + , geomancy + , gl-block + , optparse-applicative + , random + , resourcet + , transformers + , vector + , vulkan + , vulkan-examples + , vulkan-utils + , vulkan-utils-spirv + default-language: Haskell2010 + if os(windows) + ghc-options: -optl-mconsole + executable rays main-is: Main.hs other-modules: @@ -441,6 +643,72 @@ executable resize if os(windows) ghc-options: -optl-mconsole +executable texture-reflect + main-is: Main.hs + other-modules: + Cube + Cube.Shader + Render + Tri + Tri.Shader + Paths_vulkan_examples + autogen-modules: + Paths_vulkan_examples + hs-source-dirs: + texture-reflect + default-extensions: + BlockArguments + DataKinds + DefaultSignatures + DeriveFoldable + DeriveFunctor + DeriveTraversable + DerivingStrategies + DuplicateRecordFields + FlexibleContexts + FlexibleInstances + GADTs + GeneralizedNewtypeDeriving + InstanceSigs + LambdaCase + MagicHash + NamedFieldPuns + NoMonomorphismRestriction + NumDecimals + OverloadedStrings + PatternSynonyms + PolyKinds + QuantifiedConstraints + RankNTypes + RecordWildCards + RoleAnnotations + ScopedTypeVariables + StandaloneDeriving + Strict + TupleSections + TypeApplications + TypeFamilyDependencies + TypeOperators + TypeSynonymInstances + ViewPatterns + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + build-depends: + JuicyPixels + , VulkanMemoryAllocator + , base <5 + , bytestring + , gl-block + , resourcet + , spirv-reflect-ffi + , vector + , vulkan + , vulkan-examples + , vulkan-utils + , vulkan-utils-spirv + default-language: Haskell2010 + if os(windows) + ghc-options: -optl-mconsole + executable triangle-dynamic main-is: Main.hs other-modules: diff --git a/nix/haskell-packages.nix b/nix/haskell-packages.nix index 128e32a5f..de3daf9fa 100644 --- a/nix/haskell-packages.nix +++ b/nix/haskell-packages.nix @@ -53,6 +53,13 @@ let modifier = drv: addExtraLibrary pkgs.vulkan-headers (mod drv); returnShellEnv = false; }; + vulkan-utils-spirv = self.developPackage { + name = "vulkan-utils-spirv"; + root = gitignore ../utils-spirv; + # tests compile GLSL fixtures with the glslang quasiquoters + modifier = drv: addBuildTools [ pkgs.glslang ] (mod drv); + returnShellEnv = false; + }; vulkan-init-sdl2 = self.developPackage { name = "vulkan-init-sdl2"; root = gitignore ../utils-init/vulkan-init-sdl2; @@ -116,6 +123,42 @@ let binary-orphans = addBuildDepend self.OneTuple super.binary-orphans; + # + # Dependencies for vulkan-utils-spirv, absent or too old in nixpkgs + # + # dontCheck: hedgehog property gives up on discards + geomancy = dontCheck (self.callHackageDirect { + pkg = "geomancy"; + ver = "0.3.0.1"; + sha256 = "0c0mm70hg1zv6di4y8z2j7a8xbrdxccqqv2v826jis7cyfznppgp"; + } { }); + gl-block = self.callHackageDirect { + pkg = "gl-block"; + ver = "1.1"; + sha256 = "0d6gi2hi96r7yzwg7vmrz936d2wmn88qs09pqhzk1ph7qwjbaqx0"; + } { }; + spirv-enum = self.callHackageDirect { + pkg = "spirv-enum"; + ver = "1.104.350.0"; + sha256 = "0pmj7a0sqvx2nlk7fl1yqlljxdrf91l0rzaa42fwjb39qg9hxzcf"; + } { }; + spirv-reflect-ffi = self.callHackageDirect { + pkg = "spirv-reflect-ffi"; + ver = "0.4"; + sha256 = "1861z86hb5pdi2x9fagl9yqrsxvkcm0pr11il5mklhs99xzkh49x"; + } { }; + spirv-reflect-types = self.callHackageDirect { + pkg = "spirv-reflect-types"; + ver = "0.4"; + sha256 = "1v5bip44jmzmcnlhjf8ckx8zz05f7fsx4d2idlkqs6q09zd7cb6n"; + } { }; + # dontCheck: test suite wants base >= 4.18 + webcolor-labels = dontCheck (self.callHackageDirect { + pkg = "webcolor-labels"; + ver = "0.1.0.0"; + sha256 = "1cwjz31xiya9wmy0h0srn4f6brd4xh4hi0rh5ry80vkwqz7f3fhm"; + } { }); + # # Overrides for generate # diff --git a/stack.yaml b/stack.yaml index e7388215a..6734c6f57 100644 --- a/stack.yaml +++ b/stack.yaml @@ -2,6 +2,7 @@ resolver: lts-22.44 packages: - . - utils +- utils-spirv - utils-init/vulkan-init-sdl2 - utils-init/vulkan-init-glfw - examples @@ -13,6 +14,13 @@ extra-deps: - unification-fd-0.12.0.2 # generate-new - validation-selective-0.2.0.0 +- geomancy-0.3.0.1 +- gl-block-1.1 +- ptrdiff-0 +- spirv-enum-1.104.350.0 +- spirv-reflect-ffi-0.4 +- spirv-reflect-types-0.4 +- webcolor-labels-0.1.0.0 # use ghcup, nix, setup actions system-ghc: true diff --git a/utils-spirv/README.md b/utils-spirv/README.md new file mode 100644 index 000000000..2e6860510 --- /dev/null +++ b/utils-spirv/README.md @@ -0,0 +1,73 @@ +# vulkan-utils-spirv + +Generate Haskell data types and Vulkan descriptor-set / pipeline-layout +`*CreateInfo` values from compiled SPIR-V, at compile time, via +[`spirv-reflect`](https://hackage.haskell.org/package/spirv-reflect-ffi) +reflection and [`gl-block`](https://hackage.haskell.org/package/gl-block) +std140/std430 layout. + +## Types from a shader + +A Template Haskell splice generates a record β€” with a std140/std430 `Storable` +derived via gl-block β€” for every uniform / storage / push-constant block the +shader declares: + +```haskell +import Vulkan.Utils.SpirV.TH (reflectShaderTypes) + +-- e.g. `Scene { view :: Mat4, lightDir :: Vec3, time :: Float }` (geomancy types), +-- ready to poke straight into a mapped buffer. +reflectShaderTypes "shaders/scene.vert.spv" +``` + +## Pipeline layout from reflection + +`allocateReflectedLayout` merges the descriptor-set layouts and push-constant +ranges across a family of shaders β€” stage flags OR-ed, shared blocks +cross-checked β€” into one `PipelineLayout`. `allocateGraphicsPipeline` then builds +each pipeline against it, folding in the vertex stage's reflected vertex input: + +```haskell +import Data.SpirV.Reflect.FFI (loadBytes) +import Vulkan.Utils.DynamicRendering qualified as Dynamic +import Vulkan.Utils.SpirV.Pipeline (allocateGraphicsPipeline, allocateReflectedLayout) +import Vulkan.Zero (zero) + +vertModule <- loadBytes vertSpv +fragModule <- loadBytes fragSpv + +-- one layout for the whole family +(_, layout) <- allocateReflectedLayout dev [vertModule, fragModule] + +(_, pipeline) <- + allocateGraphicsPipeline dev layout + zero{Dynamic.colorFormats = [colorFormat], Dynamic.depthFormat = Just depthFormat} + () -- specialization; () for none + [(vertModule, vertSpv), (fragModule, fragSpv)] +``` + +## Compile-time stage composition + +`reflectStageSig` emits a per-shader signature; `MatchInterface` / +`CompatibleResources` then check β€” at compile time β€” that the fragment inputs +match the vertex outputs and that any shared descriptor blocks agree. A mismatch +is a type error, not a validation-layer message at runtime: + +```haskell +import Vulkan.Utils.SpirV.Stage (CompatibleResources, MatchInterface, reflectStageSig) + +reflectStageSig "VertSig" "shaders/scene.vert.spv" +reflectStageSig "FragSig" "shaders/scene.frag.spv" + +-- only type-checks if the two stages compose +pipelineComposes :: (MatchInterface VertSig FragSig, CompatibleResources VertSig FragSig) => Bool +pipelineComposes = True +``` + +## Examples + +Four end-to-end, validation-clean programs under +[`examples/`](../examples): `compute-reflect`, `pathtrace-reflect` (buffer +device address / BVH), `mesh-reflect` (a vertex shader driving a z-prepass and a +shaded pass off one merged layout), and `texture-reflect` (colour-attachment-as- +texture with reflected vertex attributes). diff --git a/utils-spirv/package.yaml b/utils-spirv/package.yaml new file mode 100644 index 000000000..eab6592f5 --- /dev/null +++ b/utils-spirv/package.yaml @@ -0,0 +1,76 @@ +name: vulkan-utils-spirv +version: "0.1.0.0" +synopsis: Generate Haskell types and Vulkan descriptor/pipeline layouts from SPIR-V reflection +category: Graphics +maintainer: Ellie Hermaszewska +github: expipiplus1/vulkan +extra-source-files: +- README.md +- package.yaml + +library: + source-dirs: src + dependencies: + - base >= 4.16 && <5 + - bytestring + - containers + - gl-block + - ptrdiff + - resourcet + - spirv-enum + - spirv-reflect-ffi + - spirv-reflect-types + - template-haskell + - text + - unliftio-core + - vector + - vulkan >= 3.27 && < 3.28 + - vulkan-utils + +tests: + spec: + main: Spec.hs + source-dirs: test + dependencies: + - base <5 + - bytestring + - containers + - geomancy + - gl-block + - spirv-reflect-ffi + - spirv-reflect-types + - tasty + - tasty-hunit + - template-haskell + - text + - vector + - vulkan + - vulkan-utils + - vulkan-utils-spirv + +ghc-options: +- -Wall + +default-extensions: +- BlockArguments +- DataKinds +- DeriveAnyClass +- DeriveGeneric +- DerivingStrategies +- DerivingVia +- DuplicateRecordFields +- FlexibleContexts +- FlexibleInstances +- ImportQualifiedPost +- LambdaCase +- NamedFieldPuns +- OverloadedRecordDot +- OverloadedStrings +- PatternSynonyms +- RecordWildCards +- ScopedTypeVariables +- TemplateHaskell +- TupleSections +- TypeApplications +- TypeOperators +- ViewPatterns diff --git a/utils-spirv/src/Vulkan/Utils/SpirV/Array.hs b/utils-spirv/src/Vulkan/Utils/SpirV/Array.hs new file mode 100644 index 000000000..815190e05 --- /dev/null +++ b/utils-spirv/src/Vulkan/Utils/SpirV/Array.hs @@ -0,0 +1,198 @@ +-- These extensions are not in the package-wide default-extensions. +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| A fixed-length array suitable as a std140\/std430 block /field/. + +@'Array' n a@ is @n@ elements of @a@ laid out as an array member: each element +occupies a layout-dependent stride (std140 rounds the element stride up to a +multiple of 16; std430 packs to the element's own alignment). The element type's +'Block' instance does the per-element encoding, so anything that is a 'Block' (a +scalar, a vector, or a generated struct record) can be the element. + +The backing 'VS.Vector' should hold exactly @n@ elements; 'write140' \/ 'write430' +write the first @n@ and ignore any extra (so a buffer is never overrun). +-} +module Vulkan.Utils.SpirV.Array + ( Array (..) + , unsafeFromList + , toList + + -- * Runtime-sized arrays + -- $runtime + , std140Stride + , std430Stride + , pokeStd140 + , pokeStd430 + , peekStd140 + , peekStd430 + ) where + +import Control.Monad.IO.Class (MonadIO (..)) +import Data.Proxy (Proxy (..)) +import Data.Vector.Storable qualified as VS +import Foreign.Ptr (Ptr, castPtr) +import Foreign.Ptr.Diff (Diff (..)) +import Foreign.Storable (Storable (..)) +import GHC.TypeNats (KnownNat, Nat, natVal) +import GHC.TypeNats qualified as TN +import Graphics.Gl.Block (Block (..), roundUp) + +-- | @n@ elements of @a@, laid out as an array block member. +newtype Array (n :: Nat) a = Array (VS.Vector a) + +deriving instance (Storable a, Eq a) => Eq (Array n a) +deriving instance (Storable a, Show a) => Show (Array n a) + +-- | Build an 'Array' from a list (should be @n@ elements long). +{-# INLINE unsafeFromList #-} +unsafeFromList :: forall n a. (KnownNat n, Storable a) => [a] -> Array n a +unsafeFromList = Array . VS.fromListN (count (Proxy @n)) + +-- | The elements of an 'Array' as a list. +toList :: (Storable a) => Array n a -> [a] +toList (Array v) = VS.toList v + +{- | A tight, host-side 'Storable' (n contiguous elements). This is unrelated to +the gl-block layout below β€” it only lets an 'Array' nest as the element of +another 'Array' (multi-dimensional arrays: @'Array' h ('Array' w a)@). +-} +instance (KnownNat n, Storable a) => Storable (Array n a) where + sizeOf _ = count (Proxy @n) * sizeOf (undefined :: a) + alignment _ = alignment (undefined :: a) + peek ptr = Array <$> VS.generateM (count (Proxy @n)) (peekElemOff (castPtr ptr)) + poke ptr (Array v) = VS.imapM_ (pokeElemOff (castPtr ptr)) (VS.take (count (Proxy @n)) v) + +instance (KnownNat n, Block a, Storable a) => Block (Array n a) where + type PackedSize (Array n a) = n TN.* PackedSize a + + isStruct _ = True + + alignment140 _ = lcm 16 (alignment140 (Proxy @a)) + alignment430 _ = alignment430 (Proxy @a) + + sizeOf140 _ = count (Proxy @n) * std140Stride (Proxy @a) + sizeOf430 _ = count (Proxy @n) * std430Stride (Proxy @a) + sizeOfPacked _ = count (Proxy @n) * sizeOfPacked (Proxy @a) + + read140 = readArrayWith (count (Proxy @n)) (std140Stride (Proxy @a)) read140 + read430 = readArrayWith (count (Proxy @n)) (std430Stride (Proxy @a)) read430 + readPacked = readArrayWith (count (Proxy @n)) (sizeOfPacked (Proxy @a)) readPacked + + write140 = writeArrayWith (count (Proxy @n)) (std140Stride (Proxy @a)) write140 + write430 = writeArrayWith (count (Proxy @n)) (std430Stride (Proxy @a)) write430 + writePacked = writeArrayWith (count (Proxy @n)) (sizeOfPacked (Proxy @a)) writePacked + {-# INLINE alignment140 #-} + {-# INLINE alignment430 #-} + {-# INLINE isStruct #-} + {-# INLINE read140 #-} + {-# INLINE read430 #-} + {-# INLINE readPacked #-} + {-# INLINE sizeOf140 #-} + {-# INLINE sizeOf430 #-} + {-# INLINE write140 #-} + {-# INLINE write430 #-} + {-# INLINE writePacked #-} + +{-# INLINE count #-} +count :: (KnownNat n) => Proxy n -> Int +count = fromIntegral . natVal + +{- | Per-element stride for an array member: std140 rounds the element size up to +a multiple of 16. +-} +std140Stride :: (Block a) => Proxy a -> Int +std140Stride p = roundUp (sizeOf140 p) (lcm 16 (alignment140 p)) + +{- | Per-element stride for an array member: std430 packs to the element's own +base alignment. +-} +std430Stride :: (Block a) => Proxy a -> Int +std430Stride p = roundUp (sizeOf430 p) (alignment430 p) + +{- $runtime +A runtime-sized array (the trailing @T[]@ of a storage buffer) has no +compile-time length, so it is /not/ a fixed-size 'Block' and is represented +directly as a @'VS.Vector' a@. These helpers (de)serialize such a vector at the +layout's element stride, using the element's own 'Block' instance β€” so an element +whose array stride differs from its packed size (e.g. a @vec3@, or a struct +padded up to its alignment) is still placed correctly. The 'Ptr' should point at +the start of the array (for a buffer whose only contents are the array, that is +the mapped base pointer). +-} + +-- | Write a runtime-length array of std140 elements starting at @ptr@. +{-# INLINE pokeStd140 #-} +pokeStd140 :: forall a x m. (Block a, Storable a, MonadIO m) => Ptr x -> VS.Vector a -> m () +pokeStd140 = pokeArrayAt (std140Stride (Proxy @a)) write140 + +-- | Write a runtime-length array of std430 elements starting at @ptr@. +{-# INLINE pokeStd430 #-} +pokeStd430 :: forall a x m. (Block a, Storable a, MonadIO m) => Ptr x -> VS.Vector a -> m () +pokeStd430 = pokeArrayAt (std430Stride (Proxy @a)) write430 + +-- | Read @n@ std140 elements starting at @ptr@. +{-# INLINE peekStd140 #-} +peekStd140 :: forall a x m. (Block a, Storable a, MonadIO m) => Int -> Ptr x -> m (VS.Vector a) +peekStd140 = peekArrayAt (std140Stride (Proxy @a)) read140 + +-- | Read @n@ std430 elements starting at @ptr@. +{-# INLINE peekStd430 #-} +peekStd430 :: forall a x m. (Block a, Storable a, MonadIO m) => Int -> Ptr x -> m (VS.Vector a) +peekStd430 = peekArrayAt (std430Stride (Proxy @a)) read430 + +{-# INLINE pokeArrayAt #-} +pokeArrayAt + :: (Storable a, MonadIO m) + => Int + -> (Ptr x -> Diff x a -> a -> IO ()) + -> Ptr x + -> VS.Vector a + -> m () +pokeArrayAt stride wr ptr v = + liftIO $ VS.imapM_ (\i x -> wr ptr (Diff (i * stride)) x) v + +{-# INLINE peekArrayAt #-} +peekArrayAt + :: (Storable a, MonadIO m) + => Int + -> (Ptr x -> Diff x a -> IO a) + -> Int + -> Ptr x + -> m (VS.Vector a) +peekArrayAt stride rd n ptr = + liftIO $ VS.generateM n (\i -> rd ptr (Diff (i * stride))) + +{-# INLINE readArrayWith #-} +readArrayWith + :: (Storable a, MonadIO m) + => Int + -- ^ element count + -> Int + -- ^ element stride + -> (Ptr x -> Diff x a -> IO a) + -- ^ element reader + -> Ptr x + -> Diff x (Array n a) + -> m (Array n a) +readArrayWith n stride rd ptr (Diff o) = + liftIO $ Array <$> VS.generateM n (\i -> rd ptr (Diff (o + i * stride))) + +{-# INLINE writeArrayWith #-} +writeArrayWith + :: (Storable a, MonadIO m) + => Int + -- ^ element count + -> Int + -- ^ element stride + -> (Ptr x -> Diff x a -> a -> IO ()) + -- ^ element writer + -> Ptr x + -> Diff x (Array n a) + -> Array n a + -> m () +writeArrayWith n stride wr ptr (Diff o) (Array v) = + liftIO $ VS.imapM_ (\i x -> wr ptr (Diff (o + i * stride)) x) (VS.take n v) diff --git a/utils-spirv/src/Vulkan/Utils/SpirV/Block.hs b/utils-spirv/src/Vulkan/Utils/SpirV/Block.hs new file mode 100644 index 000000000..5c8e7268e --- /dev/null +++ b/utils-spirv/src/Vulkan/Utils/SpirV/Block.hs @@ -0,0 +1,288 @@ +{-# LANGUAGE NoFieldSelectors #-} + +{-| Generate a Haskell record type for a reflected uniform/storage/push-constant +block, deriving its layout from gl-block: @deriving anyclass 'Block'@ (via +"GHC.Generics") plus @deriving 'Storable' via ('Std140' \/ 'Std430')@. + +Splice sites must therefore have @Graphics.Gl.Block (Std140(..), Std430(..))@ in +scope (the @via@ coercion needs the newtype constructor visible) and enable +@DataKinds@ and @TypeFamilies@ (each record also gets a +'Vulkan.Utils.SpirV.Signature.KnownLayout' instance carrying its type-level +layout signature). + +== Guardrail +gl-block's @Generic@ 'Block' instance lays a struct out correctly only when its +field alignments are non-increasing. A lower-aligned field that precedes a +higher-aligned one (e.g. @float@ before @uvec2@) is over-padded and no longer +matches the shader's std140/std430 offsets. Until that is fixed in gl-block, +'structRecordDec' refuses (with a compile error) to generate such a record rather +than emit a silently-wrong layout. +-} +module Vulkan.Utils.SpirV.Block + ( structTypeName + , structRecordDec + , collectStructs + , allMembers16 + ) where + +import Control.Monad (filterM) +import Data.Char (toLower) +import Data.List (intercalate, mapAccumL) +import Data.Maybe (fromMaybe) +import Data.Text qualified as Text +import Data.Vector qualified as V +import Foreign.Storable (Storable) +import GHC.Generics (Generic) +import Graphics.Gl.Block (Block, Std140, Std430) +import Language.Haskell.TH + +import Data.SpirV.Reflect.TypeDescription (TypeDescription) +import Data.SpirV.Reflect.TypeDescription qualified + +import Vulkan.Utils.SpirV.Array (Array) +import Vulkan.Utils.SpirV.DeviceAddress (DeviceAddress) +import Vulkan.Utils.SpirV.Layout (offsetMapOf) +import Vulkan.Utils.SpirV.Signature (knownLayoutInstance) +import Vulkan.Utils.SpirV.Types (LayoutMode (..), NumericType (..), TypeMap, arrayBaseAlign, arrayDims, classifyType, isBdaPointer, leafAlignment, structBaseAlign) + +{- | A block's struct together with every nested and array-element struct +reachable from it, each tagged with the layout to generate it under. This lets +an SSBO array of structs (e.g. @Sphere spheres[]@) yield a record for the +element type even though the wrapping block β€” a runtime array β€” isn't itself +representable as a flat record (the caller skips it). +-} +collectStructs :: LayoutMode -> TypeDescription -> [(LayoutMode, TypeDescription)] +collectStructs layout root = snd (go [] root) + where + -- Thread a visited set of SPIR-V ids so a recursive @buffer_reference@ type + -- (a shared DAG / cycle) is collected exactly once rather than unrolled + -- forever β€” a self-referential @Node@ would otherwise loop here. + go seen td + | maybe False (`elem` seen) td.id = (seen, []) + | otherwise = + let + seen' = maybe seen (: seen) td.id + (seenN, kids) = mapAccumL go seen' (concatMap targets (V.toList td.members)) + in + (seenN, (layout, td) : concat kids) + + -- The struct(s) reachable from a member: an array- or pointer-element struct + -- (via @struct_type_description@), or a directly-nested struct. Leaf members + -- (scalars/vectors/matrices, and device-address pointers) contribute none. + targets m = + case m.struct_type_description of + Just s -> [s] + Nothing + | not (V.null m.members) -> [m] + | otherwise -> [] + +{- | The Haskell type name to generate for an @OpTypeStruct@ 'TypeDescription': +its @type_name@, used verbatim (SPIR-V struct names are already capitalised +Haskell-friendly identifiers). +-} +structTypeName :: TypeDescription -> Maybe String +structTypeName td = case td.type_name of + Just t | not (Text.null t) -> Just (Text.unpack t) + _ -> Nothing + +{- | A classified record field: its name, Haskell type, base alignment (bytes) +under the layout, and whether it is a leaf (scalar/vector/matrix) as opposed to +a nested struct. +-} +data Field = Field + { name :: Name + , type' :: Type + , align :: Int + , leaf :: Bool + } + +{- | Generate the record @data@ declaration for an @OpTypeStruct@, deriving its +'Block' / 'Storable' from gl-block. Returns 'Nothing' if it has no usable name +or a member cannot be represented as a field (e.g. an array β€” see the +arrays-in-records gap), in which case the caller should skip it. Fails the +splice (guardrail) if the field order would defeat gl-block's std140/std430 +layout. Nested struct members become fields of the corresponding generated +record type. +-} +structRecordDec :: TypeMap -> LayoutMode -> TypeDescription -> Q (Maybe [Dec]) +structRecordDec tymap layout td = + case (structTypeName td, classifiedFields tymap layout (V.toList td.members)) of + (Just nameStr, Just classified) -> + case layoutViolation classified of + Just msg -> + fail $ + "vulkan-utils-spirv: refusing to generate record '" + <> nameStr + <> "': " + <> msg + Nothing -> do + let + tyName = mkName nameStr + recFields = + [ (f.name, Bang NoSourceUnpackedness NoSourceStrictness, f.type') + | f <- classified + ] + wrapper = case layout of + Std140Layout -> ''Std140 + Std430Layout -> ''Std430 + -- Derive @Show@/@Eq@ only when every field type supports them. Some + -- mapped types (e.g. geomancy's @Mat4@) lack @Eq@, and a nested struct + -- field's instances aren't yet visible mid-splice, so a record with a + -- struct field derives neither. + stockExtra <- + if all (.leaf) classified + then filterM (allFieldsAreInstances [f.type' | f <- classified]) [''Show, ''Eq] + else pure [] + let + dataDec = + DataD + [] + tyName + [] + Nothing + [RecC tyName recFields] + [ DerivClause (Just StockStrategy) (ConT ''Generic : map ConT stockExtra) + , DerivClause (Just AnyclassStrategy) [ConT ''Block] + , DerivClause + (Just (ViaStrategy (ConT wrapper `AppT` ConT tyName))) + [ConT ''Storable] + ] + -- Tie a type-level layout signature to the record, computed from + -- the same reflection (the value-level offset map is the oracle). Skipped + -- if the offset map can't be computed (shouldn't happen for a record we + -- already classified). + sigDecs = either (const []) (knownLayoutInstance tyName) (offsetMapOf layout td) + pure (Just (dataDec : sigDecs)) + _ -> pure Nothing + +-- | True when every field type is an instance of the given class. +allFieldsAreInstances :: [Type] -> Name -> Q Bool +allFieldsAreInstances tys cls = and <$> traverse (\t -> isInstance cls [t]) tys + +{- | Classify every member, failing (with 'Nothing') if any cannot be represented +as a record field (e.g. an array member). +-} +classifiedFields :: TypeMap -> LayoutMode -> [TypeDescription] -> Maybe [Field] +classifiedFields tymap layout = traverse $ \mem -> do + fname <- memberFieldName mem + (ty, align, isLeaf) <- fieldOf tymap layout mem + pure Field{name = mkName fname, type' = ty, align, leaf = isLeaf} + +{- | The Haskell type, base alignment and leaf-ness of a single member, or +'Nothing' if it can't be a field (a runtime\/multi-dimensional array, or an +unrecognised type). A fixed-size array becomes an @'Array' n@ field. +-} +fieldOf :: TypeMap -> LayoutMode -> TypeDescription -> Maybe (Type, Int, Bool) +fieldOf tymap layout mem = + case arrayDims mem of + [] -> elementOf tymap layout mem + dims + | all (> 0) dims -> do + -- Fixed-size array (any dimensionality). Multi-dimensional arrays nest: + -- @a[h][w]@ -> @Array h (Array w a)@ (outermost dimension first). + (elemTy, elemAlign, _) <- elementOf tymap layout mem + pure (foldr wrapArray elemTy dims, arrayBaseAlign layout elemAlign, False) + | otherwise -> Nothing -- contains a runtime (0) dimension + where + wrapArray d ty = ConT ''Array `AppT` LitT (NumTyLit (fromIntegral d)) `AppT` ty + +{- | The Haskell type, base alignment and leaf-ness of a member's element type +(i.e. ignoring any array dimensions). +-} +elementOf :: TypeMap -> LayoutMode -> TypeDescription -> Maybe (Type, Int, Bool) +elementOf tymap layout mem + -- A buffer_reference pointer: an 8-byte device address, typed by its pointee + -- record when that is a named struct (else @DeviceAddress ()@). The pointee + -- struct is generated separately by 'collectStructs', not inlined here. The + -- REF check precedes 'classifyType' (a pointer also carries the pointee's leaf + -- flags, e.g. @REF INT@). + | isBdaPointer mem = + -- Reported as non-leaf so the record skips auto-deriving Show/Eq: the + -- pointee (often the record being defined β€” a self-referential @Node@) is + -- not in scope mid-splice, so probing @Show (DeviceAddress Node)@ would + -- fail, exactly as for a nested-struct field. + let + pointee = mem.struct_type_description >>= structTypeName + arg = maybe (TupleT 0) (ConT . mkName) pointee + in + Just (ConT ''DeviceAddress `AppT` arg, 8, False) + | otherwise = + case classifyType mem of + Just numeric -> do + let numeric' = numeric{array = []} + ty <- tymap numeric' + pure (ty, leafAlignment layout numeric'.scalar numeric'.shape, True) + Nothing -> do + -- A nested struct member: field of the corresponding generated record. + let s = fromMaybe mem mem.struct_type_description + nm <- structTypeName s + align <- structAlignment layout s + pure (ConT (mkName nm), align, False) + +{- | Guardrail: gl-block's 'Generic' layout matches std140/std430 only when field +alignments are non-increasing. Report the first inversion, if any. +-} +layoutViolation :: [Field] -> Maybe String +layoutViolation classified = go [(nameBase f.name, f.align) | f <- classified] + where + go ((n1, a1) : rest@((n2, a2) : _)) + | a1 < a2 = + Just $ + intercalate + " " + [ "field '" <> n1 <> "' (alignment " <> show a1 <> ")" + , "precedes higher-aligned field '" <> n2 <> "' (alignment " <> show a2 <> ");" + , "gl-block's Generic layout would not match std140/std430." + , "Reorder the block's fields by non-increasing alignment" + , "(temporary gl-block limitation)." + ] + | otherwise = go rest + go _ = Nothing + +{- | The base alignment (bytes) of a struct under the given layout: the largest +member alignment, rounded up to 16 for std140. 'Nothing' if any member's +alignment can't be determined. +-} +structAlignment :: LayoutMode -> TypeDescription -> Maybe Int +structAlignment layout td = do + as <- traverse (memberBaseAlignment layout) (V.toList td.members) + pure (structBaseAlign layout as) + +-- | The base alignment of any member (leaf, nested struct, or fixed array). +memberBaseAlignment :: LayoutMode -> TypeDescription -> Maybe Int +memberBaseAlignment layout mem = + case arrayDims mem of + [] -> elementBaseAlignment layout mem + dims + | all (> 0) dims -> arrayBaseAlign layout <$> elementBaseAlignment layout mem + | otherwise -> Nothing + +-- | The base alignment of a member's element type (ignoring array dimensions). +elementBaseAlignment :: LayoutMode -> TypeDescription -> Maybe Int +elementBaseAlignment layout mem + | isBdaPointer mem = Just 8 -- device address: 8-byte scalar + | otherwise = + case classifyType mem of + Just numeric -> Just (leafAlignment layout numeric.scalar numeric.shape) + Nothing -> structAlignment layout (fromMaybe mem mem.struct_type_description) + +{- | True when every member of the struct has 16-byte base alignment. Such a +struct lays out identically under std140 and std430 (same offsets, same size), +so a single generated record can be shared across both layouts ("promotion"). +Anything else used across layouts is rejected by the sharing guardrail. +-} +allMembers16 :: TypeDescription -> Bool +allMembers16 td = not (null ms) && all is16 ms + where + ms = V.toList td.members + is16 m = memberBaseAlignment Std430Layout m == Just 16 + +uncapitalize :: String -> String +uncapitalize [] = [] +uncapitalize (c : cs) = toLower c : cs + +{- | The Haskell record-field name for a reflected member: its declared name, +uncapitalised (SPIR-V capitalises member names, Haskell fields are lower-case). +-} +memberFieldName :: TypeDescription -> Maybe String +memberFieldName = fmap (uncapitalize . Text.unpack) . (.struct_member_name) diff --git a/utils-spirv/src/Vulkan/Utils/SpirV/Buffer.hs b/utils-spirv/src/Vulkan/Utils/SpirV/Buffer.hs new file mode 100644 index 000000000..2c0026d68 --- /dev/null +++ b/utils-spirv/src/Vulkan/Utils/SpirV/Buffer.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +{-| A block of memory tagged with a type-level layout signature. + +A @'Buffer' sig@ is host memory whose byte layout is described by @sig@ (a +'SigOffsetMap' from "Vulkan.Utils.SpirV.Signature"). 'readBuffer' \/ 'writeBuffer' +move whole records in and out, but only for a record whose own layout 'Fits' the +buffer's signature β€” so a layout mismatch is a /compile/ error, and because +layout-equivalent records share a signature (and 'Fits' accepts a compatible one), +a value written as one record can be read back through any layout-compatible record +(a structural view). + +@ +buf <- 'newBuffer' (MyUbo …) -- Buffer (Sig MyUbo) +view <- 'readBuffer' buf -- any r with Fits (Sig r) (Sig MyUbo) +@ + +The signature is the soundness boundary: 'newBuffer' derives it from the record +it writes (sound by construction); 'unsafeAsBuffer' tags a foreign pointer you +already hold (e.g. VMA @mappedData@) with a signature /you/ assert it satisfies β€” +that assertion is exactly the reflected buffer's layout. +-} +module Vulkan.Utils.SpirV.Buffer + ( Buffer + , newBuffer + , allocBuffer + , allocArrayBuffer + , readBuffer + , writeBuffer + , readBufferElem + , writeBufferElem + , bufferSize + , withBufferPtr + , unsafeAsBuffer + , unsafeAsBufferPtr + ) where + +import Control.Monad.IO.Class (MonadIO (..)) +import Data.Proxy (Proxy (..)) +import Data.Word (Word8) +import Foreign.ForeignPtr (ForeignPtr, castForeignPtr, mallocForeignPtrBytes, newForeignPtr_, withForeignPtr) +import Foreign.Ptr (Ptr, castPtr, plusPtr) +import Foreign.Storable (Storable (..)) + +import Vulkan.Utils.SpirV.Layout qualified -- brings OffsetMap's fields into scope for HasField/ORD +import Vulkan.Utils.SpirV.Signature (Fits, FitsTail, KnownArrayTail, KnownLayout, KnownSigOffsetMap, Sig, SigOffsetMap, arrayTailBaseStride, sigOffsetMapVal) + +-- | Host memory laid out as @sig@. +newtype Buffer (sig :: SigOffsetMap) = Buffer (ForeignPtr Word8) + +-- | Allocate and initialize a buffer from a record, taking its layout signature. +newBuffer :: forall r io. (KnownLayout r, Storable r, MonadIO io) => r -> io (Buffer (Sig r)) +newBuffer r = liftIO $ do + fp <- mallocForeignPtrBytes (sizeOf r) + withForeignPtr fp $ \p -> poke (castPtr p) r + pure (Buffer fp) + +{- | Allocate an uninitialized buffer sized for the (statically-sized) signature +@sig@; use with a type application, e.g. @allocBuffer \@(Sig MyUbo)@. +-} +allocBuffer :: forall sig io. (KnownSigOffsetMap sig, MonadIO io) => io (Buffer sig) +allocBuffer = liftIO $ case sigSize @sig of + Just n -> Buffer <$> mallocForeignPtrBytes n + Nothing -> + ioError (userError "allocBuffer: runtime-sized layout has no static size") + +-- | Read a record out of a buffer, if its layout fits the buffer's signature. +readBuffer :: forall r sig io. (Storable r, Fits (Sig r) sig, MonadIO io) => Buffer sig -> io r +readBuffer (Buffer fp) = liftIO (withForeignPtr fp (peek . castPtr)) + +-- | Write a record into a buffer, if its layout fits the buffer's signature. +writeBuffer :: forall r sig io. (Storable r, Fits (Sig r) sig, MonadIO io) => Buffer sig -> r -> io () +writeBuffer (Buffer fp) r = liftIO (withForeignPtr fp (\p -> poke (castPtr p) r)) + +{- | Allocate a runtime-array buffer (an 'ArrayOf' signature) sized for @n@ +elements: @base + n * stride@ bytes, both taken from the signature's tail. +-} +allocArrayBuffer :: forall sig io. (KnownArrayTail sig, MonadIO io) => Int -> io (Buffer sig) +allocArrayBuffer n = liftIO (Buffer <$> mallocForeignPtrBytes (base + n * stride)) + where + (base, stride) = arrayTailBaseStride @sig + +{- | Read the @i@-th element of a runtime-array buffer (an SSBO @T[]@), if the +record's layout fits the buffer's array tail. The element is at byte offset +@base + i * stride@ taken from the buffer's signature. +-} +readBufferElem :: forall r sig io. (Storable r, FitsTail (Sig r) sig, KnownArrayTail sig, MonadIO io) => Buffer sig -> Int -> io r +readBufferElem (Buffer fp) i = + liftIO (withForeignPtr fp (\p -> peek (castPtr (p `plusPtr` elemOffset @sig i)))) + +{- | Write the @i@-th element of a runtime-array buffer, if the record's layout +fits the buffer's array tail. +-} +writeBufferElem :: forall r sig io. (Storable r, FitsTail (Sig r) sig, KnownArrayTail sig, MonadIO io) => Buffer sig -> Int -> r -> io () +writeBufferElem (Buffer fp) i r = + liftIO (withForeignPtr fp (\p -> poke (castPtr (p `plusPtr` elemOffset @sig i)) r)) + +{- | The byte offset of array element @i@ from the buffer signature's tail. + +'KnownArrayTail' provides the @(base, stride)@ from the type level. +-} +elemOffset :: forall sig. (KnownArrayTail sig) => Int -> Int +elemOffset i = base + i * stride + where + (base, stride) = arrayTailBaseStride @sig + +-- | The buffer's size in bytes, from its signature ('Nothing' if open-ended). +bufferSize :: forall sig. (KnownSigOffsetMap sig) => Buffer sig -> Maybe Int +bufferSize _ = sigSize @sig + +-- | The static byte size of a signature, if it is not runtime-sized. +sigSize :: forall sig. (KnownSigOffsetMap sig) => Maybe Int +sigSize = (sigOffsetMapVal (Proxy @sig)).size + +-- | Run an action on the raw buffer pointer (e.g. to upload to a GPU buffer). +withBufferPtr :: (MonadIO io) => Buffer sig -> (Ptr Word8 -> IO a) -> io a +withBufferPtr (Buffer fp) k = liftIO (withForeignPtr fp k) + +{- | Tag a foreign pointer with a layout signature you assert it satisfies. The +safety obligation is the caller's: @sig@ must match the memory's real layout +(for a reflected GPU buffer, its reflected block layout). +-} +unsafeAsBuffer :: ForeignPtr a -> Buffer sig +unsafeAsBuffer = Buffer . castForeignPtr + +{- | Tag a raw pointer (e.g. VMA @mappedData@) with an asserted layout signature. +The pointer's memory is owned elsewhere β€” no finalizer is attached, so the +caller must keep it alive for the buffer's lifetime. Same obligation as +'unsafeAsBuffer'. +-} +unsafeAsBufferPtr :: (MonadIO io) => Ptr a -> io (Buffer sig) +unsafeAsBufferPtr p = liftIO (Buffer . castForeignPtr <$> newForeignPtr_ p) diff --git a/utils-spirv/src/Vulkan/Utils/SpirV/Descriptors.hs b/utils-spirv/src/Vulkan/Utils/SpirV/Descriptors.hs new file mode 100644 index 000000000..ed990378e --- /dev/null +++ b/utils-spirv/src/Vulkan/Utils/SpirV/Descriptors.hs @@ -0,0 +1,143 @@ +{-| Build Vulkan descriptor-set-layout and push-constant values from a reflected +'Module' at runtime. The reflected SPIR-V enums share Vulkan's numeric values, so +'Vk.DescriptorType' / 'Vk.ShaderStageFlags' come straight from the reflected +integers. +-} +module Vulkan.Utils.SpirV.Descriptors + ( descriptorSetLayoutInfos + , singleDescriptorSetLayoutInfo + , pushConstantRanges + , mergedDescriptorSetLayoutInfos + , mergedPushConstantRanges + , moduleStageFlags + ) where + +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe) +import Data.Vector qualified as V +import Data.Word (Word32) +import Vulkan.Core10 qualified as Vk +import Vulkan.Zero (zero) + +import Data.SpirV.Reflect.BlockVariable qualified +import Data.SpirV.Reflect.DescriptorBinding qualified as DescriptorBinding +import Data.SpirV.Reflect.DescriptorSet qualified +import Data.SpirV.Reflect.Enums.DescriptorType qualified as R +import Data.SpirV.Reflect.Module (Module) +import Data.SpirV.Reflect.Module qualified + +import Vulkan.Utils.PipelineLayout (DescriptorBindingConflict (..), mergeDescriptorSetLayoutBindings, mergePushConstantRanges) +import Vulkan.Utils.SpirV.Layout (OffsetMap, mergeKeyed, renderMismatch) +import Vulkan.Utils.SpirV.Reflect.OffsetMaps (pushOffsetMaps, resourceOffsetMaps) + +{- | One @(set number, layout create-info)@ per reflected descriptor set, with +all bindings tagged with this module's shader stage. +-} +descriptorSetLayoutInfos :: Module -> [(Word32, Vk.DescriptorSetLayoutCreateInfo '[])] +descriptorSetLayoutInfos m = + [ ( ds.set + , zero + { Vk.bindings = + V.fromList [bindingToVk stage b | b <- V.toList ds.bindings] + } + ) + | ds <- V.toList m.descriptor_sets + ] + where + stage = moduleStageFlags m + +bindingToVk :: Vk.ShaderStageFlags -> DescriptorBinding.DescriptorBinding -> Vk.DescriptorSetLayoutBinding +bindingToVk stage b = + zero + { Vk.binding = b.binding + , Vk.descriptorType = Vk.DescriptorType (fromIntegral (descriptorTypeInt b)) + , Vk.descriptorCount = fromMaybe 1 b.count + , Vk.stageFlags = stage + } + +{- | The create-info of a module's sole descriptor set β€” the common single-set +shader. 'Left' if the module declares no sets or more than one. +-} +singleDescriptorSetLayoutInfo :: Module -> Either String (Vk.DescriptorSetLayoutCreateInfo '[]) +singleDescriptorSetLayoutInfo m = + case descriptorSetLayoutInfos m of + [(_, info)] -> Right info + [] -> Left "shader declares no descriptor sets" + sets -> Left ("shader declares " <> show (length sets) <> " descriptor sets, expected exactly one") + +{- | One range per reflected push-constant block, tagged with this module's +shader stage. +-} +pushConstantRanges :: Module -> [Vk.PushConstantRange] +pushConstantRanges m = + [ zero + { Vk.stageFlags = stage + , Vk.offset = pc.absolute_offset + , Vk.size = pc.size + } + | pc <- V.toList m.push_constants + ] + where + stage = moduleStageFlags m + +{- | Descriptor set layouts for a /pipeline/ built from several stages: bindings +are collected across all modules and each binding's @stageFlags@ is the OR of the +stages that declare it β€” correct for a set shared between, say, vertex and +fragment (unlike the single-stage 'descriptorSetLayoutInfos'). + +On top of the generic Vulkan-binding merge ('mergeDescriptorSetLayoutBindings'), +stages sharing a @(set, binding)@ must also agree on its /block layout/ (their +reflected offset maps are unified, see "Vulkan.Utils.SpirV.Layout"). Either a +descriptor-type or a layout disagreement is a 'Left' naming the offending binding. +-} +mergedDescriptorSetLayoutInfos :: [Module] -> Either String [(Word32, Vk.DescriptorSetLayoutCreateInfo '[])] +mergedDescriptorSetLayoutInfos modules = do + verifyKeyed descKey (concatMap resourceOffsetMaps modules) + traverse mergeSet (Map.toAscList bindingsBySet) + where + descKey (s, b) = "descriptor set " <> show s <> " binding " <> show b + + -- set -> the bindings every stage contributes to it (each tagged with its stage). + bindingsBySet :: Map Word32 [Vk.DescriptorSetLayoutBinding] + bindingsBySet = + Map.fromListWith + (flip (++)) + [ (b.set, [bindingToVk (moduleStageFlags m) b]) + | m <- modules + , b <- V.toList m.descriptor_bindings + ] + + mergeSet (setNo, bs) = case mergeDescriptorSetLayoutBindings bs of + Right merged -> Right (setNo, zero{Vk.bindings = V.fromList merged}) + Left c -> + Left (descKey (setNo, c.binding) <> ": descriptor type disagreement between stages") + +{- | Push-constant ranges for a multi-stage pipeline: ranges with the same offset +and size are merged with their stage flags OR-ed. Stages that share a range must +agree on its block layout (the offset maps are unified); a disagreement is a 'Left'. +-} +mergedPushConstantRanges :: [Module] -> Either String [Vk.PushConstantRange] +mergedPushConstantRanges modules = do + verifyKeyed pushKey (concatMap pushOffsetMaps modules) + pure (mergePushConstantRanges (concatMap pushConstantRanges modules)) + where + pushKey (o, sz) = "push constant at offset " <> show o <> " size " <> show sz + +-- | A module's shader stage as a Vulkan flag (SPIR-V shares Vulkan's values). +moduleStageFlags :: Module -> Vk.ShaderStageFlags +moduleStageFlags m = Vk.ShaderStageFlagBits (fromIntegral m.shader_stage) + +-- Layout agreement across stages. ----------------------------------------------- + +{- | Entries sharing a key must unify; the first disagreement is reported with the +key rendered by @shw@. +-} +verifyKeyed :: (Ord k) => (k -> String) -> [(k, OffsetMap)] -> Either String () +verifyKeyed shw entries = case mergeKeyed entries of + Right _ -> Right () + Left (k, mm) -> Left (shw k <> ": " <> renderMismatch mm) + +-- | The reflected descriptor type as its raw integer (Vulkan-compatible). +descriptorTypeInt :: DescriptorBinding.DescriptorBinding -> Int +descriptorTypeInt b = let R.DescriptorType n = b.descriptor_type in n diff --git a/utils-spirv/src/Vulkan/Utils/SpirV/DeviceAddress.hs b/utils-spirv/src/Vulkan/Utils/SpirV/DeviceAddress.hs new file mode 100644 index 000000000..29fb9c8c1 --- /dev/null +++ b/utils-spirv/src/Vulkan/Utils/SpirV/DeviceAddress.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} + +{-| A 64-bit buffer device address β€” a GPU pointer to a @buffer_reference@ / +@PhysicalStorageBuffer@ block. + +A @buffer_reference@ member of a shader block is stored as an 8-byte address, not +the pointee inline, so reflection-driven codegen maps it to a 'DeviceAddress' +field. The phantom @a@ records the pointee's generated record type (e.g. +@DeviceAddress Node@), purely for documentation and type-safety at the call site; +the runtime representation is just the 'Word64' address. + +The 'Graphics.Gl.Block.Block' instance lays it out as a single 8-byte scalar +(alignment 8) under both std140 and std430 β€” matching @VkDeviceAddress@ β€” so a +generated record carrying one gets the right offsets via @deriving Storable via +(Std430 …)@. +-} +module Vulkan.Utils.SpirV.DeviceAddress + ( DeviceAddress (..) + ) where + +import Data.Word (Word64) +import Foreign.Ptr.Diff (peekDiffOff, pokeDiffOff) +import Foreign.Storable (Storable) +import Graphics.Gl.Block (Block (..)) + +-- | A device address pointing at a @buffer_reference@ block of type @a@. +newtype DeviceAddress a = DeviceAddress Word64 + deriving stock (Eq, Ord, Show) + deriving newtype (Storable) + +{- | One 8-byte scalar (alignment 8) under both layouts; mirrors the @Double@ +scalar instance gl-block ships, since @a@ is phantom. +-} +instance Block (DeviceAddress a) where + type PackedSize (DeviceAddress a) = 8 + alignment140 _ = 8 + sizeOf140 = sizeOfPacked + alignment430 = alignment140 + sizeOf430 = sizeOf140 + isStruct _ = False + read140 = peekDiffOff + write140 = pokeDiffOff + read430 = read140 + write430 = write140 + readPacked = read140 + writePacked = write140 diff --git a/utils-spirv/src/Vulkan/Utils/SpirV/Layout.hs b/utils-spirv/src/Vulkan/Utils/SpirV/Layout.hs new file mode 100644 index 000000000..246451a7d --- /dev/null +++ b/utils-spirv/src/Vulkan/Utils/SpirV/Layout.hs @@ -0,0 +1,423 @@ +{-# LANGUAGE NoFieldSelectors #-} + +{-| A self-contained, reversible description of a block's memory layout, plus a +value-level unifier over those layouts. + +This is the IR the reflection-driven type machinery is built on. Two levels: + + * 'Layout' \/ 'Member' \/ 'FieldType' β€” the /structured/ form. It keeps every + member's name, byte offset, and full semantic shape (scalar kind, vector \/ + matrix dimensions, array sizes, nested structs), so it carries enough + information to drive code generation /and/ to be run backwards (e.g. towards + authoring SPIR-V), not merely the flattened offsets. + + * 'OffsetMap' β€” the /normalized/ form: the flattened offset table of occupied + scalar 'Slot's (each a byte offset + scalar type), plus an optional + runtime-array tail. This is exactly the offset map the GPU sees, so it is the + canonical form for /layout equivalence/: @mat4@, @vec4[4]@ and @float[16]@ + reduce to the same std430 offset map (and correctly diverge under std140, + where the array strides round to 16). This is structural/layout equivalence β€” + identical normalized bytes β€” not memory aliasing in the SPIR-V @Aliased@ \/ C + pointer sense. + +'unify' is the compatibility relation: not equality and not a prefix match, but +unification. Two layouts unify when their offset maps can be reconciled (a runtime +tail absorbs a concrete repeat, pinning its length); the result is the +most-defined offset map, which can be folded against further layouts ('foldUnify') +to accumulate a combined picture across pipelines. A failure is reported as a +'Mismatch' with a legible 'renderMismatch'. +-} +module Vulkan.Utils.SpirV.Layout + ( -- * Layout mode + layoutForDescriptor + + -- * Structured layout + , Layout (..) + , Member (..) + , FieldType (..) + , ArraySize (..) + , layoutOf + , fromFields + , leafFieldType + + -- * Normalized offset map + , Slot (..) + , OffsetMap (..) + , RuntimeTail (..) + , normalize + , offsetMapOf + + -- * Unification + , Mismatch (..) + , renderMismatch + , unify + , foldUnify + , mergeKeyed + ) where + +import Data.List (foldl', sortOn) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Vector qualified as V +import Graphics.Gl.Block (roundUp) + +import Data.SpirV.Reflect.Enums.DescriptorType qualified as R +import Data.SpirV.Reflect.TypeDescription (TypeDescription) +import Data.SpirV.Reflect.TypeDescription qualified + +import Vulkan.Utils.SpirV.Types (LayoutMode (..), MemberShape (..), NumericType (..), ScalarType (..), arrayBaseAlign, arrayDims, classifyType, isBdaPointer, leafAlignment, scalarWidth, structBaseAlign) + +{- | The gl-block layout a descriptor's block follows: uniform buffers use +std140, storage buffers std430. Other descriptor types carry no block layout +('Nothing'). +-} +layoutForDescriptor :: R.DescriptorType -> Maybe LayoutMode +layoutForDescriptor = \case + R.DESCRIPTOR_TYPE_UNIFORM_BUFFER -> Just Std140Layout + R.DESCRIPTOR_TYPE_STORAGE_BUFFER -> Just Std430Layout + _ -> Nothing + +{- | A struct's layout under a given 'LayoutMode': its members at their resolved +byte offsets, total size and base alignment. 'size' is 'Nothing' when the struct +ends in a runtime-sized array (its size is not known statically). +-} +data Layout = Layout + { name :: Maybe Text + , mode :: LayoutMode + , members :: [Member] + , size :: Maybe Int + , align :: Int + } + deriving (Eq, Show) + +-- | A struct member: its name, byte offset within the struct, and structured type. +data Member = Member + { name :: Text + , offset :: Int + , type' :: FieldType + } + deriving (Eq, Show) + +{- | The structured type of a member. Multi-dimensional arrays nest +(@'ArrayOf' a ('ArrayOf' b t)@, outermost dimension first). +-} +data FieldType + = Scalar ScalarType + | -- | component count (2..4) + Vector ScalarType Int + | -- | columns, rows + Matrix ScalarType Int Int + | ArrayOf ArraySize FieldType + | Struct Layout + deriving (Eq, Show) + +-- | An array dimension: a fixed length, or a runtime (unsized) trailing array. +data ArraySize = Sized Int | Runtime + deriving (Eq, Show) + +-- Layout arithmetic (std140/std430). -------------------------------------------- + +{- | @(base alignment, size)@ of a field type; size is 'Nothing' for a runtime +array (open). +-} +fieldExtent :: LayoutMode -> FieldType -> (Int, Maybe Int) +fieldExtent mode = \case + Scalar s -> (leafAlignment mode s ShScalar, Just (scalarWidth s)) + Vector s n -> (leafAlignment mode s (ShVector n), Just (n * scalarWidth s)) + Matrix s c r -> + let colStride = leafAlignment mode s (ShMatrix c r) + in (colStride, Just (c * colStride)) + ArrayOf Runtime e -> + let (ea, _) = fieldExtent mode e + in (arrayBaseAlign mode ea, Nothing) + ArrayOf (Sized n) e -> + let + (ea, es) = fieldExtent mode e + align = arrayBaseAlign mode ea + stride = roundUp (fromMaybe 0 es) align + in + (align, Just (n * stride)) + Struct l -> (l.align, l.size) + +{- | The stride between elements of an array of @e@ under the layout. Defined only +when @e@ has a static size (i.e. is not itself a runtime array). +-} +arrayStride :: LayoutMode -> FieldType -> Int +arrayStride mode e = + let (ea, es) = fieldExtent mode e + in roundUp (fromMaybe 0 es) (arrayBaseAlign mode ea) + +-- Building from reflection. ----------------------------------------------------- + +-- | Compute the layout of a reflected @OpTypeStruct@ under the given mode. +layoutOf :: LayoutMode -> TypeDescription -> Either String Layout +layoutOf mode td = do + members <- traverse (memberOf mode) (V.toList td.members) + pure (fromFields mode (structName td) members) + +{- | Build a layout from named fields directly, computing each member's offset +and the struct's size and alignment (no reflection). Besides constructing +expected layouts, this is the direction an authoring front end would use. +-} +fromFields :: LayoutMode -> Maybe Text -> [(Text, FieldType)] -> Layout +fromFields mode name members = + Layout + { name + , mode + , members = [m | (m, _, _) <- placed] + , size = if openEnded then Nothing else Just (roundUp end baseAlign) + , align = baseAlign + } + where + placed = place mode members + baseAlign = structBaseAlign mode [a | (_, a, _) <- placed] + openEnded = any (\(_, _, sz) -> sz == Nothing) placed + end = case reverse placed of + [] -> 0 + ((Member _ off _, _, msz) : _) -> maybe off (off +) msz + +{- | Place members in declaration order, returning each at its offset together +with its alignment and (maybe-open) size. +-} +place :: LayoutMode -> [(Text, FieldType)] -> [(Member, Int, Maybe Int)] +place mode = go 0 + where + go _ [] = [] + go cursor ((nm, ft) : rest) = + let + (align, msz) = fieldExtent mode ft + off = roundUp cursor align + cursor' = maybe off (off +) msz + in + (Member nm off ft, align, msz) : go cursor' rest + +-- | The structured type of a single reflected member. +memberOf :: LayoutMode -> TypeDescription -> Either String (Text, FieldType) +memberOf mode mem = do + nm <- maybe (Left "member without a name") Right mem.struct_member_name + base <- baseFieldType mode mem + let + dims = arrayDims mem + wrap d ft = ArrayOf (if d == 0 then Runtime else Sized (fromIntegral d)) ft + pure (nm, foldr wrap base dims) + +{- | The element type of a member, ignoring array dimensions: a leaf +(scalar\/vector\/matrix) or a nested struct. +-} +baseFieldType :: LayoutMode -> TypeDescription -> Either String FieldType +baseFieldType mode mem + -- A buffer_reference pointer is an 8-byte device address, not the pointee + -- inline; the REF check precedes 'classifyType' because the pointer also + -- carries the pointee's leaf flags (e.g. @REF INT@). + | isBdaPointer mem = Right (Scalar STAddress) + | otherwise = + case classifyType mem of + Just numeric -> Right (leafFieldType numeric) + Nothing -> Struct <$> layoutOf mode (fromMaybe mem mem.struct_type_description) + +leafFieldType :: NumericType -> FieldType +leafFieldType NumericType{scalar, shape} = case shape of + ShScalar -> Scalar scalar + ShVector n -> Vector scalar n + ShMatrix c r -> Matrix scalar c r + +-- Normalization to the scalar offset map. --------------------------------------------- + +-- | One occupied scalar component at a byte offset. +data Slot = Slot + { offset :: Int + , scalar :: ScalarType + } + deriving (Eq, Ord, Show) + +{- | A runtime-sized array tail: a repeating element offset map starting at 'base' +with the given stride. The element 'Slot's are relative to the element start. +-} +data RuntimeTail = RuntimeTail + { base :: Int + , stride :: Int + , element :: [Slot] + } + deriving (Eq, Show) + +{- | A normalized layout: the concrete occupied scalar slots (sorted by offset), +the total size (if statically known), and an optional runtime-array tail. +-} +data OffsetMap = OffsetMap + { slots :: [Slot] + , size :: Maybe Int + , tail :: Maybe RuntimeTail + } + deriving (Eq, Show) + +-- | Flatten a structured 'Layout' to its offset map. +normalize :: Layout -> OffsetMap +normalize l = + OffsetMap + { slots = sortOn (.offset) (concatMap fst pieces) + , size = l.size + , tail = listToMaybe (mapMaybe snd pieces) + } + where + mode = l.mode + pieces = map (flattenMember mode) l.members + +-- | Build the offset map straight from reflection. +offsetMapOf :: LayoutMode -> TypeDescription -> Either String OffsetMap +offsetMapOf mode = fmap normalize . layoutOf mode + +flattenMember :: LayoutMode -> Member -> ([Slot], Maybe RuntimeTail) +flattenMember mode (Member _ off ft) = case ft of + ArrayOf Runtime e -> + ([], Just (RuntimeTail off (arrayStride mode e) (flattenAt mode 0 e))) + _ -> (flattenAt mode off ft, Nothing) + +-- | The scalar slots of a (statically-sized) field type at a base offset. +flattenAt :: LayoutMode -> Int -> FieldType -> [Slot] +flattenAt mode off = \case + Scalar s -> [Slot off s] + Vector s n -> let w = scalarWidth s in [Slot (off + i * w) s | i <- [0 .. n - 1]] + Matrix s c r -> + let + w = scalarWidth s + colStride = leafAlignment mode s (ShMatrix c r) + in + [Slot (off + col * colStride + row * w) s | col <- [0 .. c - 1], row <- [0 .. r - 1]] + ArrayOf (Sized n) e -> + let stride = arrayStride mode e + in concat [flattenAt mode (off + i * stride) e | i <- [0 .. n - 1]] + ArrayOf Runtime _ -> [] -- a runtime array can only be a struct's last member + Struct l -> concatMap (\(Member _ mo mft) -> flattenAt mode (off + mo) mft) l.members + +-- Unification. ------------------------------------------------------------------ + +-- | Why two offset maps fail to unify. +data Mismatch + = -- | differing scalar at a byte offset + SlotMismatch Int ScalarType ScalarType + | -- | differing number of occupied slots + CountMismatch Int Int + | -- | differing total size + SizeMismatch Int Int + | -- | incompatible runtime-array tails + TailMismatch String + deriving (Eq, Show) + +renderMismatch :: Mismatch -> String +renderMismatch = \case + SlotMismatch off l r -> + "scalar mismatch at byte offset " + <> show off + <> ": " + <> showScalar l + <> " vs " + <> showScalar r + CountMismatch l r -> + "different number of components: " <> show l <> " vs " <> show r + SizeMismatch l r -> + "different total size: " <> show l <> " vs " <> show r <> " bytes" + TailMismatch msg -> + "incompatible runtime arrays: " <> msg + where + showScalar STFloat = "float" + showScalar STDouble = "double" + showScalar STInt = "int" + showScalar STUInt = "uint" + showScalar STInt64 = "int64" + showScalar STUInt64 = "uint64" + showScalar STBool = "bool" + showScalar STAddress = "address" + +{- | Unify two offset maps into their most-defined common offset map, or report the first +'Mismatch'. A runtime tail on one side absorbs a matching concrete repeat on +the other (pinning the array length); two closed offset maps must coincide exactly. +-} +unify :: OffsetMap -> OffsetMap -> Either Mismatch OffsetMap +unify a b = case (a.tail, b.tail) of + (Nothing, Nothing) -> do + matchSlots a.slots b.slots + matchSize a.size b.size + pure a + (Just _, Nothing) -> absorb a b + (Nothing, Just _) -> absorb b a + (Just ta, Just tb) -> do + matchSlots a.slots b.slots + if ta == tb + then pure a + else Left (TailMismatch "tails differ in stride, element shape or base offset") + +{- | Reconcile an open offset map (with a runtime tail) against a closed one, requiring +the closed offset map to be the open offset map's prefix followed by whole repeats of its +tail element. Returns the closed (pinned) offset map. +-} +absorb :: OffsetMap -> OffsetMap -> Either Mismatch OffsetMap +absorb open closed = do + let + pre = open.slots + n = length pre + matchSlots pre (take n closed.slots) + let + tl = fromMaybe (error "absorb: open offset map has no tail") open.tail + rest = drop n closed.slots + matchRepeats tl rest + pure closed + +-- | The remaining slots must be zero or more whole repeats of the tail element. +matchRepeats :: RuntimeTail -> [Slot] -> Either Mismatch () +matchRepeats tl = go 0 + where + el = tl.element + m = length el + go _ [] = Right () + go j rest + | length chunk < m = + Left (TailMismatch "trailing bytes are not a whole array element") + | otherwise = do + matchSlots (shift (tl.base + j * tl.stride) el) chunk + go (j + 1) more + where + (chunk, more) = splitAt m rest + shift base = map (\(Slot o s) -> Slot (o + base) s) + +matchSlots :: [Slot] -> [Slot] -> Either Mismatch () +matchSlots xs ys + | length xs /= length ys = Left (CountMismatch (length xs) (length ys)) + | otherwise = + case [ (x.offset, x.scalar, y.scalar) + | (x, y) <- zip xs ys + , x.scalar /= y.scalar || x.offset /= y.offset + ] of + ((off, l, r) : _) -> Left (SlotMismatch off l r) + [] -> Right () + +matchSize :: Maybe Int -> Maybe Int -> Either Mismatch () +matchSize (Just l) (Just r) | l /= r = Left (SizeMismatch l r) +matchSize _ _ = Right () + +{- | Fold a layout against further layouts, accumulating the combined offset map (the +running most-general unifier). Use to add pipelines into a shared layout. +-} +foldUnify :: OffsetMap -> [OffsetMap] -> Either Mismatch OffsetMap +foldUnify = foldl' (\acc g -> acc >>= (`unify` g)) . Right + +{- | Merge layouts tagged by a key (e.g. a @(set, binding)@ or vertex @location@): +entries sharing a key must unify, disjoint keys union in. Reports the offending +key with its 'Mismatch'. +-} +mergeKeyed :: (Ord k) => [(k, OffsetMap)] -> Either (k, Mismatch) (Map k OffsetMap) +mergeKeyed = foldl' step (Right Map.empty) + where + step acc (k, g) = do + m <- acc + case Map.lookup k m of + Nothing -> Right (Map.insert k g m) + Just g' -> case unify g' g of + Right u -> Right (Map.insert k u m) + Left e -> Left (k, e) + +-- | The struct's @type_name@, treating an empty name as absent. +structName :: TypeDescription -> Maybe Text +structName td = td.type_name >>= \t -> if Text.null t then Nothing else Just t diff --git a/utils-spirv/src/Vulkan/Utils/SpirV/Pipeline.hs b/utils-spirv/src/Vulkan/Utils/SpirV/Pipeline.hs new file mode 100644 index 000000000..18fcba861 --- /dev/null +++ b/utils-spirv/src/Vulkan/Utils/SpirV/Pipeline.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE NoFieldSelectors #-} + +{-| Assemble a dynamic-rendering graphics pipeline from reflected SPIR-V: one +verified pipeline layout, merged across a /family/ of shaders, shared by every +pipeline built against it β€” each folding in its own reflected vertex input. + +Build the layout once from all the family's distinct modules +('allocateReflectedLayout'), so pipelines that differ only by specialization, +attachment formats or dynamic state share one 'Vk.PipelineLayout' and bind the +same descriptor sets. 'allocateGraphicsPipeline' then folds that layout and the +vertex stage's reflected vertex input into "Vulkan.Utils.DynamicRendering", +removing the by-hand wiring of merged set layouts + vertex input. +-} +module Vulkan.Utils.SpirV.Pipeline + ( ReflectedLayout (..) + , allocateReflectedLayout + , allocateGraphicsPipeline + ) where + +import Control.Monad.IO.Unlift (MonadUnliftIO) +import Control.Monad.Trans.Resource (MonadResource, ReleaseKey, allocate) +import Data.ByteString (ByteString) +import Data.List (find) +import Data.Vector qualified as V +import Data.Word (Word32) +import Vulkan.Core10 qualified as Vk +import Vulkan.Zero (zero) + +import Data.SpirV.Reflect.Module (Module) + +import Vulkan.Utils.DynamicRendering qualified as Dynamic +import Vulkan.Utils.Pipeline.Specialization (Specialization) +import Vulkan.Utils.SpirV.Descriptors (mergedDescriptorSetLayoutInfos, mergedPushConstantRanges, moduleStageFlags) +import Vulkan.Utils.SpirV.VertexInput (vertexInputState) + +{- | A materialized, verified pipeline layout reflected from a family of shaders: +the 'Vk.PipelineLayout' to bind against, and the per-set 'Vk.DescriptorSetLayout's +(keyed by set number) for allocating the descriptor sets. +-} +data ReflectedLayout = ReflectedLayout + { pipelineLayout :: Vk.PipelineLayout + , setLayouts :: [(Word32, Vk.DescriptorSetLayout)] + } + +{- | Build the descriptor-set layouts and pipeline layout for a family of pipelines +from their reflected modules. Bindings and push-constant ranges are merged across +every module β€” stage flags OR-ed, shared block layouts cross-checked (see +'mergedDescriptorSetLayoutInfos' / 'mergedPushConstantRanges') β€” and a conflict +'fail's in @m@. + +Pass every distinct shader the family uses, so the one layout stays compatible +with each pipeline built against it ('allocateGraphicsPipeline'). The layout (and the +set layouts) are owned by @m@'s 'Control.Monad.Trans.Resource.ResourceT' and must +outlive the pipelines. +-} +allocateReflectedLayout + :: (MonadResource m, MonadFail m) + => Vk.Device + -> [Module] + -> m (ReleaseKey, ReflectedLayout) +allocateReflectedLayout dev modules = do + setInfos <- orFail (mergedDescriptorSetLayoutInfos modules) + pushRanges <- orFail (mergedPushConstantRanges modules) + setLayouts <- + traverse + ( \(setNo, info) -> do + (_, layout) <- Vk.withDescriptorSetLayout dev info Nothing allocate + pure (setNo, layout) + ) + setInfos + (key, pipelineLayout) <- + Vk.withPipelineLayout + dev + zero + { Vk.setLayouts = V.fromList (map snd setLayouts) + , Vk.pushConstantRanges = V.fromList pushRanges + } + Nothing + allocate + pure (key, ReflectedLayout{pipelineLayout, setLayouts}) + where + orFail = either fail pure + +{- | Build one pipeline of a family against a shared 'ReflectedLayout', folding in +both that layout and the vertex stage's reflected vertex input. + +Each stage is its reflected 'Module' paired with the SPIR-V to compile; the stage +flag is taken from the module. This fills in the config's 'Dynamic.layout' (from the +'ReflectedLayout') and 'Dynamic.vertexInput' (from the vertex stage's reflection), +overwriting any values set on them; set the per-variant 'Dynamic.colorFormats' \/ +'Dynamic.depthFormat' \/ 'Dynamic.dynamicStates' and vary @spec@ for specialization. +For custom vertex input, drive "Vulkan.Utils.DynamicRendering" directly. +-} +allocateGraphicsPipeline + :: (MonadResource m, MonadUnliftIO m, MonadFail m, Specialization spec) + => Vk.Device + -> ReflectedLayout + -> Dynamic.PipelineConfig + -> spec + -- ^ Specialization shared by every stage; @()@ for none. + -> [(Module, ByteString)] + -- ^ Each stage's reflected module and the SPIR-V to compile. + -> m (ReleaseKey, Vk.Pipeline) +allocateGraphicsPipeline dev reflected config spec stages = + Dynamic.allocatePipelineFromShaders + dev + config + { Dynamic.layout = Just reflected.pipelineLayout + , Dynamic.vertexInput = maybe zero vertexInputState vertexModule + } + spec + [(moduleStageFlags m, spv) | (m, spv) <- stages] + where + vertexModule = fst <$> find (\(m, _) -> moduleStageFlags m == Vk.SHADER_STAGE_VERTEX_BIT) stages diff --git a/utils-spirv/src/Vulkan/Utils/SpirV/Reflect.hs b/utils-spirv/src/Vulkan/Utils/SpirV/Reflect.hs new file mode 100644 index 000000000..6e0777f28 --- /dev/null +++ b/utils-spirv/src/Vulkan/Utils/SpirV/Reflect.hs @@ -0,0 +1,32 @@ +{-| Reflect compiled SPIR-V into a 'Module', both at runtime and inside +Template Haskell splices. +-} +module Vulkan.Utils.SpirV.Reflect + ( Module + , reflectFile + , reflectBytes + , reflectFileQ + ) where + +import Control.Monad.IO.Class (MonadIO (..)) +import Data.ByteString (ByteString) +import Language.Haskell.TH.Syntax (Q, addDependentFile, runIO) + +import Data.SpirV.Reflect.FFI (load, loadBytes) +import Data.SpirV.Reflect.Module (Module) + +-- | Reflect a @.spv@ file into a 'Module'. +reflectFile :: (MonadIO m) => FilePath -> m Module +reflectFile = load + +-- | Reflect SPIR-V bytecode into a 'Module'. +reflectBytes :: (MonadIO m) => ByteString -> m Module +reflectBytes = loadBytes + +{- | Reflect a @.spv@ file at compile time, registering it as a dependency so +the splice is rerun when the file changes. +-} +reflectFileQ :: FilePath -> Q Module +reflectFileQ path = do + addDependentFile path + runIO $ reflectFile path diff --git a/utils-spirv/src/Vulkan/Utils/SpirV/Reflect/OffsetMaps.hs b/utils-spirv/src/Vulkan/Utils/SpirV/Reflect/OffsetMaps.hs new file mode 100644 index 000000000..8e60b1cb9 --- /dev/null +++ b/utils-spirv/src/Vulkan/Utils/SpirV/Reflect/OffsetMaps.hs @@ -0,0 +1,57 @@ +{-| Extract normalized 'OffsetMap's from a reflected 'Module''s resources. + +Both the runtime descriptor/push-constant builders +("Vulkan.Utils.SpirV.Descriptors") and the compile-time stage-signature +machinery ("Vulkan.Utils.SpirV.Stage") need the same thing: the std140\/std430 +'OffsetMap' of each buffer-typed descriptor binding and of each push-constant block. +That extraction β€” pick the layout mode from the descriptor type, pull the block +'TypeDescription', run 'offsetMapOf' β€” lives here once so the two callers can't drift. +-} +module Vulkan.Utils.SpirV.Reflect.OffsetMaps + ( resourceOffsetMap + , resourceOffsetMaps + , pushOffsetMap + , pushOffsetMaps + ) where + +import Data.Maybe (mapMaybe) +import Data.Vector qualified as V +import Data.Word (Word32) + +import Data.SpirV.Reflect.BlockVariable (BlockVariable) +import Data.SpirV.Reflect.BlockVariable qualified +import Data.SpirV.Reflect.DescriptorBinding (DescriptorBinding) +import Data.SpirV.Reflect.DescriptorBinding qualified +import Data.SpirV.Reflect.Module (Module) +import Data.SpirV.Reflect.Module qualified + +import Vulkan.Utils.SpirV.Layout (OffsetMap, layoutForDescriptor, offsetMapOf) +import Vulkan.Utils.SpirV.Types (LayoutMode (..)) + +{- | The @((set, binding), offset map)@ of a single buffer-typed descriptor +binding. 'Nothing' for non-buffer descriptors (samplers, images, …) and for blocks +whose offset map can't be computed. +-} +resourceOffsetMap :: DescriptorBinding -> Maybe ((Word32, Word32), OffsetMap) +resourceOffsetMap b = do + mode <- layoutForDescriptor b.descriptor_type + td <- b.type_description + g <- eitherToMaybe (offsetMapOf mode td) + pure ((b.set, b.binding), g) + +-- | The reflected block offset map of each buffer-typed binding, keyed by @(set, binding)@. +resourceOffsetMaps :: Module -> [((Word32, Word32), OffsetMap)] +resourceOffsetMaps = mapMaybe resourceOffsetMap . V.toList . (.descriptor_bindings) + +-- | The std430 offset map of a push-constant block, if it can be computed. +pushOffsetMap :: BlockVariable -> Maybe OffsetMap +pushOffsetMap pc = pc.type_description >>= eitherToMaybe . offsetMapOf Std430Layout + +-- | The reflected offset map of each push-constant block, keyed by @(offset, size)@. +pushOffsetMaps :: Module -> [((Word32, Word32), OffsetMap)] +pushOffsetMaps = mapMaybe keyed . V.toList . (.push_constants) + where + keyed pc = (,) (pc.absolute_offset, pc.size) <$> pushOffsetMap pc + +eitherToMaybe :: Either e a -> Maybe a +eitherToMaybe = either (const Nothing) Just diff --git a/utils-spirv/src/Vulkan/Utils/SpirV/Signature.hs b/utils-spirv/src/Vulkan/Utils/SpirV/Signature.hs new file mode 100644 index 000000000..fe017d43f --- /dev/null +++ b/utils-spirv/src/Vulkan/Utils/SpirV/Signature.hs @@ -0,0 +1,299 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} + +{-| Type-level layout signatures, tied to the records reflection generates. + +Each generated block record carries a ground 'SigOffsetMap' β€” the promotion of its +normalized 'OffsetMap' ("Vulkan.Utils.SpirV.Layout"), computed value-level at splice +time (the value-level layout is the oracle; see 'knownLayoutInstance'). Because +the offset map is /normalized/ before promotion, layout-equivalent layouts β€” +@mat4@, @vec4[4]@, @float[16]@ under std430 β€” promote to the /same/ 'SigOffsetMap', +so the type-level matcher 'Fits' accepts them with no special cases. + +'Fits' is intentionally thin: a use-site /matcher/ against an already-ground +signature, not a unifier (the heavy unification stays value-level in @Q@). The +ground offset map can be reflected back to a value with 'layoutSig' \/ +'sigOffsetMapVal', which is how the type level is validated against the value-level +unifier. +-} +module Vulkan.Utils.SpirV.Signature + ( -- * Type-level offset map + SigOffsetMap (..) + , SigSlot (..) + , SigTail (..) + + -- * Records carrying a signature + , KnownLayout (..) + , layoutSig + + -- * Reflecting a signature back to a value + , KnownSigOffsetMap (..) + , KnownArrayTail (..) + , KnownMaybeSig (..) + , KnownKeyedSigs (..) + + -- * Matching + , Fits + , FitsTail + , ArrayOf + + -- * Generation (Template Haskell) + , knownLayoutInstance + , promoteOffsetMap + , promoteList + , promoteMaybe + , natT + ) where + +import Data.Kind (Constraint) +import Data.Proxy (Proxy (..)) +import Data.Word (Word32) +import GHC.TypeLits (ErrorMessage (..), KnownNat, Nat, TypeError, natVal) +import Language.Haskell.TH + +import Vulkan.Utils.SpirV.Layout (OffsetMap (..), RuntimeTail (..), Slot (..)) +import Vulkan.Utils.SpirV.Types (ScalarType (..)) + +-- | One occupied scalar component at a byte offset (type-level mirror of 'Slot'). +data SigSlot = SigSlot Nat ScalarType + +{- | A runtime-array tail (mirror of 'RuntimeTail'): base offset, stride, and the +element's slots (relative to the element start). +-} +data SigTail = SigTail Nat Nat [SigSlot] + +{- | A normalized layout at the type level (mirror of 'OffsetMap'): concrete slots, the +total size if statically known, and an optional runtime-array tail. +-} +data SigOffsetMap = SigOffsetMap [SigSlot] (Maybe Nat) (Maybe SigTail) + +{- | A Haskell type with a ground, reflection-derived layout signature. Generated +records get an instance via 'knownLayoutInstance'. +-} +class (KnownSigOffsetMap (Sig a)) => KnownLayout a where + type Sig a :: SigOffsetMap + +-- | The value-level normal form of a record's signature (the oracle view). +layoutSig :: forall a. (KnownLayout a) => OffsetMap +layoutSig = sigOffsetMapVal (Proxy @(Sig a)) + +-- Reflection: type-level offset map -> value 'OffsetMap'. ---------------------------------- + +class KnownScalar (s :: ScalarType) where + scalarVal :: Proxy s -> ScalarType + +instance KnownScalar 'STFloat where scalarVal _ = STFloat +instance KnownScalar 'STDouble where scalarVal _ = STDouble +instance KnownScalar 'STInt where scalarVal _ = STInt +instance KnownScalar 'STUInt where scalarVal _ = STUInt +instance KnownScalar 'STInt64 where scalarVal _ = STInt64 +instance KnownScalar 'STUInt64 where scalarVal _ = STUInt64 +instance KnownScalar 'STBool where scalarVal _ = STBool +instance KnownScalar 'STAddress where scalarVal _ = STAddress + +class KnownSlots (xs :: [SigSlot]) where + slotsVal :: Proxy xs -> [Slot] + +instance KnownSlots '[] where + slotsVal _ = [] + +instance (KnownNat o, KnownScalar s, KnownSlots rest) => KnownSlots ('SigSlot o s ': rest) where + slotsVal _ = + Slot (fromIntegral (natVal (Proxy @o))) (scalarVal (Proxy @s)) : slotsVal (Proxy @rest) + +class KnownMaybeNat (m :: Maybe Nat) where + maybeNatVal :: Proxy m -> Maybe Int + +instance KnownMaybeNat 'Nothing where + maybeNatVal _ = Nothing + +instance (KnownNat n) => KnownMaybeNat ('Just n) where + maybeNatVal _ = Just (fromIntegral (natVal (Proxy @n))) + +class KnownTail (t :: SigTail) where + tailVal :: Proxy t -> RuntimeTail + +instance (KnownNat b, KnownNat s, KnownSlots es) => KnownTail ('SigTail b s es) where + tailVal _ = + RuntimeTail + (fromIntegral (natVal (Proxy @b))) + (fromIntegral (natVal (Proxy @s))) + (slotsVal (Proxy @es)) + +class KnownMaybeTail (m :: Maybe SigTail) where + maybeTailVal :: Proxy m -> Maybe RuntimeTail + +instance KnownMaybeTail 'Nothing where + maybeTailVal _ = Nothing + +instance (KnownTail t) => KnownMaybeTail ('Just t) where + maybeTailVal _ = Just (tailVal (Proxy @t)) + +-- | Reflect a ground type-level offset map back to its value form. +class KnownSigOffsetMap (g :: SigOffsetMap) where + sigOffsetMapVal :: Proxy g -> OffsetMap + +instance (KnownSlots ss, KnownMaybeNat sz, KnownMaybeTail tl) => KnownSigOffsetMap ('SigOffsetMap ss sz tl) where + sigOffsetMapVal _ = + OffsetMap (slotsVal (Proxy @ss)) (maybeNatVal (Proxy @sz)) (maybeTailVal (Proxy @tl)) + +{- | The @(base offset, element stride)@ of a buffer signature's runtime-array +tail, recovered straight from the type level. Only a layout that /has/ a tail has +an instance, so reading it is total β€” and unlike reflecting the whole 'OffsetMap' and +inspecting its 'Maybe' tail ('sigOffsetMapVal'), it forces only the two 'Nat's it +needs, not the element's slot list. So an element loop pays @O(1)@ per element, +not @O(offset map)@. +-} +class KnownArrayTail (t :: SigOffsetMap) where + arrayTailBaseStride :: (Int, Int) + +instance (KnownNat base, KnownNat stride) => KnownArrayTail ('SigOffsetMap cs csz ('Just ('SigTail base stride es))) where + arrayTailBaseStride = + (fromIntegral (natVal (Proxy @base)), fromIntegral (natVal (Proxy @stride))) + +-- | Reflect an optional ground offset map (e.g. a push-constant layout) back to a value. +class KnownMaybeSig (m :: Maybe SigOffsetMap) where + maybeSigVal :: Proxy m -> Maybe OffsetMap + +instance KnownMaybeSig 'Nothing where + maybeSigVal _ = Nothing + +instance (KnownSigOffsetMap g) => KnownMaybeSig ('Just g) where + maybeSigVal _ = Just (sigOffsetMapVal (Proxy @g)) + +-- | Reflect a list of @((set, binding), offset map)@ entries back to values. +class KnownKeyedSigs (xs :: [((Nat, Nat), SigOffsetMap)]) where + keyedSigsVal :: Proxy xs -> [((Word32, Word32), OffsetMap)] + +instance KnownKeyedSigs '[] where + keyedSigsVal _ = [] + +instance + (KnownNat s, KnownNat b, KnownSigOffsetMap g, KnownKeyedSigs rest) + => KnownKeyedSigs ('( '(s, b), g) ': rest) + where + keyedSigsVal _ = + ((nat32 (Proxy @s), nat32 (Proxy @b)), sigOffsetMapVal (Proxy @g)) + : keyedSigsVal (Proxy @rest) + +nat32 :: (KnownNat n) => Proxy n -> Word32 +nat32 = fromIntegral . natVal + +-- Matching. --------------------------------------------------------------------- + +{- | The use-site matcher: @'Fits' r t@ holds when a value of layout @r@ may be +viewed at a slot of layout @t@. Since both are normalized before promotion, +layout-equivalent layouts share a signature and match by equality; a difference is +a legible compile error. (Runtime-tail absorption is handled value-level when a +buffer's signature is built; this matcher covers the ground case.) +-} +type family Fits (r :: SigOffsetMap) (t :: SigOffsetMap) :: Constraint where + Fits g g = () + Fits r t = + TypeError + ( 'Text "Layout mismatch." + ':$$: 'Text " have: " + ':<>: 'ShowType r + ':$$: 'Text " want: " + ':<>: 'ShowType t + ) + +{- | The signature of a tightly-packed runtime array @r[]@ β€” an SSBO whose content +is a runtime array of the element layout @r@. The element becomes the array +tail: its (statically known) size is the stride, the base offset is 0, and the +closed slots clear. Use to tag a mapped SSBO pointer, e.g. +@'Vulkan.Utils.SpirV.Buffer.unsafeAsBufferPtr' p :: io (Buffer ('ArrayOf' ('Sig' Vertex)))@. +(The element's std430 standalone size equals its array stride, so this is exact +for a tightly-packed @T[]@.) +-} +type family ArrayOf (r :: SigOffsetMap) :: SigOffsetMap where + ArrayOf ('SigOffsetMap slots ('Just size) 'Nothing) = + 'SigOffsetMap '[] 'Nothing ('Just ('SigTail 0 size slots)) + ArrayOf r = + TypeError + ( 'Text "ArrayOf: the element layout must be statically sized and not itself open:" + ':$$: 'Text " " + ':<>: 'ShowType r + ) + +{- | @'FitsTail' r t@ holds when a record of layout @r@ is one element of the +runtime-array tail of buffer layout @t@: @r@ is closed with a known size equal +to the tail stride, and its slots are exactly the tail element's. Layout-equivalent +element records share a signature, so they match too; a mismatch (or a @t@ +without a tail) is a legible compile error. +-} +type family FitsTail (r :: SigOffsetMap) (t :: SigOffsetMap) :: Constraint where + FitsTail ('SigOffsetMap es ('Just sz) 'Nothing) ('SigOffsetMap _ _ ('Just ('SigTail _ sz es))) = () + FitsTail r t = + TypeError + ( 'Text "Element layout does not fit the buffer's array tail." + ':$$: 'Text " element: " + ':<>: 'ShowType r + ':$$: 'Text " buffer: " + ':<>: 'ShowType t + ) + +-- Generation. ------------------------------------------------------------------- + +{- | Emit @instance 'KnownLayout' where type 'Sig' = @, promoting the value-level normal form to the type level. +-} +knownLayoutInstance :: Name -> OffsetMap -> [Dec] +knownLayoutInstance name om = + [ InstanceD + Nothing + [] + (ConT ''KnownLayout `AppT` ConT name) + [TySynInstD (TySynEqn Nothing (ConT ''Sig `AppT` ConT name) (promoteOffsetMap om))] + ] + +promoteOffsetMap :: OffsetMap -> Type +promoteOffsetMap (OffsetMap slots msize mtail) = + PromotedT 'SigOffsetMap + `AppT` promoteSlots slots + `AppT` promoteMaybe natT msize + `AppT` promoteMaybe promoteTail mtail + +promoteTail :: RuntimeTail -> Type +promoteTail (RuntimeTail base stride es) = + PromotedT 'SigTail `AppT` natT base `AppT` natT stride `AppT` promoteSlots es + +promoteSlots :: [Slot] -> Type +promoteSlots = promoteList promoteSlot + +promoteSlot :: Slot -> Type +promoteSlot (Slot off sc) = + PromotedT 'SigSlot `AppT` natT off `AppT` PromotedT (scalarName sc) + +-- | Promote a list, element-wise, to a promoted @'[..]@. +promoteList :: (a -> Type) -> [a] -> Type +promoteList f = foldr (\x acc -> PromotedConsT `AppT` f x `AppT` acc) PromotedNilT + +-- | Promote a 'Maybe' to a promoted @'Nothing@ \/ @'Just@. +promoteMaybe :: (a -> Type) -> Maybe a -> Type +promoteMaybe _ Nothing = PromotedT 'Nothing +promoteMaybe f (Just x) = PromotedT 'Just `AppT` f x + +-- | An integral value as a type-level 'Nat' literal. +natT :: (Integral a) => a -> Type +natT = LitT . NumTyLit . fromIntegral + +scalarName :: ScalarType -> Name +scalarName = \case + STFloat -> 'STFloat + STDouble -> 'STDouble + STInt -> 'STInt + STUInt -> 'STUInt + STInt64 -> 'STInt64 + STUInt64 -> 'STUInt64 + STBool -> 'STBool + STAddress -> 'STAddress diff --git a/utils-spirv/src/Vulkan/Utils/SpirV/Specialization.hs b/utils-spirv/src/Vulkan/Utils/SpirV/Specialization.hs new file mode 100644 index 000000000..591bc6a7f --- /dev/null +++ b/utils-spirv/src/Vulkan/Utils/SpirV/Specialization.hs @@ -0,0 +1,145 @@ +{-| Build Vulkan specialization-constant values from a reflected 'Module'. + +Reflection yields each constant's @constant_id@ and name but not its type or +width, and the value side (the 'Specialization' class) is a stack of 'Word32's β€” +so only 32-bit scalar constants (@int@\/@uint@\/@float@\/@bool@, the +@GL_KHR_vulkan_glsl@ baseline) are supported, one 4-byte slot each. +'specializationMapEntries' lays them out in ascending @constant_id@ order (the +ids need not be contiguous). Wider constants are out of scope (see +@spirv-cleanup.md@); a 64-bit value supplied as two 'Word32's trips 'packed'\'s +arity check rather than being silently truncated. + +Supply the values via the 'Specialization' class from +"Vulkan.Utils.Pipeline.Specialization", in ascending @constant_id@ order. (That +module shares the 32-bit limit and additionally assumes @constantID = offset \/ 4@.) +-} +module Vulkan.Utils.SpirV.Specialization + ( specializationConstants + , specializationMapEntries + , withSpecializationInfo + , allocateSpecializationInfo + ) where + +import Control.Monad.IO.Class (liftIO) +import Control.Monad.IO.Unlift (MonadUnliftIO, withRunInIO) +import Control.Monad.Trans.Resource (MonadResource, allocate) +import Data.List (sortOn) +import Data.Text (Text) +import Data.Vector (Vector) +import Data.Vector qualified as V +import Data.Vector.Storable qualified as VS +import Data.Word (Word32) +import Foreign.Marshal.Alloc (free) +import Foreign.Marshal.Array (mallocArray, pokeArray) +import Foreign.Ptr (Ptr, castPtr) +import Vulkan.Core10 qualified as Vk +import Vulkan.Utils.Pipeline.Specialization (Specialization (..)) + +import Data.SpirV.Reflect.Module (Module) +import Data.SpirV.Reflect.Module qualified as Module +import Data.SpirV.Reflect.SpecializationConstant qualified as SC + +-- | Reflected specialization constants as @(constant_id, name)@, ascending by id. +specializationConstants :: Module -> [(Word32, Maybe Text)] +specializationConstants m = + sortOn fst [(scId c, scName c) | c <- V.toList (moduleSpecConstants m)] + +{- | One tightly-packed 32-bit map entry per reflected spec constant, ascending +by @constant_id@ (offset @= index * 4@, size 4). +-} +specializationMapEntries :: Module -> Vector Vk.SpecializationMapEntry +specializationMapEntries m = + V.fromList + [ Vk.SpecializationMapEntry + { Vk.constantID = cid + , Vk.offset = fromIntegral (ix * 4) + , Vk.size = 4 + } + | (ix, (cid, _)) <- zip [0 :: Int ..] (specializationConstants m) + ] + +{- | Pack a 'Specialization' against the reflected map entries, yielding a +'Vk.SpecializationInfo' valid for the callback's duration (pipeline creation +copies the values out β€” build and create the pipeline inside the callback). +'Nothing' when the shader declares no spec constants. + +The supplied values must be in ascending @constant_id@ order and number the +shader's declared constants; a mismatch is a programmer error and 'error's. +-} +withSpecializationInfo + :: (Specialization spec, MonadUnliftIO m) + => Module + -> spec + -> (Maybe Vk.SpecializationInfo -> m a) + -> m a +withSpecializationInfo m spec action = + case packed m spec of + Nothing -> action Nothing + Just (entries, ws) -> + withRunInIO $ \run -> + VS.unsafeWith (VS.fromList ws) $ \p -> + run . action $ Just (specInfo entries (length ws) (castPtr p)) + +{- | As 'withSpecializationInfo', but the backing buffer lives until the +surrounding 'Control.Monad.Trans.Resource.ResourceT' scope ends rather than a +callback β€” so it survives a later pipeline creation. 'Nothing' when the shader +declares no spec constants. +-} +allocateSpecializationInfo + :: (Specialization spec, MonadResource m) + => Module + -> spec + -> m (Maybe Vk.SpecializationInfo) +allocateSpecializationInfo m spec = + case packed m spec of + Nothing -> pure Nothing + Just (entries, 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 (specInfo entries n (castPtr ptr)) + +{- | Reflected map entries paired with the caller's packed values, or 'Nothing' +when there are no spec constants. 'error's on an arity mismatch. +-} +packed + :: (Specialization spec) + => Module + -> spec + -> Maybe (Vector Vk.SpecializationMapEntry, [Word32]) +packed m spec + | V.null entries = Nothing + | length ws /= n = + error $ + "Vulkan.Utils.SpirV.Specialization: shader declares " + <> show n + <> " specialization constant(s) but " + <> show (length ws) + <> " value(s) were supplied" + | otherwise = Just (entries, ws) + where + entries = specializationMapEntries m + n = V.length entries + ws = specializationData spec + +specInfo :: Vector Vk.SpecializationMapEntry -> Int -> Ptr () -> Vk.SpecializationInfo +specInfo entries n p = + Vk.SpecializationInfo + { Vk.mapEntries = entries + , Vk.dataSize = fromIntegral (n * 4) + , Vk.data' = p + } + +-- Field accessors via record patterns (the constructor disambiguates the +-- DuplicateRecordFields names). + +moduleSpecConstants :: Module -> Vector SC.SpecializationConstant +moduleSpecConstants Module.Module{Module.spec_constants = cs} = cs + +scId :: SC.SpecializationConstant -> Word32 +scId SC.SpecializationConstant{SC.constant_id = i} = i + +scName :: SC.SpecializationConstant -> Maybe Text +scName SC.SpecializationConstant{SC.name = n} = n diff --git a/utils-spirv/src/Vulkan/Utils/SpirV/Stage.hs b/utils-spirv/src/Vulkan/Utils/SpirV/Stage.hs new file mode 100644 index 000000000..0142a00b7 --- /dev/null +++ b/utils-spirv/src/Vulkan/Utils/SpirV/Stage.hs @@ -0,0 +1,392 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoFieldSelectors #-} + +{-| Per-shader /stage signatures/ and the type-level checks that compose them. + +A 'ShaderSig' captures, at the type level, a shader stage's interface (its @in@ +and @out@ variables, by location) and its resource layouts (descriptor blocks by +@(set, binding)@, and push constants) β€” each as a normalized 'SigOffsetMap' +("Vulkan.Utils.SpirV.Signature"). 'reflectStageSig' emits one from a compiled +@.spv@; the value-level 'StageInfo' it is promoted from is also returned by +'stageInfoOf' for use as the oracle and for building Vulkan create-infos. + +The composition checks are thin type-level /matchers/ (the heavy work stayed +value-level): 'MatchInterface' requires every fragment input to have a +matching-typed vertex output at the same location. + +'reflectPipelineLayoutSig' goes one step further: it promotes the /merged/ +pipeline-layout signature (descriptor blocks by @(set, binding)@ + push) across a +family of shaders β€” the type-level counterpart of the runtime merge in +"Vulkan.Utils.SpirV.Descriptors". +-} +module Vulkan.Utils.SpirV.Stage + ( -- * Stage signatures + ShaderSig (..) + , StageKind (..) + + -- * Value-level extraction (the oracle) + , StageInfo (..) + , stageInfoOf + , matchInterface + , Linked (..) + , linkStages + + -- * Type-level checks + , MatchInterface + , CompatibleResources + + -- * Merged pipeline-layout signature + , LayoutSig (..) + , LayoutInfo (..) + , mergeLayout + , KnownLayoutSig (..) + + -- * Generation + , reflectStageSig + , reflectStageSigBytes + , reflectPipelineLayoutSig + , reflectPipelineLayoutSigBytes + ) where + +import Data.ByteString (ByteString) +import Data.Kind (Constraint) +import Data.List (foldl', sortOn) +import Data.Proxy (Proxy (..)) +import Data.Vector qualified as V +import Data.Word (Word32) +import GHC.TypeLits (ErrorMessage (..), Nat, TypeError) +import Language.Haskell.TH + +import Data.SpirV.Enum (BuiltIn (..)) +import Data.SpirV.Reflect.InterfaceVariable qualified as InterfaceVariable +import Data.SpirV.Reflect.Module (Module) +import Data.SpirV.Reflect.Module qualified +import Data.SpirV.Reflect.TypeDescription (TypeDescription) + +import Vulkan.Utils.SpirV.Layout (OffsetMap, fromFields, leafFieldType, normalize) +import Vulkan.Utils.SpirV.Reflect (reflectBytes, reflectFileQ) +import Vulkan.Utils.SpirV.Reflect.OffsetMaps (pushOffsetMap, resourceOffsetMaps) +import Vulkan.Utils.SpirV.Signature (KnownKeyedSigs (..), KnownMaybeSig (..), SigOffsetMap, natT, promoteList, promoteMaybe, promoteOffsetMap) +import Vulkan.Utils.SpirV.Types (LayoutMode (..), classifyType) + +-- | Which pipeline stage a shader is. +data StageKind = VertexStage | FragmentStage | ComputeStage + deriving (Eq, Show) + +{- | A stage's type-level signature: stage, inputs and outputs (location ↦ layout), +resources (@(set, binding)@ ↦ block layout) and an optional push-constant layout. +-} +data ShaderSig + = ShaderSig + StageKind + [(Nat, SigOffsetMap)] + [(Nat, SigOffsetMap)] + [((Nat, Nat), SigOffsetMap)] + (Maybe SigOffsetMap) + +-- Value-level extraction. ------------------------------------------------------- + +{- | The value-level form of a 'ShaderSig', reflected from a 'Module'. This is the +oracle the type level is promoted from, and the source for Vulkan create-infos. +-} +data StageInfo = StageInfo + { stage :: StageKind + , inputs :: [(Word32, OffsetMap)] + , outputs :: [(Word32, OffsetMap)] + , resources :: [((Word32, Word32), OffsetMap)] + , push :: Maybe OffsetMap + } + deriving (Eq, Show) + +-- | Reflect a module's stage signature. +stageInfoOf :: Module -> StageInfo +stageInfoOf m = + StageInfo + { stage = stageKindOf m.shader_stage + , inputs = interfaceOffsetMaps m.input_variables + , outputs = interfaceOffsetMaps m.output_variables + , resources = sortOn fst (resourceOffsetMaps m) + , push = + case V.toList m.push_constants of + (pc : _) -> pushOffsetMap pc + [] -> Nothing + } + +-- | Interface variables as @(location, offset map)@, built-ins dropped, ascending. +interfaceOffsetMaps :: V.Vector InterfaceVariable.InterfaceVariable -> [(Word32, OffsetMap)] +interfaceOffsetMaps vs = + sortOn + fst + -- a non-built-in reads as Nothing (ffi) or the @BuiltIn (-1)@ sentinel (yaml) + [ (v.location, g) + | v <- V.toList vs + , v.built_in `elem` [Nothing, Just (BuiltIn (-1))] + , Just td <- [v.type_description] + , Just g <- [interfaceOffsetMap td] + ] + +-- | The offset map of a single interface variable (a scalar/vector at offset 0). +interfaceOffsetMap :: TypeDescription -> Maybe OffsetMap +interfaceOffsetMap td = do + numeric <- classifyType td + pure (normalize (fromFields Std430Layout Nothing [("v", leafFieldType numeric)])) + +stageKindOf :: Int -> StageKind +stageKindOf n + | n == 0x01 = VertexStage + | n == 0x10 = FragmentStage + | otherwise = ComputeStage + +{- | The interface oracle: every input of the second stage must have an +equal-typed output in the first. (Use as @matchInterface vert frag@.) +-} +matchInterface :: StageInfo -> StageInfo -> Either String () +matchInterface producer consumer = + mapM_ check consumer.inputs + where + outs = producer.outputs + check (loc, want) = + case lookup loc outs of + Just have + | have == want -> Right () + | otherwise -> + Left ("interface mismatch at location " <> show loc) + Nothing -> + Left ("input at location " <> show loc <> " has no matching output") + +{- | A linked vertex+fragment pipeline's combined signature (value-level oracle): +the merged resources (shared @(set, binding)@s deduped) and push constants, the +vertex stage's inputs (vertex attributes) and the fragment stage's outputs +(colour attachments). +-} +data Linked = Linked + { resources :: [((Word32, Word32), OffsetMap)] + , push :: Maybe OffsetMap + , inputs :: [(Word32, OffsetMap)] + , outputs :: [(Word32, OffsetMap)] + } + deriving (Eq, Show) + +{- | Link a vertex and a fragment stage: the interface must match, shared bindings +and push constants must agree, and the resources union. Mirrors the type-level +'MatchInterface' + 'CompatibleResources'. +-} +linkStages :: StageInfo -> StageInfo -> Either String Linked +linkStages vert frag = do + matchInterface vert frag + resources <- mergeAssoc showKey vert.resources frag.resources + push <- mergePush vert.push frag.push + pure + Linked + { resources = sortOn fst resources + , push + , inputs = vert.inputs + , outputs = frag.outputs + } + where + showKey (s, b) = "(set " <> show s <> ", binding " <> show b <> ")" + +-- | Union two keyed offset-map lists; a shared key whose maps differ is an error. +mergeAssoc :: (Eq k) => (k -> String) -> [(k, OffsetMap)] -> [(k, OffsetMap)] -> Either String [(k, OffsetMap)] +mergeAssoc shw xs ys = foldr step (Right xs) ys + where + step (k, g) acc = do + m <- acc + case lookup k m of + Nothing -> Right ((k, g) : m) + Just g' + | g' == g -> Right m + | otherwise -> Left ("incompatible layouts at " <> shw k) + +mergePush :: Maybe OffsetMap -> Maybe OffsetMap -> Either String (Maybe OffsetMap) +mergePush Nothing b = Right b +mergePush a Nothing = Right a +mergePush (Just a) (Just b) + | a == b = Right (Just a) + | otherwise = Left "incompatible push-constant layouts between stages" + +-- Merged pipeline-layout signature. --------------------------------------------- + +{- | A merged pipeline-layout signature at the type level: the descriptor blocks by +@(set, binding)@ and the push-constant block, unified across a family of shaders. +The type-level mirror of 'LayoutInfo'. +-} +data LayoutSig = LayoutSig [((Nat, Nat), SigOffsetMap)] (Maybe SigOffsetMap) + +{- | The value-level merged layout 'reflectPipelineLayoutSig' promotes (its oracle): +each descriptor block's 'OffsetMap' by @(set, binding)@ ascending, and the +push-constant block. +-} +data LayoutInfo = LayoutInfo + { resources :: [((Word32, Word32), OffsetMap)] + , push :: Maybe OffsetMap + } + deriving (Eq, Show) + +{- | Merge several stages into one pipeline-layout signature: descriptor blocks are +unioned (a shared @(set, binding)@ whose layouts disagree is a 'Left') and the +push-constant blocks unified. Unlike 'linkStages' there is no interface check β€” one +layout is shared across pipelines whose vertex\/fragment interfaces differ. +-} +mergeLayout :: [Module] -> Either String LayoutInfo +mergeLayout modules = do + resources <- foldl' addResources (Right []) infos + push <- foldl' addPush (Right Nothing) infos + pure LayoutInfo{resources = sortOn fst resources, push} + where + infos = map stageInfoOf modules + addResources acc info = acc >>= mergeAssoc showKey info.resources + addPush acc info = acc >>= \p -> mergePush p info.push + showKey (s, b) = "(set " <> show s <> ", binding " <> show b <> ")" + +{- | Reflect a type-level 'LayoutSig' back to its value 'LayoutInfo' β€” the oracle +view, for validating the promotion and (later) driving bind-site checks. +-} +class KnownLayoutSig (sig :: LayoutSig) where + layoutSigVal :: Proxy sig -> LayoutInfo + +instance (KnownKeyedSigs rs, KnownMaybeSig p) => KnownLayoutSig ('LayoutSig rs p) where + layoutSigVal _ = LayoutInfo{resources = keyedSigsVal (Proxy @rs), push = maybeSigVal (Proxy @p)} + +-- Type-level checks. ------------------------------------------------------------ + +{- | Holds when every input of @f@ has a matching-typed output of @v@ at the same +location (extra outputs of @v@ are allowed). A mismatch is a compile error. +-} +type family MatchInterface (v :: ShaderSig) (f :: ShaderSig) :: Constraint where + MatchInterface ('ShaderSig _ _ vouts _ _) ('ShaderSig _ fins _ _ _) = MatchAll fins vouts + +type family MatchAll (ins :: [(Nat, SigOffsetMap)]) (outs :: [(Nat, SigOffsetMap)]) :: Constraint where + MatchAll '[] _ = () + MatchAll ('(loc, g) ': rest) outs = (MatchOne loc g (Lookup loc outs), MatchAll rest outs) + +type family MatchOne (loc :: Nat) (want :: SigOffsetMap) (have :: Maybe SigOffsetMap) :: Constraint where + MatchOne _ g ('Just g) = () + MatchOne loc want ('Just have) = + TypeError + ( 'Text "Interface mismatch at location " + ':<>: 'ShowType loc + ':<>: 'Text ":" + ':$$: 'Text " vertex out: " + ':<>: 'ShowType have + ':$$: 'Text " fragment in: " + ':<>: 'ShowType want + ) + MatchOne loc _ 'Nothing = + TypeError + ('Text "Fragment input at location " ':<>: 'ShowType loc ':<>: 'Text " has no matching vertex output.") + +type family Lookup (k :: Nat) (xs :: [(Nat, SigOffsetMap)]) :: Maybe SigOffsetMap where + Lookup _ '[] = 'Nothing + Lookup k ('(k, v) ': _) = 'Just v + Lookup k ('(_, _) ': rest) = Lookup k rest + +{- | Holds when every descriptor block and push constant the two stages /share/ +(same @(set, binding)@) has the same layout. Disjoint resources are fine; a +shared binding with differing layouts is a compile error. +-} +type family CompatibleResources (v :: ShaderSig) (f :: ShaderSig) :: Constraint where + CompatibleResources ('ShaderSig _ _ _ vres vpush) ('ShaderSig _ _ _ fres fpush) = + (CompatAll vres fres, CompatPush vpush fpush) + +type family CompatAll (xs :: [((Nat, Nat), SigOffsetMap)]) (ys :: [((Nat, Nat), SigOffsetMap)]) :: Constraint where + CompatAll '[] _ = () + CompatAll ('(k, g) ': rest) ys = (CompatOne k g (LookupR k ys), CompatAll rest ys) + +type family CompatOne (k :: (Nat, Nat)) (g :: SigOffsetMap) (m :: Maybe SigOffsetMap) :: Constraint where + CompatOne _ _ 'Nothing = () + CompatOne _ g ('Just g) = () + CompatOne k _ ('Just _) = + TypeError + ( 'Text "Resource layout mismatch at set/binding " + ':<>: 'ShowType k + ':<>: 'Text " between stages." + ) + +type family CompatPush (a :: Maybe SigOffsetMap) (b :: Maybe SigOffsetMap) :: Constraint where + CompatPush 'Nothing _ = () + CompatPush _ 'Nothing = () + CompatPush ('Just g) ('Just g) = () + CompatPush ('Just _) ('Just _) = + TypeError ('Text "Push-constant layouts differ between stages.") + +type family LookupR (k :: (Nat, Nat)) (xs :: [((Nat, Nat), SigOffsetMap)]) :: Maybe SigOffsetMap where + LookupR _ '[] = 'Nothing + LookupR k ('(k, v) ': _) = 'Just v + LookupR k ('(_, _) ': rest) = LookupR k rest + +-- Generation. ------------------------------------------------------------------- + +-- | Reflect a compiled @.spv@ and emit @type \ = \@. +reflectStageSig :: String -> FilePath -> Q [Dec] +reflectStageSig name path = do + m <- reflectFileQ path + pure [TySynD (mkName name) [] (promoteStageInfo (stageInfoOf m))] + +{- | As 'reflectStageSig', but from SPIR-V bytecode already in hand β€” e.g. a +quasiquoted shader imported from another module (the Template Haskell stage +restriction applies). +-} +reflectStageSigBytes :: String -> ByteString -> Q [Dec] +reflectStageSigBytes name bytes = do + m <- runIO (reflectBytes bytes) + pure [TySynD (mkName name) [] (promoteStageInfo (stageInfoOf m))] + +promoteStageInfo :: StageInfo -> Type +promoteStageInfo si = + PromotedT 'ShaderSig + `AppT` promoteStage si.stage + `AppT` promoteList (promoteLocated promoteOffsetMap) si.inputs + `AppT` promoteList (promoteLocated promoteOffsetMap) si.outputs + `AppT` promoteList (promoteKeyed promoteOffsetMap) si.resources + `AppT` promoteMaybe promoteOffsetMap si.push + +promoteStage :: StageKind -> Type +promoteStage = \case + VertexStage -> PromotedT 'VertexStage + FragmentStage -> PromotedT 'FragmentStage + ComputeStage -> PromotedT 'ComputeStage + +promoteLocated :: (a -> Type) -> (Word32, a) -> Type +promoteLocated f (loc, x) = pair (natT loc) (f x) + +promoteKeyed :: (a -> Type) -> ((Word32, Word32), a) -> Type +promoteKeyed f ((s, b), x) = pair (pair (natT s) (natT b)) (f x) + +pair :: Type -> Type -> Type +pair a b = PromotedTupleT 2 `AppT` a `AppT` b + +{- | Reflect the @.spv@ of a pipeline's shaders and emit +@type \ = \@ β€” the descriptor blocks by +@(set, binding)@ and push constants merged across the stages ('mergeLayout' is the +oracle). A layout disagreement between stages fails the splice. The type-level +counterpart of 'Vulkan.Utils.SpirV.Descriptors.mergedDescriptorSetLayoutInfos'. +-} +reflectPipelineLayoutSig :: String -> [FilePath] -> Q [Dec] +reflectPipelineLayoutSig name paths = do + modules <- traverse reflectFileQ paths + case mergeLayout modules of + Left err -> fail ("reflectPipelineLayoutSig: " <> err) + Right info -> pure [TySynD (mkName name) [] (promoteLayoutSig info)] + +-- | As 'reflectPipelineLayoutSig', but from SPIR-V bytecode already in hand. +reflectPipelineLayoutSigBytes :: String -> [ByteString] -> Q [Dec] +reflectPipelineLayoutSigBytes name bytess = do + modules <- runIO (traverse reflectBytes bytess) + case mergeLayout modules of + Left err -> fail ("reflectPipelineLayoutSigBytes: " <> err) + Right info -> pure [TySynD (mkName name) [] (promoteLayoutSig info)] + +promoteLayoutSig :: LayoutInfo -> Type +promoteLayoutSig info = + PromotedT 'LayoutSig + `AppT` promoteList (promoteKeyed promoteOffsetMap) info.resources + `AppT` promoteMaybe promoteOffsetMap info.push diff --git a/utils-spirv/src/Vulkan/Utils/SpirV/TH.hs b/utils-spirv/src/Vulkan/Utils/SpirV/TH.hs new file mode 100644 index 000000000..49008d6bf --- /dev/null +++ b/utils-spirv/src/Vulkan/Utils/SpirV/TH.hs @@ -0,0 +1,140 @@ +{-| Template Haskell entry points: reflect a compiled @.spv@ at build time and +splice Haskell record types for its uniform / storage / push-constant blocks. + +Types are keyed by their SPIR-V struct name and generated at most once; a name +that already resolves in scope (e.g. generated from another shader that shares +an include) is referenced rather than redefined, so shared GLSL types map to a +single shared Haskell type. +-} +module Vulkan.Utils.SpirV.TH + ( reflectShaderTypes + , reflectShaderTypesWith + , reflectShaderTypesBytes + , reflectShaderTypesBytesWith + , reflectModuleTypes + , reflectModuleTypesWith + ) where + +import Data.ByteString (ByteString) +import Data.Map.Strict qualified as Map +import Data.Vector qualified as V +import Language.Haskell.TH + +import Data.SpirV.Reflect.BlockVariable qualified +import Data.SpirV.Reflect.DescriptorBinding qualified +import Data.SpirV.Reflect.Enums.DescriptorType qualified as R +import Data.SpirV.Reflect.Module (Module) +import Data.SpirV.Reflect.Module qualified +import Data.SpirV.Reflect.TypeDescription (TypeDescription) + +import Vulkan.Utils.SpirV.Block (allMembers16, collectStructs, structRecordDec, structTypeName) +import Vulkan.Utils.SpirV.Reflect (reflectBytes, reflectFileQ) +import Vulkan.Utils.SpirV.Types (LayoutMode (..), TypeMap, geomancyTypeMap) + +{- | Reflect a @.spv@ file and generate record types for its blocks, using the +default 'geomancyTypeMap'. +-} +reflectShaderTypes :: FilePath -> Q [Dec] +reflectShaderTypes = reflectShaderTypesWith geomancyTypeMap + +-- | As 'reflectShaderTypes', with a caller-supplied 'TypeMap'. +reflectShaderTypesWith :: TypeMap -> FilePath -> Q [Dec] +reflectShaderTypesWith tymap path = reflectFileQ path >>= reflectModuleTypesWith tymap + +{- | As 'reflectShaderTypes', but reflecting SPIR-V bytecode already in hand +rather than reading a @.spv@ file β€” e.g. the 'ByteString' a @[comp|…|]@ +quasiquoter produced in a shader module, referenced from the module that +assembles the pipeline: + +@ +reflectShaderTypesBytes Shaders.compSpirv +@ + +No file is involved. Because the bytes are an ordinary imported binding, GHC's +cross-module recompilation reruns the splice when they change, so (unlike the +file path) there is no 'Language.Haskell.TH.Syntax.addDependentFile' to forget. +The usual Template Haskell stage restriction applies: the bytes must come from a +different module than the splice. +-} +reflectShaderTypesBytes :: ByteString -> Q [Dec] +reflectShaderTypesBytes = reflectShaderTypesBytesWith geomancyTypeMap + +-- | As 'reflectShaderTypesBytes', with a caller-supplied 'TypeMap'. +reflectShaderTypesBytesWith :: TypeMap -> ByteString -> Q [Dec] +reflectShaderTypesBytesWith tymap bytes = runIO (reflectBytes bytes) >>= reflectModuleTypesWith tymap + +{- | Generate record types for every block a reflected 'Module' declares. + +The shared core of 'reflectShaderTypes' and 'reflectShaderTypesBytes', exposed so +a caller who already holds a 'Module' can reach codegen without re-reflecting β€” +and can reflect once, then splice from the same 'Module' in more than one place. +-} +reflectModuleTypes :: Module -> Q [Dec] +reflectModuleTypes = reflectModuleTypesWith geomancyTypeMap + +-- | As 'reflectModuleTypes', with a caller-supplied 'TypeMap'. +reflectModuleTypesWith :: TypeMap -> Module -> Q [Dec] +reflectModuleTypesWith tymap = genStructs tymap . moduleStructCandidates + +{- | The @OpTypeStruct@ descriptions worth turning into records, each paired with +the layout its 'Storable' should follow. Each block is expanded through +'collectStructs' so nested and array-element structs (e.g. an SSBO's @Sphere[]@ +element) are generated too. +-} +moduleStructCandidates :: Module -> [(LayoutMode, TypeDescription)] +moduleStructCandidates m = + concatMap (uncurry collectStructs) $ + [ (layoutForDescriptor b.descriptor_type, td) + | b <- V.toList m.descriptor_bindings + , Just td <- [b.type_description] + ] + ++ [ (Std430Layout, td) + | pc <- V.toList m.push_constants + , Just td <- [pc.type_description] + ] + +layoutForDescriptor :: R.DescriptorType -> LayoutMode +layoutForDescriptor = \case + R.DESCRIPTOR_TYPE_UNIFORM_BUFFER -> Std140Layout + _ -> Std430Layout + +genStructs :: TypeMap -> [(LayoutMode, TypeDescription)] -> Q [Dec] +genStructs tymap = go Map.empty + where + go _ [] = pure [] + go seen ((layout, td) : rest) = + case structTypeName td of + Nothing -> go seen rest + Just nm -> + case Map.lookup nm seen of + -- Already requested in this splice. + Just prev + | prev == layout -> go seen rest -- same layout; reference it + | allMembers16 td -> go seen rest -- std140 == std430; safe to share + | otherwise -> fail (sharingError nm prev layout) + Nothing -> do + existing <- lookupTypeName nm + case existing of + Just _ -> go (Map.insert nm layout seen) rest -- defined elsewhere; reference it + Nothing -> do + mdec <- structRecordDec tymap layout td + decs <- go (Map.insert nm layout seen) rest + pure $ maybe decs (++ decs) mdec + +{- | A struct used under two layouts that aren't byte-compatible (see +'allMembers16') can't be represented by a single Haskell record. +-} +sharingError :: String -> LayoutMode -> LayoutMode -> String +sharingError nm a b = + "vulkan-utils-spirv: struct '" + <> nm + <> "' is used under both " + <> showLayout a + <> " and " + <> showLayout b + <> " layouts but is not layout-compatible: not every member is 16-byte " + <> "aligned. Make each member 16-byte aligned (e.g. use vec4/mat4) so the " + <> "layouts coincide, or keep the struct to a single layout." + where + showLayout Std140Layout = "std140" + showLayout Std430Layout = "std430" diff --git a/utils-spirv/src/Vulkan/Utils/SpirV/Types.hs b/utils-spirv/src/Vulkan/Utils/SpirV/Types.hs new file mode 100644 index 000000000..fbfd6cea1 --- /dev/null +++ b/utils-spirv/src/Vulkan/Utils/SpirV/Types.hs @@ -0,0 +1,292 @@ +{-# LANGUAGE NoFieldSelectors #-} + +{-| Classify a reflected block member into a base scalar + shape, and map it to +a Haskell type that carries a 'Graphics.Gl.Block.Block' instance. + +The mapping is pluggable ('TypeMap'). The default is 'geomancyTypeMap', onto +[geomancy](https://hackage.haskell.org/package/geomancy)'s @Vec*@ \/ @IVec*@ \/ +@UVec*@ \/ @Mat4@ (which carry native std140/std430 'Block' instances). +'linearTypeMap' is a worked /example/ of the same recipe for a library whose +types are parametric (it is not usable for codegen yet β€” see its note). + +A map names its types by /raw qualified name/ against the library's base module +(e.g. @Geomancy.Vec3@) rather than a compile-time @''@ quote, so this package +depends on no vector library. The names resolve at the /splice site/, so a module +that splices these records must @import Geomancy qualified@ β€” under the base +module's own name, not an @as@ alias β€” and have a 'Graphics.Gl.Block.Block' +instance in scope for each mapped type. A missing import surfaces as a plain +\"Not in scope: type constructor Geomancy.Vec3\". + +Build a map for any other vector library the same way with 'mkTypeMap' + +'qualType' (+ 'scalarLeaf' for the base components): 'geomancyTypeMap' shows the +monomorphic case (the scalar is baked into the name), 'linearTypeMap' the +parametric case (the scalar is applied as a type argument). +-} +module Vulkan.Utils.SpirV.Types + ( ScalarType (..) + , MemberShape (..) + , NumericType (..) + , classifyType + , isBdaPointer + , arrayDims + , LayoutMode (..) + , scalarWidth + , arrayBaseAlign + , leafAlignment + , structBaseAlign + , TypeMap + , mkTypeMap + , scalarLeaf + , qualType + , geomancyTypeMap + , linearTypeMap + ) where + +import Data.Bits ((.&.)) +import Data.Int (Int32, Int64) +import Data.Vector.Storable qualified as VS +import Data.Word (Word32, Word64) +import Graphics.Gl.Block (roundUp) +import Language.Haskell.TH (Type (AppT, ConT), mkName) + +import Data.SpirV.Reflect.Enums.TypeFlags qualified as TypeFlags +import Data.SpirV.Reflect.Traits qualified as Traits +import Data.SpirV.Reflect.TypeDescription (TypeDescription) +import Data.SpirV.Reflect.TypeDescription qualified as TypeDescription + +{- | The base component type of a block member. + +'STInt64' \/ 'STUInt64' are 64-bit integers (@int64_t@ \/ @uint64_t@, the +@GL_EXT_shader_explicit_arithmetic_types_int64@ scalars): 8-byte slots, like +'STDouble'. 'STAddress' is a 64-bit buffer device address (@buffer_reference@ / +@PhysicalStorageBuffer@ pointer): no GLSL scalar spelling, but one 8-byte slot +like any other scalar. Sub-32-bit scalars (@float16@ \/ @int16@) are out of scope. +-} +data ScalarType = STFloat | STDouble | STInt | STUInt | STInt64 | STUInt64 | STBool | STAddress + deriving (Eq, Ord, Show) + +-- | The shape of a block member. +data MemberShape + = ShScalar + | -- | component count (2..4) + ShVector Int + | -- | columns, rows + ShMatrix Int Int + deriving (Eq, Ord, Show) + +{- | Which gl-block layout a block follows. Uniform buffers use std140; storage +buffers and push constants use std430. +-} +data LayoutMode = Std140Layout | Std430Layout + deriving (Eq, Show) + +-- | The byte width of a scalar component (64-bit scalars are 8, the rest 4). +scalarWidth :: ScalarType -> Int +scalarWidth STDouble = 8 +scalarWidth STInt64 = 8 +scalarWidth STUInt64 = 8 +scalarWidth STAddress = 8 +scalarWidth _ = 4 + +{- | The base alignment of an array or matrix column: std140 rounds the +element\/column alignment up to a multiple of 16, std430 keeps it. +-} +arrayBaseAlign :: LayoutMode -> Int -> Int +arrayBaseAlign Std140Layout a = roundUp a 16 +arrayBaseAlign Std430Layout a = a + +{- | The base alignment of a leaf member (scalar\/vector\/matrix) under the +layout. A matrix aligns as its column vector (rounded up to 16 under std140). +-} +leafAlignment :: LayoutMode -> ScalarType -> MemberShape -> Int +leafAlignment mode s = \case + ShScalar -> w + ShVector 2 -> 2 * w + ShVector _ -> 4 * w + ShMatrix _ r -> arrayBaseAlign mode (if r <= 2 then 2 * w else 4 * w) + where + w = scalarWidth s + +{- | The base alignment of a struct: the largest member alignment (at least 1), +rounded up to 16 under std140. +-} +structBaseAlign :: LayoutMode -> [Int] -> Int +structBaseAlign mode alignments = case mode of + Std140Layout -> roundUp base 16 + Std430Layout -> base + where + base = maximum (1 : alignments) + +{- | A numeric (non-struct) leaf type: a base scalar component, a shape +(scalar\/vector\/matrix), and zero or more array dimensions (outermost first; +empty means not an array). +-} +data NumericType = NumericType + { scalar :: ScalarType + , shape :: MemberShape + , array :: [Word32] + } + deriving (Eq, Ord, Show) + +{- | Classify a reflected struct member (a 'TypeDescription') from its numeric +traits and type flags. +-} +classifyType :: TypeDescription -> Maybe NumericType +classifyType + TypeDescription.TypeDescription + { TypeDescription.type_flags = flags + , TypeDescription.traits = mtraits + } = do + Traits.Numeric + { Traits.scalar = Traits.Scalar{Traits.width = width, Traits.signed = signed} + , Traits.vector = Traits.Vector{Traits.component_count = vecN} + , Traits.matrix = Traits.Matrix{Traits.column_count = cols, Traits.row_count = rows} + } <- + numericOf mtraits + let + shape + | cols > 0 = ShMatrix (fromIntegral cols) (fromIntegral rows) + | vecN > 1 = ShVector (fromIntegral vecN) + | otherwise = ShScalar + wide = width >= 64 + baseScalar + | has TypeFlags.TYPE_FLAG_FLOAT = Just $ if wide then STDouble else STFloat + | has TypeFlags.TYPE_FLAG_INT = Just $ case (signed, wide) of + (True, False) -> STInt + (False, False) -> STUInt + (True, True) -> STInt64 + (False, True) -> STUInt64 + | has TypeFlags.TYPE_FLAG_BOOL = Just STBool + | otherwise = Nothing + scalar <- baseScalar + pure + NumericType + { scalar + , shape + , array = maybe [] dimsOf (arrayOf mtraits) + } + where + has bit = (flags .&. bit) /= TypeFlags.TypeFlagBits 0 + + numericOf t = do + TypeDescription.Traits{TypeDescription.numeric = n} <- t + Just n + + arrayOf t = do + TypeDescription.Traits{TypeDescription.array = a} <- t + Just a + +{- | True when this type is a buffer device address: a @buffer_reference@ \/ +@PhysicalStorageBuffer@ pointer (the @REF@ type flag). Such a member is stored as +an 8-byte address, not its pointee inline. +-} +isBdaPointer :: TypeDescription -> Bool +isBdaPointer td = (td.type_flags .&. TypeFlags.TYPE_FLAG_REF) /= TypeFlags.TypeFlagBits 0 + +{- | The array dimensions of a member (outermost first); @[]@ for a non-array, +@[0]@ for a runtime (unsized) array. +-} +arrayDims :: TypeDescription -> [Word32] +arrayDims td = maybe [] dimsOf (fmap (.array) td.traits) + +dimsOf :: Traits.Array -> [Word32] +dimsOf a + | a.dims_count == 0 = [] + | otherwise = VS.toList a.dims + +{- | A pluggable mapping from a classified member to the Haskell type used for +the generated record field. The returned type must have a +'Graphics.Gl.Block.Block' instance. Returning 'Nothing' rejects the member +(the block record is then not generated). +-} +type TypeMap = NumericType -> Maybe Type + +{- | Assemble a 'TypeMap' from a vector and a matrix spelling β€” the shared core +of 'geomancyTypeMap' / 'linearTypeMap'. Scalars always map to base types (via +'scalarLeaf'); only the vector/matrix cases differ between libraries. + +This maps an /element/ type only: array dimensions are handled one layer up (in +"Vulkan.Utils.SpirV.Block", which wraps the result in 'Vulkan.Utils.SpirV.Array.Array'), +so a member that still carries array dims here is rejected. +-} +mkTypeMap + :: (ScalarType -> Int -> Maybe Type) + -- ^ vector: component scalar and count (2..4) + -> (ScalarType -> Int -> Int -> Maybe Type) + -- ^ matrix: component scalar, columns, rows + -> TypeMap +mkTypeMap vector matrix NumericType{scalar, shape, array} + | not (null array) = Nothing + | otherwise = case shape of + ShScalar -> scalarLeaf scalar + ShVector n -> vector scalar n + ShMatrix c r -> matrix scalar c r + +{- | The Haskell type for a base scalar component, as a global @''@ quote: 'base' +is always in scope, so a field of this type needs no import at the splice site. +'STAddress' has no scalar spelling β€” a pointer member is mapped to +'Vulkan.Utils.SpirV.DeviceAddress.DeviceAddress' before it reaches a 'TypeMap'. +-} +scalarLeaf :: ScalarType -> Maybe Type +scalarLeaf = \case + STFloat -> Just (ConT ''Float) + STDouble -> Just (ConT ''Double) + STInt -> Just (ConT ''Int32) + STUInt -> Just (ConT ''Word32) + STInt64 -> Just (ConT ''Int64) + STUInt64 -> Just (ConT ''Word64) + STBool -> Just (ConT ''Bool) + STAddress -> Nothing + +{- | A type referenced by /raw qualified name/ (@Module.Type@), resolved at the +splice site. This is how a default 'TypeMap' names a vector library's types +without this package depending on it: the splice site supplies the import. +-} +qualType :: String -> String -> Type +qualType modName typeName = ConT (mkName (modName <> "." <> typeName)) + +{- | The default mapping, onto [geomancy](https://hackage.haskell.org/package/geomancy)'s +vector/matrix types (which carry native std140/std430 'Block' instances). The +names resolve against geomancy's base module, so the splice site needs only a +single @import Geomancy qualified@. +-} +geomancyTypeMap :: TypeMap +geomancyTypeMap = mkTypeMap vector matrix + where + -- geomancy spells the scalar into the type name: Vec3 / IVec3 / UVec3. + vector STFloat n = geomancy <$> sized "Vec" n + vector STInt n = geomancy <$> sized "IVec" n + vector STUInt n = geomancy <$> sized "UVec" n + vector _ _ = Nothing + matrix STFloat 4 4 = Just (geomancy "Mat4") + matrix _ _ _ = Nothing + geomancy = qualType "Geomancy" + +{- | A worked /example/ of mapping a vector library whose types are /parametric/: +[linear](https://hackage.haskell.org/package/linear)'s @V2@ \/ @V3@ \/ @V4@ \/ +@M44@ take the component scalar as a type argument, so the map applies it +(@V3 Float@, @M44 Float@) instead of spelling it into the name as 'geomancyTypeMap' +does. Names resolve against linear's base module (a single @import Linear qualified@). + +Not usable for record generation yet: neither linear nor gl-block ships a +'Graphics.Gl.Block.Block' instance for @V3 Float@ etc., so a generated record +could not derive its 'Foreign.Storable.Storable'. It stands as the template for +the parametric case until linear gains those instances, at which point it becomes +a real alternative default. +-} +linearTypeMap :: TypeMap +linearTypeMap = mkTypeMap vector matrix + where + -- linear's vectors are parametric (V3 a): apply the component scalar. + vector s n + | s `elem` [STFloat, STInt, STUInt] = AppT . linear <$> sized "V" n <*> scalarLeaf s + | otherwise = Nothing + matrix STFloat 4 4 = AppT (linear "M44") <$> scalarLeaf STFloat + matrix _ _ _ = Nothing + linear = qualType "Linear" + +-- | A library type whose name carries its component count, e.g. @Vec3@ \/ @V4@. +sized :: String -> Int -> Maybe String +sized prefix n + | n >= 2 && n <= 4 = Just (prefix <> show n) + | otherwise = Nothing diff --git a/utils-spirv/src/Vulkan/Utils/SpirV/VertexInput.hs b/utils-spirv/src/Vulkan/Utils/SpirV/VertexInput.hs new file mode 100644 index 000000000..305e01e8b --- /dev/null +++ b/utils-spirv/src/Vulkan/Utils/SpirV/VertexInput.hs @@ -0,0 +1,91 @@ +{-| Build Vulkan vertex-input descriptions from a reflected vertex shader's input +variables. Built-in inputs (e.g. @gl_VertexIndex@) are skipped; the remaining +inputs are packed tightly into a single binding (binding 0), ordered by +@location@, with per-attribute formats taken directly from reflection (SPIR-V +@Format@ shares Vulkan's numeric values). +-} +module Vulkan.Utils.SpirV.VertexInput + ( vertexInputState + , vertexInputAttributes + , vertexInputBinding + ) where + +import Data.List (sortOn) +import Data.Vector qualified as V +import Data.Word (Word32) +import Vulkan.Core10 qualified as Vk +import Vulkan.Zero (zero) + +import Data.SpirV.Enum (BuiltIn (..)) +import Data.SpirV.Reflect.Enums.Format qualified as R +import Data.SpirV.Reflect.InterfaceVariable qualified as InterfaceVariable +import Data.SpirV.Reflect.Module (Module) +import Data.SpirV.Reflect.Module qualified +import Data.SpirV.Reflect.Traits qualified as Traits + +{- | The vertex-input state reflected from a vertex module: the single packed +binding plus its attributes ('vertexInputBinding' + 'vertexInputAttributes'). A +module with no vertex inputs β€” e.g. one pulling geometry from an SSBO via +@gl_VertexIndex@ β€” yields 'zero' (no bindings, no attributes). +-} +vertexInputState :: Module -> Vk.PipelineVertexInputStateCreateInfo '[] +vertexInputState m = + case vertexInputAttributes m of + [] -> zero + attrs -> + zero + { Vk.vertexBindingDescriptions = V.fromList [vertexInputBinding m] + , Vk.vertexAttributeDescriptions = V.fromList attrs + } + +-- | One attribute per non-built-in input variable, tightly packed into binding 0. +vertexInputAttributes :: Module -> [Vk.VertexInputAttributeDescription] +vertexInputAttributes m = go 0 (inputs m) + where + go _ [] = [] + go off ((loc, fmt, sz) : rest) = + zero + { Vk.location = loc + , Vk.binding = 0 + , Vk.format = fmt + , Vk.offset = off + } + : go (off + sz) rest + +{- | The single binding (binding 0, per-vertex) covering all inputs, with stride +equal to their packed size. +-} +vertexInputBinding :: Module -> Vk.VertexInputBindingDescription +vertexInputBinding m = + zero + { Vk.binding = 0 + , Vk.stride = sum [sz | (_, _, sz) <- inputs m] + , Vk.inputRate = Vk.VERTEX_INPUT_RATE_VERTEX + } + +-- | @(location, format, byte size)@ for each non-built-in input, ordered by location. +inputs :: Module -> [(Word32, Vk.Format, Word32)] +inputs m = + sortOn + (\(loc, _, _) -> loc) + -- a non-built-in reads as Nothing (ffi) or the @BuiltIn (-1)@ sentinel (yaml) + [ (v.location, ivFormat v, ivSize v) + | v <- V.toList m.input_variables + , v.built_in `elem` [Nothing, Just (BuiltIn (-1))] + ] + +-- Vulkan-side field extractions. + +ivFormat :: InterfaceVariable.InterfaceVariable -> Vk.Format +ivFormat InterfaceVariable.InterfaceVariable{InterfaceVariable.format = R.Format n} = + Vk.Format (fromIntegral n) + +ivSize :: InterfaceVariable.InterfaceVariable -> Word32 +ivSize InterfaceVariable.InterfaceVariable{InterfaceVariable.numeric = num} = + components * (width `div` 8) + where + Traits.Numeric + { Traits.scalar = Traits.Scalar{Traits.width = width} + , Traits.vector = Traits.Vector{Traits.component_count = vecN} + } = num + components = max 1 vecN diff --git a/utils-spirv/test/Fixtures.hs b/utils-spirv/test/Fixtures.hs new file mode 100644 index 000000000..5b82ece02 --- /dev/null +++ b/utils-spirv/test/Fixtures.hs @@ -0,0 +1,428 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} + +{-| The test fixture shaders, compiled to SPIR-V at build time by the +vulkan-utils GLSL quasiquoters. + +The reflection splices in "Spec" and "LayoutSpec" consume these bytes; the +Template Haskell stage restriction is why they live in their own module. +-} +module Fixtures + ( juliaComp + , pushComp + , ssboStructComp + , nestedComp + , arrayFieldComp + , array2dComp + , bdaComp + , wideComp + , specComp + , meshVert + , meshFrag + , triVert + ) where + +import Data.ByteString (ByteString) +import Vulkan.Utils.ShaderQQ.GLSL.Glslang (comp, compileShaderQ, frag, glsl, vert) + +{- | A Julia-set compute shader whose @Params@ UBO (set 0, binding 0, std140) +becomes the generated record, next to an @OutputBuffer@ runtime-array SSBO +(binding 1, not generated). Fields are ordered by non-increasing alignment +(vec2\/uvec2 = 8, float\/uint = 4). +-} +juliaComp :: ByteString +juliaComp = + [comp| + #version 450 + + layout(local_size_x = 16, local_size_y = 16) in; + + layout(set = 0, binding = 0, std140) uniform Params { + vec2 center; // align 8 @0 + uvec2 resolution; // align 8 @8 + float escapeRadius; // align 4 @16 + uint maxIterations; // align 4 @20 + } params; + + layout(set = 0, binding = 1, std430) buffer OutputBuffer { + vec4 pixels[]; + }; + + void main() { + uvec2 gid = gl_GlobalInvocationID.xy; + if (gid.x >= params.resolution.x || gid.y >= params.resolution.y) { + return; + } + vec2 z = (vec2(gid) / vec2(params.resolution) * 2.0 - 1.0) * params.escapeRadius; + uint i = 0u; + for (; i < params.maxIterations; ++i) { + z = vec2(z.x * z.x - z.y * z.y, 2.0 * z.x * z.y) + params.center; + if (dot(z, z) > params.escapeRadius * params.escapeRadius) { + break; + } + } + pixels[gid.y * params.resolution.x + gid.x] = + vec4(vec3(float(i) / float(params.maxIterations)), 1.0); + } + |] + +{- | Push-constant reflection: the @Push@ block becomes a Haskell record with a +gl-block std430 Storable, and @pushConstantRanges@ derives the +VkPushConstantRange. Fields are ordered by non-increasing alignment (mat4 = +16, vec2 = 8, float\/int = 4) to satisfy the gl-block layout guardrail. +-} +pushComp :: ByteString +pushComp = + [comp| + #version 450 + + layout(local_size_x = 64) in; + + layout(push_constant, std430) uniform Push { + mat4 transform; + vec2 offset; + float scale; + int count; + } push; + + layout(set = 0, binding = 0, std430) buffer Output { + vec4 data[]; + }; + + void main() { + uint i = gl_GlobalInvocationID.x; + if (i >= uint(push.count)) { + return; + } + data[i] = push.transform * vec4(push.offset * push.scale, 0.0, 1.0); + } + |] + +{- | SSBO arrays of structs: the @Particle@ element type is generated as a +std430 record even though the wrapping @Particles@ block is a runtime array +(not itself representable as a flat record). Fields are ordered by +non-increasing alignment (vec3 = 16, vec2 = 8, float\/uint = 4). +-} +ssboStructComp :: ByteString +ssboStructComp = + [comp| + #version 450 + + layout(local_size_x = 64) in; + + struct Particle { + vec3 position; // align 16 @0 + vec2 velocity; // align 8 @16 + float mass; // align 4 @24 + uint flags; // align 4 @28 + }; + + layout(set = 0, binding = 0, std430) buffer Particles { + Particle items[]; + }; + + void main() { + uint i = gl_GlobalInvocationID.x; + items[i].position += vec3(items[i].velocity, 0.0) * items[i].mass; + } + |] + +{- | Nested structs as fields, plus cross-layout sharing. The @Material@ struct +is all-vec4 (every member 16-byte aligned), so std140 and std430 lay it out +identically: it is used both as a field of the std140 @Scene@ UBO and as the +element of the std430 @Mats@ SSBO, and a single generated record is shared +("promoted") across both. +-} +nestedComp :: ByteString +nestedComp = + [comp| + #version 450 + + layout(local_size_x = 1) in; + + struct Material { + vec4 albedo; + vec4 emission; + }; + + layout(set = 0, binding = 0, std140) uniform Scene { + Material sun; // nested struct field @0 (size 32) + vec4 tint; // @32 + } scene; + + layout(set = 0, binding = 1, std430) buffer Mats { + Material mats[]; + }; + + layout(set = 0, binding = 2, std430) writeonly buffer O { + vec4 o[]; + }; + + void main() { + o[0] = scene.sun.albedo + scene.sun.emission + scene.tint + mats[0].emission; + } + |] + +{- | Fixed-size array fields, mapped to @Array n a@. The same fields appear in a +std140 UBO and a std430 SSBO to show the stride difference: std140 rounds +every element up to 16 bytes, std430 packs tightly. +-} +arrayFieldComp :: ByteString +arrayFieldComp = + [comp| + #version 450 + + layout(local_size_x = 1) in; + + layout(set = 0, binding = 0, std140) uniform Kernel140 { + vec4 taps[4]; // stride 16 in both + float weights[4]; // stride 16 in std140 + } k140; + + layout(set = 0, binding = 1, std430) buffer Kernel430 { + vec4 taps[4]; // stride 16 + float weights[4]; // stride 4 in std430 + } k430; + + layout(set = 0, binding = 2, std430) writeonly buffer O { + vec4 o[]; + }; + + void main() { + o[0] = k140.taps[0] * k140.weights[0] + k430.taps[0] * k430.weights[0]; + } + |] + +{- | A multi-dimensional array field: @float grid[3][4]@ maps to +@Array 3 (Array 4 Float)@. In std430 the inner stride is 4 (outer 16); in +std140 the inner stride is 16 (outer 64). +-} +array2dComp :: ByteString +array2dComp = + [comp| + #version 450 + + layout(local_size_x = 1) in; + + layout(set = 0, binding = 0, std430) buffer Grid430 { + vec4 head; // @0 + float grid[3][4]; // @16, inner stride 4, outer stride 16 + } g430; + + layout(set = 0, binding = 1, std140) uniform Grid140 { + vec4 head; // @0 + float grid[3][4]; // @16, inner stride 16, outer stride 64 + } g140; + + layout(set = 0, binding = 2, std430) writeonly buffer O { + vec4 o[]; + }; + + void main() { + o[0] = g430.head + g140.head + vec4(g430.grid[0][0] + g140.grid[0][0]); + } + |] + +{- | A self-referential buffer_reference (BDA) type: a BVH-ish node whose +children are 64-bit device addresses back to @Node@. Reflection-driven codegen +maps the pointer members to @DeviceAddress Node@ (8-byte address), not an +inlined struct, and generates @Node@ once despite the cycle. + +buffer_reference needs SPIR-V 1.3+, hence the vulkan1.2 target. +-} +bdaComp :: ByteString +bdaComp = + $( compileShaderQ + (Just "vulkan1.2") + "comp" + Nothing + [glsl| + #version 460 + #extension GL_EXT_buffer_reference : require + + layout(local_size_x = 64) in; + + layout(buffer_reference) buffer Node; // fwd decl enables self-reference + layout(buffer_reference, std430) buffer Node { + vec4 boundsMin; + vec4 boundsMax; + Node left; // BDA pointer -> cycle + Node right; // BDA pointer -> cycle + uint primCount; + }; + + layout(push_constant, std430) uniform Bvh { + Node root; // entry address into the graph + } bvh; + + layout(set = 0, binding = 0, std430) writeonly buffer Out { + uint hits[]; + }; + + void main() { + Node n = bvh.root; + uint count = 0u; + for (int i = 0; i < 8; ++i) { + count += n.primCount; + n = n.left; + } + hits[gl_GlobalInvocationID.x] = count; + } + |] + ) + +{- | 64-bit integer block members. A uint64_t\/int64_t occupies an 8-byte std430 +slot (alignment 8), exactly like a double β€” the regression fixture for +scalar-width-faithful classification, so a 64-bit int is never laid out as a +4-byte int. Fields are ordered by non-increasing alignment (8, 8, 4) to keep +gl-block's Generic layout valid. + +int64 needs the Int64 capability, hence the vulkan1.1 target. +-} +wideComp :: ByteString +wideComp = + $( compileShaderQ + (Just "vulkan1.1") + "comp" + Nothing + [glsl| + #version 460 + #extension GL_EXT_shader_explicit_arithmetic_types_int64 : require + + layout(local_size_x = 1) in; + + layout(push_constant, std430) uniform Wide { + uint64_t hi; // align 8 @0, size 8 + int64_t lo; // align 8 @8, size 8 + uint tag; // align 4 @16, size 4 + } wide; + + layout(set = 0, binding = 0, std430) writeonly buffer Out { + uint sink[]; + }; + + void main() { + sink[0] = uint(wide.hi) + uint(wide.lo) + wide.tag; + } + |] + ) + +{- | Specialization-constant reflection. The ids are deliberately non-contiguous +(0 and 3) to show that map entries follow the shader's actual constant_ids +while values pack tightly (offsets 0, 4). +-} +specComp :: ByteString +specComp = + [comp| + #version 450 + + layout(local_size_x = 64) in; + + layout(constant_id = 0) const uint count = 1u; + layout(constant_id = 3) const float scale = 1.0; + + layout(set = 0, binding = 0, std430) buffer Output { + float xs[]; + }; + + void main() { + uint i = gl_GlobalInvocationID.x; + if (i < count) { + xs[i] = scale; + } + } + |] + +{- | Vertex stage for the type-verified pipeline-assembly tests. Shares the +@Scene@ UBO (set 0, binding 0) with 'meshFrag' (vertex uses viewProj; fragment +uses the light fields), carries a vertex-only @Model@ push constant, and feeds +the fragment stage @outNormal@ (loc 0) + @outUV@ (loc 1). +-} +meshVert :: ByteString +meshVert = + [vert| + #version 450 + + layout(location = 0) in vec3 inPosition; + layout(location = 1) in vec3 inNormal; + layout(location = 2) in vec2 inUV; + + layout(set = 0, binding = 0, std140) uniform Scene { + mat4 viewProj; + vec4 lightDir; + vec4 lightColor; + } scene; + + layout(push_constant, std430) uniform Model { + mat4 model; + } model; + + layout(location = 0) out vec3 outNormal; + layout(location = 1) out vec2 outUV; + + void main() { + gl_Position = scene.viewProj * model.model * vec4(inPosition, 1.0); + outNormal = mat3(model.model) * inNormal; + outUV = inUV; + } + |] + +{- | Fragment stage paired with 'meshVert'. Consumes the vertex outputs +(inNormal loc 0, inUV loc 1), shares the @Scene@ UBO (set 0, binding 0 β€” using +the light fields the vertex stage ignores), and reads a fragment-only +@Materials@ SSBO (set 0, binding 1). +-} +meshFrag :: ByteString +meshFrag = + [frag| + #version 450 + + layout(location = 0) in vec3 inNormal; + layout(location = 1) in vec2 inUV; + + layout(set = 0, binding = 0, std140) uniform Scene { + mat4 viewProj; + vec4 lightDir; + vec4 lightColor; + } scene; + + struct Material { + vec4 albedo; + vec4 params; + }; + + layout(set = 0, binding = 1, std430) buffer Materials { + Material materials[]; + }; + + layout(location = 0) out vec4 outColor; + + void main() { + float ndl = max(dot(normalize(inNormal), normalize(scene.lightDir.xyz)), 0.0); + vec4 albedo = materials[0].albedo * vec4(inUV, 1.0, 1.0); + outColor = albedo * scene.lightColor * ndl; + } + |] + +{- | Vertex-input reflection: three attributes (vec3 \/ vec2 \/ vec4 at +locations 0\/1\/2) that pack tightly to offsets 0\/12\/20 and a 36-byte binding +stride. +-} +triVert :: ByteString +triVert = + [vert| + #version 450 + + layout(location = 0) in vec3 inPosition; + layout(location = 1) in vec2 inUV; + layout(location = 2) in vec4 inColor; + + layout(location = 0) out vec2 outUV; + layout(location = 1) out vec4 outColor; + + void main() { + gl_Position = vec4(inPosition, 1.0); + outUV = inUV; + outColor = inColor; + } + |] diff --git a/utils-spirv/test/LayoutSpec.hs b/utils-spirv/test/LayoutSpec.hs new file mode 100644 index 000000000..7560eed3a --- /dev/null +++ b/utils-spirv/test/LayoutSpec.hs @@ -0,0 +1,231 @@ +{-# LANGUAGE OverloadedStrings #-} + +{-| Tests for the structured 'Layout' IR, its normalization to a scalar 'OffsetMap', +and the value-level unifier. +-} +module LayoutSpec (tests) where + +import Data.Either (isLeft) +import Data.List (isInfixOf) +import Data.Map.Strict qualified as Map +import Data.Text (unpack) +import Data.Vector qualified as V +import Test.Tasty +import Test.Tasty.HUnit + +import Data.SpirV.Reflect.BlockVariable qualified +import Data.SpirV.Reflect.DescriptorBinding qualified +import Data.SpirV.Reflect.FFI (loadBytes) +import Data.SpirV.Reflect.Module (Module) +import Data.SpirV.Reflect.Module qualified +import Data.SpirV.Reflect.TypeDescription (TypeDescription) + +import Vulkan.Utils.SpirV.Layout +import Vulkan.Utils.SpirV.Layout qualified as OffsetMap (OffsetMap (..)) +import Vulkan.Utils.SpirV.Types (LayoutMode (..), ScalarType (..)) + +import Fixtures qualified + +tests :: TestTree +tests = + testGroup + "layout IR + unification" + [ structuredTests + , normalizeTests + , unifyTests + , runtimeTests + , mergeTests + , reflectionTests + ] + +-- Convenience constructors. ----------------------------------------------------- + +-- | A single-member std430 layout. +field430 :: FieldType -> Layout +field430 ft = fromFields Std430Layout Nothing [("x", ft)] + +-- | A single-member std140 layout. +field140 :: FieldType -> Layout +field140 ft = fromFields Std140Layout Nothing [("x", ft)] + +structuredTests :: TestTree +structuredTests = + testGroup + "structured layout (fromFields)" + [ testCase "std430 packs by member alignment" $ do + -- mat4 (align 16) @0 size 64, vec2 (align 8) @64, float @72, int @76 + let l = + fromFields + Std430Layout + (Just "Push") + [ ("transform", Matrix STFloat 4 4) + , ("offset", Vector STFloat 2) + , ("scale", Scalar STFloat) + , ("count", Scalar STInt) + ] + offsets l @?= [("transform", 0), ("offset", 64), ("scale", 72), ("count", 76)] + l.size @?= Just 80 + l.align @?= 16 + , testCase "std140 rounds a scalar array's stride and the struct align to 16" $ do + let l = field140 (ArrayOf (Sized 4) (Scalar STFloat)) + l.align @?= 16 + l.size @?= Just 64 -- stride 16 * 4 + , testCase "std430 packs a scalar array tightly" $ do + let l = field430 (ArrayOf (Sized 4) (Scalar STFloat)) + l.align @?= 4 + l.size @?= Just 16 + , testCase "vec3 occupies 12 bytes but aligns to 16" $ do + let l = fromFields Std430Layout Nothing [("a", Vector STFloat 3), ("b", Scalar STFloat)] + offsets l @?= [("a", 0), ("b", 12)] + ] + +normalizeTests :: TestTree +normalizeTests = + testGroup + "normalize to scalar offset map" + [ testCase "vec4 flattens to four floats" $ + (normalize (field430 (Vector STFloat 4))).slots + @?= [Slot 0 STFloat, Slot 4 STFloat, Slot 8 STFloat, Slot 12 STFloat] + , testCase "mat4 flattens column-major to a 16-float offset map" $ + map (.offset) (normalize (field430 (Matrix STFloat 4 4))).slots + @?= [0, 4, 8, 12, 16, 20, 24, 28, 32, 36, 40, 44, 48, 52, 56, 60] + , testCase "std140 float[4] strides by 16" $ + map (.offset) (normalize (field140 (ArrayOf (Sized 4) (Scalar STFloat)))).slots + @?= [0, 16, 32, 48] + ] + +unifyTests :: TestTree +unifyTests = + testGroup + "unify (layout equivalence)" + [ testCase "mat4 == vec4[4] == float[16] under std430" $ do + let + m = normalize (field430 (Matrix STFloat 4 4)) + v = normalize (field430 (ArrayOf (Sized 4) (Vector STFloat 4))) + f = normalize (field430 (ArrayOf (Sized 16) (Scalar STFloat))) + foldUnify m [v, f] @?= Right m + , testCase "float[16] under std140 is NOT layout-equivalent to mat4" $ do + let + m = normalize (field430 (Matrix STFloat 4 4)) + f = normalize (field140 (ArrayOf (Sized 16) (Scalar STFloat))) + case unify m f of + Left (SlotMismatch off _ _) -> off @?= 4 -- first divergence: mat4 has a float here + other -> assertFailure ("expected a SlotMismatch at 4, got " <> show other) + , testCase "a scalar-kind mismatch is reported with its offset" $ do + let + a = normalize (field430 (Vector STFloat 2)) + b = normalize (field430 (Vector STInt 2)) + unify a b @?= Left (SlotMismatch 0 STFloat STInt) + , testCase "differing total size fails even when slots agree" $ do + -- Same scalar slots, different declared size (e.g. extra trailing padding). + let + a = normalize (field430 (Vector STFloat 4)) + big = a{OffsetMap.size = Just 32} + unify a big @?= Left (SizeMismatch 16 32) + , testCase "renderMismatch is legible" $ + assertBool "mentions offset and types" $ + "offset 4" `isInfixOf` renderMismatch (SlotMismatch 4 STFloat STInt) + && "float" `isInfixOf` renderMismatch (SlotMismatch 4 STFloat STInt) + ] + +runtimeTests :: TestTree +runtimeTests = + testGroup + "runtime arrays (unification with a hole)" + [ testCase "an open vec4[] offset map is open (no size, has a tail)" $ do + let g = normalize (field430 (ArrayOf Runtime (Vector STFloat 4))) + g.size @?= Nothing + fmap (.stride) g.tail @?= Just 16 + , testCase "a runtime vec4[] unifies with a concrete vec4[3], pinning the length" $ do + let + open = normalize (field430 (ArrayOf Runtime (Vector STFloat 4))) + closed = normalize (field430 (ArrayOf (Sized 3) (Vector STFloat 4))) + unify open closed @?= Right closed + unify closed open @?= Right closed -- symmetric + , testCase "a runtime vec4[] rejects an offset map that is not whole elements" $ do + let + open = normalize (field430 (ArrayOf Runtime (Vector STFloat 4))) + ragged = normalize (field430 (ArrayOf (Sized 5) (Scalar STFloat))) + assertBool "should not unify" (isLeft (unify open ragged)) + ] + +mergeTests :: TestTree +mergeTests = + testGroup + "mergeKeyed (row unification across pipelines)" + [ testCase "disjoint keys union; shared keys must agree" $ do + let + camera = normalize (field140 (Vector STFloat 4)) + lights = normalize (field430 (ArrayOf (Sized 2) (Vector STFloat 4))) + merged = + mergeKeyed + [ ((0, 0) :: (Int, Int), camera) -- vertex stage: set 0 binding 0 + , ((0, 1), lights) -- vertex stage: set 0 binding 1 + , ((0, 0), camera) -- fragment stage: same UBO, must agree + ] + fmap Map.keys merged @?= Right [(0, 0), (0, 1)] + , testCase "a conflicting shared key reports the key and the mismatch" $ do + let + a = normalize (field430 (Vector STFloat 4)) + b = normalize (field430 (Vector STInt 4)) + case mergeKeyed [((0, 0) :: (Int, Int), a), ((0, 0), b)] of + Left (k, SlotMismatch{}) -> k @?= (0, 0) + other -> assertFailure ("expected a keyed SlotMismatch, got " <> show other) + ] + +reflectionTests :: TestTree +reflectionTests = + testGroup + "built from reflected SPIR-V" + [ testCase "push.comp Push has std430 offsets 0/64/72/76, size 80" $ do + m <- loadBytes Fixtures.pushComp + td <- maybe (assertFailure "no push constant block") pure (pushBlock m) + l <- either (assertFailure . ("layoutOf: " <>)) pure (layoutOf Std430Layout td) + map snd (offsets l) @?= [0, 64, 72, 76] + l.size @?= Just 80 + , testCase "push.comp Output (vec4 data[]) is an open offset map with stride 16" $ do + m <- loadBytes Fixtures.pushComp + td <- maybe (assertFailure "no SSBO binding") pure (firstBinding m) + g <- either (assertFailure . ("offsetMapOf: " <>)) pure (offsetMapOf Std430Layout td) + g.size @?= Nothing + fmap (.stride) g.tail @?= Just 16 + , testCase "ssbo-struct Particle[] tail unifies with a concrete Particle[2]" $ do + m <- loadBytes Fixtures.ssboStructComp + td <- maybe (assertFailure "no SSBO binding") pure (firstBinding m) + open <- either (assertFailure . ("offsetMapOf: " <>)) pure (offsetMapOf Std430Layout td) + -- Particle = vec3 @0, vec2 @16, float @24, uint @28 (stride 32). + let + particle = + Struct + ( fromFields + Std430Layout + (Just "Particle") + [ ("position", Vector STFloat 3) + , ("velocity", Vector STFloat 2) + , ("mass", Scalar STFloat) + , ("flags", Scalar STUInt) + ] + ) + closed = normalize (fromFields Std430Layout Nothing [("items", ArrayOf (Sized 2) particle)]) + open `unifies` closed + ] + +-- Helpers. ---------------------------------------------------------------------- + +offsets :: Layout -> [(String, Int)] +offsets l = [(unpack m.name, m.offset) | m <- l.members] + +unifies :: OffsetMap -> OffsetMap -> Assertion +unifies a b = case unify a b of + Right _ -> pure () + Left e -> assertFailure (renderMismatch e) + +pushBlock :: Module -> Maybe TypeDescription +pushBlock m = case V.toList m.push_constants of + (pc : _) -> pc.type_description + [] -> Nothing + +firstBinding :: Module -> Maybe TypeDescription +firstBinding m = case V.toList m.descriptor_bindings of + (b : _) -> b.type_description + [] -> Nothing diff --git a/utils-spirv/test/Spec.hs b/utils-spirv/test/Spec.hs new file mode 100644 index 000000000..709208619 --- /dev/null +++ b/utils-spirv/test/Spec.hs @@ -0,0 +1,697 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module Main (main) where + +import Data.Bits ((.|.)) +import Data.Either (isLeft) +import Data.Int (Int32, Int64) +import Data.List (sortOn) +import Data.Maybe (isJust) +import Data.Proxy (Proxy (..)) +import Data.Vector qualified as V +import Data.Vector.Storable qualified as VS +import Data.Word (Word32, Word64) +import Foreign.Marshal.Alloc (allocaBytes) +import Foreign.Marshal.Utils (fillBytes) +import Foreign.Ptr (castPtr) +import Foreign.Storable (Storable (..)) +import GHC.Generics (Generic) +import Geomancy qualified +import Geomancy.Mat4 (identity) +import Geomancy.UVec2 (uvec2) +import Geomancy.Vec2 (Vec2, vec2) +import Geomancy.Vec3 (vec3) +import Geomancy.Vec4 (Vec4, vec4) +import Graphics.Gl.Block (Block, Std140 (..), Std430 (..)) +import Language.Haskell.TH (Type (AppT, ConT), mkName) +import Test.Tasty +import Test.Tasty.HUnit + +import Vulkan.Core10 qualified as Vk + +import Data.SpirV.Reflect.FFI (loadBytes) +import Vulkan.Utils.SpirV.Array qualified as Array +import Vulkan.Utils.SpirV.Buffer (allocArrayBuffer, newBuffer, readBuffer, readBufferElem, writeBufferElem) +import Vulkan.Utils.SpirV.Descriptors (descriptorSetLayoutInfos, mergedDescriptorSetLayoutInfos, mergedPushConstantRanges, pushConstantRanges) +import Vulkan.Utils.SpirV.DeviceAddress (DeviceAddress (..)) +import Vulkan.Utils.SpirV.Layout (ArraySize (..), FieldType (..), fromFields, normalize) +import Vulkan.Utils.SpirV.Layout qualified +import Vulkan.Utils.SpirV.Signature (ArrayOf, Fits, Sig, knownLayoutInstance, layoutSig) +import Vulkan.Utils.SpirV.Specialization (specializationConstants, specializationMapEntries) +import Vulkan.Utils.SpirV.Stage (CompatibleResources, KnownLayoutSig (..), MatchInterface, linkStages, matchInterface, mergeLayout, reflectPipelineLayoutSigBytes, reflectStageSigBytes, stageInfoOf) +import Vulkan.Utils.SpirV.Stage qualified +import Vulkan.Utils.SpirV.Stage qualified as StageInfo (StageInfo (..)) +import Vulkan.Utils.SpirV.TH (reflectShaderTypesBytes) +import Vulkan.Utils.SpirV.Types (LayoutMode (..), MemberShape (..), NumericType (..), ScalarType (..), geomancyTypeMap, linearTypeMap) +import Vulkan.Utils.SpirV.VertexInput (vertexInputAttributes, vertexInputBinding, vertexInputState) + +import Fixtures qualified +import LayoutSpec qualified + +-- Generate the @Params@ record from the quasiquoted compute fixture. +reflectShaderTypesBytes Fixtures.juliaComp + +-- Generate the @Push@ push-constant record (std430) from its fixture. +reflectShaderTypesBytes Fixtures.pushComp + +-- Generate the @Particle@ element record of an SSBO array of structs. The +-- wrapping @Particles@ runtime-array block is (correctly) not generated. +reflectShaderTypesBytes Fixtures.ssboStructComp + +-- Generate @Material@ (shared across a std140 UBO field and a std430 SSBO array, +-- safe because all members are 16-byte aligned) and @Scene@, which has the +-- nested @Material@ as a field. +reflectShaderTypesBytes Fixtures.nestedComp + +-- Generate @Kernel140@ / @Kernel430@: records with fixed-size @Array n a@ fields +-- under std140 (element stride 16) and std430 (tight) layouts. +reflectShaderTypesBytes Fixtures.arrayFieldComp + +-- Generate @Grid430@ / @Grid140@: a 2D array field @float grid[3][4]@ maps to +-- @Array 3 (Array 4 Float)@. +reflectShaderTypesBytes Fixtures.array2dComp + +-- Generate @Node@ (a self-referential @buffer_reference@ struct) and @Bvh@ (a +-- push-constant block holding a @Node@ device address). The pointer members map +-- to @DeviceAddress Node@; @Node@ is generated once despite the cycle. +reflectShaderTypesBytes Fixtures.bdaComp + +-- Generate @Wide@: a std430 push-constant block with 64-bit integer members +-- (@uint64_t hi@ / @int64_t lo@), which must occupy 8-byte slots like a double. +reflectShaderTypesBytes Fixtures.wideComp + +-- A std430 element whose array stride (32) exceeds its packed size (20): vec4 @0 +-- + float @16 -> size 20, rounded up to its 16-byte alignment for the stride. +data Pad = Pad Vec4 Float + deriving stock (Generic, Eq, Show) + deriving anyclass (Block) + deriving (Storable) via (Std430 Pad) + +-- Three types that are layout-equivalent under std430 (same scalar offset map): mat4, vec4[4] and +-- float[16]. Their layout signatures are produced from the value-level normal +-- form (the oracle), so they promote to the SAME 'Sig' and 'Fits' accepts them. +data EquivMat4 +data EquivVec4x4 +data EquivFloat16 + +pure + ( knownLayoutInstance + ''EquivMat4 + (normalize (fromFields Std430Layout Nothing [("m", Matrix STFloat 4 4)])) + ) +pure + ( knownLayoutInstance + ''EquivVec4x4 + (normalize (fromFields Std430Layout Nothing [("a", ArrayOf (Sized 4) (Vector STFloat 4))])) + ) +pure + ( knownLayoutInstance + ''EquivFloat16 + (normalize (fromFields Std430Layout Nothing [("a", ArrayOf (Sized 16) (Scalar STFloat))])) + ) + +-- Compile-time witnesses: each body only type-checks if the 'Fits' constraint +-- holds (a mismatch is a compile error). Returned as 'Bool' so a test can run. +mat4FitsVec4x4 :: (Fits (Sig EquivMat4) (Sig EquivVec4x4)) => Bool +mat4FitsVec4x4 = True + +vec4x4FitsFloat16 :: (Fits (Sig EquivVec4x4) (Sig EquivFloat16)) => Bool +vec4x4FitsFloat16 = True + +pushFitsItself :: (Fits (Sig Push) (Sig Push)) => Bool +pushFitsItself = True + +-- Two records that are layout-equivalent under std430: two vec4s vs four vec2s both flatten to +-- eight floats at offsets 0,4,..,28 (size 32). Real 'Storable' records, so a +-- value written as one can be read back through the other. +data PairA = PairA Vec4 Vec4 + deriving stock (Generic, Eq, Show) + deriving anyclass (Block) + deriving (Storable) via (Std430 PairA) + +data PairB = PairB Vec2 Vec2 Vec2 Vec2 + deriving stock (Generic, Eq, Show) + deriving anyclass (Block) + deriving (Storable) via (Std430 PairB) + +pure + ( knownLayoutInstance + ''PairA + (normalize (fromFields Std430Layout Nothing [("a", Vector STFloat 4), ("b", Vector STFloat 4)])) + ) +pure + ( knownLayoutInstance + ''PairB + ( normalize + ( fromFields + Std430Layout + Nothing + [("a", Vector STFloat 2), ("b", Vector STFloat 2), ("c", Vector STFloat 2), ("d", Vector STFloat 2)] + ) + ) + ) + +-- Stage signatures for a matched vertex+fragment pair (shared Scene UBO, vertex +-- push constant, fragment SSBO). Phase 1 exercises only the interface. +reflectStageSigBytes "MeshVert" Fixtures.meshVert +reflectStageSigBytes "MeshFrag" Fixtures.meshFrag + +-- The merged pipeline-layout signature of the same pair, promoted to the type level. +reflectPipelineLayoutSigBytes "MeshLayout" [Fixtures.meshVert, Fixtures.meshFrag] + +-- Compile-time witness: only type-checks if the vertexβ†’fragment interface matches. +meshInterfaceOk :: (MatchInterface MeshVert MeshFrag) => Bool +meshInterfaceOk = True + +-- Compile-time witness: only type-checks if the shared resources are compatible +-- (the Scene UBO is declared identically in both stages). +meshResourcesOk :: (CompatibleResources MeshVert MeshFrag) => Bool +meshResourcesOk = True + +main :: IO () +main = + defaultMain $ + testGroup + "vulkan-utils-spirv" + [ testGroup + "block record (std140)" + [ testCase "alignment is std140 vec4 (16)" $ + alignment params @?= 16 + , testCase "fields land at the shader's std140 offsets" $ do + -- shader.comp: center@0, resolution@8, escapeRadius@16, maxIterations@20 + let n = sizeOf params + (resX, esc, maxIt) <- allocaBytes n $ \ptr -> do + fillBytes ptr 0 n + poke (castPtr ptr) params + (,,) + <$> (peekByteOff ptr 8 :: IO Word32) + <*> (peekByteOff ptr 16 :: IO Float) + <*> (peekByteOff ptr 20 :: IO Int32) + resX @?= 512 + esc @?= 2.0 + maxIt @?= 1000 + , testCase "round-trips through Storable" $ do + let n = sizeOf params + rt <- allocaBytes n $ \ptr -> do + fillBytes ptr 0 n + poke (castPtr ptr) params + peek (castPtr ptr) + rt @?= params + ] + , testGroup + "field type spelling (TypeMap)" + -- geomancyTypeMap is also exercised end-to-end by the record fixtures. + -- linearTypeMap is a worked example of the parametric case with no Block + -- instances to splice against yet, so these pure checks pin its spelling. + [ testCase "geomancy: scalar in name, single qualifier" $ do + geomancyTypeMap (NumericType STFloat (ShVector 3) []) @?= Just (ConT (mkName "Geomancy.Vec3")) + geomancyTypeMap (NumericType STUInt (ShVector 2) []) @?= Just (ConT (mkName "Geomancy.UVec2")) + geomancyTypeMap (NumericType STFloat (ShMatrix 4 4) []) @?= Just (ConT (mkName "Geomancy.Mat4")) + , testCase "linear: parametric, scalar applied" $ do + linearTypeMap (NumericType STFloat (ShVector 3) []) @?= Just (AppT (ConT (mkName "Linear.V3")) (ConT ''Float)) + linearTypeMap (NumericType STUInt (ShVector 2) []) @?= Just (AppT (ConT (mkName "Linear.V2")) (ConT ''Word32)) + linearTypeMap (NumericType STFloat (ShMatrix 4 4) []) @?= Just (AppT (ConT (mkName "Linear.M44")) (ConT ''Float)) + , testCase "both reject array members and address scalars" $ do + geomancyTypeMap (NumericType STFloat (ShVector 3) [4]) @?= Nothing + linearTypeMap (NumericType STAddress ShScalar []) @?= Nothing + ] + , testGroup + "push-constant block (std430)" + [ testCase "alignment is mat4 (16)" $ + alignment pushc @?= 16 + , testCase "fields land at the shader's std430 offsets" $ do + -- push.comp: transform@0, offset@64, scale@72, count@76 + let n = sizeOf pushc + (sc, cnt) <- allocaBytes n $ \ptr -> do + fillBytes ptr 0 n + poke (castPtr ptr) pushc + (,) + <$> (peekByteOff ptr 72 :: IO Float) + <*> (peekByteOff ptr 76 :: IO Int32) + sc @?= 2.5 + cnt @?= 7 + , testCase "size covers the last member (80)" $ + sizeOf pushc @?= 80 + , testCase "round-trips through Storable" $ do + -- @Push@ has a @Mat4@ field (no @Eq@), so compare the comparable + -- fields after a Storable round-trip rather than the whole record. + let n = sizeOf pushc + rt <- allocaBytes n $ \ptr -> do + fillBytes ptr 0 n + poke (castPtr ptr) pushc + peek (castPtr ptr) :: IO Push + (rt.offset, rt.scale, rt.count) @?= (pushc.offset, pushc.scale, pushc.count) + ] + , testCase "push-constant range from reflection" $ do + m <- loadBytes Fixtures.pushComp + case pushConstantRanges m of + [r] -> do + r.offset @?= 0 + r.size @?= 80 + r.stageFlags @?= Vk.SHADER_STAGE_COMPUTE_BIT + other -> assertFailure ("expected one range, got " <> show (length other)) + , testGroup + "64-bit integer scalars (std430)" + [ testCase "uint64_t/int64_t members land at 8-byte-aligned offsets" $ do + -- wide.comp: hi@0, lo@8, tag@16. A 64-bit int is an 8-byte slot, so + -- tag sits at 16 β€” under the old 32-bit assumption it would be at 8. + let n = sizeOf wide + (hi, lo, tag) <- allocaBytes n $ \ptr -> do + fillBytes ptr 0 n + poke (castPtr ptr) wide + (,,) + <$> (peekByteOff ptr 0 :: IO Word64) + <*> (peekByteOff ptr 8 :: IO Int64) + <*> (peekByteOff ptr 16 :: IO Word32) + (hi, lo, tag) @?= (0xDEADBEEFCAFEF00D, -42, 7) + , testCase "record rounds up to its 8-byte alignment (24)" $ + -- gl-block pads the record to a multiple of its base alignment (8); + -- the SPIR-V block extent below is the unpadded 20. + sizeOf wide @?= 24 + , testCase "push-constant range from reflection ends at 20" $ do + -- 16 + 4: tag (a uint) ends at 20, so each int64 before it took 8 + -- bytes β€” a 4-byte misclassification would put the end at 12. + m <- loadBytes Fixtures.wideComp + case pushConstantRanges m of + [r] -> (r.offset, r.size) @?= (0, 20) + other -> assertFailure ("expected one range, got " <> show (length other)) + , testCase "Wide's std430 Sig has 8-byte int slots at 0/8, uint at 16" $ + layoutSig @Wide + @?= normalize + ( fromFields + Std430Layout + Nothing + [ ("hi", Scalar STUInt64) + , ("lo", Scalar STInt64) + , ("tag", Scalar STUInt) + ] + ) + ] + , testGroup + "buffer_reference (BDA)" + [ testCase "Node's std430 Sig has DeviceAddress slots at 32/40, size 64" $ + -- boundsMin@0, boundsMax@16, left@32, right@40, primCount@48; size 64. + layoutSig @Node + @?= normalize + ( fromFields + Std430Layout + Nothing + [ ("boundsMin", Vector STFloat 4) + , ("boundsMax", Vector STFloat 4) + , ("left", Scalar STAddress) + , ("right", Scalar STAddress) + , ("primCount", Scalar STUInt) + ] + ) + , testCase "DeviceAddress fields land at std430 byte offsets 32 and 40" $ do + let n = Node (vec4 0 0 0 0) (vec4 0 0 0 0) (DeviceAddress 0xCAFE) (DeviceAddress 0xBEEF) 0 + (a32, a40) <- allocaBytes (sizeOf (Std430 n)) $ \p -> do + poke (castPtr p) (Std430 n) + (,) <$> (peekByteOff p 32 :: IO Word64) <*> (peekByteOff p 40 :: IO Word64) + (a32, a40) @?= (0xCAFE, 0xBEEF) + , testCase "push-constant block is a single 8-byte device address" $ do + m <- loadBytes Fixtures.bdaComp + case pushConstantRanges m of + [r] -> (r.offset, r.size) @?= (0, 8) + other -> assertFailure ("expected one range, got " <> show (length other)) + ] + , testGroup + "SSBO array-of-struct element (std430)" + [ testCase "element record alignment is vec3 (16)" $ + alignment particle @?= 16 + , testCase "fields land at the shader's std430 offsets" $ do + -- ssbo-struct.comp: position@0, velocity@16, mass@24, flags@28 + let n = sizeOf particle + (vx, m, fl) <- allocaBytes n $ \ptr -> do + fillBytes ptr 0 n + poke (castPtr ptr) particle + (,,) + <$> (peekByteOff ptr 16 :: IO Float) + <*> (peekByteOff ptr 24 :: IO Float) + <*> (peekByteOff ptr 28 :: IO Word32) + vx @?= 3.0 + m @?= 1.5 + fl @?= 7 + , testCase "element size is std430-padded (32)" $ + sizeOf particle @?= 32 + ] + , testGroup + "nested struct as a field (shared across layouts)" + [ testCase "nested element record offsets (Material)" $ do + let n = sizeOf mat + (al, em) <- allocaBytes n $ \ptr -> do + fillBytes ptr 0 n + poke (castPtr ptr) mat + (,) <$> (peekByteOff ptr 0 :: IO Float) <*> (peekByteOff ptr 16 :: IO Float) + alignment mat @?= 16 + sizeOf mat @?= 32 + al @?= 1.0 + em @?= 2.0 + , testCase "parent embeds the nested struct at its std140 offsets" $ do + -- nested.comp: sun@0 (albedo@0, emission@16), tint@32 + let n = sizeOf scene + (al, em, ti) <- allocaBytes n $ \ptr -> do + fillBytes ptr 0 n + poke (castPtr ptr) scene + (,,) + <$> (peekByteOff ptr 0 :: IO Float) + <*> (peekByteOff ptr 16 :: IO Float) + <*> (peekByteOff ptr 32 :: IO Float) + alignment scene @?= 16 + sizeOf scene @?= 48 + al @?= 1.0 + em @?= 2.0 + ti @?= 3.0 + ] + , testGroup + "fixed-size array fields (Array n a)" + [ testCase "std140 rounds element stride up to 16" $ do + -- Kernel140: taps[4] vec4 @0 (stride 16), weights[4] float @64 (stride 16) + let n = sizeOf k140 + (t0, t1, w0, w1, w3) <- allocaBytes n $ \ptr -> do + fillBytes ptr 0 n + poke (castPtr ptr) k140 + (,,,,) + <$> (peekByteOff ptr 0 :: IO Float) + <*> (peekByteOff ptr 16 :: IO Float) + <*> (peekByteOff ptr 64 :: IO Float) + <*> (peekByteOff ptr 80 :: IO Float) -- std140 stride 16 + <*> (peekByteOff ptr 112 :: IO Float) + alignment k140 @?= 16 + sizeOf k140 @?= 128 + (t0, t1) @?= (1, 2) + (w0, w1, w3) @?= (10, 20, 40) + , testCase "std430 packs the float array tightly (stride 4)" $ do + -- Kernel430: taps[4] vec4 @0, weights[4] float @64 (stride 4) + let n = sizeOf k430 + (w0, w1, w3) <- allocaBytes n $ \ptr -> do + fillBytes ptr 0 n + poke (castPtr ptr) k430 + (,,) + <$> (peekByteOff ptr 64 :: IO Float) + <*> (peekByteOff ptr 68 :: IO Float) -- std430 stride 4 + <*> (peekByteOff ptr 76 :: IO Float) + sizeOf k430 @?= 80 + (w0, w1, w3) @?= (10, 20, 40) + ] + , testGroup + "multi-dimensional array field (Array h (Array w a))" + [ testCase "std430 nested strides (inner 4, outer 16)" $ do + -- Grid430: head@0, grid[3][4] @16; grid[i][j] @ 16 + i*16 + j*4 + let n = sizeOf g430 + (h, g00, g01, g10, g23) <- allocaBytes n $ \ptr -> do + fillBytes ptr 0 n + poke (castPtr ptr) g430 + (,,,,) + <$> (peekByteOff ptr 0 :: IO Float) + <*> (peekByteOff ptr 16 :: IO Float) + <*> (peekByteOff ptr 20 :: IO Float) + <*> (peekByteOff ptr 32 :: IO Float) + <*> (peekByteOff ptr 60 :: IO Float) + sizeOf g430 @?= 64 + h @?= 9 + (g00, g01, g10, g23) @?= (1, 2, 5, 12) + , testCase "std140 nested strides (inner 16, outer 64)" $ do + -- Grid140: head@0, grid[3][4] @16; grid[i][j] @ 16 + i*64 + j*16 + let n = sizeOf g140 + (g00, g01, g10) <- allocaBytes n $ \ptr -> do + fillBytes ptr 0 n + poke (castPtr ptr) g140 + (,,) + <$> (peekByteOff ptr 16 :: IO Float) + <*> (peekByteOff ptr 32 :: IO Float) -- inner stride 16 + <*> (peekByteOff ptr 80 :: IO Float) -- outer stride 64 + sizeOf g140 @?= 208 + (g00, g01, g10) @?= (1, 2, 5) + ] + , testGroup + "runtime-sized array (Storable.Vector at the std430 stride)" + [ testCase "elements placed at the array stride (32 > element size 20)" $ do + let + pads = VS.fromList [Pad (vec4 1 0 0 0) 2, Pad (vec4 9 0 0 0) 8] + stride = Array.std430Stride (Proxy :: Proxy Pad) + n = 2 * stride + (a0, b0, a1, b1) <- allocaBytes n $ \ptr -> do + fillBytes ptr 0 n + Array.pokeStd430 ptr pads + (,,,) + <$> (peekByteOff ptr 0 :: IO Float) + <*> (peekByteOff ptr 16 :: IO Float) + <*> (peekByteOff ptr 32 :: IO Float) -- second element at stride 32 + <*> (peekByteOff ptr 48 :: IO Float) + stride @?= 32 + (a0, b0, a1, b1) @?= (1, 2, 9, 8) + , testCase "round-trips through pokeStd430/peekStd430" $ do + let + pads = VS.fromList [Pad (vec4 1 2 3 4) 5, Pad (vec4 6 7 8 9) 10] + stride = Array.std430Stride (Proxy :: Proxy Pad) + rt <- allocaBytes (2 * stride) $ \ptr -> do + fillBytes ptr 0 (2 * stride) + Array.pokeStd430 ptr pads + Array.peekStd430 2 ptr + VS.toList rt @?= VS.toList pads + ] + , testGroup + "specialization constants from reflection" + [ testCase "reflects ids and names (ascending, non-contiguous)" $ do + m <- loadBytes Fixtures.specComp + specializationConstants m + @?= [(0, Just "count"), (3, Just "scale")] + , testCase "map entries keep real ids but pack tightly" $ do + m <- loadBytes Fixtures.specComp + let es = toL (specializationMapEntries m) + map (\e -> (e.constantID, e.offset, e.size)) es + @?= [(0, 0, 4), (3, 4, 4)] + ] + , testCase "descriptor set layout from reflection" $ do + m <- loadBytes Fixtures.juliaComp + case descriptorSetLayoutInfos m of + [(setNo, info)] -> do + setNo @?= 0 + let bs = toL info.bindings + map (.binding) bs @?= [0, 1] + map (.descriptorType) bs + @?= [Vk.DESCRIPTOR_TYPE_UNIFORM_BUFFER, Vk.DESCRIPTOR_TYPE_STORAGE_BUFFER] + all ((== Vk.SHADER_STAGE_COMPUTE_BIT) . (.stageFlags)) bs @? "all compute stage" + other -> assertFailure ("expected one set, got " <> show (length other)) + , testGroup + "vertex input from reflection" + [ testCase "attributes: format + tightly-packed offset" $ do + m <- loadBytes Fixtures.triVert + let attrs = vertexInputAttributes m + map (\a -> (a.location, a.format, a.offset)) attrs + @?= [ (0, Vk.FORMAT_R32G32B32_SFLOAT, 0) + , (1, Vk.FORMAT_R32G32_SFLOAT, 12) + , (2, Vk.FORMAT_R32G32B32A32_SFLOAT, 20) + ] + , testCase "binding stride is packed size" $ do + m <- loadBytes Fixtures.triVert + (vertexInputBinding m).stride @?= 36 + , testCase "vertexInputState packs the reflected binding + attributes" $ do + m <- loadBytes Fixtures.triVert + let vis = vertexInputState m + map (.stride) (toL vis.vertexBindingDescriptions) @?= [36] + map (.offset) (toL vis.vertexAttributeDescriptions) @?= [0, 12, 20] + , testCase "vertexInputState is empty when a module declares no vertex inputs" $ do + m <- loadBytes Fixtures.juliaComp + let vis = vertexInputState m + null (toL vis.vertexBindingDescriptions) @? "no bindings" + null (toL vis.vertexAttributeDescriptions) @? "no attributes" + ] + , testGroup + "type-level signatures" + [ testCase "a record's Sig reflects back to its value-level offset map (the oracle)" $ + -- Push: mat4 @0, vec2 @64, float @72, int @76, size 80. + layoutSig @Push + @?= normalize + ( fromFields + Std430Layout + Nothing + [ ("transform", Matrix STFloat 4 4) + , ("offset", Vector STFloat 2) + , ("scale", Scalar STFloat) + , ("count", Scalar STInt) + ] + ) + , testCase "layout-equivalent layouts promote to the SAME Sig (mat4 == vec4[4] == float[16])" $ do + layoutSig @EquivMat4 @?= layoutSig @EquivVec4x4 + layoutSig @EquivVec4x4 @?= layoutSig @EquivFloat16 + , testCase "Fits accepts layout-equivalent layouts at the type level" $ do + -- These only type-check because the 'Fits' constraints are satisfied. + mat4FitsVec4x4 @?= True + vec4x4FitsFloat16 @?= True + pushFitsItself @?= True + ] + , testGroup + "buffer (structural views)" + [ testCase "Storable size matches the layout signature size" $ + (layoutSig @PairA).size @?= Just (sizeOf (undefined :: PairA)) + , testCase "round-trips the same record" $ do + let a = PairA (vec4 9 8 7 6) (vec4 5 4 3 2) + buf <- newBuffer a + a' <- readBuffer buf + a' @?= a + , testCase "write one layout, read a layout-compatible one back (typed view)" $ do + buf <- newBuffer (PairA (vec4 1 2 3 4) (vec4 5 6 7 8)) + -- Fits (Sig PairB) (Sig PairA) holds because the layouts are equivalent. + PairB x y z w <- readBuffer buf + (x, y, z, w) @?= (vec2 1 2, vec2 3 4, vec2 5 6, vec2 7 8) + ] + , testGroup + "buffer (runtime-array element access)" + [ testCase "writes and reads back array elements by index" $ do + -- ArrayOf (Sig PairA): a runtime PairA[] (stride 32, base 0). + buf <- allocArrayBuffer @(ArrayOf (Sig PairA)) 2 + let + p0 = PairA (vec4 1 2 3 4) (vec4 5 6 7 8) + p1 = PairA (vec4 9 10 11 12) (vec4 13 14 15 16) + writeBufferElem buf 0 p0 + writeBufferElem buf 1 p1 + e0 <- readBufferElem buf 0 + e1 <- readBufferElem buf 1 + (e0, e1) @?= (p0, p1) + , testCase "reads an element back through a layout-compatible record (typed view)" $ do + buf <- allocArrayBuffer @(ArrayOf (Sig PairA)) 2 + writeBufferElem buf 0 (PairA (vec4 1 2 3 4) (vec4 5 6 7 8)) + writeBufferElem buf 1 (PairA (vec4 10 20 30 40) (vec4 50 60 70 80)) + -- FitsTail (Sig PairB) (ArrayOf (Sig PairA)) holds: the element layout is equivalent. + PairB x y z w <- readBufferElem buf 1 + (x, y, z, w) @?= (vec2 10 20, vec2 30 40, vec2 50 60, vec2 70 80) + ] + , testGroup + "stage interface matching" + [ testCase "vertex outputs reflect at locations 0 (vec3) and 1 (vec2)" $ do + vm <- loadBytes Fixtures.meshVert + let outs = (stageInfoOf vm).outputs + map fst outs @?= [0, 1] + map (length . (.slots) . snd) outs @?= [3, 2] + , testCase "vertex outputs match fragment inputs (value oracle)" $ do + vm <- loadBytes Fixtures.meshVert + fm <- loadBytes Fixtures.meshFrag + matchInterface (stageInfoOf vm) (stageInfoOf fm) @?= Right () + , testCase "a mismatched interface is rejected (value oracle)" $ do + vm <- loadBytes Fixtures.meshVert + fm <- loadBytes Fixtures.meshFrag + -- frag outputs (vec4 @loc0) cannot satisfy the vertex's own inputs. + assertBool "should not match" (isLeft (matchInterface (stageInfoOf fm) (stageInfoOf vm))) + , testCase "MatchInterface holds at the type level" $ + meshInterfaceOk @?= True + ] + , testGroup + "stage resource linking (shared UBO)" + [ testCase "the Scene UBO reflects identically from both stages" $ do + vm <- loadBytes Fixtures.meshVert + fm <- loadBytes Fixtures.meshFrag + lookup (0, 0) (stageInfoOf vm).resources + @?= lookup (0, 0) (stageInfoOf fm).resources + , testCase "linking unions resources, push and the external interface" $ do + vm <- loadBytes Fixtures.meshVert + fm <- loadBytes Fixtures.meshFrag + case linkStages (stageInfoOf vm) (stageInfoOf fm) of + Left e -> assertFailure e + Right linked -> do + map fst linked.resources @?= [(0, 0), (0, 1)] -- Scene (shared) + Materials + isJust linked.push @?= True -- vertex Model push constant + map fst linked.inputs @?= [0, 1, 2] -- vertex attributes + map fst linked.outputs @?= [0] -- fragment colour output + , testCase "a conflicting shared binding is rejected" $ do + vm <- loadBytes Fixtures.meshVert + fm <- loadBytes Fixtures.meshFrag + let bad = + (stageInfoOf fm) + { StageInfo.resources = [((0, 0), normalize (fromFields Std140Layout Nothing [("x", Vector STFloat 2)]))] + } + assertBool "should conflict" (isLeft (linkStages (stageInfoOf vm) bad)) + , testCase "CompatibleResources holds at the type level" $ + meshResourcesOk @?= True + , testCase "the merged layout signature round-trips to the value-level merge" $ do + vm <- loadBytes Fixtures.meshVert + fm <- loadBytes Fixtures.meshFrag + let info = layoutSigVal (Proxy @MeshLayout) -- reflected from the promoted type + mergeLayout [vm, fm] @?= Right info -- equals the value-level merge + map fst info.resources @?= [(0, 0), (0, 1)] -- Scene (shared) + Materials + isJust info.push @?= True -- vertex Model push constant + ] + , testGroup + "pipeline layout (depth-only vs depth+color from one vertex shader)" + [ testCase "depth-only: the vertex stage alone" $ do + vm <- loadBytes Fixtures.meshVert + -- Only the vertex-visible resources: Scene UBO at (0,0), vertex stage. + stageBindings [vm] + @?= [(0, Vk.SHADER_STAGE_VERTEX_BIT)] + fmap length (mergedPushConstantRanges [vm]) @?= Right 1 -- the Model push constant + , testCase "depth+color: vertex+fragment, Scene gains the fragment stage" $ do + vm <- loadBytes Fixtures.meshVert + fm <- loadBytes Fixtures.meshFrag + stageBindings [vm, fm] + @?= [ (0, Vk.SHADER_STAGE_VERTEX_BIT .|. Vk.SHADER_STAGE_FRAGMENT_BIT) -- Scene, shared + , (1, Vk.SHADER_STAGE_FRAGMENT_BIT) -- Materials, frag-only + ] + ] + , LayoutSpec.tests + ] + where + -- (binding, stageFlags) across all sets, for the merged pipeline layout. + stageBindings modules = + sortOn + fst + [ (b.binding, b.stageFlags) + | (_set, info) <- either error id (mergedDescriptorSetLayoutInfos modules) + , b <- V.toList info.bindings + ] + params = + Params + { center = vec2 (-0.8) 0.156 + , resolution = uvec2 512 512 + , escapeRadius = 2.0 + , maxIterations = 1000 + } + pushc = + Push + { transform = identity + , offset = vec2 1 2 + , scale = 2.5 + , count = 7 + } + wide = + Wide + { hi = 0xDEADBEEFCAFEF00D + , lo = -42 + , tag = 7 + } + particle = + Particle + { position = vec3 (-1) 0 0 + , velocity = vec2 3 4 + , mass = 1.5 + , flags = 7 + } + mat = + Material + { albedo = vec4 1 0 0 0 + , emission = vec4 2 0 0 0 + } + scene = + Scene + { sun = mat + , tint = vec4 3 0 0 0 + } + taps = Array.unsafeFromList [vec4 1 0 0 0, vec4 2 0 0 0, vec4 3 0 0 0, vec4 4 0 0 0] :: Array.Array 4 Vec4 + weights = Array.unsafeFromList [10, 20, 30, 40] :: Array.Array 4 Float + k140 = Kernel140{taps = taps, weights = weights} + k430 = Kernel430{taps = taps, weights = weights} + grid = + Array.unsafeFromList (map Array.unsafeFromList [[1, 2, 3, 4], [5, 6, 7, 8], [9, 10, 11, 12]]) + :: Array.Array 3 (Array.Array 4 Float) + g430 = Grid430{head = vec4 9 0 0 0, grid = grid} + g140 = Grid140{head = vec4 9 0 0 0, grid = grid} + toL = foldr (:) [] diff --git a/utils-spirv/vulkan-utils-spirv.cabal b/utils-spirv/vulkan-utils-spirv.cabal new file mode 100644 index 000000000..b566547e3 --- /dev/null +++ b/utils-spirv/vulkan-utils-spirv.cabal @@ -0,0 +1,135 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.39.1. +-- +-- see: https://github.com/sol/hpack + +name: vulkan-utils-spirv +version: 0.1.0.0 +synopsis: Generate Haskell types and Vulkan descriptor/pipeline layouts from SPIR-V reflection +category: Graphics +homepage: https://github.com/expipiplus1/vulkan#readme +bug-reports: https://github.com/expipiplus1/vulkan/issues +maintainer: Ellie Hermaszewska +build-type: Simple +extra-source-files: + README.md + package.yaml + +source-repository head + type: git + location: https://github.com/expipiplus1/vulkan + +library + exposed-modules: + Vulkan.Utils.SpirV.Array + Vulkan.Utils.SpirV.Block + Vulkan.Utils.SpirV.Buffer + Vulkan.Utils.SpirV.Descriptors + Vulkan.Utils.SpirV.DeviceAddress + Vulkan.Utils.SpirV.Layout + Vulkan.Utils.SpirV.Pipeline + Vulkan.Utils.SpirV.Reflect + Vulkan.Utils.SpirV.Reflect.OffsetMaps + Vulkan.Utils.SpirV.Signature + Vulkan.Utils.SpirV.Specialization + Vulkan.Utils.SpirV.Stage + Vulkan.Utils.SpirV.TH + Vulkan.Utils.SpirV.Types + Vulkan.Utils.SpirV.VertexInput + other-modules: + Paths_vulkan_utils_spirv + hs-source-dirs: + src + default-extensions: + BlockArguments + DataKinds + DeriveAnyClass + DeriveGeneric + DerivingStrategies + DerivingVia + DuplicateRecordFields + FlexibleContexts + FlexibleInstances + ImportQualifiedPost + LambdaCase + NamedFieldPuns + OverloadedRecordDot + OverloadedStrings + PatternSynonyms + RecordWildCards + ScopedTypeVariables + TemplateHaskell + TupleSections + TypeApplications + TypeOperators + ViewPatterns + ghc-options: -Wall + build-depends: + base >=4.16 && <5 + , bytestring + , containers + , gl-block + , ptrdiff + , resourcet + , spirv-enum + , spirv-reflect-ffi + , spirv-reflect-types + , template-haskell + , text + , unliftio-core + , vector + , vulkan ==3.27.* + , vulkan-utils + default-language: Haskell2010 + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Fixtures + LayoutSpec + Paths_vulkan_utils_spirv + hs-source-dirs: + test + default-extensions: + BlockArguments + DataKinds + DeriveAnyClass + DeriveGeneric + DerivingStrategies + DerivingVia + DuplicateRecordFields + FlexibleContexts + FlexibleInstances + ImportQualifiedPost + LambdaCase + NamedFieldPuns + OverloadedRecordDot + OverloadedStrings + PatternSynonyms + RecordWildCards + ScopedTypeVariables + TemplateHaskell + TupleSections + TypeApplications + TypeOperators + ViewPatterns + ghc-options: -Wall + build-depends: + base <5 + , bytestring + , containers + , geomancy + , gl-block + , spirv-reflect-ffi + , spirv-reflect-types + , tasty + , tasty-hunit + , template-haskell + , text + , vector + , vulkan + , vulkan-utils + , vulkan-utils-spirv + default-language: Haskell2010