From bf4060f75e971c70fb4d89daf65aa057ca7cb543 Mon Sep 17 00:00:00 2001 From: IC Rainbow Date: Tue, 5 May 2026 00:57:52 +0300 Subject: [PATCH 1/5] Cheap thrills --- examples/compute/Main.hs | 305 +++++--------- examples/hlsl/Frame.hs | 183 --------- examples/hlsl/Init.hs | 107 +---- examples/hlsl/Main.hs | 140 +++++-- examples/hlsl/MonadFrame.hs | 164 -------- examples/hlsl/MonadVulkan.hs | 272 ------------ examples/hlsl/Pipeline.hs | 187 ++++----- examples/hlsl/Render.hs | 192 +++++---- examples/hlsl/RenderPass.hs | 83 ++-- examples/lib/AutoApply.hs | 416 ------------------- examples/lib/Frame.hs | 264 ++++++++++++ examples/lib/Framebuffer.hs | 85 ++-- examples/lib/HasVulkan.hs | 31 -- examples/lib/InstrumentDecs.hs | 41 -- examples/lib/Swapchain.hs | 306 ++++++-------- examples/lib/Triangle.hs | 549 +++++++++++++++---------- examples/lib/Utils.hs | 28 +- examples/lib/VkResources.hs | 67 +++ examples/lib/Vma.hs | 54 +++ examples/package.yaml | 31 +- examples/rays/AccelerationStructure.hs | 237 ++++++----- examples/rays/Cleanup.hs | 105 ----- examples/rays/Frame.hs | 225 ---------- examples/rays/Init.hs | 130 +----- examples/rays/Main.hs | 165 ++++++-- examples/rays/MonadFrame.hs | 154 ------- examples/rays/MonadVulkan.hs | 288 ------------- examples/rays/Pipeline.hs | 254 ++++++------ examples/rays/Render.hs | 351 +++++++++------- examples/rays/Scene.hs | 26 +- examples/readme.md | 34 +- examples/resize/Frame.hs | 174 -------- examples/resize/Init.hs | 68 +-- examples/resize/Julia.hs | 161 ++++---- examples/resize/Main.hs | 545 ++++++++++++------------ examples/resize/MonadVulkan.hs | 188 --------- examples/resize/Pipeline.hs | 210 +++++----- examples/resize/Swapchain.hs | 199 --------- examples/timeline-semaphore/Main.hs | 178 -------- examples/triangle-glfw/Main.hs | 276 ++++--------- examples/triangle-headless/Main.hs | 363 ++++++---------- examples/triangle-sdl2/Main.hs | 279 ++++--------- examples/vulkan-examples.cabal | 85 +--- 43 files changed, 2745 insertions(+), 5455 deletions(-) delete mode 100644 examples/hlsl/Frame.hs delete mode 100644 examples/hlsl/MonadFrame.hs delete mode 100644 examples/hlsl/MonadVulkan.hs delete mode 100644 examples/lib/AutoApply.hs create mode 100644 examples/lib/Frame.hs delete mode 100644 examples/lib/HasVulkan.hs delete mode 100644 examples/lib/InstrumentDecs.hs create mode 100644 examples/lib/VkResources.hs create mode 100644 examples/lib/Vma.hs delete mode 100644 examples/rays/Cleanup.hs delete mode 100644 examples/rays/Frame.hs delete mode 100644 examples/rays/MonadFrame.hs delete mode 100644 examples/rays/MonadVulkan.hs delete mode 100644 examples/resize/Frame.hs delete mode 100644 examples/resize/MonadVulkan.hs delete mode 100644 examples/resize/Swapchain.hs delete mode 100644 examples/timeline-semaphore/Main.hs diff --git a/examples/compute/Main.hs b/examples/compute/Main.hs index 9316ff21b..31a0783ce 100644 --- a/examples/compute/Main.hs +++ b/examples/compute/Main.hs @@ -1,8 +1,6 @@ -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -Wno-missing-signatures #-} module Main @@ -10,11 +8,9 @@ module Main ) where -import AutoApply import qualified Codec.Picture as JP import Control.Exception.Safe import Control.Monad.IO.Class -import Control.Monad.Trans.Reader import Control.Monad.Trans.Resource import Data.Bits import qualified Data.ByteString.Lazy as BSL @@ -22,10 +18,11 @@ import Data.Functor.Identity ( Identity(..) ) import qualified Data.Vector as V import Data.Word import Foreign.Marshal.Array ( peekArray ) -import Foreign.Ptr +import Foreign.Ptr ( Ptr, plusPtr ) import Foreign.Storable ( sizeOf ) import Say +import qualified Vma import Vulkan.CStruct.Extends import Vulkan.CStruct.Utils ( FixedArray , lowerArrayPtr @@ -35,18 +32,9 @@ import Vulkan.Core10 as Vk , withImage ) import qualified Vulkan.Core10 as CommandBufferBeginInfo (CommandBufferBeginInfo(..)) -import qualified Vulkan.Core10 as CommandPoolCreateInfo (CommandPoolCreateInfo(..)) +import qualified Vulkan.Core10 as CommandPoolCreateInfo (CommandPoolCreateInfo(..)) import qualified Vulkan.Core10 as PipelineLayoutCreateInfo (PipelineLayoutCreateInfo(..)) import qualified Vulkan.Core10.DeviceInitialization as DI -import Vulkan.Dynamic ( DeviceCmds - ( DeviceCmds - , pVkGetDeviceProcAddr - ) - , InstanceCmds - ( InstanceCmds - , pVkGetInstanceProcAddr - ) - ) import Vulkan.Extensions.VK_EXT_debug_utils import Vulkan.Requirement ( InstanceRequirement(..) ) import Vulkan.Utils.Debug ( debugCallbackPtr ) @@ -66,220 +54,124 @@ import VulkanMemoryAllocator as VMA hiding ( getPhysicalDeviceProperties ) import qualified VulkanMemoryAllocator as AllocationCreateInfo (AllocationCreateInfo(..)) ----------------------------------------------------------------- --- Define the monad in which most of the program will run ----------------------------------------------------------------- - --- | @V@ keeps track of a bunch of "global" handles and performs resource --- management. -newtype V a = V { unV :: ReaderT GlobalHandles (ResourceT IO) a } - deriving newtype ( Functor - , Applicative - , Monad - , MonadFail - , MonadThrow - , MonadCatch - , MonadMask - , MonadIO - , MonadResource - ) - -runV - :: Instance - -> PhysicalDevice - -> Word32 - -> Device - -> Allocator - -> V a - -> ResourceT IO a -runV ghInstance ghPhysicalDevice ghComputeQueueFamilyIndex ghDevice ghAllocator - = flip runReaderT GlobalHandles { .. } . unV - -data GlobalHandles = GlobalHandles - { ghInstance :: Instance - , ghPhysicalDevice :: PhysicalDevice - , ghDevice :: Device - , ghAllocator :: Allocator - , ghComputeQueueFamilyIndex :: Word32 - } - --- Getters for global handles - -getInstance :: V Instance -getInstance = V (asks ghInstance) - -getComputeQueueFamilyIndex :: V Word32 -getComputeQueueFamilyIndex = V (asks ghComputeQueueFamilyIndex) - -getPhysicalDevice :: V PhysicalDevice -getPhysicalDevice = V (asks ghPhysicalDevice) - -getDevice :: V Device -getDevice = V (asks ghDevice) - -getAllocator :: V Allocator -getAllocator = V (asks ghAllocator) - -noAllocationCallbacks :: Maybe AllocationCallbacks -noAllocationCallbacks = Nothing - --- --- Wrap a bunch of Vulkan commands so that they automatically pull global --- handles from 'V' --- --- Wrapped functions are suffixed with "'" --- -autoapplyDecs - (<> "'") - [ 'getDevice - , 'getPhysicalDevice - , 'getInstance - , 'getAllocator - , 'noAllocationCallbacks - ] - -- Allocate doesn't subsume the continuation type on the "with" commands, so - -- put it in the unifying group. - ['allocate] - [ 'invalidateAllocation - , 'withBuffer - , 'deviceWaitIdle - , 'getDeviceQueue - , 'waitForFences - , 'withCommandBuffers - , 'withCommandPool - , 'withFence - , 'withComputePipelines - , 'withPipelineLayout - , 'withShaderModule - , 'withDescriptorPool - , 'allocateDescriptorSets - , 'withDescriptorSetLayout - , 'updateDescriptorSets - ] - ---------------------------------------------------------------- -- The program ---------------------------------------------------------------- main :: IO () main = runResourceT $ do - -- Create Instance, PhysicalDevice, Device and Allocator - inst <- Main.createInstance - (phys, pdi, dev) <- Main.createDevice inst - (_, allocator) <- withAllocator - zero - { flags = zero - , physicalDevice = physicalDeviceHandle phys - , device = deviceHandle dev - , instance' = instanceHandle inst - , vulkanApiVersion = myApiVersion - , vulkanFunctions = Just $ case inst of - Instance _ InstanceCmds {..} -> case dev of - Device _ DeviceCmds {..} -> zero - { vkGetInstanceProcAddr = castFunPtr pVkGetInstanceProcAddr - , vkGetDeviceProcAddr = castFunPtr pVkGetDeviceProcAddr - } - } - allocate - - -- Run our application - -- Wait for the device to become idle before tearing down any resourecs. - runV inst phys (pdiComputeQueueFamilyIndex pdi) dev allocator - . (`finally` deviceWaitIdle') - $ do - image <- render - let filename = "julia.png" - sayErr $ "Writing " <> filename - liftIO $ BSL.writeFile filename (JP.encodePng image) - --- Render the Julia set -render :: V (JP.Image JP.PixelRGBA8) -render = do - -- Some things to reuse, make sure these are the same as the values in the - -- compute shader. TODO: reduce this duplication. + inst <- Main.createInstance + (phys, computeQueueFamilyIndex, dev) <- Main.createDevice inst + allocator <- Vma.createVMA zero myApiVersion inst phys dev + + image <- render allocator dev computeQueueFamilyIndex + `finally` deviceWaitIdle dev + let filename = "julia.png" + sayErr $ "Writing " <> filename + liftIO $ BSL.writeFile filename (JP.encodePng image) + +-- | Render the Julia set +render + :: Allocator + -> Device + -> Word32 + -> ResourceT IO (JP.Image JP.PixelRGBA8) +render allocator dev computeQueueFamilyIndex = do let width, height, workgroupX, workgroupY :: Int width = 512 height = width workgroupX = 32 workgroupY = 4 - -- Create a buffer into which to render - -- - -- Use ALLOCATION_CREATE_MAPPED_BIT and MEMORY_USAGE_GPU_TO_CPU to make sure - -- it's readable on the host and starts in the mapped state - (_, (buffer, bufferAllocation, bufferAllocationInfo)) <- withBuffer' + -- Create a buffer into which to render. Mapped + GPU_TO_CPU so the host can + -- read the image back. + (_, (buffer, bufferAllocation, bufferAllocationInfo)) <- VMA.withBuffer + allocator zero { size = fromIntegral $ width * height * 4 * sizeOf (0 :: Float) , usage = BUFFER_USAGE_STORAGE_BUFFER_BIT } zero { AllocationCreateInfo.flags = ALLOCATION_CREATE_MAPPED_BIT - , usage = MEMORY_USAGE_GPU_TO_CPU + , usage = MEMORY_USAGE_GPU_TO_CPU } + allocate -- Create a descriptor set and layout for this buffer (descriptorSet, descriptorSetLayout) <- do - -- Create a descriptor pool - (_, descriptorPool) <- withDescriptorPool' zero - { maxSets = 1 - , poolSizes = [DescriptorPoolSize DESCRIPTOR_TYPE_STORAGE_BUFFER 1] - } - - -- Create a set layout - (_, descriptorSetLayout) <- withDescriptorSetLayout' zero - { bindings = [ zero { binding = 0 - , descriptorType = DESCRIPTOR_TYPE_STORAGE_BUFFER - , descriptorCount = 1 - , stageFlags = SHADER_STAGE_COMPUTE_BIT - } - ] - } - - -- Allocate a descriptor set from the pool with that layout - -- Don't use `withDescriptorSets` here as the set will be cleaned up when - -- the pool is destroyed. - [descriptorSet] <- allocateDescriptorSets' zero - { descriptorPool = descriptorPool - , setLayouts = [descriptorSetLayout] - } + (_, descriptorPool) <- withDescriptorPool + dev + zero { maxSets = 1 + , poolSizes = [DescriptorPoolSize DESCRIPTOR_TYPE_STORAGE_BUFFER 1] + } + Nothing + allocate + + (_, descriptorSetLayout) <- withDescriptorSetLayout + dev + zero { bindings = [ zero { binding = 0 + , descriptorType = DESCRIPTOR_TYPE_STORAGE_BUFFER + , descriptorCount = 1 + , stageFlags = SHADER_STAGE_COMPUTE_BIT + } + ] + } + Nothing + allocate + + -- Don't use `withDescriptorSets`: the set is freed when the pool is. + [descriptorSet] <- allocateDescriptorSets + dev + zero { descriptorPool = descriptorPool + , setLayouts = [descriptorSetLayout] + } pure (descriptorSet, descriptorSetLayout) - -- Assign the buffer in this descriptor set - updateDescriptorSets' + updateDescriptorSets + dev [ SomeStruct zero { dstSet = descriptorSet , dstBinding = 0 , descriptorType = DESCRIPTOR_TYPE_STORAGE_BUFFER , descriptorCount = 1 - , bufferInfo = [DescriptorBufferInfo buffer 0 WHOLE_SIZE] + , bufferInfo = [DescriptorBufferInfo buffer 0 WHOLE_SIZE] } ] [] -- Create our shader and compute pipeline - shader <- createShader - (_, pipelineLayout) <- withPipelineLayout' zero { PipelineLayoutCreateInfo.setLayouts = [descriptorSetLayout] } + shader <- createShader dev + (_, pipelineLayout) <- withPipelineLayout + dev + zero { PipelineLayoutCreateInfo.setLayouts = [descriptorSetLayout] } + Nothing + allocate let pipelineCreateInfo :: ComputePipelineCreateInfo '[] pipelineCreateInfo = zero { layout = pipelineLayout , stage = shader , basePipelineHandle = zero } - (_, (_, [computePipeline])) <- withComputePipelines' + (_, (_, [computePipeline])) <- withComputePipelines + dev zero [SomeStruct pipelineCreateInfo] + Nothing + allocate -- Create a command buffer - computeQueueFamilyIndex <- getComputeQueueFamilyIndex - let commandPoolCreateInfo = zero { CommandPoolCreateInfo.queueFamilyIndex = computeQueueFamilyIndex } - (_, commandPool) <- withCommandPool' commandPoolCreateInfo - let commandBufferAllocateInfo = zero { commandPool = commandPool - , level = COMMAND_BUFFER_LEVEL_PRIMARY - , commandBufferCount = 1 - } - (_, [commandBuffer]) <- withCommandBuffers' commandBufferAllocateInfo + let commandPoolCreateInfo = zero + { CommandPoolCreateInfo.queueFamilyIndex = computeQueueFamilyIndex + } + (_, commandPool) <- withCommandPool dev commandPoolCreateInfo Nothing allocate + let commandBufferAllocateInfo = zero + { commandPool = commandPool + , level = COMMAND_BUFFER_LEVEL_PRIMARY + , commandBufferCount = 1 + } + (_, [commandBuffer]) <- withCommandBuffers dev commandBufferAllocateInfo allocate -- Fill command buffer - useCommandBuffer commandBuffer - zero { CommandBufferBeginInfo.flags = COMMAND_BUFFER_USAGE_ONE_TIME_SUBMIT_BIT } + useCommandBuffer + commandBuffer + zero { CommandBufferBeginInfo.flags = COMMAND_BUFFER_USAGE_ONE_TIME_SUBMIT_BIT } $ do - -- Set up our state, pipeline and descriptor set cmdBindPipeline commandBuffer PIPELINE_BIND_POINT_COMPUTE computePipeline @@ -289,29 +181,25 @@ render = do 0 [descriptorSet] [] - - -- Dispatch the compute shader cmdDispatch commandBuffer - (ceiling (realToFrac width / realToFrac @_ @Float workgroupX)) + (ceiling (realToFrac width / realToFrac @_ @Float workgroupX)) (ceiling (realToFrac height / realToFrac @_ @Float workgroupY)) 1 -- Create a fence so we can know when render is finished - (_, fence) <- withFence' zero - -- Submit the command buffer and wait for it to execute - let submitInfo = - zero { commandBuffers = [commandBufferHandle commandBuffer] } - computeQueue <- getDeviceQueue' computeQueueFamilyIndex 0 + (_, fence) <- withFence dev zero Nothing allocate + let submitInfo = zero { commandBuffers = [commandBufferHandle commandBuffer] } + computeQueue <- getDeviceQueue dev computeQueueFamilyIndex 0 queueSubmit computeQueue [SomeStruct submitInfo] fence let fenceTimeout = 1e9 -- 1 second - waitForFences' [fence] True fenceTimeout >>= \case + waitForFences dev [fence] True fenceTimeout >>= \case TIMEOUT -> throwString "Timed out waiting for compute" _ -> pure () -- If the buffer allocation is not HOST_COHERENT this will ensure the changes -- are present on the CPU. - invalidateAllocation' bufferAllocation 0 WHOLE_SIZE + invalidateAllocation allocator bufferAllocation 0 WHOLE_SIZE -- TODO: speed this bit up, it's hopelessly slow let pixelAddr :: Int -> Int -> Ptr (FixedArray 4 Float) @@ -328,8 +216,10 @@ render = do ) -- | Create a compute shader -createShader :: V (SomeStruct PipelineShaderStageCreateInfo) -createShader = do +createShader + :: Device + -> ResourceT IO (SomeStruct PipelineShaderStageCreateInfo) +createShader dev = do let compCode = [comp| #version 450 #extension GL_ARB_separate_shader_objects : enable @@ -393,7 +283,7 @@ createShader = do } } |] - (_, compModule) <- withShaderModule' zero { code = compCode } + (_, compModule) <- withShaderModule dev zero { code = compCode } Nothing allocate let compShaderStageCreateInfo = zero { stage = SHADER_STAGE_COMPUTE_BIT , module' = compModule , name = "main" @@ -427,8 +317,8 @@ createInstance = do { messageSeverity = DEBUG_UTILS_MESSAGE_SEVERITY_WARNING_BIT_EXT .|. DEBUG_UTILS_MESSAGE_SEVERITY_ERROR_BIT_EXT , messageType = DEBUG_UTILS_MESSAGE_TYPE_GENERAL_BIT_EXT - .|. DEBUG_UTILS_MESSAGE_TYPE_VALIDATION_BIT_EXT - .|. DEBUG_UTILS_MESSAGE_TYPE_PERFORMANCE_BIT_EXT + .|. DEBUG_UTILS_MESSAGE_TYPE_VALIDATION_BIT_EXT + .|. DEBUG_UTILS_MESSAGE_TYPE_PERFORMANCE_BIT_EXT , pfnUserCallback = debugCallbackPtr } _ <- withDebugUtilsMessengerEXT inst debugMessengerCreateInfo Nothing allocate @@ -437,9 +327,9 @@ createInstance = do createDevice :: (MonadResource m, MonadThrow m) => Instance - -> m (PhysicalDevice, PhysicalDeviceInfo, Device) + -> m (PhysicalDevice, Word32, Device) createDevice inst = do - mPd <- pickPhysicalDevice inst hasComputeQueue id + mPd <- pickPhysicalDevice inst hasComputeQueue id (_, phys) <- maybe (throwString "Unable to find appropriate PhysicalDevice") pure mPd @@ -457,7 +347,7 @@ createDevice inst = do phys zero { queueCreateInfos = SomeStruct <$> qInfos } Identity (QueueFamilyIndex computeFamilyIdx, _q) <- liftIO (getQs dev) - pure (phys, PhysicalDeviceInfo computeFamilyIdx, dev) + pure (phys, computeFamilyIdx, dev) where hasComputeQueue :: MonadIO m => PhysicalDevice -> m (Maybe Word64) hasComputeQueue phys = do @@ -467,10 +357,3 @@ createDevice inst = do heaps <- memoryHeaps <$> getPhysicalDeviceMemoryProperties phys pure (Just (sum (DI.size <$> heaps))) else pure Nothing - -newtype PhysicalDeviceInfo = PhysicalDeviceInfo - { pdiComputeQueueFamilyIndex :: Word32 - -- ^ The queue family index of the first compute queue - } - deriving (Eq, Ord) - diff --git a/examples/hlsl/Frame.hs b/examples/hlsl/Frame.hs deleted file mode 100644 index d925c91fa..000000000 --- a/examples/hlsl/Frame.hs +++ /dev/null @@ -1,183 +0,0 @@ --- | Defines the 'Frame' type, most interesting operations regarding 'Frame's --- can be found in 'MonadFrame' -module Frame where - -import Control.Monad ( replicateM_ - , unless - ) -import Control.Monad.IO.Class ( MonadIO(liftIO) ) -import Control.Monad.Trans.Reader ( asks ) -import Control.Monad.Trans.Resource ( InternalState - , ReleaseKey - , allocate - , closeInternalState - , createInternalState - , release - ) -import Data.Foldable -import Data.IORef -import Data.Vector ( Vector ) -import qualified Data.Vector as V -import Data.Word -import qualified Framebuffer -import MonadVulkan -import qualified Pipeline -import RefCounted -import RenderPass -import qualified SDL -import SDL ( Window ) -import qualified SDL.Video.Vulkan as SDL -import Swapchain -import UnliftIO.Exception ( throwString ) -import Vulkan.CStruct.Extends -import Vulkan.Core10 -import qualified Vulkan.Core10 as CommandPoolCreateInfo (CommandPoolCreateInfo(..)) -import Vulkan.Core12.Promoted_From_VK_KHR_timeline_semaphore -import Vulkan.Extensions.VK_KHR_surface -import Vulkan.Extensions.VK_KHR_surface as SurfaceFormatKHR (SurfaceFormatKHR(..)) -import Vulkan.Utils.QueueAssignment -import Vulkan.Zero - --- | Must be positive, duh -numConcurrentFrames :: Int -numConcurrentFrames = 3 - --- | All the information required to render a single frame -data Frame = Frame - { fIndex :: Word64 -- ^ Which number frame is this - -- SDL things - , fWindow :: SDL.Window - -- Vulkan things - , fSurface :: SurfaceKHR - , fSwapchainResources :: SwapchainResources - , fPipeline :: Pipeline - , fRenderPass :: RenderPass - , fFramebuffers :: Vector Framebuffer - , fReleaseFramebuffers :: RefCounted - , fRenderFinishedHostSemaphore :: Semaphore - -- ^ A timeline semaphore which increments to fIndex when this frame is - -- done, the host can wait on this semaphore - , fRecycledResources :: RecycledResources - -- ^ Resources which can be used for this frame and are then passed on to a - -- later frame. - , fGPUWork :: IORef [(Semaphore, Word64)] - -- ^ Timeline semaphores and corresponding wait values, updates as the - -- frame progresses. - , fResources :: (ReleaseKey, InternalState) - -- ^ The 'InternalState' for tracking frame-local resources along with the - -- key to release it in the global scope. This will be released when the - -- frame is done with GPU work. - } - -initialRecycledResources :: V RecycledResources -initialRecycledResources = do - (_, fImageAvailableSemaphore) <- withSemaphore' - (zero ::& SemaphoreTypeCreateInfo SEMAPHORE_TYPE_BINARY 0 :& ()) - - (_, fRenderFinishedSemaphore) <- withSemaphore' - (zero ::& SemaphoreTypeCreateInfo SEMAPHORE_TYPE_BINARY 0 :& ()) - - graphicsQueueFamilyIndex <- getGraphicsQueueFamilyIndex - (_, fCommandPool) <- withCommandPool' zero - { CommandPoolCreateInfo.queueFamilyIndex = unQueueFamilyIndex graphicsQueueFamilyIndex - } - - pure RecycledResources { .. } - -initialFrame :: Window -> SurfaceKHR -> V Frame -initialFrame fWindow fSurface = do - let fIndex = 1 - SDL.V2 width height <- SDL.vkGetDrawableSize fWindow - let windowSize = Extent2D (fromIntegral width) (fromIntegral height) - oldSwapchain = NULL_HANDLE - fSwapchainResources <- allocSwapchainResources oldSwapchain - windowSize - fSurface - - (_, fRenderPass) <- RenderPass.createRenderPass - (SurfaceFormatKHR.format (siSurfaceFormat (srInfo fSwapchainResources))) - - (fReleaseFramebuffers, fFramebuffers) <- createFramebuffers - fRenderPass - fSwapchainResources - - -- TODO: Cache this - -- TODO: Recreate this if the swapchain format changes - (_releasePipeline, fPipeline) <- Pipeline.createPipeline fRenderPass - - -- Don't keep the release key, this semaphore lives for the lifetime of the - -- application - (_, fRenderFinishedHostSemaphore) <- withSemaphore' - (zero ::& SemaphoreTypeCreateInfo SEMAPHORE_TYPE_TIMELINE 0 :& ()) - - bin <- V $ asks ghRecycleBin - replicateM_ (numConcurrentFrames - 1) - $ liftIO - . bin - =<< initialRecycledResources - fRecycledResources <- initialRecycledResources - - fGPUWork <- liftIO $ newIORef mempty - -- Create this resource object at the global level so it's closed correctly - -- on exception - fResources <- allocate createInternalState closeInternalState - - pure Frame { .. } - -createFramebuffers - :: RenderPass -> SwapchainResources -> V (RefCounted, Vector Framebuffer) -createFramebuffers renderPass SwapchainResources {..} = do - let SwapchainInfo {..} = srInfo - -- Also create a framebuffer for each one - (framebufferKeys, framebuffers) <- - fmap V.unzip . V.forM srImageViews $ \imageView -> - Framebuffer.createFramebuffer renderPass imageView siImageExtent - releaseFramebuffers <- newRefCounted (traverse_ release framebufferKeys) - pure (releaseFramebuffers, framebuffers) - --- | Create the next frame -advanceFrame :: Bool -> Frame -> V Frame -advanceFrame needsNewSwapchain f = do - -- Wait for a prior frame to finish, then we can steal it's resources! - nib <- V $ asks ghRecycleNib - -- Handle mvar indefinite timeout exception here: - -- https://github.com/expipiplus1/vulkan/issues/236 - fRecycledResources <- liftIO $ nib >>= \case - Left block -> block - Right rs -> pure rs - - (fSwapchainResources, fFramebuffers, fReleaseFramebuffers) <- - if needsNewSwapchain - then do - swapchainResources <- recreateSwapchainResources - (fWindow f) - (fSwapchainResources f) - unless - ( siSurfaceFormat (srInfo swapchainResources) - == siSurfaceFormat (srInfo swapchainResources) - ) - $ throwString "TODO: Handle swapchain changing formats" - releaseRefCounted (fReleaseFramebuffers f) - (releaseFramebuffers, framebuffers) <- createFramebuffers - (fRenderPass f) - swapchainResources - pure (swapchainResources, framebuffers, releaseFramebuffers) - else pure (fSwapchainResources f, fFramebuffers f, fReleaseFramebuffers f) - - -- The per-frame resource helpers need to be created fresh - fGPUWork <- liftIO $ newIORef mempty - fResources <- allocate createInternalState closeInternalState - - pure Frame { fIndex = succ (fIndex f) - , fWindow = fWindow f - , fSurface = fSurface f - , fSwapchainResources - , fFramebuffers - , fReleaseFramebuffers - , fRenderPass = fRenderPass f - , fPipeline = fPipeline f - , fRenderFinishedHostSemaphore = fRenderFinishedHostSemaphore f - , fGPUWork - , fResources - , fRecycledResources - } diff --git a/examples/hlsl/Init.hs b/examples/hlsl/Init.hs index e89a8ae41..d12636712 100644 --- a/examples/hlsl/Init.hs +++ b/examples/hlsl/Init.hs @@ -3,41 +3,30 @@ module Init ( Init.createInstance , Init.createDevice , createVMA - , createCommandPools ) where +import Control.Applicative ( empty ) import Control.Monad ( unless ) import Control.Monad.IO.Class import Control.Monad.Trans.Maybe ( MaybeT(..) ) import Control.Monad.Trans.Resource import qualified Data.Vector as V +import Data.Vector ( Vector ) import Data.Word -import HasVulkan import Say -import UnliftIO.Exception import Vulkan.Core12.Promoted_From_VK_KHR_timeline_semaphore import Vulkan.Extensions.VK_KHR_timeline_semaphore -import Control.Applicative -import Data.Foldable ( for_ ) -import Data.Vector ( Vector ) -import GHC.IO.Exception ( IOErrorType(NoSuchThing) - , IOException(IOError) - ) -import MonadVulkan ( Queues(..) - , checkCommands - ) import qualified SDL.Video as SDL +import Utils ( noSuchThing, (<&&>) ) +import VkResources ( Queues(..) ) +import qualified Vma import Vulkan.CStruct.Extends import Vulkan.Core10 as Vk hiding ( withBuffer , withImage ) -import qualified Vulkan.Core10 as CommandPoolCreateInfo (CommandPoolCreateInfo(..)) import qualified Vulkan.Core10 as MemoryHeap (MemoryHeap(..)) -import Vulkan.Dynamic ( DeviceCmds(DeviceCmds, pVkGetDeviceProcAddr) - , InstanceCmds(InstanceCmds, pVkGetInstanceProcAddr) - ) import Vulkan.Extensions.VK_KHR_get_physical_device_properties2 import Vulkan.Extensions.VK_KHR_surface import Vulkan.Extensions.VK_KHR_swapchain @@ -47,13 +36,8 @@ import Vulkan.Utils.Initialization import Vulkan.Utils.QueueAssignment import qualified Vulkan.Utils.Requirements.TH as U import Vulkan.Zero -import VulkanMemoryAllocator ( Allocator - , AllocatorCreateInfo(..) - , VulkanFunctions(..) - , withAllocator - ) +import VulkanMemoryAllocator ( Allocator ) import Window.SDL2 -import Foreign.Ptr (castFunPtr) myApiVersion :: Word32 myApiVersion = API_VERSION_1_0 @@ -102,8 +86,7 @@ createDevice inst win = do VK_KHR_timeline_semaphore PhysicalDeviceTimelineSemaphoreFeatures.timelineSemaphore |] - dev <- createDeviceFromRequirements reqs [] phys deviceCreateInfo - requireCommands inst dev + dev <- createDeviceFromRequirements reqs [] phys deviceCreateInfo queues <- liftIO $ pdiGetQueues pdi dev pure (phys, dev, queues, surf) @@ -145,17 +128,14 @@ physicalDeviceInfo surf phys = runMaybeT $ do (pdiQueueCreateInfos, pdiGetQueues) <- MaybeT $ assignQueues phys (queueRequirements phys surf) - -- - -- We'll use the amount of memory to pick the "best" device - -- + -- Score by total device memory. pdiTotalMemory <- do heaps <- memoryHeaps <$> getPhysicalDeviceMemoryProperties phys pure $ sum (MemoryHeap.size <$> heaps) pure PhysicalDeviceInfo { .. } --- | Requirements for a 'Queue' which has graphics suppor and can present to --- the specified surface. +-- | A graphics queue that can also present to the given surface. queueRequirements :: MonadIO m => PhysicalDevice -> SurfaceKHR -> Queues (QueueSpec m) queueRequirements phys surf = Queues (QueueSpec 1 isGraphicsPresentQueue) @@ -164,10 +144,6 @@ queueRequirements phys surf = Queues (QueueSpec 1 isGraphicsPresentQueue) pure (isGraphicsQueueFamily queueFamilyProperties) <&&> isPresentQueueFamily phys surf queueFamilyIndex ----------------------------------------------------------------- --- Physical device tools ----------------------------------------------------------------- - deviceHasSwapchain :: MonadIO m => PhysicalDevice -> m Bool deviceHasSwapchain dev = do (_, extensions) <- enumerateDeviceExtensionProperties dev Nothing @@ -184,9 +160,8 @@ deviceHasTimelineSemaphores phys = do hasFeat = do feats <- getPhysicalDeviceFeatures2KHR phys - let - _ ::& (PhysicalDeviceTimelineSemaphoreFeatures hasTimelineSemaphores :& ()) - = feats + let _ ::& (PhysicalDeviceTimelineSemaphoreFeatures hasTimelineSemaphores :& ()) + = feats pure hasTimelineSemaphores hasExt <&&> hasFeat @@ -197,62 +172,4 @@ deviceHasTimelineSemaphores phys = do createVMA :: MonadResource m => Instance -> PhysicalDevice -> Device -> m Allocator -createVMA inst phys dev = - snd - <$> withAllocator - zero - { flags = zero - , physicalDevice = physicalDeviceHandle phys - , device = deviceHandle dev - , instance' = instanceHandle inst - , vulkanApiVersion = myApiVersion - , vulkanFunctions = Just $ case inst of - Instance _ InstanceCmds {..} -> case dev of - Device _ DeviceCmds {..} -> zero - { vkGetInstanceProcAddr = castFunPtr pVkGetInstanceProcAddr - , vkGetDeviceProcAddr = castFunPtr pVkGetDeviceProcAddr - } - } - allocate - ----------------------------------------------------------------- --- Command pools ----------------------------------------------------------------- - --- | Create several command pools for a queue family -createCommandPools - :: MonadResource m - => Device - -> Int - -- ^ Number of pools to create - -> QueueFamilyIndex - -- ^ Queue family for the pools - -> m (Vector CommandPool) -createCommandPools dev n (QueueFamilyIndex queueFamilyIndex) = do - let commandPoolCreateInfo = zero { CommandPoolCreateInfo.queueFamilyIndex = queueFamilyIndex } - V.replicateM - n - ( snd - <$> withCommandPool dev - commandPoolCreateInfo - noAllocationCallbacks - allocate - ) - ----------------------------------------------------------------- --- Utils ----------------------------------------------------------------- - -requireCommands :: MonadIO f => Instance -> Device -> f () -requireCommands inst dev = case checkCommands inst dev of - [] -> pure () - xs -> do - for_ xs $ \n -> sayErr ("Failed to load function pointer for: " <> n) - noSuchThing "Missing commands" - -noSuchThing :: MonadIO m => String -> m a -noSuchThing message = - liftIO . throwIO $ IOError Nothing NoSuchThing "" message Nothing Nothing - -(<&&>) :: Applicative f => f Bool -> f Bool -> f Bool -(<&&>) = liftA2 (&&) +createVMA = Vma.createVMA zero myApiVersion diff --git a/examples/hlsl/Main.hs b/examples/hlsl/Main.hs index e0ba1c7a9..5a8aee4c6 100644 --- a/examples/hlsl/Main.hs +++ b/examples/hlsl/Main.hs @@ -1,18 +1,55 @@ +{-# LANGUAGE TypeApplications #-} + module Main where import Control.Monad.IO.Class import Control.Monad.Trans.Resource -import Frame -import Init -import MonadFrame -import MonadVulkan -import Render +import Data.Foldable ( traverse_ ) +import Data.IORef +import qualified Data.Vector as V +import Data.Vector ( Vector ) +import Frame ( Frame(..) + , advanceFrame + , initialFrame + , runFrame + ) +import qualified Framebuffer +import Init ( createDevice + , createInstance + , createVMA + ) +import RefCounted ( RefCounted + , newRefCounted + , releaseRefCounted + ) +import Render ( renderFrame ) +import qualified RenderPass import SDL ( showWindow , time ) -import Swapchain ( threwSwapchainError ) -import Utils -import Window.SDL2 +import qualified SDL +import qualified SDL.Video.Vulkan as SDL +import Swapchain ( Swapchain(..) + , allocSwapchain + , recreateSwapchain + , threwSwapchainError + ) +import Utils ( loopJust ) +import VkResources ( mkVkResources ) +import qualified Pipeline +import Vulkan.Core10 ( Device + , Extent2D(..) + , Framebuffer + , RenderPass + , pattern NULL_HANDLE + ) +import Vulkan.Extensions.VK_KHR_surface as SurfaceFormatKHR + ( SurfaceFormatKHR(..) ) +import Window.SDL2 ( RefreshLimit(..) + , createWindow + , shouldQuit + , withSDL + ) main :: IO () main = runResourceT $ do @@ -20,31 +57,72 @@ main = runResourceT $ do -- Initialization -- withSDL - win <- createWindow "Vulkan 🚀 Haskell" 1280 720 + win <- createWindow "Vulkan 🚀 Haskell" 1280 720 inst <- Init.createInstance win (phys, dev, qs, surf) <- Init.createDevice inst win vma <- createVMA inst phys dev + vr <- liftIO $ mkVkResources inst phys dev vma qs - -- - -- Go - -- - start <- SDL.time @Double - let reportFPS f = do + -- Initial swapchain + initialSize <- liftIO $ drawableSize win + initialSC <- allocSwapchain vr NULL_HANDLE initialSize surf + (_, renderPass) <- RenderPass.createRenderPass dev (SurfaceFormatKHR.format (sFormat initialSC)) + (_, pipeline) <- Pipeline.createPipeline dev renderPass + initialFBs <- createFramebuffers dev renderPass initialSC + + scRef <- liftIO $ newIORef initialSC + fbsRef <- liftIO $ newIORef initialFBs + + initial <- initialFrame vr initialSC + + showWindow win + start <- SDL.time @Double + + let + perFrame f = do + currentSC <- liftIO $ readIORef scRef + (currentFBs, _rel) <- liftIO $ readIORef fbsRef + let f' = f { fSwapchain = currentSC } + needsNew <- threwSwapchainError $ liftIO $ runFrame vr f' $ + renderFrame vr renderPass pipeline currentFBs f' + sc' <- if needsNew + then do + newSize <- liftIO $ drawableSize win + sc' <- recreateSwapchain vr newSize currentSC + newFBs <- createFramebuffers dev renderPass sc' + (_oldFbs, oldRel) <- liftIO $ readIORef fbsRef + releaseRefCounted oldRel + liftIO $ writeIORef scRef sc' + liftIO $ writeIORef fbsRef newFBs + pure sc' + else pure currentSC + advanceFrame vr sc' f' + + loop f = shouldQuit (TimeLimit 6) >>= \case + True -> do end <- SDL.time - let frames = fIndex f - mean = realToFrac frames / (end - start) - liftIO $ putStrLn $ "Average: " <> show mean - - let frame f = do - shouldQuit (TimeLimit 6) >>= \case - True -> do - reportFPS f - pure Nothing - False -> Just <$> do - needsNewSwapchain <- threwSwapchainError (runFrame f renderFrame) - advanceFrame needsNewSwapchain f - - runV inst phys dev qs vma $ do - initial <- initialFrame win surf - showWindow win - loopJust frame initial + let fps = realToFrac (fIndex f) / (end - start) :: Double + liftIO $ putStrLn $ "Average: " <> show fps + pure Nothing + False -> Just <$> perFrame f + + loopJust loop initial + +drawableSize :: SDL.Window -> IO Extent2D +drawableSize win = do + SDL.V2 w h <- SDL.vkGetDrawableSize win + pure $ Extent2D (fromIntegral w) (fromIntegral h) + +-- | Build a framebuffer per swapchain image; bundle a 'RefCounted' that +-- frees them all when no in-flight frame still uses them. +createFramebuffers + :: MonadResource m + => Device + -> RenderPass + -> Swapchain + -> m (Vector Framebuffer, RefCounted) +createFramebuffers dev rp sc = do + (keys, fbs) <- fmap V.unzip . V.forM (sImageViews sc) $ \iv -> + Framebuffer.createFramebuffer dev rp iv (sExtent sc) + rel <- newRefCounted (traverse_ release keys) + pure (fbs, rel) diff --git a/examples/hlsl/MonadFrame.hs b/examples/hlsl/MonadFrame.hs deleted file mode 100644 index 1d73007f1..000000000 --- a/examples/hlsl/MonadFrame.hs +++ /dev/null @@ -1,164 +0,0 @@ -module MonadFrame - ( F - , runFrame - , liftV - , queueSubmitFrame - , allocateGlobal - , allocateGlobal_ - , frameRefCount - , askFrame - , asksFrame - ) where - - -import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Trans.Class ( lift ) -import Control.Monad.Trans.Reader ( ReaderT - , ask - , asks - , runReaderT - ) -import Control.Monad.Trans.Resource -import qualified Data.Vector as V -import Data.Vector ( Vector ) -import Data.Word -import Frame -import GHC.IO.Exception ( IOErrorType(TimeExpired) - , IOException(IOError) - ) -import HasVulkan -import MonadVulkan -import RefCounted -import UnliftIO -import Vulkan.CStruct.Extends ( SomeStruct ) -import Vulkan.Core10 -import Vulkan.Core12.Promoted_From_VK_KHR_timeline_semaphore -import Vulkan.NamedType -import Vulkan.Zero ( Zero(zero) ) - -newtype F a = F {unF :: ReaderT Frame V a } - deriving newtype ( Functor - , Applicative - , Monad - , MonadFail - , MonadIO - , HasVulkan - ) - -instance MonadUnliftIO F where - withRunInIO a = F $ withRunInIO (\r -> a (r . unF)) - ----------------------------------------------------------------- --- Vulkan Operations ----------------------------------------------------------------- - --- | Runs a frame and spawns a thread to wait for the GPU work to complete, at --- which point the frame-specific resources are collected. -runFrame :: Frame -> F a -> V a -runFrame f@Frame {..} (F r) = runReaderT r f `finally` do - waits <- liftIO $ readIORef fGPUWork - let oneSecond = 1e9 -- one second - spawn_ $ do - -- Wait for the GPU work to finish (if we have any) - unless (null waits) $ do - let waitInfo = zero { semaphores = V.fromList (fst <$> waits) - , values = V.fromList (snd <$> waits) - } - waitTwice waitInfo oneSecond >>= \case - TIMEOUT -> - timeoutError "Timed out (1s) waiting for frame to finish on Device" - _ -> pure () - - -- Free resources wanted elsewhere now, all those in RecycledResources - resetCommandPool' (fCommandPool fRecycledResources) - COMMAND_POOL_RESET_RELEASE_RESOURCES_BIT - - -- Signal we're done by making the recycled resources available - bin <- V $ asks ghRecycleBin - liftIO $ bin fRecycledResources - - -- Destroy frame-specific resources at our leisure - retireFrame f - --- | 'queueSubmit' and add wait for the 'Fence' before retiring the frame. -queueSubmitFrame - :: Queue -> Vector (SomeStruct SubmitInfo) -> Semaphore -> Word64 -> F () -queueSubmitFrame q ss sem value = do - gpuWork <- asksFrame fGPUWork - -- Make sure we don't get interrupted between submitting the work and - -- recording the wait - mask $ \_ -> do - queueSubmit q ss NULL_HANDLE - liftIO $ atomicModifyIORef' gpuWork ((, ()) . ((sem, value) :)) - -liftV :: V a -> F a -liftV = F . lift - ----------------------------------------------------------------- --- Resource handling ----------------------------------------------------------------- - --- | By default resources allocated will only last until the frame is retired, --- i.e. the GPU work is complete. --- --- To allocate something globally use 'allocateGlobal' -instance MonadResource F where - liftResourceT r = do - i <- asksFrame (snd . fResources) - liftIO $ runInternalState r i - --- | Allocate a resource in the 'V' scope -allocateGlobal - :: F a - -- ^ Create to be calle dnow - -> (a -> F ()) - -- ^ Destroy, to be called at program termination - -> F (ReleaseKey, a) -allocateGlobal create destroy = do - createIO <- toIO create - run <- askRunInIO - F $ allocate createIO (run . destroy) - --- | c.f. 'bracket' and 'bracket_' -allocateGlobal_ :: F a -> F () -> F (ReleaseKey, a) -allocateGlobal_ create destroy = allocateGlobal create (const destroy) - --- | Free frame resources, the frame must have finished GPU execution first. -retireFrame :: MonadIO m => Frame -> m () -retireFrame Frame {..} = release (fst fResources) - --- | Make sure a reference is held until this frame is retired -frameRefCount :: RefCounted -> F () -frameRefCount = resourceTRefCount - ----------------------------------------------------------------- --- Small Operations ----------------------------------------------------------------- - --- | Get the current 'Frame' -askFrame :: F Frame -askFrame = F ask - --- | Get a function of the current 'Frame' -asksFrame :: (Frame -> a) -> F a -asksFrame = F . asks - ----------------------------------------------------------------- --- Utils ----------------------------------------------------------------- - --- | Wait for some semaphores, if the wait times out give the frame one last --- chance to complete with a zero timeout. --- --- It could be that the program was suspended during the preceding --- wait causing it to timeout, this will check if it actually --- finished. -waitTwice :: SemaphoreWaitInfo -> ("timeout" ::: Word64) -> V Result -waitTwice waitInfo t = waitSemaphoresSafe' waitInfo t >>= \case - TIMEOUT -> waitSemaphores' waitInfo 0 - r -> pure r - -timeoutError :: MonadIO m => String -> m a -timeoutError message = - liftIO . throwIO $ IOError Nothing TimeExpired "" message Nothing Nothing diff --git a/examples/hlsl/MonadVulkan.hs b/examples/hlsl/MonadVulkan.hs deleted file mode 100644 index d52fc76ac..000000000 --- a/examples/hlsl/MonadVulkan.hs +++ /dev/null @@ -1,272 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -Wno-missing-signatures #-} - -module MonadVulkan where - -import AutoApply -import Control.Concurrent.Chan.Unagi -import Control.Concurrent.MVar -import Control.Monad ( replicateM - , void - ) -import Control.Monad.IO.Class -import Control.Monad.Trans.Reader -import Control.Monad.Trans.Resource -import Data.ByteString ( ByteString ) -import Data.List ( isSuffixOf ) -import HasVulkan -import Language.Haskell.TH -import Language.Haskell.TH.Syntax ( addTopDecls ) -import OpenTelemetry.Eventlog ( beginSpan - , endSpan - ) -import UnliftIO ( Async - , MonadUnliftIO(withRunInIO) - , asyncWithUnmask - , mask - , toIO - , uninterruptibleCancel - ) -import UnliftIO.Exception ( bracket ) -import Vulkan.CStruct.Extends -import Vulkan.Core10 as Vk - hiding ( withBuffer - , withImage - ) -import Vulkan.Core12.Promoted_From_VK_KHR_timeline_semaphore - as Timeline -import Vulkan.Extensions.VK_KHR_surface -import Vulkan.Extensions.VK_KHR_swapchain -import Vulkan.Utils.CommandCheck -import Vulkan.Utils.QueueAssignment -import VulkanMemoryAllocator as VMA - hiding ( getPhysicalDeviceProperties ) - ----------------------------------------------------------------- --- Define the monad in which most of the program will run ----------------------------------------------------------------- - --- | @V@ keeps track of a bunch of "global" handles and performs resource --- management. -newtype V a = V { unV :: ReaderT GlobalHandles (ResourceT IO) a } - deriving newtype ( Functor - , Applicative - , Monad - , MonadFail - , MonadIO - , MonadResource - ) - -instance MonadUnliftIO V where - withRunInIO a = V $ withRunInIO (\r -> a (r . unV)) - -newtype CmdT m a = CmdT { unCmdT :: ReaderT CommandBuffer m a } - deriving newtype ( Functor - , Applicative - , Monad - , MonadIO - , MonadResource - , HasVulkan - ) - -instance MonadUnliftIO m => MonadUnliftIO (CmdT m) where - withRunInIO a = CmdT $ withRunInIO (\r -> a (r . unCmdT)) - -instance HasVulkan V where - getInstance = V (asks ghInstance) - getGraphicsQueue = V (asks (snd . graphicsQueue . ghQueues)) - getPhysicalDevice = V (asks ghPhysicalDevice) - getDevice = V (asks ghDevice) - getAllocator = V (asks ghAllocator) - -getGraphicsQueueFamilyIndex :: V QueueFamilyIndex -getGraphicsQueueFamilyIndex = V (asks (fst . graphicsQueue . ghQueues)) - -getCommandBuffer :: Monad m => CmdT m CommandBuffer -getCommandBuffer = CmdT ask - -useCommandBuffer' - :: forall a m r - . ( Extendss CommandBufferBeginInfo a - , PokeChain a - , MonadIO m - , MonadUnliftIO m - ) - => CommandBuffer - -> CommandBufferBeginInfo a - -> CmdT m r - -> m r -useCommandBuffer' commandBuffer beginInfo (CmdT a) = - useCommandBuffer commandBuffer beginInfo (runReaderT a commandBuffer) - -runV - :: Instance - -> PhysicalDevice - -> Device - -> Queues (QueueFamilyIndex, Queue) - -> Allocator - -> V a - -> ResourceT IO a -runV ghInstance ghPhysicalDevice ghDevice ghQueues ghAllocator v = do - (bin, nib) <- liftIO newChan - let ghRecycleBin = writeChan bin - ghRecycleNib = do - (try, block) <- tryReadChan nib - maybe (Left block) Right <$> tryRead try - - flip runReaderT GlobalHandles { .. } . unV $ v - --- | A bunch of global, unchanging state we cart around -data GlobalHandles = GlobalHandles - { ghInstance :: Instance - , ghPhysicalDevice :: PhysicalDevice - , ghDevice :: Device - , ghAllocator :: Allocator - , ghQueues :: Queues (QueueFamilyIndex, Queue) - , ghRecycleBin :: RecycledResources -> IO () - -- ^ Filled with resources which aren't destroyed after finishing a frame, - -- but instead are used by another frame which executes after that one is - -- retired, (taken from ghRecycleNib) - -- - -- Make sure not to pass any resources which were created with a frame-only - -- scope however! - , ghRecycleNib :: IO (Either (IO RecycledResources) RecycledResources) - -- ^ The resources of prior frames waiting to be taken - } - --- | These are resources which are reused by a later frame when the current --- frame is retired -data RecycledResources = RecycledResources - { fImageAvailableSemaphore :: Semaphore - -- ^ A binary semaphore passed to 'acquireNextImageKHR' - , fRenderFinishedSemaphore :: Semaphore - -- ^ A binary semaphore to synchronize rendering and presenting - , fCommandPool :: CommandPool - -- ^ Pool for this frame's commands (might want more than one of these for - -- multithreaded recording) - } - --- | The shape of all the queues we use for our program, parameterized over the --- queue type so we can use it with 'Vulkan.Utils.QueueAssignment.assignQueues' -newtype Queues q = Queues { graphicsQueue :: q } - deriving (Functor, Foldable, Traversable) - ----------------------------------------------------------------- --- Helpers ----------------------------------------------------------------- - --- Start an async thread which will be cancelled at the end of the ResourceT --- block -spawn :: V a -> V (Async a) -spawn a = do - aIO <- toIO a - -- If we don't remove the release key when the thread is done it'll leak, - -- remove it at the end of the async action when the thread is going to die - -- anyway. - -- - -- Mask this so there's no chance we're inturrupted before writing the mvar. - kv <- liftIO newEmptyMVar - UnliftIO.mask $ \_ -> do - (k, r) <- allocate - (asyncWithUnmask - (\unmask -> unmask $ aIO <* (unprotect =<< liftIO (readMVar kv))) - ) - uninterruptibleCancel - liftIO $ putMVar kv k - pure r - -spawn_ :: V () -> V () -spawn_ = void . spawn - --- Profiling span -withSpan_ :: MonadUnliftIO m => ByteString -> m c -> m c -withSpan_ n x = bracket (beginSpan n) endSpan (const x) - ----------------------------------------------------------------- --- Commands ----------------------------------------------------------------- - --- --- Wrap a bunch of Vulkan commands so that they automatically pull global --- handles from any `HasVulkan` instance. --- --- Wrapped functions are suffixed with "'" --- -do - let vmaCommands = - [ 'withBuffer - , 'invalidateAllocation - ] - commands = - [ 'acquireNextImageKHRSafe - , 'allocateDescriptorSets - , 'cmdBindDescriptorSets - , 'cmdBindPipeline - , 'cmdDispatch - , 'cmdDraw - , 'cmdPushConstants - , 'cmdSetScissor - , 'cmdSetViewport - , 'cmdUseRenderPass - , 'deviceWaitIdle - , 'deviceWaitIdleSafe - , 'getDeviceQueue - , 'getPhysicalDeviceSurfaceCapabilitiesKHR - , 'getPhysicalDeviceSurfaceFormatsKHR - , 'getPhysicalDeviceSurfacePresentModesKHR - , 'getSwapchainImagesKHR - , 'resetCommandPool - , 'updateDescriptorSets - , 'waitForFences - , 'waitForFencesSafe - , 'Timeline.waitSemaphores - , 'Timeline.waitSemaphoresSafe - , 'withCommandBuffers - , 'withCommandPool - , 'withComputePipelines - , 'withDescriptorPool - , 'withDescriptorSetLayout - , 'withFence - , 'withFramebuffer - , 'withGraphicsPipelines - , 'withImageView - , 'withInstance - , 'withPipelineLayout - , 'withRenderPass - , 'withSemaphore - , 'withShaderModule - , 'withSwapchainKHR - ] - addTopDecls =<< [d|checkCommands = $(checkCommandsExp commands)|] - ds <- autoapplyDecs - (<> "''") - [ 'getDevice - , 'getPhysicalDevice - , 'getInstance - , 'getAllocator - , 'noAllocationCallbacks - , 'getCommandBuffer - ] - -- Allocate doesn't subsume the continuation type on the "with" commands, so - -- put it in the unifying group. - ['allocate] - (vmaCommands <> commands) - -- TODO: neaten this! - ds' <- concat <$> sequenceA [ case d of - FunD n [Clause ps (NormalB o) _ ] - | b <- nameBase n - , "''" `isSuffixOf` b - -> do - let n' = mkName (init b) - vkName = init (init b) - eArity = \case - LamE ls e -> length ls + eArity e - _ -> 0 - arity = length ps + eArity o - vs <- replicateM arity (newName "x") - e <- [|withSpan_ $(litE (StringL vkName)) $(foldl appE (varE n) (varE <$> vs))|] - pure [FunD n' [Clause (VarP <$> vs) (NormalB e) []]] - _ -> pure [d] - | d <- ds - ] - pure (ds <> ds') diff --git a/examples/hlsl/Pipeline.hs b/examples/hlsl/Pipeline.hs index b8752719b..29b30acec 100644 --- a/examples/hlsl/Pipeline.hs +++ b/examples/hlsl/Pipeline.hs @@ -4,127 +4,96 @@ module Pipeline ( createPipeline - , Pipeline.createRenderPass ) where import Control.Monad.Trans.Resource import Data.Bits -import Data.Foldable ( traverse_ ) -import qualified Data.Vector as V -import MonadVulkan +import Data.Foldable ( traverse_ ) +import qualified Data.Vector as V import Vulkan.CStruct.Extends -import Vulkan.Core10 as Vk - hiding ( withBuffer - , withImage - ) -import Vulkan.Utils.ShaderQQ.HLSL.Shaderc ( vert - , frag ) +import Vulkan.Core10 as Vk + hiding ( withBuffer + , withImage + ) +import Vulkan.Utils.ShaderQQ.HLSL.Shaderc + ( frag + , vert + ) import Vulkan.Zero --- Create the most vanilla rendering pipeline -createPipeline :: RenderPass -> V (ReleaseKey, Pipeline) -createPipeline renderPass = do - (shaderKeys, shaderStages ) <- V.unzip <$> createShaders - (layoutKey , pipelineLayout) <- withPipelineLayout' zero - let - pipelineCreateInfo :: GraphicsPipelineCreateInfo '[] - pipelineCreateInfo = zero - { stages = shaderStages - , vertexInputState = Just zero - , inputAssemblyState = Just zero - { topology = PRIMITIVE_TOPOLOGY_TRIANGLE_LIST - , primitiveRestartEnable = False - } - , viewportState = Just - $ SomeStruct zero { viewportCount = 1, scissorCount = 1 } - , rasterizationState = Just . SomeStruct $ zero - { depthClampEnable = False - , rasterizerDiscardEnable = False - , lineWidth = 1 - , polygonMode = POLYGON_MODE_FILL - , cullMode = CULL_MODE_NONE - , frontFace = FRONT_FACE_CLOCKWISE - , depthBiasEnable = False - } - , multisampleState = Just . SomeStruct $ zero - { sampleShadingEnable = False - , rasterizationSamples = SAMPLE_COUNT_1_BIT - , minSampleShading = 1 - , sampleMask = [maxBound] - } - , depthStencilState = Nothing - , colorBlendState = Just . SomeStruct $ zero - { logicOpEnable = False - , attachments = [ zero - { colorWriteMask = - COLOR_COMPONENT_R_BIT - .|. COLOR_COMPONENT_G_BIT - .|. COLOR_COMPONENT_B_BIT - .|. COLOR_COMPONENT_A_BIT - , blendEnable = False - } - ] - } - , dynamicState = Just zero - { dynamicStates = [ DYNAMIC_STATE_VIEWPORT - , DYNAMIC_STATE_SCISSOR - ] - } - , layout = pipelineLayout - , renderPass = renderPass - , subpass = 0 - , basePipelineHandle = zero - } - (key, (_, ~[graphicsPipeline])) <- withGraphicsPipelines' +-- | The most vanilla rendering pipeline; draws three vertices. +createPipeline + :: (MonadResource m, MonadFail m) + => Device + -> RenderPass + -> m (ReleaseKey, Pipeline) +createPipeline dev renderPass = do + (shaderKeys, shaderStages) <- V.unzip <$> createShaders dev + (layoutKey , pipelineLayout) <- withPipelineLayout dev zero Nothing allocate + let pipelineCreateInfo :: GraphicsPipelineCreateInfo '[] + pipelineCreateInfo = zero + { stages = shaderStages + , vertexInputState = Just zero + , inputAssemblyState = Just zero + { topology = PRIMITIVE_TOPOLOGY_TRIANGLE_LIST + , primitiveRestartEnable = False + } + , viewportState = Just + $ SomeStruct zero { viewportCount = 1, scissorCount = 1 } + , rasterizationState = Just . SomeStruct $ zero + { depthClampEnable = False + , rasterizerDiscardEnable = False + , lineWidth = 1 + , polygonMode = POLYGON_MODE_FILL + , cullMode = CULL_MODE_NONE + , frontFace = FRONT_FACE_CLOCKWISE + , depthBiasEnable = False + } + , multisampleState = Just . SomeStruct $ zero + { sampleShadingEnable = False + , rasterizationSamples = SAMPLE_COUNT_1_BIT + , minSampleShading = 1 + , sampleMask = [maxBound] + } + , depthStencilState = Nothing + , colorBlendState = Just . SomeStruct $ zero + { logicOpEnable = False + , attachments = + [ zero + { colorWriteMask = + COLOR_COMPONENT_R_BIT + .|. COLOR_COMPONENT_G_BIT + .|. COLOR_COMPONENT_B_BIT + .|. COLOR_COMPONENT_A_BIT + , blendEnable = False + } + ] + } + , dynamicState = Just zero + { dynamicStates = [ DYNAMIC_STATE_VIEWPORT + , DYNAMIC_STATE_SCISSOR + ] + } + , layout = pipelineLayout + , renderPass = renderPass + , subpass = 0 + , basePipelineHandle = zero + } + (key, (_, ~[graphicsPipeline])) <- withGraphicsPipelines + dev zero [SomeStruct pipelineCreateInfo] + Nothing + allocate release layoutKey traverse_ release shaderKeys pure (key, graphicsPipeline) --- | Create a renderpass with a single subpass -createRenderPass :: Format -> V (ReleaseKey, RenderPass) -createRenderPass imageFormat = do - let - attachmentDescription :: AttachmentDescription - attachmentDescription = zero - { format = imageFormat - , samples = SAMPLE_COUNT_1_BIT - , loadOp = ATTACHMENT_LOAD_OP_CLEAR - , storeOp = ATTACHMENT_STORE_OP_STORE - , stencilLoadOp = ATTACHMENT_LOAD_OP_DONT_CARE - , stencilStoreOp = ATTACHMENT_STORE_OP_DONT_CARE - , initialLayout = IMAGE_LAYOUT_UNDEFINED - , finalLayout = IMAGE_LAYOUT_PRESENT_SRC_KHR - } - subpass :: SubpassDescription - subpass = zero - { pipelineBindPoint = PIPELINE_BIND_POINT_GRAPHICS - , colorAttachments = - [ zero { attachment = 0 - , layout = IMAGE_LAYOUT_COLOR_ATTACHMENT_OPTIMAL - } - ] - } - subpassDependency :: SubpassDependency - subpassDependency = zero - { srcSubpass = SUBPASS_EXTERNAL - , dstSubpass = 0 - , srcStageMask = PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT - , srcAccessMask = zero - , dstStageMask = PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT - , dstAccessMask = ACCESS_COLOR_ATTACHMENT_READ_BIT - .|. ACCESS_COLOR_ATTACHMENT_WRITE_BIT - } - withRenderPass' zero { attachments = [attachmentDescription] - , subpasses = [subpass] - , dependencies = [subpassDependency] - } - --- | Create a vertex and fragment shader which render a colored triangle createShaders - :: V (V.Vector (ReleaseKey, SomeStruct PipelineShaderStageCreateInfo)) -createShaders = do + :: MonadResource m + => Device + -> m (V.Vector (ReleaseKey, SomeStruct PipelineShaderStageCreateInfo)) +createShaders dev = do let fragCode = [frag| float4 main([[vk::location(0)]] const float3 col) : SV_TARGET { @@ -158,8 +127,8 @@ createShaders = do return output; } |] - (fragKey, fragModule) <- withShaderModule' zero { code = fragCode } - (vertKey, vertModule) <- withShaderModule' zero { code = vertCode } + (fragKey, fragModule) <- withShaderModule dev zero { code = fragCode } Nothing allocate + (vertKey, vertModule) <- withShaderModule dev zero { code = vertCode } Nothing allocate let vertShaderStageCreateInfo = zero { stage = SHADER_STAGE_VERTEX_BIT , module' = vertModule , name = "main" diff --git a/examples/hlsl/Render.hs b/examples/hlsl/Render.hs index 88c53a692..6ba5acadf 100644 --- a/examples/hlsl/Render.hs +++ b/examples/hlsl/Render.hs @@ -6,19 +6,25 @@ module Render import Control.Exception ( throwIO ) import Control.Monad.IO.Class -import Data.Vector ( (!) ) -import Data.Word -import Frame +import Control.Monad.Trans.Resource ( ResourceT + , allocate + ) +import Data.Vector ( (!), Vector ) +import Frame ( Frame(..) + , queueSubmitFrame + ) import GHC.IO.Exception ( IOErrorType(TimeExpired) , IOException(IOError) ) -import HasVulkan -import MonadFrame -import MonadVulkan -import Swapchain -import UnliftIO ( MonadUnliftIO ) +import RefCounted ( resourceTRefCount ) +import Swapchain ( Swapchain(..) ) import UnliftIO.Exception ( throwString ) +import VkResources ( Queues(..) + , RecycledResources(..) + , VkResources(..) + ) import Vulkan.CStruct.Extends +import Vulkan.Exception ( VulkanException(..) ) import Vulkan.Core10 as Core10 import qualified Vulkan.Core10 as CommandBufferBeginInfo (CommandBufferBeginInfo(..)) import qualified Vulkan.Core10 as Extent2D (Extent2D(..)) @@ -27,98 +33,102 @@ import Vulkan.Extensions.VK_KHR_swapchain as Swap import Vulkan.Zero -renderFrame :: F () -renderFrame = do - f@Frame {..} <- askFrame - let RecycledResources {..} = fRecycledResources - let oneSecond = 1e9 - SwapchainResources {..} = fSwapchainResources - SwapchainInfo {..} = srInfo +-- | Acquire an image, record a clear+draw, submit, and present. +renderFrame + :: VkResources + -> RenderPass + -> Pipeline + -> Vector Framebuffer + -> Frame + -> ResourceT IO () +renderFrame vr renderPass pipeline framebuffers f = do + let RecycledResources {..} = fRecycled f + sc = fSwapchain f + dev = vrDevice vr + Queues (_, gQ) = vrQueues vr + oneSecond = 1e9 - -- Ensure that the swapchain survives for the duration of this frame - frameRefCount srRelease - frameRefCount fReleaseFramebuffers + -- Hold a refcount on the swapchain release group so it survives this frame + -- if the window resizes mid-flight. + resourceTRefCount (sRelease sc) - -- Make sure we'll have an image to render to - imageIndex <- - acquireNextImageKHRSafe' siSwapchain - oneSecond - fImageAvailableSemaphore - NULL_HANDLE + -- Acquire next image. + (acquireResult, imageIndex) <- + acquireNextImageKHRSafe dev (sSwapchain sc) oneSecond rrImageAvailable NULL_HANDLE >>= \case - (SUCCESS, imageIndex) -> pure imageIndex - (TIMEOUT, _) -> - timeoutError "Timed out (1s) trying to acquire next image" - _ -> throwString "Unexpected Result from acquireNextImageKHR" + r@(SUCCESS, _) -> pure r + r@(SUBOPTIMAL_KHR, _) -> pure r + (TIMEOUT, _) -> timeoutError "Timed out (1s) acquiring next image" + _ -> throwString "Unexpected Result from acquireNextImageKHR" + + -- Allocate a per-frame command buffer from the recycled pool. + (_, ~[commandBuffer]) <- withCommandBuffers + dev + zero { commandPool = rrCommandPool + , level = COMMAND_BUFFER_LEVEL_PRIMARY + , commandBufferCount = 1 + } + allocate - -- Allocate a command buffer and populate it - let commandBufferAllocateInfo = zero { commandPool = fCommandPool - , level = COMMAND_BUFFER_LEVEL_PRIMARY - , commandBufferCount = 1 - } - (_, ~[commandBuffer]) <- withCommandBuffers' commandBufferAllocateInfo - useCommandBuffer' commandBuffer - zero { CommandBufferBeginInfo.flags = COMMAND_BUFFER_USAGE_ONE_TIME_SUBMIT_BIT } - $ myRecordCommandBuffer f imageIndex + let renderPassBeginInfo = zero + { renderPass = renderPass + , framebuffer = framebuffers ! fromIntegral imageIndex + , renderArea = Rect2D { offset = zero, extent = sExtent sc } + , clearValues = [Color (Float32 0.3 0.4 0.8 1)] + } + + useCommandBuffer + commandBuffer + zero { CommandBufferBeginInfo.flags = COMMAND_BUFFER_USAGE_ONE_TIME_SUBMIT_BIT } + $ do + cmdUseRenderPass commandBuffer renderPassBeginInfo SUBPASS_CONTENTS_INLINE + $ do + cmdSetViewport commandBuffer + 0 + [ Viewport + { x = 0 + , y = 0 + , width = realToFrac (Extent2D.width (sExtent sc)) + , height = realToFrac (Extent2D.height (sExtent sc)) + , minDepth = 0 + , maxDepth = 1 + } + ] + cmdSetScissor commandBuffer + 0 + [Rect2D { offset = Offset2D 0 0, extent = sExtent sc }] + cmdBindPipeline commandBuffer PIPELINE_BIND_POINT_GRAPHICS pipeline + cmdDraw commandBuffer 3 1 0 0 - -- Submit the work - let -- Wait for the 'imageAvailableSemaphore' before outputting to the color - -- attachment - submitInfo = - zero - { Core10.waitSemaphores = [fImageAvailableSemaphore] - , waitDstStageMask = [PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT] - , commandBuffers = [commandBufferHandle commandBuffer] - , signalSemaphores = [ fRenderFinishedSemaphore - , fRenderFinishedHostSemaphore - ] - } - ::& zero { waitSemaphoreValues = [1] - , signalSemaphoreValues = [1, fIndex] - } - :& () - graphicsQueue <- getGraphicsQueue - queueSubmitFrame graphicsQueue - [SomeStruct submitInfo] - fRenderFinishedHostSemaphore - fIndex + let submitInfo = + zero { Core10.waitSemaphores = [rrImageAvailable] + , waitDstStageMask = [PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT] + , commandBuffers = [commandBufferHandle commandBuffer] + , signalSemaphores = [rrRenderFinished, fHostTimeline f] + } + ::& zero { waitSemaphoreValues = [1] + , signalSemaphoreValues = [1, fIndex f] + } + :& () + liftIO $ queueSubmitFrame gQ + f + [SomeStruct submitInfo] + (fHostTimeline f) + (fIndex f) - -- Present the frame when the render is finished - -- The return code here could be SUBOPTIMAL_KHR - -- TODO, check for that - _ <- queuePresentKHR - graphicsQueue - zero { Swap.waitSemaphores = [fRenderFinishedSemaphore] - , swapchains = [siSwapchain] + presentResult <- queuePresentKHR + gQ + zero { Swap.waitSemaphores = [rrRenderFinished] + , swapchains = [sSwapchain sc] , imageIndices = [imageIndex] } - pure () --- | Clear and render a triangle -myRecordCommandBuffer :: MonadUnliftIO m => Frame -> Word32 -> CmdT m () -myRecordCommandBuffer Frame {..} imageIndex = do - let SwapchainResources {..} = fSwapchainResources - SwapchainInfo {..} = srInfo - renderPassBeginInfo = zero - { renderPass = fRenderPass - , framebuffer = fFramebuffers ! fromIntegral imageIndex - , renderArea = Rect2D { offset = zero, extent = siImageExtent } - , clearValues = [Color (Float32 0.3 0.4 0.8 1)] - } - cmdUseRenderPass' renderPassBeginInfo SUBPASS_CONTENTS_INLINE $ do - cmdSetViewport' - 0 - [ Viewport { x = 0 - , y = 0 - , width = realToFrac (Extent2D.width siImageExtent) - , height = realToFrac (Extent2D.height siImageExtent) - , minDepth = 0 - , maxDepth = 1 - } - ] - cmdSetScissor' 0 [Rect2D { offset = Offset2D 0 0, extent = siImageExtent }] - cmdBindPipeline' PIPELINE_BIND_POINT_GRAPHICS fPipeline - cmdDraw' 3 1 0 0 + -- Surface either reported SUBOPTIMAL on acquire or present — bubble it up + -- as an OUT_OF_DATE so the main loop will recreate the swapchain. + case (acquireResult, presentResult) of + (SUBOPTIMAL_KHR, _) -> liftIO . throwIO $ VulkanException ERROR_OUT_OF_DATE_KHR + (_, SUBOPTIMAL_KHR) -> liftIO . throwIO $ VulkanException ERROR_OUT_OF_DATE_KHR + _ -> pure () ---------------------------------------------------------------- -- Utils diff --git a/examples/hlsl/RenderPass.hs b/examples/hlsl/RenderPass.hs index 0e083fa73..8afb0246a 100644 --- a/examples/hlsl/RenderPass.hs +++ b/examples/hlsl/RenderPass.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedLists #-} module RenderPass @@ -8,48 +6,51 @@ module RenderPass import Control.Monad.Trans.Resource import Data.Bits -import MonadVulkan import Vulkan.Core10 as Vk hiding ( withBuffer , withImage ) import Vulkan.Zero --- | Create a renderpass with a single subpass -createRenderPass :: Format -> V (ReleaseKey, RenderPass) -createRenderPass imageFormat = do - let - attachmentDescription :: AttachmentDescription - attachmentDescription = zero - { format = imageFormat - , samples = SAMPLE_COUNT_1_BIT - , loadOp = ATTACHMENT_LOAD_OP_CLEAR - , storeOp = ATTACHMENT_STORE_OP_STORE - , stencilLoadOp = ATTACHMENT_LOAD_OP_DONT_CARE - , stencilStoreOp = ATTACHMENT_STORE_OP_DONT_CARE - , initialLayout = IMAGE_LAYOUT_UNDEFINED - , finalLayout = IMAGE_LAYOUT_PRESENT_SRC_KHR - } - subpass :: SubpassDescription - subpass = zero - { pipelineBindPoint = PIPELINE_BIND_POINT_GRAPHICS - , colorAttachments = - [ zero { attachment = 0 - , layout = IMAGE_LAYOUT_COLOR_ATTACHMENT_OPTIMAL - } - ] - } - subpassDependency :: SubpassDependency - subpassDependency = zero - { srcSubpass = SUBPASS_EXTERNAL - , dstSubpass = 0 - , srcStageMask = PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT - , srcAccessMask = zero - , dstStageMask = PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT - , dstAccessMask = ACCESS_COLOR_ATTACHMENT_READ_BIT - .|. ACCESS_COLOR_ATTACHMENT_WRITE_BIT - } - withRenderPass' zero { attachments = [attachmentDescription] - , subpasses = [subpass] - , dependencies = [subpassDependency] - } +-- | Create a renderpass with a single subpass that clears + presents. +createRenderPass + :: MonadResource m + => Device + -> Format + -> m (ReleaseKey, RenderPass) +createRenderPass dev imageFormat = withRenderPass + dev + zero { attachments = [attachmentDescription] + , subpasses = [subpass] + , dependencies = [subpassDependency] + } + Nothing + allocate + where + attachmentDescription :: AttachmentDescription + attachmentDescription = zero + { format = imageFormat + , samples = SAMPLE_COUNT_1_BIT + , loadOp = ATTACHMENT_LOAD_OP_CLEAR + , storeOp = ATTACHMENT_STORE_OP_STORE + , stencilLoadOp = ATTACHMENT_LOAD_OP_DONT_CARE + , stencilStoreOp = ATTACHMENT_STORE_OP_DONT_CARE + , initialLayout = IMAGE_LAYOUT_UNDEFINED + , finalLayout = IMAGE_LAYOUT_PRESENT_SRC_KHR + } + subpass :: SubpassDescription + subpass = zero + { pipelineBindPoint = PIPELINE_BIND_POINT_GRAPHICS + , colorAttachments = + [zero { attachment = 0, layout = IMAGE_LAYOUT_COLOR_ATTACHMENT_OPTIMAL }] + } + subpassDependency :: SubpassDependency + subpassDependency = zero + { srcSubpass = SUBPASS_EXTERNAL + , dstSubpass = 0 + , srcStageMask = PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT + , srcAccessMask = zero + , dstStageMask = PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT + , dstAccessMask = ACCESS_COLOR_ATTACHMENT_READ_BIT + .|. ACCESS_COLOR_ATTACHMENT_WRITE_BIT + } diff --git a/examples/lib/AutoApply.hs b/examples/lib/AutoApply.hs deleted file mode 100644 index df49108ed..000000000 --- a/examples/lib/AutoApply.hs +++ /dev/null @@ -1,416 +0,0 @@ -{-# LANGUAGE DeriveFoldable, DeriveFunctor, DeriveTraversable, DerivingStrategies, FlexibleContexts, KindSignatures, LambdaCase, PatternSynonyms, RankNTypes, RecordWildCards, ScopedTypeVariables, TemplateHaskellQuotes, TupleSections, TypeApplications, TypeFamilies, ViewPatterns #-} -module AutoApply - ( autoapply - , autoapplyDecs - ) where - -import Control.Applicative -import Control.Arrow ( (>>>) ) -import Control.Monad -import Control.Monad.Logic ( LogicT - , observeManyT - ) -import Control.Monad.Trans as T -import Control.Monad.Trans.Except -import Control.Unification -import Control.Unification.IntVar -import Control.Unification.Types -import Data.Foldable -import Data.Functor -import Data.Functor.Fixedpoint -import Data.Maybe -import Data.Traversable -import Language.Haskell.TH -import Language.Haskell.TH.Desugar -import Prelude hiding ( pred ) - --- | @autoapply argsSubsuming argsUnifying fun@ creates an expression which is --- equal to @fun@ applied to as many of the values in @argsSubsuming@ and --- @argsUnifying@ as possible. --- --- The types of first list of args must subsume the type of the argument --- they're passed to. The types of the second list must merely unify. -autoapply - :: [Name] - -- ^ Values which will be used if their type subsumes the argument type - -> [Name] - -- ^ Values which will be used if their type unifies with the argument type - -> Name - -- ^ A function to apply to some values - -> Q Exp -autoapply subsuming unifying fun = do - unifyingInfos <- for unifying $ fmap (uncurry (Given Unifying)) . reifyVal - "Argument" - subsumingInfos <- for subsuming $ fmap (uncurry (Given Subsuming)) . reifyVal - "Argument" - funInfo <- uncurry Function <$> reifyVal "Function" fun - autoapply1 (unifyingInfos <> subsumingInfos) funInfo - --- | @autoapplyDecs mkName argsSubsuming argsUnifying funs@ will wrap every --- function in @funs@ by applying it to as many of the values in --- @argsSubsuming@ and @argsUnifying@ as possible. The new function name will --- be @mkName@ applied to the wrapped function name. --- --- The types of first list of args must subsume the type of the argument --- they're passed to. The types of the second list must merely unify. --- --- Type signatures are not generated, so you may want to add these yourself or --- turn on @NoMonomorphismRestriction@ if you have polymorphic constraints. -autoapplyDecs - :: (String -> String) - -- ^ A function to generate a new name for the wrapping function - -> [Name] - -- ^ A list of values which will be passed to any arguments their type subsumes - -> [Name] - -- ^ A list of values which will be passed to any arguments their type unify with - -> [Name] - -- ^ A list of function to wrap with the above parameters - -> Q [Dec] -autoapplyDecs getNewName subsuming unifying funs = do - unifyingInfos <- for unifying $ fmap (uncurry (Given Unifying)) . reifyVal - "Argument" - subsumingInfos <- for subsuming $ fmap (uncurry (Given Subsuming)) . reifyVal - "Argument" - funInfos <- for funs $ fmap (uncurry Function) . reifyVal "Function" - let mkFun fun = do - exp' <- autoapply1 (unifyingInfos <> subsumingInfos) fun - pure $ FunD (mkName . getNewName . nameBase . fName $ fun) - [Clause [] (NormalB exp') []] - traverse mkFun funInfos - --- | A given is something we can try to pass as an argument -data Given = Given - { gUnificationType :: UnificationType - , gName :: Name - , gType :: DType - } - deriving Show - -data UnificationType = Unifying | Subsuming - deriving Show - --- | A function we are wrapping -data Function = Function - { fName :: Name - , fType :: DType - } - deriving (Show) - -autoapply1 :: [Given] -> Function -> Q Exp -autoapply1 givens fun = do - -- In this function we: - -- - -- - Instantiate the command type with new unification variables - -- - Split it into arguments and return type - -- - Try to unify or subsume it with every 'Given' at every argument - -- - If we can unify the monad of the 'Given' with that of the functions and - -- unify the argument type, use that. - -- - If nothing matches we just use an 'Argument' - -- - Take the first result of all these tries - - let - (fmap varBndrName -> cmdVarNames, preds, args, ret) = unravel (fType fun) - defaultMaybe m = (Just <$> m) <|> pure Nothing - liftQ :: Q a -> IntBindingT TypeF (LogicT Q) a - liftQ = T.lift . T.lift - errorToLogic go = runExceptT go >>= \case - Left (_ :: UFailure TypeF IntVar) -> empty - Right x -> pure x - -- Quant will invent new variable names for any unification variables - -- still free - quant t = do - vs <- getFreeVars t - for_ vs $ \v -> bindVar v . (UTerm . VarF) =<< liftQ (newName "a") - - - -- Use LogicT so we can backtrack on failure - genProvs :: LogicT Q [ArgProvenance] - genProvs = evalIntBindingT $ do - cmdVars <- sequence [ (n, ) <$> freeVar | n <- cmdVarNames ] - instArgs <- traverse - (fmap (instWithVars cmdVars . snd) . liftQ . typeDtoF) - args - - cmdM <- UVar <$> freeVar - retInst <- fmap (instWithVars cmdVars . snd) . liftQ . typeDtoF $ ret - - -- A list of - -- ( type to unify - -- , predicate to use this match - -- , the given providing the value - -- ) - -- - -- The predicate is there to make sure we only match unifiable monads - instGivens <- fmap concat . for givens $ \g@Given {..} -> do - -- The Given applied as is - nonApp <- do - instTy <- uncurry inst <=< liftQ . typeDtoF $ gType - v <- liftQ $ newName "g" - pure (instTy, pure (), BoundPure v g) - -- The given, but in an applicative context, only possible if we can - -- unify the monad and there is a Monad instance - app <- case stripForall gType of - (vars, DAppT m a) -> - liftQ (isInstance ''Applicative [sweeten m]) >>= \case - False -> pure Nothing - True -> do - m' <- inst vars . snd <=< liftQ . typeDtoF $ m - a' <- inst vars . snd <=< liftQ . typeDtoF $ a - v <- liftQ $ newName "g" - let predicate = do - _ <- unify m' cmdM - pure () - pure $ Just (a', predicate, Bound v g) - _ -> pure Nothing - pure ([nonApp] <> toList app) - - as <- for instArgs $ \argTy -> - defaultMaybe . asum $ instGivens <&> \(givenTy, predicate, g) -> do - errorToLogic $ do - predicate - freshGivenTy <- freshen givenTy - let u = case g of - Bound _ Given {..} -> gUnificationType - BoundPure _ Given {..} -> gUnificationType - Argument _ _ -> Unifying - case u of - Unifying -> void $ unify freshGivenTy argTy - Subsuming -> do - s <- subsumes freshGivenTy argTy - lift $ guard s - pure g - - -- If we used any monadic bindings, we must have a Monad instance for - -- the return variable. If it's polymorphic then assume an instance. - when (any isMonadicBind (catMaybes as)) $ do - a <- UVar <$> freeVar - ret' <- errorToLogic $ unify retInst (UTerm (AppF cmdM a)) - quant ret' - retFrozen <- freeze <$> errorToLogic (applyBindings ret') - case retFrozen of - Just (Fix (AppF m _)) -> do - let typeD = typeFtoD m - liftQ (isInstance ''Applicative [sweeten typeD]) >>= \case - False -> empty - True -> pure () - Nothing -> - liftQ - $ fail - "\"impossible\", return type didn't freeze while checking monadic bindings" - _ -> empty - - -- Guard on all the instances being satisfiable - -- - -- This must come after the Monadic binding checker so that the (possibly - -- new) return type has been constrained a little. - for_ preds $ \pred -> do - - -- Get the constraint with the correct unification variables - instPred <- fmap (instWithVars cmdVars . snd) . liftQ . typeDtoF $ pred - - -- Quantify over any still free - quant instPred - - -- Freeze it - instFrozen <- freeze <$> errorToLogic (applyBindings instPred) - - case instFrozen of - Just f -> do - let (class', predArgs) = unfoldDType (typeFtoD f) - typeArgs = [ a | DTANormal a <- predArgs ] - className <- case class' of - DConT n -> pure n - _ -> liftQ $ fail "unfolded predicate didn't begin with a ConT" - - -- Ignore when the name is a type family because of - -- https://gitlab.haskell.org/ghc/ghc/issues/18153 - liftQ (reifyWithWarning className) >>= \case - ClassI _ _ -> - liftQ (isInstance className (sweeten <$> typeArgs)) >>= \case - False -> empty - True -> pure () - FamilyI _ _ -> pure () - _ -> liftQ $ fail "Predicate name isn't a class or a type family" - Nothing -> - liftQ - $ fail - "\"impossible\": predicate didn't freeze while checking predicates" - - - for (zip args as) $ \case - (_, Just p ) -> pure p - (t, Nothing) -> (`Argument` t) <$> liftQ (newName "a") - - argProvenances <- - note - "\"Impossible\" Finding argument provenances failed (unless the function context containts a class with no instances)" - . listToMaybe - =<< observeManyT 1 genProvs - unless (length argProvenances == length args) $ fail - "\"Impossible\", incorrect number of argument provenances were found" - - let bindGiven = \case - BoundPure _ _ -> Nothing - Bound n g -> Just $ BindS (VarP n) (VarE (gName g)) - Argument _ _ -> Nothing - bs = catMaybes (bindGiven <$> argProvenances) - ret' = applyDExp - (DVarE (fName fun)) - (argProvenances <&> \case - Bound n _ -> DVarE n - BoundPure _ (Given _ n _) -> DVarE n - Argument n _ -> DVarE n - ) - exp' <- dsDoStmts Nothing (bs <> [NoBindS (sweeten ret')]) - - -- Typing the arguments here is important, if we don't then some skolems - -- might escape! - -- - -- Consider wrapping @f :: (forall a. a) -> ()@ (and supplying no arguments). - -- We end up with the splice @myF x = f x@, and the @a@ in the argument to - -- @f@ escapes. We can fix this by typing the pattern explicitly, thusly @myF - -- (x :: forall a. a) = f x@ - pure $ LamE [ SigP (VarP n) (sweeten t) | Argument n t <- argProvenances ] - (sweeten exp') - -data ArgProvenance - = Bound Name Given - -- ^ Comes from a monadic binding - | BoundPure Name Given - -- ^ Comes from a pure binding, i.e. let ... in - | Argument Name DType - -- ^ Comes from an argument to the wrapped function - deriving (Show) - -isMonadicBind :: ArgProvenance -> Bool -isMonadicBind = \case - Bound _ _ -> True - _ -> False - ----------------------------------------------------------------- --- Haskell types as a fixed point of TypeF ----------------------------------------------------------------- - -data TypeF a - = AppF a a - | VarF Name - | ConF Name - | ArrowF - | LitF TyLit - deriving (Show, Functor, Foldable, Traversable) - --- TODO: Derive this with generics -instance Unifiable TypeF where - zipMatch (AppF l1 r1) (AppF l2 r2) = - Just (AppF (Right (l1, l2)) (Right (r1, r2))) - zipMatch (VarF n1) (VarF n2) | n1 == n2 = Just (VarF n1) - zipMatch (ConF n1) (ConF n2) | n1 == n2 = Just (ConF n1) - zipMatch ArrowF ArrowF = Just ArrowF - zipMatch (LitF l1) (LitF l2) | l1 == l2 = Just (LitF l1) - zipMatch _ _ = Nothing - --- | Returns the type as a @Fix TypeF@ along with any quantified names. Drops --- any context. -typeDtoF :: MonadFail m => DType -> m ([Name], Fix TypeF) -typeDtoF = traverse go . stripForall - where - go = \case - DForallT{} -> fail "TODO: Higher ranked types" - DConstrainedT{} -> fail "TODO: Higher ranked types" - DAppT l r -> do - l' <- go l - r' <- go r - pure $ Fix (AppF l' r') - DAppKindT t _ -> go t - DSigT t _ -> go t - DVarT n -> pure . Fix $ VarF n - DConT n -> pure . Fix $ ConF n - DArrowT -> pure . Fix $ ArrowF - DLitT l -> pure . Fix $ LitF l - DWildCardT -> fail "TODO: Wildcards" - -typeFtoD :: Fix TypeF -> DType -typeFtoD = unFix >>> \case - AppF l r -> DAppT (typeFtoD l) (typeFtoD r) - VarF n -> DVarT n - ConF n -> DConT n - ArrowF -> DArrowT - LitF l -> DLitT l - -varBndrName :: DTyVarBndrUnit -> Name -varBndrName = \case - DPlainTV n () -> n - DKindedTV n () _ -> n - --- | Raise foralls on the spine of the function type to the top --- --- For example @forall a. a -> forall b. b@ becomes @forall a b. a -> b@ -raiseForalls :: DType -> DType -raiseForalls = go >>> \case - (vs, ctx, t) -> DForallT (DForallVis vs) . DConstrainedT ctx $ t - where - go = \case - DForallT vs t -> let (vs', ctx', t') = go t in (telescopeBndrs vs <> vs', ctx', t') - DConstrainedT ctx t -> - let (vs', ctx', t') = go t in (vs', ctx <> ctx', t') - l :~> r -> let (vs, ctx, r') = go r in (vs, ctx, l :~> r') - t -> ([], [], t) - -pattern (:~>) :: DType -> DType -> DType -pattern l :~> r = DArrowT `DAppT` l `DAppT` r - --- | Instantiate a type with unification variables -inst - :: BindingMonad TypeF IntVar m - => [Name] - -> Fix TypeF - -> m (UTerm TypeF IntVar) -inst ns t = do - vs <- sequence [ (n, ) <$> freeVar | n <- ns ] - pure $ instWithVars vs t - --- | Instantiate a type with unification variables -instWithVars :: [(Name, IntVar)] -> Fix TypeF -> UTerm TypeF IntVar -instWithVars vs t = - let go (Fix f) = case f of - AppF l r -> UTerm (AppF (go l) (go r)) - VarF n | Just v <- lookup n vs -> UVar v - VarF n -> UTerm (VarF n) - ConF n -> UTerm (ConF n) - ArrowF -> UTerm ArrowF - LitF l -> UTerm (LitF l) - in go t - ----------------------------------------------------------------- --- Utils ----------------------------------------------------------------- - -reifyVal :: String -> Name -> Q (Name, DType) -reifyVal d n = dsReify n >>= \case - Just (DVarI name ty _) -> pure (name, ty) - _ -> fail $ d <> " " <> show n <> " isn't a value" - -stripForall :: DType -> ([Name], DType) -stripForall = raiseForalls >>> \case - DForallT vs (DConstrainedT _ ty) -> (varBndrName <$> telescopeBndrs vs, ty) - DForallT vs ty -> (varBndrName <$> telescopeBndrs vs, ty) - DConstrainedT _ ty -> ([], ty) - ty -> ([], ty) - -telescopeBndrs :: DForallTelescope -> [DTyVarBndrUnit] -telescopeBndrs = \case - DForallVis vs -> vs - DForallInvis vs -> (() <$) <$> vs - -unravel :: DType -> ([DTyVarBndrUnit], [DPred], [DType], DType) -unravel t = - let (argList, ret) = unravelDType t - go = \case - DFANil -> ([], [], []) - DFAForalls vs as -> (telescopeBndrs vs, [], []) <> go as - DFACxt preds as -> ([], preds, []) <> go as - DFAAnon a as -> ([], [], [a]) <> go as - in let (vs, preds, args) = go argList in (vs, preds, args, ret) - -note :: MonadFail m => String -> Maybe a -> m a -note s = maybe (fail s) pure diff --git a/examples/lib/Frame.hs b/examples/lib/Frame.hs new file mode 100644 index 000000000..ffe224e04 --- /dev/null +++ b/examples/lib/Frame.hs @@ -0,0 +1,264 @@ +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | Per-frame state and the recycling-Frame loop. Each frame owns a binary +-- image-available semaphore, a binary render-finished semaphore, and a +-- command pool — those three are 'RecycledResources' that get handed back +-- to a channel in 'VkResources' once the frame's GPU work has completed. +-- +-- The host-side timeline semaphore (@fHostTimeline@) lives across frames: +-- each frame increments it to its own 'fIndex' on the GPU, and the host +-- waits on it inside the spawned wait-and-recycle thread. +module Frame + ( Frame(..) + , numConcurrentFrames + , initialFrame + , advanceFrame + , runFrame + , queueSubmitFrame + , withTimelineSemaphore + , frameInstanceRequirements + , frameDeviceRequirements + ) where + +import Control.Concurrent ( forkIO ) +import Control.Monad ( replicateM_ + , unless + , void + ) +import Control.Monad.IO.Class ( liftIO ) +import Control.Monad.Trans.Resource ( InternalState + , MonadResource + , ReleaseKey + , ResourceT + , allocate + , closeInternalState + , createInternalState + , release + , runInternalState + ) +import qualified Data.Vector as V +import Data.IORef ( IORef + , newIORef + , readIORef + ) +import Data.Word +import Say ( sayErr ) +import Swapchain ( Swapchain ) +import UnliftIO ( atomicModifyIORef' + , finally + , mask_ + ) +import VkResources ( Queues(..) + , RecycledResources(..) + , VkResources(..) + ) +import Vulkan.CStruct.Extends ( SomeStruct + , pattern (:&) + , pattern (::&) + ) +import Vulkan.Core10 +import qualified Vulkan.Core10 as CommandPoolCreateInfo + ( CommandPoolCreateInfo(..) ) +import Vulkan.Core12.Promoted_From_VK_KHR_timeline_semaphore + as Timeline +import Vulkan.Extensions.VK_KHR_get_physical_device_properties2 + ( pattern KHR_GET_PHYSICAL_DEVICE_PROPERTIES_2_EXTENSION_NAME ) +import Vulkan.Requirement ( DeviceRequirement + , InstanceRequirement(..) + ) +import Vulkan.Utils.QueueAssignment ( QueueFamilyIndex(..) ) +import qualified Vulkan.Utils.Requirements.TH as U +import Vulkan.Zero ( zero ) + +-- | Instance-level requirements for the recycling 'Frame' machinery. Merge +-- with your example's other 'InstanceRequirement's when calling +-- 'Vulkan.Utils.Init.SDL2.withInstance' (or equivalent). +-- +-- Required because checking @PhysicalDeviceTimelineSemaphoreFeatures@ at +-- physical-device pick time goes through @VkPhysicalDeviceFeatures2@, which +-- needs either Vulkan 1.1+ or this extension. +frameInstanceRequirements :: [InstanceRequirement] +frameInstanceRequirements = + [ RequireInstanceExtension + Nothing + KHR_GET_PHYSICAL_DEVICE_PROPERTIES_2_EXTENSION_NAME + minBound + ] + +-- | The device-level requirements needed by 'runFrame' / 'queueSubmitFrame' / +-- 'withTimelineSemaphore'. Merge into your example's other 'DeviceRequirement's +-- when calling 'createDeviceFromRequirements'. +frameDeviceRequirements :: [DeviceRequirement] +frameDeviceRequirements = [U.reqs| + VK_KHR_timeline_semaphore + PhysicalDeviceTimelineSemaphoreFeatures.timelineSemaphore + |] + +-- | How many frames to keep in flight. Determines how many spare +-- 'RecycledResources' get pre-populated into the recycle channel at startup. +numConcurrentFrames :: Int +numConcurrentFrames = 3 + +-- | Per-frame state. +data Frame = Frame + { fIndex :: Word64 + -- ^ Monotonic, used as the timeline-semaphore signal value for this frame. + , fSwapchain :: Swapchain + -- ^ The swapchain this frame targets. Held by reference so a frame + -- in flight keeps its swapchain alive across recreation. + , fRecycled :: RecycledResources + -- ^ This frame's image-available / render-finished / command-pool — all + -- borrowed from the recycle channel; returned at retire time. + , fHostTimeline :: Semaphore + -- ^ Long-lived timeline semaphore. Each frame increments it to 'fIndex' + -- on the GPU; the host wait thread blocks on this. + , fGPUWork :: IORef [(Semaphore, Word64)] + -- ^ (Timeline semaphore, value) pairs the host wait thread will block on. + -- Appended to by 'queueSubmitFrame'. + , fResources :: (ReleaseKey, InternalState) + -- ^ ResourceT scope for frame-local allocations; closed when the frame + -- retires. The 'ReleaseKey' lives in the outer ResourceT so the + -- scope is freed cleanly even on early shutdown. + } + +---------------------------------------------------------------- +-- Construction +---------------------------------------------------------------- + +-- | Build the initial frame and pre-populate the recycle channel with +-- @'numConcurrentFrames' - 1@ spare 'RecycledResources'. +initialFrame :: MonadResource m => VkResources -> Swapchain -> m Frame +initialFrame vr fSwapchain = do + replicateM_ (numConcurrentFrames - 1) $ do + rr <- mkRecycledResources vr + liftIO (vrRecycleBin vr rr) + fRecycled <- mkRecycledResources vr + (_, fHostTimeline) <- withTimelineSemaphore (vrDevice vr) 0 + fGPUWork <- liftIO $ newIORef mempty + fResources <- allocate createInternalState closeInternalState + pure Frame { fIndex = 1, .. } + +-- | Build the next frame, taking one set of recycled resources from the bin. +-- Caller passes the (possibly-recreated) 'Swapchain'. +advanceFrame + :: MonadResource m + => VkResources + -> Swapchain -- ^ Same as old, or freshly recreated + -> Frame -- ^ The just-finished frame + -> m Frame +advanceFrame vr sc f = do + fRecycled <- liftIO $ vrRecycleNib vr >>= \case + Left block -> block + Right rr -> pure rr + fGPUWork <- liftIO $ newIORef mempty + fResources <- allocate createInternalState closeInternalState + pure Frame { fIndex = succ (fIndex f) + , fSwapchain = sc + , fRecycled + , fHostTimeline = fHostTimeline f + , fGPUWork + , fResources + } + +---------------------------------------------------------------- +-- Loop +---------------------------------------------------------------- + +-- | Run a per-frame action against this frame's per-frame ResourceT scope, +-- then asynchronously wait for the GPU work and recycle. The wait/recycle +-- runs in a forked thread so the next frame can begin recording immediately. +-- +-- Anything 'allocate'd inside @action@ is freed when the frame retires. +runFrame :: VkResources -> Frame -> ResourceT IO a -> IO a +runFrame vr f action = + runInternalState action (snd (fResources f)) + `finally` waitAndRecycle vr f + +waitAndRecycle :: VkResources -> Frame -> IO () +waitAndRecycle vr f = do + waits <- readIORef (fGPUWork f) + void . forkIO $ do + unless (null waits) $ do + let waitInfo = zero { semaphores = V.fromList (fst <$> waits) + , values = V.fromList (snd <$> waits) + } + r <- waitTwice (vrDevice vr) waitInfo oneSecond + case r of + TIMEOUT -> sayErr "Frame wait timed out (1s) — GPU may be hung" + _ -> pure () + -- Pool reuse: reset, dropping all recorded buffers. + resetCommandPool (vrDevice vr) + (rrCommandPool (fRecycled f)) + COMMAND_POOL_RESET_RELEASE_RESOURCES_BIT + -- Hand the borrowed resources back to whoever's waiting on them. + vrRecycleBin vr (fRecycled f) + -- Free the per-frame ResourceT scope. + release (fst (fResources f)) + where + oneSecond :: Word64 + oneSecond = 1000000000 + +-- | Submit GPU work for this frame and record the timeline semaphore + value +-- the wait thread will block on. +-- +-- Wraps 'queueSubmit' to keep the submit and the bookkeeping atomic. +queueSubmitFrame + :: Queue + -> Frame + -> V.Vector (SomeStruct SubmitInfo) + -> Semaphore -- ^ Timeline semaphore that will be signalled to @value@ + -> Word64 -- ^ Value the timeline reaches once this submit completes + -> IO () +queueSubmitFrame q f ss sem value = mask_ $ do + queueSubmit q ss NULL_HANDLE + atomicModifyIORef' (fGPUWork f) ((, ()) . ((sem, value) :)) + +---------------------------------------------------------------- +-- Small helpers +---------------------------------------------------------------- + +-- | Allocate a timeline semaphore initialised to the given value. +withTimelineSemaphore + :: MonadResource m => Device -> Word64 -> m (ReleaseKey, Semaphore) +withTimelineSemaphore dev initial = + withSemaphore dev + (zero ::& SemaphoreTypeCreateInfo SEMAPHORE_TYPE_TIMELINE initial :& ()) + Nothing + allocate + +---------------------------------------------------------------- +-- Internals +---------------------------------------------------------------- + +-- | Build one set of recycled resources: two binary semaphores + a +-- command pool keyed to the graphics queue family. +mkRecycledResources :: MonadResource m => VkResources -> m RecycledResources +mkRecycledResources vr = do + let dev = vrDevice vr + QueueFamilyIndex qfi = fst (graphicsQueue (vrQueues vr)) + (_, rrImageAvailable) <- withSemaphore + dev + (zero ::& SemaphoreTypeCreateInfo SEMAPHORE_TYPE_BINARY 0 :& ()) + Nothing + allocate + (_, rrRenderFinished) <- withSemaphore + dev + (zero ::& SemaphoreTypeCreateInfo SEMAPHORE_TYPE_BINARY 0 :& ()) + Nothing + allocate + (_, rrCommandPool) <- withCommandPool + dev + zero { CommandPoolCreateInfo.queueFamilyIndex = qfi } + Nothing + allocate + pure RecycledResources { .. } + +-- | Wait for some semaphores; if the wait times out, give the device one +-- more chance with a zero timeout. Catches the case where the host was +-- suspended during the wait and the GPU has actually finished. +waitTwice :: Device -> SemaphoreWaitInfo -> Word64 -> IO Result +waitTwice dev waitInfo t = Timeline.waitSemaphoresSafe dev waitInfo t >>= \case + TIMEOUT -> Timeline.waitSemaphores dev waitInfo 0 + r -> pure r diff --git a/examples/lib/Framebuffer.hs b/examples/lib/Framebuffer.hs index fbe0a1e38..c1c18761f 100644 --- a/examples/lib/Framebuffer.hs +++ b/examples/lib/Framebuffer.hs @@ -1,45 +1,32 @@ {-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -Wno-missing-signatures #-} + +-- | Tiny helpers for the boilerplate that each rendering example needs: +-- a framebuffer over a single image view, and a vanilla 2D color image view. module Framebuffer ( Framebuffer.createFramebuffer , Framebuffer.createImageView ) where -import AutoApply -import Control.Monad.Trans.Resource -import HasVulkan -import Vulkan.Core10 as Vk - hiding ( withBuffer - , withImage +import Control.Monad.Trans.Resource ( MonadResource + , ReleaseKey + , allocate ) -import Vulkan.Core10 as Extent2D (Extent2D(..)) -import Vulkan.Core10 as ImageViewCreateInfo (ImageViewCreateInfo(..)) +import Vulkan.Core10 as Vk + hiding ( withImage ) +import Vulkan.Core10 as Extent2D (Extent2D(..)) +import Vulkan.Core10 as ImageViewCreateInfo + ( ImageViewCreateInfo(..) ) import Vulkan.Zero -autoapplyDecs - (<> "'") - [ 'getDevice - , 'getPhysicalDevice - , 'getInstance - , 'getAllocator - , 'noAllocationCallbacks - , 'noPipelineCache - ] - [ 'allocate ] - [ 'withFramebuffer - , 'withImageView - ] - --- | Create a framebuffer filling the whole image. +-- | Create a framebuffer covering the whole image with a single attachment. createFramebuffer - :: (MonadResource m, HasVulkan m) - => RenderPass + :: MonadResource m + => Device + -> RenderPass -> ImageView -> Extent2D -> m (ReleaseKey, Framebuffer) -createFramebuffer renderPass imageView imageSize = do - -- Create a framebuffer +createFramebuffer dev renderPass imageView imageSize = let framebufferCreateInfo :: FramebufferCreateInfo '[] framebufferCreateInfo = zero { renderPass = renderPass , attachments = [imageView] @@ -47,29 +34,31 @@ createFramebuffer renderPass imageView imageSize = do , height = Extent2D.height imageSize , layers = 1 } - withFramebuffer' framebufferCreateInfo + in withFramebuffer dev framebufferCreateInfo Nothing allocate --- | Create a pretty vanilla ImageView covering the whole image +-- | Vanilla 2D color image view covering the whole image. createImageView - :: (MonadResource m, HasVulkan m) - => Format + :: MonadResource m + => Device + -> Format -> Image -> m (ReleaseKey, ImageView) -createImageView format = \image -> - withImageView' imageViewCreateInfo { ImageViewCreateInfo.image = image } +createImageView dev format image = + withImageView dev imageViewCreateInfo Nothing allocate where imageViewCreateInfo = zero - { viewType = IMAGE_VIEW_TYPE_2D - , format = format - , components = zero { r = COMPONENT_SWIZZLE_IDENTITY - , g = COMPONENT_SWIZZLE_IDENTITY - , b = COMPONENT_SWIZZLE_IDENTITY - , a = COMPONENT_SWIZZLE_IDENTITY - } - , subresourceRange = zero { aspectMask = IMAGE_ASPECT_COLOR_BIT - , baseMipLevel = 0 - , levelCount = 1 - , baseArrayLayer = 0 - , layerCount = 1 - } + { ImageViewCreateInfo.image = image + , viewType = IMAGE_VIEW_TYPE_2D + , format = format + , components = zero { r = COMPONENT_SWIZZLE_IDENTITY + , g = COMPONENT_SWIZZLE_IDENTITY + , b = COMPONENT_SWIZZLE_IDENTITY + , a = COMPONENT_SWIZZLE_IDENTITY + } + , subresourceRange = zero { aspectMask = IMAGE_ASPECT_COLOR_BIT + , baseMipLevel = 0 + , levelCount = 1 + , baseArrayLayer = 0 + , layerCount = 1 + } } diff --git a/examples/lib/HasVulkan.hs b/examples/lib/HasVulkan.hs deleted file mode 100644 index 0726e6265..000000000 --- a/examples/lib/HasVulkan.hs +++ /dev/null @@ -1,31 +0,0 @@ -module HasVulkan - ( HasVulkan(..) - , noAllocationCallbacks - , noPipelineCache - ) where - -import Control.Monad.Trans.Class ( MonadTrans(lift) ) -import Control.Monad.Trans.Reader ( ReaderT ) -import Vulkan.Core10 -import VulkanMemoryAllocator - --- | A class for Monads which can provide some Vulkan handles -class HasVulkan m where - getInstance :: m Instance - getGraphicsQueue :: m Queue - getPhysicalDevice :: m PhysicalDevice - getDevice :: m Device - getAllocator :: m Allocator - -instance (Monad m, HasVulkan m) => HasVulkan (ReaderT r m) where - getInstance = lift getInstance - getGraphicsQueue = lift getGraphicsQueue - getPhysicalDevice = lift getPhysicalDevice - getDevice = lift getDevice - getAllocator = lift getAllocator - -noAllocationCallbacks :: Maybe AllocationCallbacks -noAllocationCallbacks = Nothing - -noPipelineCache :: PipelineCache -noPipelineCache = NULL_HANDLE diff --git a/examples/lib/InstrumentDecs.hs b/examples/lib/InstrumentDecs.hs deleted file mode 100644 index db0639473..000000000 --- a/examples/lib/InstrumentDecs.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - -module InstrumentDecs - ( withSpan_ - , instrumentDecs - ) where - -import Control.Monad ( replicateM ) -import Data.ByteString ( ByteString ) -import Language.Haskell.TH -import OpenTelemetry.Eventlog ( beginSpan - , endSpan - ) -import UnliftIO ( MonadUnliftIO ) -import UnliftIO.Exception ( bracket ) - --- Profiling span -withSpan_ :: MonadUnliftIO m => ByteString -> m c -> m c -withSpan_ n x = bracket (beginSpan n) endSpan (const x) - -instrumentDecs :: (Name -> Maybe String) -> [Dec] -> Q [Dec] -instrumentDecs p ds = do - concat <$> sequenceA - [ case d of - FunD n [Clause ps (NormalB o) _] | Just s <- p n -> do - d' <- instrumentFun s n ps o - pure [d'] - _ -> pure [d] - | d <- ds - ] - -instrumentFun :: String -> Name -> [Pat] -> Exp -> Q Dec -instrumentFun s n ps o = do - let n' = n - eArity = \case - LamE ls e -> length ls + eArity e - _ -> 0 - arity = length ps + eArity o - vs <- replicateM arity (newName "x") - e <- [|withSpan_ $(litE (StringL s)) $(foldl appE (pure o) (varE <$> vs))|] - pure $ FunD n' [Clause (VarP <$> vs) (NormalB e) []] diff --git a/examples/lib/Swapchain.hs b/examples/lib/Swapchain.hs index 8b84e8ea8..f00bbd37d 100644 --- a/examples/lib/Swapchain.hs +++ b/examples/lib/Swapchain.hs @@ -1,17 +1,16 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -Wno-missing-signatures #-} +-- | Swapchain creation, recreation, and the small helper for catching +-- swapchain-out-of-date exceptions thrown elsewhere. module Swapchain - ( SwapchainInfo(..) - , SwapchainResources(..) - , allocSwapchainResources - , recreateSwapchainResources + ( Swapchain(..) + , allocSwapchain + , recreateSwapchain , threwSwapchainError ) where -import AutoApply import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Resource @@ -22,243 +21,204 @@ import Data.Foldable ( for_ ) import qualified Data.Vector as V import Data.Vector ( Vector ) -import Framebuffer +import qualified Framebuffer import GHC.Generics ( Generic ) -import HasVulkan -import InstrumentDecs -import Language.Haskell.TH ( nameBase ) import NoThunks.Class import Orphans ( ) import RefCounted -import qualified SDL -import qualified SDL.Video.Vulkan as SDL import UnliftIO.Exception ( throwString , tryJust ) +import VkResources ( VkResources(..) ) import Vulkan.Core10 import Vulkan.Exception import Vulkan.Extensions.VK_KHR_surface -import Vulkan.Extensions.VK_KHR_surface as SurfaceCapabilitiesKHR (SurfaceCapabilitiesKHR(..)) -import Vulkan.Extensions.VK_KHR_surface as SurfaceFormatKHR (SurfaceFormatKHR(..)) +import Vulkan.Extensions.VK_KHR_surface as SurfaceCapabilitiesKHR + ( SurfaceCapabilitiesKHR(..) ) +import Vulkan.Extensions.VK_KHR_surface as SurfaceFormatKHR + ( SurfaceFormatKHR(..) ) import Vulkan.Extensions.VK_KHR_swapchain -import Vulkan.Utils.Misc +import Vulkan.Utils.Misc ( (.&&.) ) import Vulkan.Zero -instrumentDecs (Just . init . nameBase) =<< autoapplyDecs - (<> "'") - [ 'getDevice - , 'getPhysicalDevice - , 'getInstance - , 'getAllocator - , 'noAllocationCallbacks - , 'noPipelineCache - ] - [ 'allocate ] - [ 'getSwapchainImagesKHR - , 'getPhysicalDeviceSurfaceCapabilitiesKHR - , 'getPhysicalDeviceSurfacePresentModesKHR - , 'getPhysicalDeviceSurfaceFormatsKHR - , 'withSwapchainKHR - ] - -data SwapchainInfo = SwapchainInfo - { siSwapchain :: SwapchainKHR - , siSwapchainReleaseKey :: ReleaseKey - , siPresentMode :: PresentModeKHR - , siSurfaceFormat :: SurfaceFormatKHR - , siImageExtent :: Extent2D - , siSurface :: SurfaceKHR - } - deriving (Generic, NoThunks) - -data SwapchainResources = SwapchainResources - { srInfo :: SwapchainInfo - , srImageViews :: Vector ImageView - , srImages :: Vector Image - , srRelease :: RefCounted +data Swapchain = Swapchain + { sSwapchain :: SwapchainKHR + , sSurface :: SurfaceKHR + , sFormat :: SurfaceFormatKHR + , sExtent :: Extent2D + , sPresentMode :: PresentModeKHR + , sImages :: Vector Image + , sImageViews :: Vector ImageView + , sRelease :: RefCounted + -- ^ Held until no in-flight frame still uses this swapchain. } deriving (Generic, NoThunks) ---------------------------------------------------------------- --- All the resources which depend on the swapchain +-- Allocate / recreate ---------------------------------------------------------------- --- | Allocate everything which depends on the swapchain -allocSwapchainResources - :: (MonadUnliftIO m, MonadResource m, HasVulkan m) - => SwapchainKHR - -- ^ Previous swapchain, can be NULL_HANDLE - -> Extent2D - -- ^ If the swapchain size determines the surface size, use this size +-- | Allocate a new swapchain plus its image views. +allocSwapchain + :: (MonadUnliftIO m, MonadResource m) + => VkResources + -> SwapchainKHR -- ^ Previous swapchain ('NULL_HANDLE' for first) + -> Extent2D -- ^ Fallback size when the surface lets us pick -> SurfaceKHR - -> m SwapchainResources -allocSwapchainResources oldSwapchain windowSize surface = do - info@SwapchainInfo {..} <- createSwapchain oldSwapchain windowSize surface - - -- Get all the swapchain images, and create views for them - (_, swapchainImages) <- getSwapchainImagesKHR' siSwapchain - (imageViewKeys, imageViews) <- - fmap V.unzip . V.forM swapchainImages $ \image -> - Framebuffer.createImageView - (SurfaceFormatKHR.format siSurfaceFormat) - image - - -- This refcount is released in 'recreateSwapchainResources' - releaseResources <- newRefCounted $ do + -> m Swapchain +allocSwapchain vr oldSwapchain windowSize surface = do + (sSwapchain, sFormat, sExtent, sPresentMode, swapchainKey) <- + createSwapchain vr oldSwapchain windowSize surface + + (_, sImages) <- getSwapchainImagesKHR (vrDevice vr) sSwapchain + (imageViewKeys, sImageViews) <- + fmap V.unzip . V.forM sImages $ \image -> + Framebuffer.createImageView (vrDevice vr) + (SurfaceFormatKHR.format sFormat) + image + + -- Released by the next 'recreateSwapchain' (when frames stop using it). + sRelease <- newRefCounted $ do traverse_ release imageViewKeys - release siSwapchainReleaseKey - - pure $ SwapchainResources info imageViews swapchainImages releaseResources - -recreateSwapchainResources - :: (MonadUnliftIO m, MonadResource m, HasVulkan m) - => SDL.Window - -> SwapchainResources - -- ^ The reference to these resources will be dropped - -> m SwapchainResources -recreateSwapchainResources win oldResources = do - SDL.V2 width height <- SDL.vkGetDrawableSize win - let oldSwapchain = siSwapchain . srInfo $ oldResources - oldSurface = siSurface . srInfo $ oldResources - r <- allocSwapchainResources - oldSwapchain - (Extent2D (fromIntegral width) (fromIntegral height)) - oldSurface - releaseRefCounted (srRelease oldResources) - pure r + release swapchainKey + + pure Swapchain { sSurface = surface, .. } + +-- | Build a new swapchain at a new size, dropping the reference to the old +-- one so its resources can be released once in-flight frames complete. +recreateSwapchain + :: (MonadUnliftIO m, MonadResource m) + => VkResources + -> Extent2D -- ^ New window size + -> Swapchain + -> m Swapchain +recreateSwapchain vr newSize old = do + fresh <- allocSwapchain vr (sSwapchain old) newSize (sSurface old) + releaseRefCounted (sRelease old) + pure fresh ---------------------------------------------------------------- --- Creating the actual swapchain +-- Internals ---------------------------------------------------------------- --- | Create a swapchain from a 'SurfaceKHR' createSwapchain - :: (MonadUnliftIO m, MonadResource m, HasVulkan m) - => SwapchainKHR - -- ^ Old swapchain, can be NULL_HANDLE + :: (MonadUnliftIO m, MonadResource m) + => VkResources + -> SwapchainKHR -> Extent2D - -- ^ If the swapchain size determines the surface size, use this size -> SurfaceKHR - -> m SwapchainInfo -createSwapchain oldSwapchain explicitSize surf = do - surfaceCaps <- getPhysicalDeviceSurfaceCapabilitiesKHR' surf + -> m (SwapchainKHR, SurfaceFormatKHR, Extent2D, PresentModeKHR, ReleaseKey) +createSwapchain vr oldSwapchain explicitSize surf = do + let phys = vrPhysicalDevice vr + dev = vrDevice vr + + surfaceCaps <- getPhysicalDeviceSurfaceCapabilitiesKHR phys surf - -- Check flags + -- Sanity-check that the surface advertises the usages we need. for_ requiredUsageFlags $ \f -> unless (supportedUsageFlags surfaceCaps .&&. f) $ throwString ("Surface images do not support " <> show f) - -- Select a present mode - (_, availablePresentModes) <- getPhysicalDeviceSurfacePresentModesKHR' surf - presentMode <- + -- Pick a present mode in our preference order. + (_, availablePresentModes) <- getPhysicalDeviceSurfacePresentModesKHR phys surf + presentMode <- case filter (`V.elem` availablePresentModes) desiredPresentModes of - [] -> throwString "Unable to find a suitable present mode for swapchain" + [] -> throwString "Unable to find a suitable present mode for swapchain" x : _ -> pure x - -- Select a surface format - -- getPhysicalDeviceSurfaceFormatsKHR doesn't return an empty list - (_, availableFormats) <- getPhysicalDeviceSurfaceFormatsKHR' surf - surfaceFormat <- selectSurfaceFormat availableFormats + -- Pick a surface format. Vulkan guarantees at least one. + (_, availableFormats) <- getPhysicalDeviceSurfaceFormatsKHR phys surf + surfaceFormat <- selectSurfaceFormat phys availableFormats - -- Calculate the extent + -- Use the surface's reported extent unless it tells us we can pick. let imageExtent = case currentExtent (surfaceCaps :: SurfaceCapabilitiesKHR) of Extent2D w h | w == maxBound, h == maxBound -> explicitSize e -> e - let - imageCount = - let - limit = case maxImageCount (surfaceCaps :: SurfaceCapabilitiesKHR) of - 0 -> maxBound - n -> n - -- Request one additional image to prevent us having to wait for - -- the driver to finish - buffer = 1 - desired = - buffer + SurfaceCapabilitiesKHR.minImageCount surfaceCaps - in - min limit desired + let imageCount = + let + limit = case maxImageCount (surfaceCaps :: SurfaceCapabilitiesKHR) of + 0 -> maxBound + n -> n + buffer = 1 -- request one extra to avoid waiting on the driver + desired = buffer + SurfaceCapabilitiesKHR.minImageCount surfaceCaps + in + min limit desired compositeAlphaMode <- if COMPOSITE_ALPHA_OPAQUE_BIT_KHR .&&. supportedCompositeAlpha surfaceCaps then pure COMPOSITE_ALPHA_OPAQUE_BIT_KHR else throwString "Surface doesn't support COMPOSITE_ALPHA_OPAQUE_BIT_KHR" - let - swapchainCreateInfo = SwapchainCreateInfoKHR - { surface = surf - , next = () - , flags = zero - , queueFamilyIndices = mempty -- No need to specify when not using concurrent access - , minImageCount = imageCount - , imageFormat = SurfaceFormatKHR.format surfaceFormat - , imageColorSpace = colorSpace surfaceFormat - , imageExtent = imageExtent - , imageArrayLayers = 1 - , imageUsage = foldr (.|.) zero requiredUsageFlags - , imageSharingMode = SHARING_MODE_EXCLUSIVE - , preTransform = SurfaceCapabilitiesKHR.currentTransform surfaceCaps - , compositeAlpha = compositeAlphaMode - , presentMode = presentMode - , clipped = True - , oldSwapchain = oldSwapchain - } + let swapchainCreateInfo = SwapchainCreateInfoKHR + { surface = surf + , next = () + , flags = zero + , queueFamilyIndices = mempty + , minImageCount = imageCount + , imageFormat = SurfaceFormatKHR.format surfaceFormat + , imageColorSpace = colorSpace surfaceFormat + , imageExtent = imageExtent + , imageArrayLayers = 1 + , imageUsage = foldr (.|.) zero requiredUsageFlags + , imageSharingMode = SHARING_MODE_EXCLUSIVE + , preTransform = SurfaceCapabilitiesKHR.currentTransform surfaceCaps + , compositeAlpha = compositeAlphaMode + , presentMode = presentMode + , clipped = True + , oldSwapchain = oldSwapchain + } + + (key, swapchain) <- withSwapchainKHR dev swapchainCreateInfo Nothing allocate + + pure (swapchain, surfaceFormat, imageExtent, presentMode, key) - (key, swapchain) <- withSwapchainKHR' swapchainCreateInfo +---------------------------------------------------------------- +-- Format selection +---------------------------------------------------------------- - pure $ SwapchainInfo swapchain key presentMode surfaceFormat imageExtent surf +-- | Prefer formats whose 'optimalTilingFeatures' satisfy +-- 'requiredFormatFeatures'; SRGB formats typically omit +-- 'FORMAT_FEATURE_STORAGE_IMAGE_BIT' and would otherwise cause +-- @vkCreateSwapchainKHR@ to fail. +selectSurfaceFormat + :: MonadIO m => PhysicalDevice -> Vector SurfaceFormatKHR -> m SurfaceFormatKHR +selectSurfaceFormat phys fmts = do + let suitable f = do + props <- getPhysicalDeviceFormatProperties phys + (SurfaceFormatKHR.format f) + pure $ all (optimalTilingFeatures props .&&.) requiredFormatFeatures + good <- V.filterM suitable fmts + pure $ if V.null good then V.head fmts else V.head good ---------------------------------------------------------------- --- Utils +-- Specifications ---------------------------------------------------------------- --- | Catch an ERROR_OUT_OF_DATE_KHR exception and return 'True' if that happened +-- | Catch an 'ERROR_OUT_OF_DATE_KHR' exception and return 'True' when caught. threwSwapchainError :: MonadUnliftIO f => f b -> f Bool threwSwapchainError = fmap isLeft . tryJust swapchainError where swapchainError = \case VulkanException e@ERROR_OUT_OF_DATE_KHR -> Just e - -- TODO handle this case - -- VulkanException e@ERROR_SURFACE_LOST_KHR -> Just e + -- TODO: handle ERROR_SURFACE_LOST_KHR too VulkanException _ -> Nothing ----------------------------------------------------------------- --- Specifications ----------------------------------------------------------------- - --- The vector passed will have at least one element. Prefer formats whose --- 'optimalTilingFeatures' satisfy 'requiredFormatFeatures'; SRGB formats --- typically omit 'FORMAT_FEATURE_STORAGE_IMAGE_BIT' and would otherwise --- cause @vkCreateSwapchainKHR@ to fail. -selectSurfaceFormat - :: (MonadIO m, HasVulkan m) => Vector SurfaceFormatKHR -> m SurfaceFormatKHR -selectSurfaceFormat fmts = do - phys <- getPhysicalDevice - let suitable f = do - props <- getPhysicalDeviceFormatProperties - phys - (SurfaceFormatKHR.format f) - pure $ all (optimalTilingFeatures props .&&.) requiredFormatFeatures - good <- V.filterM suitable fmts - pure $ if V.null good then V.head fmts else V.head good - --- | An ordered list of the present mode to be chosen for the swapchain. +-- | Present-mode preference, best first. desiredPresentModes :: [PresentModeKHR] desiredPresentModes = [ PRESENT_MODE_FIFO_RELAXED_KHR - , PRESENT_MODE_FIFO_KHR -- ^ This will always be present - , PRESENT_MODE_IMMEDIATE_KHR -- ^ Keep this here for easy swapping for testing + , PRESENT_MODE_FIFO_KHR + , PRESENT_MODE_IMMEDIATE_KHR ] --- | The images in the swapchain must support these flags. +-- | Image usages every swapchain image must support. requiredUsageFlags :: [ImageUsageFlagBits] requiredUsageFlags = [IMAGE_USAGE_COLOR_ATTACHMENT_BIT, IMAGE_USAGE_STORAGE_BIT] --- | Format features the swapchain image's format must report. Used by --- 'selectSurfaceFormat' to skip formats (notably SRGB) that don't support --- the usages in 'requiredUsageFlags'. +-- | Format feature flags the chosen surface format must support. requiredFormatFeatures :: [FormatFeatureFlagBits] requiredFormatFeatures = [FORMAT_FEATURE_COLOR_ATTACHMENT_BIT, FORMAT_FEATURE_STORAGE_IMAGE_BIT] diff --git a/examples/lib/Triangle.hs b/examples/lib/Triangle.hs index a80b5e689..53b4b6fe2 100644 --- a/examples/lib/Triangle.hs +++ b/examples/lib/Triangle.hs @@ -3,271 +3,368 @@ {-# LANGUAGE QuasiQuotes #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} --- | Backend-independent triangle renderer used by both the SDL2 and GLFW --- triangle examples. Sets up a render pass, graphics pipeline, framebuffers, --- command buffers and semaphores, then runs a render loop until the supplied --- @shouldQuit@ poller returns 'True'. +-- | Backend-independent triangle renderer using the recycling 'Frame' loop +-- from "Frame". Each backend (SDL2, GLFW) builds 'VkResources' + an initial +-- 'Swapchain', supplies callbacks for "current drawable size" and "should +-- quit", and hands off to 'runTriangle'. module Triangle ( runTriangle ) where -import Control.Monad.IO.Class ( liftIO ) -import Control.Monad.Trans.Resource ( ResourceT, allocate ) +import Control.Exception ( throwIO ) +import Control.Monad.IO.Class +import Control.Monad.Trans.Resource import Data.Bits ( (.|.) ) -import Data.Traversable ( for ) +import Data.Foldable ( traverse_ ) import qualified Data.Vector as V -import Data.Word ( Word32 ) +import Data.Vector ( Vector ) -import Vulkan.CStruct.Extends ( SomeStruct(..) ) -import Vulkan.Core10 hiding ( createRenderPass ) +import Frame ( Frame(..) + , advanceFrame + , initialFrame + , queueSubmitFrame + , runFrame + ) +import qualified Framebuffer +import Data.IORef +import RefCounted ( RefCounted + , newRefCounted + , releaseRefCounted + ) +import Swapchain ( Swapchain(..) + , recreateSwapchain + , threwSwapchainError + ) +import Utils ( loopJust ) +import VkResources ( Queues(..) + , RecycledResources(..) + , VkResources(..) + ) + +import Vulkan.CStruct.Extends +import Vulkan.Core10 as Vk + hiding ( withImage + , createRenderPass + ) import qualified Vulkan.Core10 as CommandBufferBeginInfo (CommandBufferBeginInfo(..)) -import qualified Vulkan.Core10 as CommandPoolCreateInfo (CommandPoolCreateInfo(..)) +import Vulkan.Core12.Promoted_From_VK_KHR_timeline_semaphore +import Vulkan.Exception ( VulkanException(..) ) +import Vulkan.Extensions.VK_KHR_surface as SurfaceFormatKHR + ( SurfaceFormatKHR(..) ) import Vulkan.Extensions.VK_KHR_swapchain + as Swap import Vulkan.Utils.ShaderQQ.GLSL.Glslang - ( frag, vert ) -import Vulkan.Zero ( zero ) - -import Window ( VulkanWindow(..) ) +import Vulkan.Zero --- | Render a static triangle into the swapchain inside the given --- 'VulkanWindow' until @shouldQuit@ reports 'True'. +-- | Drive a recycling-Frame render loop drawing the colored triangle. runTriangle - :: VulkanWindow w - -> IO Bool -- ^ Per-frame poller; 'True' = exit + :: VkResources + -> Swapchain -- ^ Initial swapchain + -> IO Extent2D -- ^ Get current drawable size (for resize) + -> IO Bool -- ^ Per-frame poller; 'True' means quit -> ResourceT IO () -runTriangle VulkanWindow{..} shouldQuit = do - renderPass <- createRenderPass vwDevice vwFormat - graphicsPipeline <- createGraphicsPipeline vwDevice renderPass vwExtent - framebuffers <- createFramebuffers vwDevice vwImageViews renderPass vwExtent - commandBuffers <- createCommandBuffers vwDevice renderPass graphicsPipeline vwGraphicsQueueFamilyIndex framebuffers vwExtent - (imageAvailableSemaphore, renderFinishedSemaphore) <- createSemaphores vwDevice - liftIO $ mainLoop $ - drawFrame vwDevice vwSwapchain vwGraphicsQueue vwPresentQueue imageAvailableSemaphore renderFinishedSemaphore commandBuffers - deviceWaitIdle vwDevice - where - mainLoop draw = do - quit <- shouldQuit - if quit then pure () else draw >> mainLoop draw - -drawFrame - :: Device - -> SwapchainKHR - -> Queue - -> Queue - -> Semaphore - -> Semaphore - -> V.Vector CommandBuffer - -> IO () -drawFrame dev swapchain graphicsQueue presentQueue imageAvailableSemaphore renderFinishedSemaphore commandBuffers = do - (_, imageIndex) <- acquireNextImageKHR dev swapchain maxBound imageAvailableSemaphore zero - let submitInfo = zero - { waitSemaphores = [imageAvailableSemaphore] - , waitDstStageMask = [PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT] - , commandBuffers = [commandBufferHandle (commandBuffers V.! fromIntegral imageIndex)] - , signalSemaphores = [renderFinishedSemaphore] - } - presentInfo = zero - { waitSemaphores = [renderFinishedSemaphore] - , swapchains = [swapchain] - , imageIndices = [imageIndex] - } - queueSubmit graphicsQueue [SomeStruct submitInfo] zero - _ <- queuePresentKHR presentQueue presentInfo - pure () +runTriangle vr initialSC getDrawableSize shouldQuit = do + let dev = vrDevice vr + (_, renderPass) <- createRenderPass dev (SurfaceFormatKHR.format (sFormat initialSC)) + (_, pipeline) <- createGraphicsPipeline dev renderPass + initialFBs <- createFramebuffers dev renderPass initialSC -allocate' :: IO a -> (a -> IO ()) -> ResourceT IO a -allocate' c d = snd <$> allocate c d + scRef <- liftIO $ newIORef initialSC + fbsRef <- liftIO $ newIORef initialFBs -createSemaphores :: Device -> ResourceT IO (Semaphore, Semaphore) -createSemaphores dev = do - imageAvailableSemaphore <- withSemaphore dev zero Nothing allocate' - renderFinishedSemaphore <- withSemaphore dev zero Nothing allocate' - pure (imageAvailableSemaphore, renderFinishedSemaphore) + initial <- initialFrame vr initialSC -createCommandBuffers - :: Device -> RenderPass -> Pipeline -> Word32 -> V.Vector Framebuffer -> Extent2D - -> ResourceT IO (V.Vector CommandBuffer) -createCommandBuffers dev renderPass graphicsPipeline graphicsQueueFamilyIndex framebuffers swapchainExtent = do - let commandPoolCreateInfo = zero { CommandPoolCreateInfo.queueFamilyIndex = graphicsQueueFamilyIndex } - commandPool <- withCommandPool dev commandPoolCreateInfo Nothing allocate' - let commandBufferAllocateInfo = zero - { commandPool = commandPool - , level = COMMAND_BUFFER_LEVEL_PRIMARY - , commandBufferCount = fromIntegral $ V.length framebuffers - } - cbFlags = zero { CommandBufferBeginInfo.flags = COMMAND_BUFFER_USAGE_SIMULTANEOUS_USE_BIT } - buffers <- withCommandBuffers dev commandBufferAllocateInfo allocate' - liftIO . V.forM_ (V.zip framebuffers buffers) $ \(framebuffer, buffer) -> - useCommandBuffer buffer cbFlags $ do - let renderPassBeginInfo = zero - { renderPass = renderPass - , framebuffer = framebuffer - , renderArea = Rect2D { offset = zero, extent = swapchainExtent } - , clearValues = [Color (Float32 0.1 0.1 0.1 0)] - } - cmdUseRenderPass buffer renderPassBeginInfo SUBPASS_CONTENTS_INLINE $ do - cmdBindPipeline buffer PIPELINE_BIND_POINT_GRAPHICS graphicsPipeline - cmdDraw buffer 3 1 0 0 - pure buffers + let perFrame f = do + currentSC <- liftIO $ readIORef scRef + (currentFBs, _rel) <- liftIO $ readIORef fbsRef + let f' = f { fSwapchain = currentSC } + needsNew <- threwSwapchainError $ liftIO $ runFrame vr f' $ + drawTriangle vr renderPass pipeline currentFBs f' + sc' <- if needsNew + then do + newSize <- liftIO getDrawableSize + sc' <- recreateSwapchain vr newSize currentSC + newFBs <- createFramebuffers dev renderPass sc' + (_oldFbs, oldRel) <- liftIO $ readIORef fbsRef + releaseRefCounted oldRel + liftIO $ writeIORef scRef sc' + liftIO $ writeIORef fbsRef newFBs + pure sc' + else pure currentSC + advanceFrame vr sc' f' -createShaders - :: Device -> ResourceT IO (V.Vector (SomeStruct PipelineShaderStageCreateInfo)) -createShaders dev = do - let - fragCode = [frag| - #version 450 - #extension GL_ARB_separate_shader_objects : enable + loop f = liftIO shouldQuit >>= \case + True -> do + deviceWaitIdle dev + pure Nothing + False -> Just <$> perFrame f - layout(location = 0) in vec3 fragColor; - layout(location = 0) out vec4 outColor; + loopJust loop initial - void main() { - outColor = vec4(fragColor, 1.0); - } - |] - vertCode = [vert| - #version 450 - #extension GL_ARB_separate_shader_objects : enable +---------------------------------------------------------------- +-- Per-frame draw +---------------------------------------------------------------- - layout(location = 0) out vec3 fragColor; +drawTriangle + :: VkResources + -> RenderPass + -> Pipeline + -> Vector Framebuffer + -> Frame + -> ResourceT IO () +drawTriangle vr renderPass pipeline framebuffers f = do + let RecycledResources {..} = fRecycled f + sc = fSwapchain f + dev = vrDevice vr + Queues (_, gQ) = vrQueues vr + oneSecond = 1e9 - vec2 positions[3] = vec2[]( - vec2(0.0, -0.5), - vec2(0.5, 0.5), - vec2(-0.5, 0.5) - ); + (acquireResult, imageIndex) <- + acquireNextImageKHRSafe dev (sSwapchain sc) oneSecond rrImageAvailable NULL_HANDLE + >>= \case + r@(SUCCESS, _) -> pure r + r@(SUBOPTIMAL_KHR, _) -> pure r + (TIMEOUT, _) -> liftIO . throwIO $ VulkanException ERROR_OUT_OF_DATE_KHR + _ -> liftIO . throwIO $ VulkanException ERROR_OUT_OF_DATE_KHR - vec3 colors[3] = vec3[]( - vec3(1.0, 1.0, 0.0), - vec3(0.0, 1.0, 1.0), - vec3(1.0, 0.0, 1.0) - ); + (_, ~[commandBuffer]) <- withCommandBuffers + dev + zero { commandPool = rrCommandPool + , level = COMMAND_BUFFER_LEVEL_PRIMARY + , commandBufferCount = 1 + } + allocate - void main() { - gl_Position = vec4(positions[gl_VertexIndex], 0.0, 1.0); - fragColor = colors[gl_VertexIndex]; - } - |] - fragModule <- withShaderModule dev zero { code = fragCode } Nothing allocate' - vertModule <- withShaderModule dev zero { code = vertCode } Nothing allocate' - let vertShaderStageCreateInfo = zero - { stage = SHADER_STAGE_VERTEX_BIT - , module' = vertModule - , name = "main" + let renderPassBeginInfo = zero + { renderPass = renderPass + , framebuffer = framebuffers V.! fromIntegral imageIndex + , renderArea = Rect2D { offset = zero, extent = sExtent sc } + , clearValues = [Color (Float32 0.1 0.1 0.1 0)] } - fragShaderStageCreateInfo = zero - { stage = SHADER_STAGE_FRAGMENT_BIT - , module' = fragModule - , name = "main" - } - pure [SomeStruct vertShaderStageCreateInfo, SomeStruct fragShaderStageCreateInfo] -createRenderPass :: Device -> Format -> ResourceT IO RenderPass -createRenderPass dev swapchainImageFormat = do - let attachmentDescription :: AttachmentDescription - attachmentDescription = zero - { format = swapchainImageFormat - , samples = SAMPLE_COUNT_1_BIT - , loadOp = ATTACHMENT_LOAD_OP_CLEAR - , storeOp = ATTACHMENT_STORE_OP_STORE - , stencilLoadOp = ATTACHMENT_LOAD_OP_DONT_CARE - , stencilStoreOp = ATTACHMENT_STORE_OP_DONT_CARE - , initialLayout = IMAGE_LAYOUT_UNDEFINED - , finalLayout = IMAGE_LAYOUT_PRESENT_SRC_KHR - } - subpass :: SubpassDescription - subpass = zero - { pipelineBindPoint = PIPELINE_BIND_POINT_GRAPHICS - , colorAttachments = - [ zero { attachment = 0, layout = IMAGE_LAYOUT_COLOR_ATTACHMENT_OPTIMAL } ] - } - subpassDependency :: SubpassDependency - subpassDependency = zero - { srcSubpass = SUBPASS_EXTERNAL - , dstSubpass = 0 - , srcStageMask = PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT - , srcAccessMask = zero - , dstStageMask = PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT - , dstAccessMask = ACCESS_COLOR_ATTACHMENT_READ_BIT .|. ACCESS_COLOR_ATTACHMENT_WRITE_BIT - } - withRenderPass dev zero - { attachments = [attachmentDescription] - , subpasses = [subpass] - , dependencies = [subpassDependency] - } Nothing allocate' + useCommandBuffer + commandBuffer + zero { CommandBufferBeginInfo.flags = COMMAND_BUFFER_USAGE_ONE_TIME_SUBMIT_BIT } + $ do + cmdUseRenderPass commandBuffer renderPassBeginInfo SUBPASS_CONTENTS_INLINE $ do + let Extent2D w h = sExtent sc + cmdSetViewport commandBuffer 0 + [ Viewport { x = 0 + , y = 0 + , width = realToFrac w + , height = realToFrac h + , minDepth = 0 + , maxDepth = 1 + } + ] + cmdSetScissor commandBuffer 0 + [Rect2D { offset = Offset2D 0 0, extent = sExtent sc }] + cmdBindPipeline commandBuffer PIPELINE_BIND_POINT_GRAPHICS pipeline + cmdDraw commandBuffer 3 1 0 0 + + let submitInfo = + zero { Vk.waitSemaphores = [rrImageAvailable] + , waitDstStageMask = [PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT] + , commandBuffers = [commandBufferHandle commandBuffer] + , signalSemaphores = [rrRenderFinished, fHostTimeline f] + } + ::& zero { waitSemaphoreValues = [1] + , signalSemaphoreValues = [1, fIndex f] + } + :& () + liftIO $ queueSubmitFrame gQ + f + [SomeStruct submitInfo] + (fHostTimeline f) + (fIndex f) + + presentResult <- queuePresentKHR + gQ + zero { Swap.waitSemaphores = [rrRenderFinished] + , swapchains = [sSwapchain sc] + , imageIndices = [imageIndex] + } + + case (acquireResult, presentResult) of + (SUBOPTIMAL_KHR, _) -> liftIO . throwIO $ VulkanException ERROR_OUT_OF_DATE_KHR + (_, SUBOPTIMAL_KHR) -> liftIO . throwIO $ VulkanException ERROR_OUT_OF_DATE_KHR + _ -> pure () + +---------------------------------------------------------------- +-- Render pass + pipeline (long-lived) +---------------------------------------------------------------- + +createRenderPass + :: MonadResource m => Device -> Format -> m (ReleaseKey, RenderPass) +createRenderPass dev imageFormat = withRenderPass + dev + zero { attachments = [attachmentDescription] + , subpasses = [subpass] + , dependencies = [subpassDependency] + } + Nothing + allocate + where + attachmentDescription :: AttachmentDescription + attachmentDescription = zero + { format = imageFormat + , samples = SAMPLE_COUNT_1_BIT + , loadOp = ATTACHMENT_LOAD_OP_CLEAR + , storeOp = ATTACHMENT_STORE_OP_STORE + , stencilLoadOp = ATTACHMENT_LOAD_OP_DONT_CARE + , stencilStoreOp = ATTACHMENT_STORE_OP_DONT_CARE + , initialLayout = IMAGE_LAYOUT_UNDEFINED + , finalLayout = IMAGE_LAYOUT_PRESENT_SRC_KHR + } + subpass :: SubpassDescription + subpass = zero + { pipelineBindPoint = PIPELINE_BIND_POINT_GRAPHICS + , colorAttachments = + [zero { attachment = 0, layout = IMAGE_LAYOUT_COLOR_ATTACHMENT_OPTIMAL }] + } + subpassDependency :: SubpassDependency + subpassDependency = zero + { srcSubpass = SUBPASS_EXTERNAL + , dstSubpass = 0 + , srcStageMask = PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT + , srcAccessMask = zero + , dstStageMask = PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT + , dstAccessMask = ACCESS_COLOR_ATTACHMENT_READ_BIT + .|. ACCESS_COLOR_ATTACHMENT_WRITE_BIT + } createGraphicsPipeline - :: Device -> RenderPass -> Extent2D -> ResourceT IO Pipeline -createGraphicsPipeline dev renderPass swapchainExtent = do - shaderStages <- createShaders dev - pipelineLayout <- withPipelineLayout dev zero Nothing allocate' - let Extent2D { width = swapchainWidth, height = swapchainHeight } = swapchainExtent - pipelineCreateInfo :: GraphicsPipelineCreateInfo '[] + :: (MonadResource m, MonadFail m) + => Device + -> RenderPass + -> m (ReleaseKey, Pipeline) +createGraphicsPipeline dev renderPass = do + (shaderKeys, shaderStages) <- V.unzip <$> createShaders dev + (layoutKey , pipelineLayout) <- withPipelineLayout dev zero Nothing allocate + let pipelineCreateInfo :: GraphicsPipelineCreateInfo '[] pipelineCreateInfo = zero { stages = shaderStages , vertexInputState = Just zero , inputAssemblyState = Just zero - { topology = PRIMITIVE_TOPOLOGY_TRIANGLE_LIST - , primitiveRestartEnable = False - } - , viewportState = Just . SomeStruct $ zero - { viewports = [ Viewport - { x = 0 - , y = 0 - , width = realToFrac swapchainWidth - , height = realToFrac swapchainHeight - , minDepth = 0 - , maxDepth = 1 - } ] - , scissors = [ Rect2D { offset = Offset2D 0 0, extent = swapchainExtent } ] - } + { topology = PRIMITIVE_TOPOLOGY_TRIANGLE_LIST + , primitiveRestartEnable = False + } + , viewportState = Just + $ SomeStruct zero { viewportCount = 1, scissorCount = 1 } , rasterizationState = Just . SomeStruct $ zero - { depthClampEnable = False - , rasterizerDiscardEnable = False - , lineWidth = 1 - , polygonMode = POLYGON_MODE_FILL - , cullMode = CULL_MODE_NONE - , frontFace = FRONT_FACE_CLOCKWISE - , depthBiasEnable = False - } + { depthClampEnable = False + , rasterizerDiscardEnable = False + , lineWidth = 1 + , polygonMode = POLYGON_MODE_FILL + , cullMode = CULL_MODE_NONE + , frontFace = FRONT_FACE_CLOCKWISE + , depthBiasEnable = False + } , multisampleState = Just . SomeStruct $ zero - { sampleShadingEnable = False - , rasterizationSamples = SAMPLE_COUNT_1_BIT - , minSampleShading = 1 - , sampleMask = [maxBound] - } + { sampleShadingEnable = False + , rasterizationSamples = SAMPLE_COUNT_1_BIT + , minSampleShading = 1 + , sampleMask = [maxBound] + } , depthStencilState = Nothing , colorBlendState = Just . SomeStruct $ zero - { logicOpEnable = False - , attachments = - [ zero - { colorWriteMask = - COLOR_COMPONENT_R_BIT - .|. COLOR_COMPONENT_G_BIT - .|. COLOR_COMPONENT_B_BIT - .|. COLOR_COMPONENT_A_BIT - , blendEnable = False - } ] - } - , dynamicState = Nothing + { logicOpEnable = False + , attachments = + [ zero + { colorWriteMask = + COLOR_COMPONENT_R_BIT + .|. COLOR_COMPONENT_G_BIT + .|. COLOR_COMPONENT_B_BIT + .|. COLOR_COMPONENT_A_BIT + , blendEnable = False + } + ] + } + , dynamicState = Just zero + { dynamicStates = [ DYNAMIC_STATE_VIEWPORT + , DYNAMIC_STATE_SCISSOR + ] + } , layout = pipelineLayout , renderPass = renderPass , subpass = 0 , basePipelineHandle = zero } - V.head . snd <$> withGraphicsPipelines dev zero [SomeStruct pipelineCreateInfo] Nothing allocate' + (key, (_, [graphicsPipeline])) <- withGraphicsPipelines + dev + zero + [SomeStruct pipelineCreateInfo] + Nothing + allocate + release layoutKey + traverse_ release shaderKeys + pure (key, graphicsPipeline) + +createShaders + :: MonadResource m + => Device + -> m (V.Vector (ReleaseKey, SomeStruct PipelineShaderStageCreateInfo)) +createShaders dev = do + let fragCode = [frag| + #version 450 + #extension GL_ARB_separate_shader_objects : enable + + layout(location = 0) in vec3 fragColor; + layout(location = 0) out vec4 outColor; + + void main() { + outColor = vec4(fragColor, 1.0); + } + |] + vertCode = [vert| + #version 450 + #extension GL_ARB_separate_shader_objects : enable + + layout(location = 0) out vec3 fragColor; + + vec2 positions[3] = vec2[]( + vec2(0.0, -0.5), + vec2(0.5, 0.5), + vec2(-0.5, 0.5) + ); + vec3 colors[3] = vec3[]( + vec3(1.0, 1.0, 0.0), + vec3(0.0, 1.0, 1.0), + vec3(1.0, 0.0, 1.0) + ); + + void main() { + gl_Position = vec4(positions[gl_VertexIndex], 0.0, 1.0); + fragColor = colors[gl_VertexIndex]; + } + |] + (fragKey, fragModule) <- withShaderModule dev zero { code = fragCode } Nothing allocate + (vertKey, vertModule) <- withShaderModule dev zero { code = vertCode } Nothing allocate + let vertShaderStageCreateInfo = zero { stage = SHADER_STAGE_VERTEX_BIT + , module' = vertModule + , name = "main" + } + fragShaderStageCreateInfo = zero { stage = SHADER_STAGE_FRAGMENT_BIT + , module' = fragModule + , name = "main" + } + pure + [ (vertKey, SomeStruct vertShaderStageCreateInfo) + , (fragKey, SomeStruct fragShaderStageCreateInfo) + ] + +---------------------------------------------------------------- +-- Framebuffers +---------------------------------------------------------------- createFramebuffers - :: Device -> V.Vector ImageView -> RenderPass -> Extent2D - -> ResourceT IO (V.Vector Framebuffer) -createFramebuffers dev imageViews renderPass Extent2D { width, height } = - for imageViews $ \imageView -> do - let framebufferCreateInfo :: FramebufferCreateInfo '[] - framebufferCreateInfo = zero - { renderPass = renderPass - , attachments = [imageView] - , width = width - , height = height - , layers = 1 - } - withFramebuffer dev framebufferCreateInfo Nothing allocate' + :: MonadResource m + => Device + -> RenderPass + -> Swapchain + -> m (Vector Framebuffer, RefCounted) +createFramebuffers dev rp sc = do + (keys, fbs) <- fmap V.unzip . V.forM (sImageViews sc) $ \iv -> + Framebuffer.createFramebuffer dev rp iv (sExtent sc) + rel <- newRefCounted (traverse_ release keys) + pure (fbs, rel) diff --git a/examples/lib/Utils.hs b/examples/lib/Utils.hs index d3197ae55..e169005e8 100644 --- a/examples/lib/Utils.hs +++ b/examples/lib/Utils.hs @@ -1,7 +1,17 @@ -module Utils where +module Utils + ( loopJust + , loopUntilM + , noSuchThing + , (<&&>) + ) where -import Control.Concurrent ( ) -import Control.Monad +import Control.Concurrent ( ) +import Control.Monad ( unless ) +import Control.Monad.IO.Class ( MonadIO, liftIO ) +import GHC.IO.Exception ( IOErrorType(NoSuchThing) + , IOException(IOError) + ) +import UnliftIO.Exception ( throwIO ) loopJust :: Monad m => (a -> m (Maybe a)) -> a -> m () loopJust f x = f x >>= \case @@ -12,3 +22,15 @@ loopUntilM :: Monad m => m Bool -> m () loopUntilM m = do q <- m unless q $ loopUntilM m + +-- | Throw 'IOError' with 'NoSuchThing' as the error type. Mirrors the small +-- helper duplicated across several example executables. +noSuchThing :: MonadIO m => String -> m a +noSuchThing message = + liftIO . throwIO $ IOError Nothing NoSuchThing "" message Nothing Nothing + +-- | Short-circuiting applicative @&&@ — evaluates the right action only if +-- the left one yielded 'True'… well, actually 'liftA2' evaluates both, but +-- this matches the original pre-existing helper used in hlsl/rays. +(<&&>) :: Applicative f => f Bool -> f Bool -> f Bool +(<&&>) = liftA2 (&&) diff --git a/examples/lib/VkResources.hs b/examples/lib/VkResources.hs new file mode 100644 index 000000000..5ae201e0e --- /dev/null +++ b/examples/lib/VkResources.hs @@ -0,0 +1,67 @@ +-- | Application-static Vulkan handles plus the recycle channel ends used by +-- the recycling 'Frame' machinery in "Frame". +module VkResources + ( VkResources(..) + , Queues(..) + , RecycledResources(..) + , mkVkResources + ) where + +import Control.Concurrent.Chan.Unagi +import Vulkan.Core10 ( CommandPool + , Device + , Instance + , PhysicalDevice + , Semaphore + ) +import Vulkan.Utils.QueueAssignment ( QueueFamilyIndex ) +import Vulkan.Core10 ( Queue ) +import VulkanMemoryAllocator ( Allocator ) + +-- | A bunch of long-lived handles that the application carries around. +-- Constructed once, never modified. +data VkResources = VkResources + { vrInstance :: Instance + , vrPhysicalDevice :: PhysicalDevice + , vrDevice :: Device + , vrAllocator :: Allocator + , vrQueues :: Queues (QueueFamilyIndex, Queue) + , vrRecycleBin :: RecycledResources -> IO () + -- ^ Drop a frame's reusable bits back into the pool. Called from the + -- per-frame wait thread once the GPU is done with the frame. + , vrRecycleNib :: IO (Either (IO RecycledResources) RecycledResources) + -- ^ Pull a frame's reusable bits out. 'Right' if available immediately; + -- 'Left' is a blocking read. + } + +-- | The shape of the queues each example needs. Single graphics queue covers +-- every windowed example here; parameterised over the queue type so the same +-- shape works with 'Vulkan.Utils.QueueAssignment.assignQueues'. +newtype Queues q = Queues { graphicsQueue :: q } + deriving (Functor, Foldable, Traversable) + +-- | The bits of state recycled between frames: two binary semaphores used +-- for image-acquire / render-done synchronisation, and the command pool the +-- frame's commands are recorded into. +data RecycledResources = RecycledResources + { rrImageAvailable :: Semaphore + , rrRenderFinished :: Semaphore + , rrCommandPool :: CommandPool + } + +-- | Assemble a 'VkResources' from already-constructed handles. Builds the +-- recycle channel internally. +mkVkResources + :: Instance + -> PhysicalDevice + -> Device + -> Allocator + -> Queues (QueueFamilyIndex, Queue) + -> IO VkResources +mkVkResources vrInstance vrPhysicalDevice vrDevice vrAllocator vrQueues = do + (binW, binR) <- newChan + let vrRecycleBin = writeChan binW + vrRecycleNib = do + (try, block) <- tryReadChan binR + maybe (Left block) Right <$> tryRead try + pure VkResources { .. } diff --git a/examples/lib/Vma.hs b/examples/lib/Vma.hs new file mode 100644 index 000000000..549df9d70 --- /dev/null +++ b/examples/lib/Vma.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE RecordWildCards #-} + +-- | Shared 'Allocator' construction for VMA-using examples. Each caller passes +-- its own create flags and target Vulkan API version. +module Vma + ( createVMA + ) where + +import Control.Monad.Trans.Resource ( MonadResource, allocate ) +import Data.Word ( Word32 ) +import Foreign.Ptr ( castFunPtr ) +import Vulkan.Core10 ( Device(..) + , Instance(..) + , PhysicalDevice + , deviceHandle + , instanceHandle + , physicalDeviceHandle + ) +import Vulkan.Dynamic ( DeviceCmds(DeviceCmds, pVkGetDeviceProcAddr) + , InstanceCmds(InstanceCmds, pVkGetInstanceProcAddr) + ) +import Vulkan.Zero ( zero ) +import VulkanMemoryAllocator ( Allocator + , AllocatorCreateFlags + , AllocatorCreateInfo(..) + , VulkanFunctions(..) + , withAllocator + ) + +createVMA + :: MonadResource m + => AllocatorCreateFlags + -> Word32 -- ^ Target Vulkan API version + -> Instance + -> PhysicalDevice + -> Device + -> m Allocator +createVMA flags' apiVer inst phys dev = + snd + <$> withAllocator + zero + { flags = flags' + , physicalDevice = physicalDeviceHandle phys + , device = deviceHandle dev + , instance' = instanceHandle inst + , vulkanApiVersion = apiVer + , vulkanFunctions = Just $ case inst of + Instance _ InstanceCmds {..} -> case dev of + Device _ DeviceCmds {..} -> zero + { vkGetInstanceProcAddr = castFunPtr pVkGetInstanceProcAddr + , vkGetDeviceProcAddr = castFunPtr pVkGetDeviceProcAddr + } + } + allocate diff --git a/examples/package.yaml b/examples/package.yaml index 161602815..d401414e1 100644 --- a/examples/package.yaml +++ b/examples/package.yaml @@ -16,24 +16,21 @@ library: dependencies: - VulkanMemoryAllocator - base <5 - - logict - - mtl - - template-haskell - - th-desugar < 2 - - unification-fd - bytestring - derive-storable >= 0.3 - derive-storable-plugin >= 0.2.3.3 - GLFW-b - lens - linear + - mtl - nothunks >= 0.1.2 - - opentelemetry - resourcet >= 1.2.4 + - say - sdl2 >= 2.5.0 - template-haskell - text - transformers + - unagi-chan - unliftio - vector - vulkan @@ -146,20 +143,6 @@ executables: - vulkan-init-sdl2 - vulkan-utils - timeline-semaphore: - main: Main.hs - source-dirs: timeline-semaphore - dependencies: - - vulkan-examples - - base <5 - - resourcet - - say - - transformers - - unliftio - - vector - - vulkan - - vulkan-utils >= 0.3 - hlsl: main: Main.hs source-dirs: hlsl @@ -169,18 +152,15 @@ executables: - base <5 - bytestring - containers - - opentelemetry - resourcet >= 1.2.4 - say - sdl2 - template-haskell - text - transformers - - unagi-chan - unliftio - vector - vulkan - - vulkan-examples - vulkan-init-sdl2 - vulkan-utils >= 0.3 when: @@ -197,13 +177,10 @@ executables: - base <5 - bytestring - colour - - containers - derive-storable >= 0.3 - derive-storable-plugin >= 0.2.3.3 - lens - linear - - nothunks >= 0.1.2 - - opentelemetry - random - resourcet >= 1.2.4 - say @@ -211,11 +188,9 @@ executables: - template-haskell - text - transformers - - unagi-chan - unliftio - vector - vulkan >= 3.7 - - vulkan-examples - vulkan-init-sdl2 - vulkan-utils >= 0.3 when: diff --git a/examples/rays/AccelerationStructure.hs b/examples/rays/AccelerationStructure.hs index c5504f952..a8eb2c716 100644 --- a/examples/rays/AccelerationStructure.hs +++ b/examples/rays/AccelerationStructure.hs @@ -1,6 +1,8 @@ {-# LANGUAGE OverloadedLists #-} -module AccelerationStructure where +module AccelerationStructure + ( createTLAS + ) where import Control.Monad.IO.Class import Control.Monad.Trans.Resource @@ -8,76 +10,74 @@ import Data.Bits import Data.Coerce ( coerce ) import Data.Vector ( Vector ) import Foreign.Storable ( Storable(poke, sizeOf) ) -import HasVulkan -import MonadVulkan import Scene import UnliftIO.Foreign ( castPtr ) +import VkResources ( Queues(..) + , VkResources(..) + ) import Vulkan.CStruct import Vulkan.CStruct.Extends import Vulkan.Core10 import Vulkan.Core12.Promoted_From_VK_KHR_buffer_device_address import Vulkan.Extensions.VK_KHR_acceleration_structure +import Vulkan.Utils.Debug ( nameObject ) import Vulkan.Utils.QueueAssignment import Vulkan.Zero -import VulkanMemoryAllocator ( AllocationCreateInfo - ( requiredFlags - , usage - ) - , MemoryUsage - ( MEMORY_USAGE_GPU_ONLY - ) - ) +import VulkanMemoryAllocator as VMA + hiding ( getPhysicalDeviceProperties ) ---------------------------------------------------------------- -- TLAS ---------------------------------------------------------------- -createTLAS :: SceneBuffers -> V (ReleaseKey, AccelerationStructureKHR) -createTLAS sceneBuffers = do +createTLAS + :: (MonadResource m, MonadFail m) + => VkResources + -> SceneBuffers + -> m (ReleaseKey, AccelerationStructureKHR) +createTLAS vr sceneBuffers = do + let dev = vrDevice vr + vma = vrAllocator vr -- - -- Create the bottom level accelerationStructures + -- Create the bottom level acceleration structure. -- - (_blasReleaseKey, blas) <- createBLAS sceneBuffers - blasAddress <- getAccelerationStructureDeviceAddressKHR' zero + (_blasReleaseKey, blas) <- createBLAS vr sceneBuffers + blasAddress <- getAccelerationStructureDeviceAddressKHR dev zero { accelerationStructure = blas } let identity = TransformMatrixKHR (1, 0, 0, 0) (0, 1, 0, 0) (0, 0, 1, 0) inst :: AccelerationStructureInstanceKHR inst = zero - { transform = identity - , instanceCustomIndex = 0 - , mask = complement 0 + { transform = identity + , instanceCustomIndex = 0 + , mask = complement 0 , instanceShaderBindingTableRecordOffset = 0 , flags = GEOMETRY_INSTANCE_TRIANGLE_FACING_CULL_DISABLE_BIT_KHR - , accelerationStructureReference = coerce blasAddress + , accelerationStructureReference = coerce blasAddress } - -- - -- Create the buffer for the top level instances - -- let numInstances = 1 instanceDescsSize = numInstances * cStructSize @AccelerationStructureInstanceKHR - (_instBufferReleaseKey, (instBuffer, instBufferAllocation, _)) <- withBuffer' + (_instBufferReleaseKey, (instBuffer, instBufferAllocation, _)) <- VMA.withBuffer + vma zero { usage = - BUFFER_USAGE_ACCELERATION_STRUCTURE_BUILD_INPUT_READ_ONLY_BIT_KHR - .|. BUFFER_USAGE_SHADER_DEVICE_ADDRESS_BIT + BUFFER_USAGE_ACCELERATION_STRUCTURE_BUILD_INPUT_READ_ONLY_BIT_KHR + .|. BUFFER_USAGE_SHADER_DEVICE_ADDRESS_BIT , size = fromIntegral instanceDescsSize } - -- TODO: Make this GPU only and transfer to it zero { requiredFlags = MEMORY_PROPERTY_HOST_VISIBLE_BIT .|. MEMORY_PROPERTY_HOST_COHERENT_BIT } - nameObject' instBuffer "TLAS instances" - instBufferDeviceAddress <- getBufferDeviceAddress' zero { buffer = instBuffer - } + allocate + nameObject dev instBuffer "TLAS instances" + instBufferDeviceAddress <- getBufferDeviceAddress dev zero + { buffer = instBuffer + } - -- - -- populate the instance buffer - -- - (instMapKey, instMapPtr) <- withMappedMemory' instBufferAllocation + (instMapKey, instMapPtr) <- VMA.withMappedMemory vma instBufferAllocation allocate liftIO $ poke (castPtr @_ @AccelerationStructureInstanceKHR instMapPtr) inst release instMapKey @@ -91,51 +91,58 @@ createTLAS sceneBuffers = do , flags = GEOMETRY_OPAQUE_BIT_KHR } ] - buildInfo = zero { type' = ACCELERATION_STRUCTURE_TYPE_TOP_LEVEL_KHR - , mode = BUILD_ACCELERATION_STRUCTURE_MODE_BUILD_KHR -- ignored but used later - , srcAccelerationStructure = NULL_HANDLE -- ignored - , dstAccelerationStructure = NULL_HANDLE -- ignored - , geometries = buildGeometries - , scratchData = zero - } + buildInfo = zero + { type' = ACCELERATION_STRUCTURE_TYPE_TOP_LEVEL_KHR + , mode = BUILD_ACCELERATION_STRUCTURE_MODE_BUILD_KHR + , srcAccelerationStructure = NULL_HANDLE + , dstAccelerationStructure = NULL_HANDLE + , geometries = buildGeometries + , scratchData = zero + } maxPrimitiveCounts = [1] rangeInfos = [zero { primitiveCount = 1, primitiveOffset = 0 }] - sizes <- getAccelerationStructureBuildSizesKHR' + sizes <- getAccelerationStructureBuildSizesKHR + dev ACCELERATION_STRUCTURE_BUILD_TYPE_DEVICE_KHR buildInfo maxPrimitiveCounts - (_tlasBufferKey, tlasKey, tlas) <- buildAccelerationStructure buildInfo - rangeInfos - sizes - nameObject' tlas "TLAS" + (_tlasBufferKey, tlasKey, tlas) <- buildAccelerationStructure + vr + buildInfo + rangeInfos + sizes + nameObject dev tlas "TLAS" pure (tlasKey, tlas) buildAccelerationStructure - :: AccelerationStructureBuildGeometryInfoKHR + :: (MonadResource m, MonadFail m) + => VkResources + -> AccelerationStructureBuildGeometryInfoKHR -> Vector AccelerationStructureBuildRangeInfoKHR -> AccelerationStructureBuildSizesInfoKHR - -> V (ReleaseKey, ReleaseKey, AccelerationStructureKHR) -buildAccelerationStructure geom ranges sizes = do - -- - -- Allocate the buffer to hold the acceleration structure - -- - let bufferSize = accelerationStructureSize sizes - (asBufferKey, (asBuffer, _, _)) <- withBuffer' + -> m (ReleaseKey, ReleaseKey, AccelerationStructureKHR) +buildAccelerationStructure vr geom ranges sizes = do + let dev = vrDevice vr + vma = vrAllocator vr + bufferSize = accelerationStructureSize sizes + + (asBufferKey, (asBuffer, _, _)) <- VMA.withBuffer + vma zero { size = bufferSize , usage = BUFFER_USAGE_ACCELERATION_STRUCTURE_STORAGE_BIT_KHR } zero { usage = MEMORY_USAGE_GPU_ONLY } + allocate - -- - -- Allocate scratch space for building - -- - (scratchBufferKey, (scratchBuffer, _, _)) <- withBuffer' + (scratchBufferKey, (scratchBuffer, _, _)) <- VMA.withBuffer + vma zero { size = buildScratchSize sizes , usage = BUFFER_USAGE_SHADER_DEVICE_ADDRESS_BIT } zero { usage = MEMORY_USAGE_GPU_ONLY } - scratchBufferDeviceAddress <- getBufferDeviceAddress' zero + allocate + scratchBufferDeviceAddress <- getBufferDeviceAddress dev zero { buffer = scratchBuffer } @@ -144,10 +151,11 @@ buildAccelerationStructure geom ranges sizes = do , offset = 0 , size = bufferSize } - (asKey, as) <- withAccelerationStructureKHR' asci + (asKey, as) <- withAccelerationStructureKHR dev asci Nothing allocate - oneShotComputeCommands $ do - cmdBuildAccelerationStructuresKHR' + oneShotComputeCommands vr $ \cmd -> + cmdBuildAccelerationStructuresKHR + cmd [ geom { dstAccelerationStructure = as , scratchData = DeviceAddress scratchBufferDeviceAddress } @@ -158,40 +166,48 @@ buildAccelerationStructure geom ranges sizes = do pure (asKey, asBufferKey, as) --- --- Create the bottom level acceleration structure --- -createBLAS :: SceneBuffers -> V (ReleaseKey, AccelerationStructureKHR) -createBLAS sceneBuffers = do - (sceneGeom, sceneOffsets) <- sceneGeometry sceneBuffers - - let buildInfo = zero { type' = ACCELERATION_STRUCTURE_TYPE_BOTTOM_LEVEL_KHR - , mode = BUILD_ACCELERATION_STRUCTURE_MODE_BUILD_KHR -- ignored but used later - , srcAccelerationStructure = NULL_HANDLE -- ignored - , dstAccelerationStructure = NULL_HANDLE -- ignored - , geometries = [SomeStruct sceneGeom] - , scratchData = zero - } +createBLAS + :: (MonadResource m, MonadFail m) + => VkResources + -> SceneBuffers + -> m (ReleaseKey, AccelerationStructureKHR) +createBLAS vr sceneBuffers = do + let dev = vrDevice vr + (sceneGeom, sceneOffsets) <- sceneGeometry vr sceneBuffers + + let buildInfo = zero + { type' = ACCELERATION_STRUCTURE_TYPE_BOTTOM_LEVEL_KHR + , mode = BUILD_ACCELERATION_STRUCTURE_MODE_BUILD_KHR + , srcAccelerationStructure = NULL_HANDLE + , dstAccelerationStructure = NULL_HANDLE + , geometries = [SomeStruct sceneGeom] + , scratchData = zero + } maxPrimitiveCounts = [sceneSize sceneBuffers] - sizes <- getAccelerationStructureBuildSizesKHR' + sizes <- getAccelerationStructureBuildSizesKHR + dev ACCELERATION_STRUCTURE_BUILD_TYPE_DEVICE_KHR buildInfo maxPrimitiveCounts - (_blasBufferKey, blasKey, blas) <- buildAccelerationStructure buildInfo - sceneOffsets - sizes - nameObject' blas "BLAS" + (_blasBufferKey, blasKey, blas) <- buildAccelerationStructure + vr + buildInfo + sceneOffsets + sizes + nameObject dev blas "BLAS" pure (blasKey, blas) sceneGeometry - :: SceneBuffers - -> V + :: MonadIO m + => VkResources + -> SceneBuffers + -> m ( AccelerationStructureGeometryKHR '[] , Vector AccelerationStructureBuildRangeInfoKHR ) -sceneGeometry SceneBuffers {..} = do - boxAddr <- getBufferDeviceAddress' zero { buffer = sceneAabbs } +sceneGeometry vr SceneBuffers {..} = do + boxAddr <- getBufferDeviceAddress (vrDevice vr) zero { buffer = sceneAabbs } let boxData = AccelerationStructureGeometryAabbsDataKHR { data' = DeviceAddressConst boxAddr , stride = fromIntegral (sizeOf (undefined :: AabbPositionsKHR)) @@ -205,39 +221,40 @@ sceneGeometry SceneBuffers {..} = do pure (geom, offsetInfo) ---------------------------------------------------------------- --- Utils +-- One-shot command submission for setup work ---------------------------------------------------------------- --- TODO: use compute queue here -oneShotComputeCommands :: CmdT V () -> V () -oneShotComputeCommands cmds = do - -- - -- Create command buffers - -- - graphicsQueue <- getGraphicsQueue - QueueFamilyIndex graphicsQueueFamilyIndex <- getGraphicsQueueFamilyIndex - (poolKey, commandPool) <- withCommandPool' zero - { queueFamilyIndex = graphicsQueueFamilyIndex - } - ~[commandBuffer] <- allocateCommandBuffers' zero - { commandPool = commandPool - , level = COMMAND_BUFFER_LEVEL_PRIMARY - , commandBufferCount = 1 - } +oneShotComputeCommands + :: (MonadResource m, MonadFail m) + => VkResources + -> (CommandBuffer -> IO ()) + -> m () +oneShotComputeCommands vr cmds = do + let dev = vrDevice vr + Queues (QueueFamilyIndex graphicsQueueFamilyIndex, graphicsQueue) = + vrQueues vr + (poolKey, commandPool) <- withCommandPool + dev + zero { queueFamilyIndex = graphicsQueueFamilyIndex } + Nothing + allocate + ~[commandBuffer] <- allocateCommandBuffers + dev + zero { commandPool = commandPool + , level = COMMAND_BUFFER_LEVEL_PRIMARY + , commandBufferCount = 1 + } - -- - -- Record and kick off the build commands - -- - useCommandBuffer' commandBuffer - zero { flags = COMMAND_BUFFER_USAGE_ONE_TIME_SUBMIT_BIT } - cmds - (fenceKey, fence) <- withFence' zero + useCommandBuffer commandBuffer + zero { flags = COMMAND_BUFFER_USAGE_ONE_TIME_SUBMIT_BIT } + (liftIO (cmds commandBuffer)) + (fenceKey, fence) <- withFence dev zero Nothing allocate queueSubmit graphicsQueue [SomeStruct zero { commandBuffers = [commandBufferHandle commandBuffer] }] fence let oneSecond = 1e9 - waitForFencesSafe' [fence] True oneSecond >>= \case + waitForFencesSafe dev [fence] True oneSecond >>= \case SUCCESS -> pure () TIMEOUT -> error "Timed out running one shot commands" _ -> error "Unhandled exit code in oneShotComputeCommands" diff --git a/examples/rays/Cleanup.hs b/examples/rays/Cleanup.hs deleted file mode 100644 index 28782ca84..000000000 --- a/examples/rays/Cleanup.hs +++ /dev/null @@ -1,105 +0,0 @@ -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE OverloadedLists #-} - -module Cleanup where - -import Control.Concurrent.Chan.Unagi -import Control.Exception ( throwIO ) -import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Trans.Reader -import Data.Word -import GHC.IO.Exception ( IOErrorType(TimeExpired) - , IOException(IOError) - ) -import MonadVulkan -import NoThunks.Class ( InspectHeap(..) - , NoThunks - ) -import Vulkan.Core10 -import Vulkan.Core12.Promoted_From_VK_KHR_timeline_semaphore -import Vulkan.NamedType -import Vulkan.Zero - -data Cleaner = Cleaner - { cChanIn :: (V RecycledResources, V ()) -> IO () - , cChanOut :: IO (V RecycledResources, V ()) - } - deriving NoThunks via InspectHeap Cleaner - -newCleaner :: Word64 -> Semaphore -> V Cleaner -newCleaner nextIndex sem = do - (inChan, outChan) <- liftIO newChan - let cChanIn = writeChan inChan - cChanOut = readChan outChan - spawn_ $ cleanupThread cChanOut nextIndex sem - pure Cleaner { .. } - -pushCleanup :: Cleaner -> V RecycledResources -> V () -> V () -pushCleanup Cleaner {..} recycle discard = liftIO $ cChanIn (recycle, discard) - --- | A thread which watches the frame finished semaphore and performs frame --- cleanup when it advances. --- --- A frame should push work onto the cleanup queue iff if increments the --- semaphore. -cleanupThread - :: IO (V RecycledResources, V ()) - -- ^ An IO action which resets any resources and returns the set of resources - -- ready to be used. - -> Word64 - -- ^ The index to wait for before recycling the resources - -> Semaphore - -- ^ The timeline semaphore containing that index - -> V a -cleanupThread getCleanup nextIndex sem = do - -- Make sure we have something worth waiting for, otherwise we could be - -- waiting for a semaphore which won't increment - firstCleanup <- liftIO getCleanup - - -- Wait for the semaphore to reach our value - let waitInfo = zero { semaphores = [sem], values = [nextIndex] } - oneSecond = 1e9 - waitTwice waitInfo oneSecond >>= \case - TIMEOUT -> - timeoutError "Timed out (1s) waiting for frame to finish on Device" - _ -> pure () - - -- See if we can release more than one frame - v <- getSemaphoreCounterValue' sem - let nextIndex' = succ v - numExtraFrames = fromIntegral (v - nextIndex) - - runCleanup firstCleanup - replicateM_ numExtraFrames $ runCleanup =<< liftIO getCleanup - - cleanupThread getCleanup nextIndex' sem - -runCleanup :: (V RecycledResources, V ()) -> V () -runCleanup (releaseResources, finalRetire) = do - -- Get the next resources and send them down the line - rs <- releaseResources - -- Signal we're done by making the recycled resources available - bin <- V $ asks ghRecycleBin - liftIO $ bin rs - -- Release anything else - finalRetire - ----------------------------------------------------------------- --- Utils ----------------------------------------------------------------- - --- | Wait for some semaphores, if the wait times out give the frame one last --- chance to complete with a zero timeout. --- --- It could be that the program was suspended during the preceding --- wait causing it to timeout, this will check if it actually --- finished. -waitTwice :: SemaphoreWaitInfo -> ("timeout" ::: Word64) -> V Result -waitTwice waitInfo t = waitSemaphoresSafe' waitInfo t >>= \case - TIMEOUT -> waitSemaphores' waitInfo 0 - r -> pure r - -timeoutError :: MonadIO m => String -> m a -timeoutError message = - liftIO . throwIO $ IOError Nothing TimeExpired "" message Nothing Nothing diff --git a/examples/rays/Frame.hs b/examples/rays/Frame.hs deleted file mode 100644 index caf7a62a9..000000000 --- a/examples/rays/Frame.hs +++ /dev/null @@ -1,225 +0,0 @@ -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} - --- | Defines the 'Frame' type, most interesting operations regarding 'Frame's --- can be found in 'MonadFrame' -module Frame where - -import AccelerationStructure -import Camera -import Cleanup -import Control.Arrow ( Arrow((&&&)) ) -import Control.Monad ( zipWithM ) -import Control.Monad.IO.Class ( MonadIO(liftIO) ) -import Control.Monad.Trans.Reader ( asks ) -import Control.Monad.Trans.Resource ( InternalState - , ReleaseKey - , allocate - , closeInternalState - , createInternalState - ) -import Data.Foldable -import Data.IORef -import qualified Data.Vector as V -import Data.Word -import Foreign.Ptr ( Ptr - , castPtr - ) -import Foreign.Storable -import GHC.Generics -import InstrumentDecs ( withSpan_ ) -import MonadVulkan -import NoThunks.Class -import Orphans ( ) -import qualified Pipeline -import qualified SDL -import SDL ( Window ) -import qualified SDL.Video.Vulkan as SDL -import Scene -import Swapchain -import Vulkan.CStruct.Extends -import Vulkan.Core10 -import Vulkan.Core12.Promoted_From_VK_KHR_buffer_device_address -import Vulkan.Core12.Promoted_From_VK_KHR_timeline_semaphore -import Vulkan.Extensions.VK_KHR_acceleration_structure -import Vulkan.Extensions.VK_KHR_surface -import Vulkan.Utils.QueueAssignment -import Vulkan.Zero -import VulkanMemoryAllocator - --- | Must be positive, duh -numConcurrentFrames :: Word64 -numConcurrentFrames = 3 - --- | All the information required to render a single frame -data Frame = Frame - { fIndex :: Word64 -- ^ Which number frame is this - -- SDL things - , fWindow :: SDL.Window - -- Vulkan things - , fSurface :: SurfaceKHR - , fSwapchainResources :: SwapchainResources - , fPipeline :: Pipeline - , fPipelineLayout :: PipelineLayout - , fAccelerationStructure :: AccelerationStructureKHR - , fShaderBindingTable :: Buffer - , fShaderBindingTableAddress :: DeviceAddress - , fCameraMatricesBuffer :: Buffer - , fCameraMatricesAllocation :: Allocation - , fCameraMatricesBufferData :: Ptr CameraMatrices - , fRenderFinishedHostSemaphore :: Semaphore - -- ^ A timeline semaphore which increments to fIndex when this frame is - -- done, the host can wait on this semaphore - , fRecycledResources :: RecycledResources - -- ^ Resources which can be used for this frame and are then passed on to a - -- later frame. - , fCleaner :: Cleaner - -- ^ Handle to the thread doing cleanup after frames - , fWorkProgress :: IORef WorkProgress - , fResources :: (ReleaseKey, InternalState) - -- ^ The 'InternalState' for tracking frame-local resources along with the - -- key to release it in the global scope. This will be released when the - -- frame is done with GPU work. - } - deriving (Generic, NoThunks) - -data WorkProgress - = NoWorkSubmitted - -- ^ We've not submitted anything to the GPU yet and resources are free to - -- be recycled without waiting. - | SomeWorkSubmitted - -- ^ We have failed to finish submitting all work to the GPU and the frame - -- counter semaphore won't be incremented. This is exceptional. - | AllWorkSubmitted - -- ^ We submitted all work and the device will bump the frame counter - -- semaphore. - deriving (Generic, NoThunks) - -initialRecycledResources :: Word64 -> DescriptorSet -> V RecycledResources -initialRecycledResources index fDescriptorSet = do - (_, fImageAvailableSemaphore) <- withSemaphore' - (zero ::& SemaphoreTypeCreateInfo SEMAPHORE_TYPE_BINARY 0 :& ()) - - (_, fRenderFinishedSemaphore) <- withSemaphore' - (zero ::& SemaphoreTypeCreateInfo SEMAPHORE_TYPE_BINARY 0 :& ()) - - graphicsQueueFamilyIndex <- getGraphicsQueueFamilyIndex - (_, fCommandPool) <- withCommandPool' zero - { queueFamilyIndex = unQueueFamilyIndex graphicsQueueFamilyIndex - } - let fCameraMatricesOffset = - index * fromIntegral (sizeOf (undefined :: CameraMatrices)) - - pure RecycledResources { .. } - --- | Create a 'Frame' from scratch -initialFrame :: Window -> SurfaceKHR -> V Frame -initialFrame fWindow fSurface = do - let fIndex = 1 - - -- Create our swapchain for this 'Window' - -- These resources will last for longer than this frame - SDL.V2 width height <- SDL.vkGetDrawableSize fWindow - let windowSize = Extent2D (fromIntegral width) (fromIntegral height) - oldSwapchain = NULL_HANDLE - fSwapchainResources <- allocSwapchainResources oldSwapchain - windowSize - fSurface - - sceneBuffers <- makeSceneBuffers - - -- The acceleration structure - (_, fAccelerationStructure) <- createTLAS sceneBuffers - - -- Create the RT pipeline - (_, descriptorSetLayout ) <- Pipeline.createRTDescriptorSetLayout - (_, fPipelineLayout) <- Pipeline.createRTPipelineLayout descriptorSetLayout - (_, fPipeline, numGroups) <- Pipeline.createPipeline fPipelineLayout - (_, fShaderBindingTable) <- Pipeline.createShaderBindingTable fPipeline - numGroups - fShaderBindingTableAddress <- getBufferDeviceAddress' zero - { buffer = fShaderBindingTable - } - descriptorSets <- Pipeline.createRTDescriptorSets - descriptorSetLayout - fAccelerationStructure - sceneBuffers - (fromIntegral numConcurrentFrames) - - (_, (fCameraMatricesBuffer, fCameraMatricesAllocation, bufferAllocInfo)) <- - withBuffer' - zero - { size = numConcurrentFrames * fromIntegral - (sizeOf (error "sizeof evaluated" :: CameraMatrices)) - , usage = BUFFER_USAGE_UNIFORM_BUFFER_BIT - } - zero { flags = ALLOCATION_CREATE_MAPPED_BIT - , usage = MEMORY_USAGE_CPU_TO_GPU - , requiredFlags = MEMORY_PROPERTY_HOST_VISIBLE_BIT - } - let fCameraMatricesBufferData = - castPtr @() @CameraMatrices (mappedData bufferAllocInfo) - - -- Don't keep the release key, this semaphore lives for the lifetime of the - -- application - (_, fRenderFinishedHostSemaphore) <- withSemaphore' - (zero ::& SemaphoreTypeCreateInfo SEMAPHORE_TYPE_TIMELINE 0 :& ()) - - fCleaner <- newCleaner fIndex fRenderFinishedHostSemaphore - - -- Create the 'RecycledResources' necessary to kick off the rest of the - -- concurrent frames and push them into the chan. - let (ourDescriptorSet, otherDescriptorSets) = - (V.head &&& (toList . V.tail)) descriptorSets - ~(fRecycledResources : otherRecycledResources) <- zipWithM - initialRecycledResources - [0 ..] - (ourDescriptorSet : otherDescriptorSets) - bin <- V $ asks ghRecycleBin - liftIO $ for_ otherRecycledResources bin - - fWorkProgress <- liftIO $ newIORef NoWorkSubmitted - -- Create the frame resource tracker at the global level so it's closed - -- correctly on exception - fResources <- allocate createInternalState closeInternalState - - pure Frame { .. } - --- | Create the next frame -advanceFrame :: Bool -> Frame -> V Frame -advanceFrame needsNewSwapchain f = do - -- Wait for a prior frame to finish, then we can steal it's resources! - nib <- V $ asks ghRecycleNib - fRecycledResources <- withSpan_ "CPU is ahead" $ liftIO $ nib >>= \case - Left block -> block - Right rs -> pure rs - - fSwapchainResources <- if needsNewSwapchain - then recreateSwapchainResources (fWindow f) (fSwapchainResources f) - else pure $ fSwapchainResources f - - -- The per-frame resource helpers need to be created fresh - fWorkProgress <- liftIO $ newIORef NoWorkSubmitted - fResources <- allocate createInternalState closeInternalState - - let f' = Frame - { fIndex = succ (fIndex f) - , fWindow = fWindow f - , fSurface = fSurface f - , fSwapchainResources - , fPipeline = fPipeline f - , fPipelineLayout = fPipelineLayout f - , fShaderBindingTable = fShaderBindingTable f - , fShaderBindingTableAddress = fShaderBindingTableAddress f - , fAccelerationStructure = fAccelerationStructure f - , fCameraMatricesBuffer = fCameraMatricesBuffer f - , fCameraMatricesAllocation = fCameraMatricesAllocation f - , fCameraMatricesBufferData = fCameraMatricesBufferData f - , fRenderFinishedHostSemaphore = fRenderFinishedHostSemaphore f - , fCleaner = fCleaner f - , fWorkProgress - , fResources - , fRecycledResources - } - pure f' diff --git a/examples/rays/Init.hs b/examples/rays/Init.hs index 3663586a6..f67ea6756 100644 --- a/examples/rays/Init.hs +++ b/examples/rays/Init.hs @@ -4,52 +4,35 @@ module Init ( Init.createInstance , Init.createDevice , PhysicalDeviceInfo(..) + , RTInfo(..) , createVMA - , createCommandPools ) where -import Control.Applicative +import Control.Applicative ( empty ) import Control.Monad.IO.Class import Control.Monad.Trans.Maybe ( MaybeT(..) ) import Control.Monad.Trans.Resource -import Data.Foldable ( for_ - , traverse_ - ) -import qualified Data.Vector as V +import Data.Foldable ( traverse_ ) import Data.Vector ( Vector ) import Data.Word -import GHC.IO.Exception ( IOErrorType(NoSuchThing) - , IOException(IOError) - ) -import HasVulkan -import MonadVulkan ( Queues(..) - , RTInfo(..) - , checkCommands - ) import qualified SDL.Video as SDL import Say -import UnliftIO.Exception +import Utils ( noSuchThing + , (<&&>) + ) +import VkResources ( Queues(..) ) +import qualified Vma import Vulkan.CStruct.Extends import Vulkan.Core10 as Vk hiding ( withBuffer , withImage ) import qualified Vulkan.Core10 as MemoryHeap (MemoryHeap(..)) -import qualified Vulkan.Core10 as CommandPoolCreateInfo (CommandPoolCreateInfo(..)) import Vulkan.Core11 ( pattern API_VERSION_1_1 ) import Vulkan.Core12.Promoted_From_VK_KHR_buffer_device_address import Vulkan.Core12.Promoted_From_VK_KHR_timeline_semaphore ( PhysicalDeviceTimelineSemaphoreFeatures(..) ) -import Vulkan.Dynamic ( DeviceCmds - ( DeviceCmds - , pVkGetDeviceProcAddr - ) - , InstanceCmds - ( InstanceCmds - , pVkGetInstanceProcAddr - ) - ) import Vulkan.Extensions.VK_EXT_debug_utils ( pattern EXT_DEBUG_UTILS_EXTENSION_NAME ) import Vulkan.Extensions.VK_KHR_acceleration_structure @@ -65,13 +48,8 @@ import Vulkan.Utils.Requirements.TH ( reqs ) import Vulkan.Zero import VulkanMemoryAllocator ( Allocator , AllocatorCreateFlagBits(..) - , AllocatorCreateInfo(..) - , VulkanFunctions(..) - , vkGetInstanceProcAddr - , withAllocator ) import Window.SDL2 -import Foreign.Ptr (castFunPtr) myApiVersion :: Word32 myApiVersion = API_VERSION_1_1 @@ -98,7 +76,12 @@ createInstance win = VkInit.withInstance -- Device creation ---------------------------------------------------------------- --- TODO: check VkPhysicalDeviceBufferDeviceAddressFeatures::bufferDeviceAddress. +-- | Information for ray tracing (queried from device properties). +data RTInfo = RTInfo + { rtiShaderGroupHandleSize :: Word32 + , rtiShaderGroupBaseAlignment :: Word32 + } + createDevice :: forall m . (MonadResource m) @@ -121,8 +104,6 @@ createDevice inst win = do (_, dev) <- withDevice phys dci Nothing allocate - requireCommands inst dev - queues <- liftIO $ pdiGetQueues pdi dev pure (phys, pdi, dev, queues, surf) @@ -156,7 +137,6 @@ deviceRequirements = [reqs| data PhysicalDeviceInfo = PhysicalDeviceInfo { pdiTotalMemory :: Word64 , pdiRTInfo :: RTInfo - -- ^ The relevant information from PhysicalDeviceProperties2KHR , pdiQueueCreateInfos :: Vector (DeviceQueueCreateInfo '[]) , pdiGetQueues :: Device -> IO (Queues (QueueFamilyIndex, Queue)) } @@ -170,39 +150,23 @@ physicalDeviceInfo -> PhysicalDevice -> m (Maybe (PhysicalDeviceInfo, SomeStruct DeviceCreateInfo)) physicalDeviceInfo surf phys = runMaybeT $ do - -- - -- Check device requirements - -- - (mbDCI, rs, os) <- checkDeviceRequirements deviceRequirements [] phys zero - -- Report any missing features + (mbDCI, rs, os) <- checkDeviceRequirements deviceRequirements [] phys zero traverse_ sayErrString (requirementReport rs os) - -- Fail if we didn't meet requirements SomeStruct dciNoQueues <- maybe empty pure mbDCI - -- - -- Assign queues - -- (pdiQueueCreateInfos, pdiGetQueues) <- MaybeT $ assignQueues phys (queueRequirements phys surf) let dci = dciNoQueues { queueCreateInfos = SomeStruct <$> pdiQueueCreateInfos } - -- - -- Query properties - -- pdiRTInfo <- getDeviceRTProps phys - -- - -- We'll use the amount of memory to pick the "best" device - -- pdiTotalMemory <- do heaps <- memoryHeaps <$> getPhysicalDeviceMemoryProperties phys pure $ sum (MemoryHeap.size <$> heaps) pure (PhysicalDeviceInfo { .. }, SomeStruct dci) --- | Requirements for a 'Queue' which has graphics suppor and can present to --- the specified surface. queueRequirements :: MonadIO m => PhysicalDevice -> SurfaceKHR -> Queues (QueueSpec m) queueRequirements phys surf = Queues (QueueSpec 1 isGraphicsPresentQueue) @@ -211,10 +175,6 @@ queueRequirements phys surf = Queues (QueueSpec 1 isGraphicsPresentQueue) pure (isGraphicsQueueFamily queueFamilyProperties) <&&> isPresentQueueFamily phys surf queueFamilyIndex ----------------------------------------------------------------- --- Physical device tools ----------------------------------------------------------------- - getDeviceRTProps :: MonadIO m => PhysicalDevice -> m RTInfo getDeviceRTProps phys = do props <- getPhysicalDeviceProperties2KHR phys @@ -229,62 +189,4 @@ getDeviceRTProps phys = do createVMA :: MonadResource m => Instance -> PhysicalDevice -> Device -> m Allocator -createVMA inst phys dev = - snd - <$> withAllocator - zero - { flags = ALLOCATOR_CREATE_BUFFER_DEVICE_ADDRESS_BIT - , physicalDevice = physicalDeviceHandle phys - , device = deviceHandle dev - , instance' = instanceHandle inst - , vulkanApiVersion = myApiVersion - , vulkanFunctions = Just $ case inst of - Instance _ InstanceCmds {..} -> case dev of - Device _ DeviceCmds {..} -> zero - { vkGetInstanceProcAddr = castFunPtr pVkGetInstanceProcAddr - , vkGetDeviceProcAddr = castFunPtr pVkGetDeviceProcAddr - } - } - allocate - ----------------------------------------------------------------- --- Command pools ----------------------------------------------------------------- - --- | Create several command pools for a queue family -createCommandPools - :: MonadResource m - => Device - -> Int - -- ^ Number of pools to create - -> QueueFamilyIndex - -- ^ Queue family for the pools - -> m (Vector CommandPool) -createCommandPools dev n (QueueFamilyIndex queueFamilyIndex) = do - let commandPoolCreateInfo = zero { CommandPoolCreateInfo.queueFamilyIndex = queueFamilyIndex } - V.replicateM - n - ( snd - <$> withCommandPool dev - commandPoolCreateInfo - noAllocationCallbacks - allocate - ) - ----------------------------------------------------------------- --- Utils ----------------------------------------------------------------- - -requireCommands :: MonadIO f => Instance -> Device -> f () -requireCommands inst dev = case checkCommands inst dev of - [] -> pure () - xs -> do - for_ xs $ \n -> sayErr ("Failed to load function pointer for: " <> n) - noSuchThing "Missing commands" - -noSuchThing :: MonadIO m => String -> m a -noSuchThing message = - liftIO . throwIO $ IOError Nothing NoSuchThing "" message Nothing Nothing - -(<&&>) :: Applicative f => f Bool -> f Bool -> f Bool -(<&&>) = liftA2 (&&) +createVMA = Vma.createVMA ALLOCATOR_CREATE_BUFFER_DEVICE_ADDRESS_BIT myApiVersion diff --git a/examples/rays/Main.hs b/examples/rays/Main.hs index 2d716e9da..7060209de 100644 --- a/examples/rays/Main.hs +++ b/examples/rays/Main.hs @@ -1,52 +1,149 @@ +{-# LANGUAGE TypeApplications #-} + module Main where +import AccelerationStructure ( createTLAS ) +import Camera ( CameraMatrices ) import Control.Monad.IO.Class import Control.Monad.Trans.Resource -import Frame -import Init -import MonadFrame -import MonadVulkan -import Render -import SDL ( showWindow - , time +import Data.Foldable ( for_ ) +import Data.IORef +import Data.Word ( Word64 ) +import qualified Data.Vector as V +import Foreign.Ptr ( castPtr ) +import Foreign.Storable ( sizeOf ) +import Frame ( Frame(..) + , advanceFrame + , initialFrame + , numConcurrentFrames + , runFrame + ) +import Init ( PhysicalDeviceInfo(..) + , createDevice + , createInstance + , createVMA + ) +import qualified Pipeline +import Render ( RenderState(..) + , renderFrame + ) +import qualified SDL +import qualified SDL.Video.Vulkan as SDL +import Scene ( makeSceneBuffers ) +import Swapchain ( Swapchain(..) + , allocSwapchain + , recreateSwapchain + , threwSwapchainError + ) +import Utils ( loopJust ) +import VkResources ( mkVkResources ) +import Vulkan.Core10 +import Vulkan.Zero ( zero ) +import Vulkan.Core12.Promoted_From_VK_KHR_buffer_device_address + ( BufferDeviceAddressInfo(..) + , getBufferDeviceAddress + ) +import VulkanMemoryAllocator as VMA + hiding ( getPhysicalDeviceProperties ) +import Window.SDL2 ( RefreshLimit(..) + , createWindow + , shouldQuit + , withSDL ) -import Swapchain ( threwSwapchainError ) -import Utils -import Window.SDL2 main :: IO () main = runResourceT $ do - -- - -- Initialization - -- withSDL win <- createWindow "Vulkan ⚡ Haskell" 1280 720 inst <- Init.createInstance win (phys, pdi, dev, qs, surf) <- Init.createDevice inst win vma <- createVMA inst phys dev + vr <- liftIO $ mkVkResources inst phys dev vma qs + + -- Initial swapchain + initialSize <- liftIO $ drawableSize win + initialSC <- allocSwapchain vr NULL_HANDLE initialSize surf - -- - -- Go - -- - start <- SDL.time @Double - let reportFPS f = do + -- Scene + acceleration structure + sceneBuffers <- makeSceneBuffers vma + (_, tlas) <- createTLAS vr sceneBuffers + + -- RT pipeline + descriptor sets + let rtInfo = pdiRTInfo pdi + (_, descSetLayout) <- Pipeline.createRTDescriptorSetLayout dev + (_, pipelineLayout) <- Pipeline.createRTPipelineLayout dev descSetLayout + (_, pipeline, numGroups) <- Pipeline.createPipeline dev pipelineLayout + (_, sbtBuffer) <- Pipeline.createShaderBindingTable dev vma rtInfo pipeline numGroups + sbtAddress <- getBufferDeviceAddress dev zero { buffer = sbtBuffer } + descSets <- Pipeline.createRTDescriptorSets + dev + descSetLayout + tlas + sceneBuffers + (fromIntegral numConcurrentFrames) + + -- Camera matrices buffer (one slot per concurrent frame). + let cmSize = fromIntegral numConcurrentFrames + * fromIntegral (sizeOf (undefined :: CameraMatrices)) + (_, (cmBuffer, cmAlloc, cmAllocInfo)) <- VMA.withBuffer + vma + zero { size = cmSize + , usage = BUFFER_USAGE_UNIFORM_BUFFER_BIT + } + zero + { flags = ALLOCATION_CREATE_MAPPED_BIT + , usage = MEMORY_USAGE_CPU_TO_GPU + , requiredFlags = MEMORY_PROPERTY_HOST_VISIBLE_BIT + } + allocate + let cmBufferData = castPtr @() @CameraMatrices (mappedData cmAllocInfo) + + let renderState = RenderState + { rsPipeline = pipeline + , rsPipelineLayout = pipelineLayout + , rsDescriptorSets = descSets + , rsShaderBindingTableAddress = sbtAddress + , rsCameraMatricesBuffer = cmBuffer + , rsCameraMatricesAllocation = cmAlloc + , rsCameraMatricesBufferData = cmBufferData + , rsRTInfo = rtInfo + } + + scRef <- liftIO $ newIORef initialSC + initial <- initialFrame vr initialSC + + liftIO $ for_ descSets (\_ -> pure ()) -- descSets is used; silence unused + + SDL.showWindow win + start <- SDL.time @Double + + let + perFrame f = do + currentSC <- liftIO $ readIORef scRef + let f' = f { fSwapchain = currentSC } + needsNew <- threwSwapchainError $ liftIO $ runFrame vr f' $ + renderFrame vr renderState f' + sc' <- if needsNew + then do + newSize <- liftIO $ drawableSize win + sc' <- recreateSwapchain vr newSize currentSC + liftIO $ writeIORef scRef sc' + pure sc' + else pure currentSC + advanceFrame vr sc' f' + + loop f = shouldQuit NoLimit >>= \case + True -> do end <- SDL.time - let frames = fIndex f - mean = realToFrac frames / (end - start) + let frames = fIndex f :: Word64 + mean = realToFrac frames / (end - start) :: Double liftIO $ putStrLn $ "Average: " <> show mean + pure Nothing + False -> Just <$> perFrame f - let rtInfo = pdiRTInfo pdi + loopJust loop initial - let frame f = do - shouldQuit NoLimit >>= \case - True -> do - reportFPS f - pure Nothing - False -> Just <$> do - needsNewSwapchain <- threwSwapchainError (runFrame f renderFrame) - advanceFrame needsNewSwapchain f - - runV inst phys rtInfo dev qs vma $ do - initial <- initialFrame win surf - showWindow win - loopJust frame initial +drawableSize :: SDL.Window -> IO Extent2D +drawableSize win = do + SDL.V2 w h <- SDL.vkGetDrawableSize win + pure $ Extent2D (fromIntegral w) (fromIntegral h) diff --git a/examples/rays/MonadFrame.hs b/examples/rays/MonadFrame.hs deleted file mode 100644 index 3ac4a89d7..000000000 --- a/examples/rays/MonadFrame.hs +++ /dev/null @@ -1,154 +0,0 @@ -{-# LANGUAGE OverloadedLists #-} -module MonadFrame - ( F - , runFrame - , liftV - , allocateGlobal - , allocateGlobal_ - , frameRefCount - , askFrame - , asksFrame - , finalQueueSubmitFrame - , queueSubmitFrame - ) where - - -import Cleanup -import Control.Monad.IO.Class -import Control.Monad.Trans.Class ( lift ) -import Control.Monad.Trans.Reader ( ReaderT - , ask - , asks - , runReaderT - ) -import Control.Monad.Trans.Resource -import Data.Vector ( Vector ) -import Frame -import HasVulkan -import InstrumentDecs ( withSpan_ ) -import MonadVulkan -import RefCounted -import UnliftIO -import Vulkan.CStruct.Extends -import Vulkan.Core10 -import Vulkan.Core12.Promoted_From_VK_KHR_timeline_semaphore -import Vulkan.Zero ( Zero(zero) ) - -newtype F a = F {unF :: ReaderT Frame V a } - deriving newtype ( Functor - , Applicative - , Monad - , MonadIO - , MonadFail - , HasVulkan - ) - -instance MonadUnliftIO F where - withRunInIO a = F $ withRunInIO (\r -> a (r . unF)) - ----------------------------------------------------------------- --- Vulkan Operations ----------------------------------------------------------------- - --- | Runs a frame and spawns a thread to wait for the GPU work to complete, at --- which point the frame-specific resources are collected. -runFrame :: Frame -> F a -> V a -runFrame f@Frame {..} (F r) = runReaderT r f `finally` do - let recycleResources = do - withSpan_ "resetCommandPool" - $ resetCommandPool' (fCommandPool fRecycledResources) zero - pure fRecycledResources - finalRetire = withSpan_ "final retire" $ retireFrame f - liftIO (readIORef fWorkProgress) >>= \case - -- If we have no work on the GPU we can recycle things here and now - NoWorkSubmitted -> runCleanup (recycleResources, finalRetire) - -- Otherwise we need to wait for whatever GPU work we submitted to - -- complete, make sure the frame semaphore is incremented and push the work - -- to the cleanup queue - SomeWorkSubmitted -> do - graphicsQueue <- getGraphicsQueue - queueSubmit - graphicsQueue - [ SomeStruct - ( zero { waitDstStageMask = [PIPELINE_STAGE_BOTTOM_OF_PIPE_BIT] - , signalSemaphores = [fRenderFinishedHostSemaphore] - } - ::& zero { signalSemaphoreValues = [fIndex] } - :& () - ) - ] - NULL_HANDLE - pushCleanup fCleaner recycleResources finalRetire - AllWorkSubmitted -> pushCleanup fCleaner recycleResources finalRetire - --- | Submit the specified work and set 'fWorkProgress' to 'SomeWorkSubmitted' -queueSubmitFrame :: Vector (SomeStruct SubmitInfo) -> F () -queueSubmitFrame ss = do - workProgress <- asksFrame fWorkProgress - q <- getGraphicsQueue - mask $ \_ -> do - liftIO $ writeIORef workProgress SomeWorkSubmitted - queueSubmit q ss NULL_HANDLE - --- | Submit the specified work and set 'fWorkProgress' to 'AllWorkSubmitted' --- --- A 'SubmitInfo' must increment 'fRenderFinishedHostSemaphore' to 'fIndex' -finalQueueSubmitFrame :: Vector (SomeStruct SubmitInfo) -> F () -finalQueueSubmitFrame ss = do - workProgress <- asksFrame fWorkProgress - q <- getGraphicsQueue - mask $ \_ -> do - liftIO $ writeIORef workProgress AllWorkSubmitted - queueSubmit q ss NULL_HANDLE - -liftV :: V a -> F a -liftV = F . lift - ----------------------------------------------------------------- --- Resource handling ----------------------------------------------------------------- - --- | By default resources allocated will only last until the frame is retired, --- i.e. the GPU work is complete. --- --- To allocate something globally use 'allocateGlobal' -instance MonadResource F where - liftResourceT r = do - i <- asksFrame (snd . fResources) - liftIO $ runInternalState r i - --- | Allocate a resource in the 'V' scope -allocateGlobal - :: F a - -- ^ Create to be calle dnow - -> (a -> F ()) - -- ^ Destroy, to be called at program termination - -> F (ReleaseKey, a) -allocateGlobal create destroy = do - createIO <- toIO create - run <- askRunInIO - F $ allocate createIO (run . destroy) - --- | c.f. 'bracket' and 'bracket_' -allocateGlobal_ :: F a -> F () -> F (ReleaseKey, a) -allocateGlobal_ create destroy = allocateGlobal create (const destroy) - --- | Free frame resources, the frame must have finished GPU execution first. -retireFrame :: MonadIO m => Frame -> m () -retireFrame Frame {..} = release (fst fResources) - --- | Make sure a reference is held until this frame is retired -frameRefCount :: RefCounted -> F () -frameRefCount = resourceTRefCount - ----------------------------------------------------------------- --- Small Operations ----------------------------------------------------------------- - --- | Get the current 'Frame' -askFrame :: F Frame -askFrame = F ask - --- | Get a function of the current 'Frame' -asksFrame :: (Frame -> a) -> F a -asksFrame = F . asks diff --git a/examples/rays/MonadVulkan.hs b/examples/rays/MonadVulkan.hs deleted file mode 100644 index 714af5c89..000000000 --- a/examples/rays/MonadVulkan.hs +++ /dev/null @@ -1,288 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE RecursiveDo #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -Wno-missing-signatures #-} - -module MonadVulkan where - -import AutoApply -import Control.Concurrent.Chan.Unagi -import Control.Concurrent.MVar ( newEmptyMVar - , putMVar - , readMVar - ) -import Control.Monad ( void ) -import Control.Monad.IO.Class -import Control.Monad.Trans.Reader -import Control.Monad.Trans.Resource -import Data.Word -import GHC.Generics ( Generic ) -import HasVulkan -import InstrumentDecs -import Language.Haskell.TH -import Language.Haskell.TH.Syntax ( addTopDecls ) -import NoThunks.Class -import Orphans ( ) -import UnliftIO ( Async - , MonadUnliftIO(withRunInIO) - , mask - , toIO - ) -import UnliftIO.Async ( asyncWithUnmask - , uninterruptibleCancel - ) -import Vulkan.CStruct.Extends -import Vulkan.Core10 as Vk - hiding ( withBuffer - , withImage - ) -import Vulkan.Core12.Promoted_From_VK_KHR_buffer_device_address - ( getBufferDeviceAddress ) -import Vulkan.Core12.Promoted_From_VK_KHR_timeline_semaphore - as Timeline -import Vulkan.Extensions.VK_KHR_acceleration_structure -import Vulkan.Extensions.VK_KHR_ray_tracing_pipeline -import Vulkan.Extensions.VK_KHR_surface -import Vulkan.Extensions.VK_KHR_swapchain -import Vulkan.Utils.CommandCheck -import Vulkan.Utils.Debug ( nameObject ) -import Vulkan.Utils.QueueAssignment -import VulkanMemoryAllocator as VMA - hiding ( getPhysicalDeviceProperties ) - ----------------------------------------------------------------- --- Define the monad in which most of the program will run ----------------------------------------------------------------- - --- | @V@ keeps track of a bunch of "global" handles and performs resource --- management. -newtype V a = V { unV :: ReaderT GlobalHandles (ResourceT IO) a } - deriving newtype ( Functor - , Applicative - , Monad - , MonadFail - , MonadIO - , MonadResource - ) - -instance MonadUnliftIO V where - withRunInIO a = V $ withRunInIO (\r -> a (r . unV)) - -newtype CmdT m a = CmdT { unCmdT :: ReaderT CommandBuffer m a } - deriving newtype ( Functor - , Applicative - , Monad - , MonadIO - , MonadResource - , HasVulkan - ) - -instance MonadUnliftIO m => MonadUnliftIO (CmdT m) where - withRunInIO a = CmdT $ withRunInIO (\r -> a (r . unCmdT)) - -instance HasVulkan V where - getInstance = V (asks ghInstance) - getGraphicsQueue = V (asks (snd . graphicsQueue . ghQueues)) - getPhysicalDevice = V (asks ghPhysicalDevice) - getDevice = V (asks ghDevice) - getAllocator = V (asks ghAllocator) - -getGraphicsQueueFamilyIndex :: V QueueFamilyIndex -getGraphicsQueueFamilyIndex = V (asks (fst . graphicsQueue . ghQueues)) - -getRTInfo :: V RTInfo -getRTInfo = V (asks ghRTInfo) - -getCommandBuffer :: Monad m => CmdT m CommandBuffer -getCommandBuffer = CmdT ask - -useCommandBuffer' - :: forall a m r - . (Extendss CommandBufferBeginInfo a, PokeChain a, MonadIO m) - => CommandBuffer - -> CommandBufferBeginInfo a - -> CmdT m r - -> m r -useCommandBuffer' commandBuffer beginInfo (CmdT a) = - useCommandBuffer commandBuffer beginInfo (runReaderT a commandBuffer) - -runV - :: Instance - -> PhysicalDevice - -> RTInfo - -> Device - -> Queues (QueueFamilyIndex, Queue) - -> Allocator - -> V a - -> ResourceT IO a -runV ghInstance ghPhysicalDevice ghRTInfo ghDevice ghQueues ghAllocator v = do - (bin, nib) <- liftIO newChan - let ghRecycleBin = writeChan bin - ghRecycleNib = do - (try, block) <- tryReadChan nib - maybe (Left block) Right <$> tryRead try - - flip runReaderT GlobalHandles { .. } . unV $ v - --- | A bunch of global, unchanging state we cart around -data GlobalHandles = GlobalHandles - { ghInstance :: Instance - , ghPhysicalDevice :: PhysicalDevice - , ghDevice :: Device - , ghAllocator :: Allocator - , ghQueues :: Queues (QueueFamilyIndex, Queue) - , ghRecycleBin :: RecycledResources -> IO () - -- ^ Filled with resources which aren't destroyed after finishing a frame, - -- but instead are used by another frame which executes after that one is - -- retired, (taken from ghRecycleNib) - -- - -- Make sure not to pass any resources which were created with a frame-only - -- scope however! - , ghRecycleNib :: IO (Either (IO RecycledResources) RecycledResources) - -- ^ The resources of prior frames waiting to be taken - , ghRTInfo :: RTInfo - } - --- | Information for ray tracing -data RTInfo = RTInfo - { rtiShaderGroupHandleSize :: Word32 - , rtiShaderGroupBaseAlignment :: Word32 - } - --- | These are resources which are reused by a later frame when the current --- frame is retired -data RecycledResources = RecycledResources - { fImageAvailableSemaphore :: Semaphore - -- ^ A binary semaphore passed to 'acquireNextImageKHR' - , fRenderFinishedSemaphore :: Semaphore - -- ^ A binary semaphore to synchronize rendering and presenting - , fCommandPool :: CommandPool - -- ^ Pool for this frame's commands (might want more than one of these for - -- multithreaded recording) - , fDescriptorSet :: DescriptorSet - -- ^ A descriptor set for ray tracing - , fCameraMatricesOffset :: Word64 - } - deriving (Generic, NoThunks) - --- | The shape of all the queues we use for our program, parameterized over the --- queue type so we can use it with 'Vulkan.Utils.QueueAssignment.assignQueues' -newtype Queues q = Queues { graphicsQueue :: q } - deriving (Functor, Foldable, Traversable) - ----------------------------------------------------------------- --- Helpers ----------------------------------------------------------------- - --- Start an async thread which will be cancelled by the end of the ResourceT --- block -spawn :: V a -> V (Async a) -spawn a = do - aIO <- toIO a - -- If we don't remove the release key when the thread is done it'll leak, - -- remove it at the end of the async action when the thread is going to die - -- anyway. - -- - -- Mask this so there's no chance we're inturrupted before writing the mvar. - kv <- liftIO newEmptyMVar - UnliftIO.mask $ \_ -> do - (k, r) <- allocate - (asyncWithUnmask - (\unmask -> unmask $ aIO <* (unprotect =<< liftIO (readMVar kv))) - ) - uninterruptibleCancel - liftIO $ putMVar kv k - pure r - -spawn_ :: V () -> V () -spawn_ = void . spawn - ----------------------------------------------------------------- --- Commands ----------------------------------------------------------------- - --- --- Wrap a bunch of Vulkan commands so that they automatically pull global --- handles from any `HasVulkan` instance. --- --- Wrapped functions are suffixed with "'" --- -do - let vmaCommands = - [ 'withBuffer - , 'VMA.withMappedMemory - , 'VMA.withMemory - , 'invalidateAllocation - , 'flushAllocation - ] - commands = - [ 'acquireNextImageKHRSafe - , 'allocateCommandBuffers - , 'allocateDescriptorSets - , 'buildAccelerationStructuresKHR - , 'cmdBindDescriptorSets - , 'cmdBindPipeline - , 'cmdBuildAccelerationStructuresKHR - , 'cmdDispatch - , 'cmdDraw - , 'cmdPipelineBarrier - , 'cmdPushConstants - , 'cmdSetScissor - , 'cmdSetViewport - , 'cmdTraceRaysKHR - , 'cmdUseRenderPass - , 'deviceWaitIdle - , 'deviceWaitIdleSafe - , 'getAccelerationStructureBuildSizesKHR - , 'getAccelerationStructureDeviceAddressKHR - , 'getBufferDeviceAddress - , 'getDeviceQueue - , 'getPhysicalDeviceSurfaceCapabilitiesKHR - , 'getPhysicalDeviceSurfaceFormatsKHR - , 'getPhysicalDeviceSurfacePresentModesKHR - , 'getRayTracingShaderGroupHandlesKHR - , 'getSemaphoreCounterValue - , 'getSwapchainImagesKHR - , 'nameObject - , 'queuePresentKHR - , 'resetCommandPool - , 'updateDescriptorSets - , 'waitForFences - , 'waitForFencesSafe - , 'Timeline.waitSemaphores - , 'Timeline.waitSemaphoresSafe - , 'withAccelerationStructureKHR - , 'withCommandBuffers - , 'withCommandPool - , 'withComputePipelines - , 'withDescriptorPool - , 'withDescriptorSetLayout - , 'withFence - , 'withFramebuffer - , 'withGraphicsPipelines - , 'withImageView - , 'withInstance - , 'withPipelineLayout - , 'withRayTracingPipelinesKHR - , 'withRenderPass - , 'withSemaphore - , 'withShaderModule - , 'withSwapchainKHR - ] - addTopDecls =<< [d|checkCommands = $(checkCommandsExp commands)|] - ds <- autoapplyDecs - (<> "'") - [ 'getDevice - , 'getPhysicalDevice - , 'getInstance - , 'getAllocator - , 'noAllocationCallbacks - , 'noPipelineCache - , 'getCommandBuffer - ] - -- Allocate doesn't subsume the continuation type on the "with" commands, so - -- put it in the unifying group. - ['allocate] - (vmaCommands <> commands) - instrumentDecs (Just . init . nameBase) ds diff --git a/examples/rays/Pipeline.hs b/examples/rays/Pipeline.hs index 7cc133a4c..44f02a5ee 100644 --- a/examples/rays/Pipeline.hs +++ b/examples/rays/Pipeline.hs @@ -25,8 +25,9 @@ import Foreign.Marshal.Utils ( moveBytes ) import Foreign.Ptr ( Ptr , plusPtr ) -import MonadVulkan +import Init ( RTInfo(..) ) import Say +import Scene ( SceneBuffers(..) ) import Vulkan.CStruct.Extends import Vulkan.Core10 as Vk hiding ( withBuffer @@ -34,27 +35,31 @@ import Vulkan.Core10 as Vk ) import Vulkan.Extensions.VK_KHR_acceleration_structure import Vulkan.Extensions.VK_KHR_ray_tracing_pipeline - -import Vulkan.Utils.ShaderQQ.GLSL.Glslang ( glsl - , compileShaderQ ) +import Vulkan.Utils.Debug ( nameObject ) +import Vulkan.Utils.ShaderQQ.GLSL.Glslang ( compileShaderQ + , glsl + ) import Vulkan.Zero -import VulkanMemoryAllocator -import Scene - --- Create the most vanilla ray tracing pipeline, returns the number of shader --- groups -createPipeline :: PipelineLayout -> V (ReleaseKey, Pipeline, Word32) -createPipeline pipelineLayout = do +import VulkanMemoryAllocator as VMA + hiding ( getPhysicalDeviceProperties ) + +-- | Create the RT pipeline; returns the number of shader groups. +createPipeline + :: (MonadResource m, MonadFail m) + => Device + -> PipelineLayout + -> m (ReleaseKey, Pipeline, Word32) +createPipeline dev pipelineLayout = do (shaderKeys, shaderStages) <- V.unzip <$> sequence - [ createRayGenerationShader - , createRayIntShader - , createRayMissShader - , createRayHitShader + [ createRayGenerationShader dev + , createRayIntShader dev + , createRayMissShader dev + , createRayHitShader dev ] let genGroup = RayTracingShaderGroupCreateInfoKHR RAY_TRACING_SHADER_GROUP_TYPE_GENERAL_KHR - 0 -- The index of our general shader + 0 SHADER_UNUSED_KHR SHADER_UNUSED_KHR SHADER_UNUSED_KHR @@ -62,9 +67,9 @@ createPipeline pipelineLayout = do intGroup = RayTracingShaderGroupCreateInfoKHR RAY_TRACING_SHADER_GROUP_TYPE_PROCEDURAL_HIT_GROUP_KHR SHADER_UNUSED_KHR - 3 -- closest hit + 3 SHADER_UNUSED_KHR - 1 -- intersection + 1 nullPtr missGroup = RayTracingShaderGroupCreateInfoKHR RAY_TRACING_SHADER_GROUP_TYPE_GENERAL_KHR @@ -82,85 +87,101 @@ createPipeline pipelineLayout = do , maxPipelineRayRecursionDepth = 1 , layout = pipelineLayout } - (key, (_, ~[rtPipeline])) <- withRayTracingPipelinesKHR' - zero + (key, (_, ~[rtPipeline])) <- withRayTracingPipelinesKHR + dev + NULL_HANDLE + NULL_HANDLE [SomeStruct pipelineCreateInfo] + Nothing + allocate traverse_ release shaderKeys pure (key, rtPipeline, fromIntegral (V.length shaderGroups)) -createRTPipelineLayout :: DescriptorSetLayout -> V (ReleaseKey, PipelineLayout) -createRTPipelineLayout descriptorSetLayout = - withPipelineLayout' zero { setLayouts = [descriptorSetLayout] } - -createRTDescriptorSetLayout :: V (ReleaseKey, DescriptorSetLayout) -createRTDescriptorSetLayout = withDescriptorSetLayout' zero - { bindings = [ zero - { binding = 0 - , descriptorType = DESCRIPTOR_TYPE_ACCELERATION_STRUCTURE_KHR - , descriptorCount = 1 - , stageFlags = SHADER_STAGE_RAYGEN_BIT_KHR - } - , zero { binding = 1 - , descriptorType = DESCRIPTOR_TYPE_STORAGE_IMAGE - , descriptorCount = 1 - , stageFlags = SHADER_STAGE_RAYGEN_BIT_KHR - } - , zero - { binding = 2 - , descriptorType = DESCRIPTOR_TYPE_STORAGE_BUFFER - , descriptorCount = 1 - , stageFlags = SHADER_STAGE_INTERSECTION_BIT_KHR - .|. SHADER_STAGE_CLOSEST_HIT_BIT_KHR - } - , zero { binding = 3 - , descriptorType = DESCRIPTOR_TYPE_UNIFORM_BUFFER - , descriptorCount = 1 - , stageFlags = SHADER_STAGE_RAYGEN_BIT_KHR - } - ] - } +createRTPipelineLayout + :: MonadResource m => Device -> DescriptorSetLayout -> m (ReleaseKey, PipelineLayout) +createRTPipelineLayout dev descriptorSetLayout = withPipelineLayout + dev + zero { setLayouts = [descriptorSetLayout] } + Nothing + allocate + +createRTDescriptorSetLayout + :: MonadResource m => Device -> m (ReleaseKey, DescriptorSetLayout) +createRTDescriptorSetLayout dev = withDescriptorSetLayout + dev + zero + { bindings = [ zero + { binding = 0 + , descriptorType = DESCRIPTOR_TYPE_ACCELERATION_STRUCTURE_KHR + , descriptorCount = 1 + , stageFlags = SHADER_STAGE_RAYGEN_BIT_KHR + } + , zero { binding = 1 + , descriptorType = DESCRIPTOR_TYPE_STORAGE_IMAGE + , descriptorCount = 1 + , stageFlags = SHADER_STAGE_RAYGEN_BIT_KHR + } + , zero + { binding = 2 + , descriptorType = DESCRIPTOR_TYPE_STORAGE_BUFFER + , descriptorCount = 1 + , stageFlags = SHADER_STAGE_INTERSECTION_BIT_KHR + .|. SHADER_STAGE_CLOSEST_HIT_BIT_KHR + } + , zero { binding = 3 + , descriptorType = DESCRIPTOR_TYPE_UNIFORM_BUFFER + , descriptorCount = 1 + , stageFlags = SHADER_STAGE_RAYGEN_BIT_KHR + } + ] + } + Nothing + allocate createRTDescriptorSets - :: DescriptorSetLayout + :: MonadResource m + => Device + -> DescriptorSetLayout -> AccelerationStructureKHR -> SceneBuffers -> Word32 - -> V (Vector DescriptorSet) -createRTDescriptorSets descriptorSetLayout tlas SceneBuffers {..} numDescriptorSets + -> m (Vector DescriptorSet) +createRTDescriptorSets dev descriptorSetLayout tlas SceneBuffers {..} numDescriptorSets = do let numImagesPerSet = 1 numAccelerationStructuresPerSet = 1 numStorageBuffersPerSet = 1 numUniformBuffersPerSet = 1 - -- Create a descriptor pool - (_, descriptorPool) <- withDescriptorPool' zero - { maxSets = numDescriptorSets - , poolSizes = - [ DescriptorPoolSize DESCRIPTOR_TYPE_STORAGE_IMAGE - (numDescriptorSets * numImagesPerSet) - , DescriptorPoolSize - DESCRIPTOR_TYPE_ACCELERATION_STRUCTURE_KHR - (numDescriptorSets * numAccelerationStructuresPerSet) - , DescriptorPoolSize DESCRIPTOR_TYPE_STORAGE_BUFFER - (numDescriptorSets * numStorageBuffersPerSet) - , DescriptorPoolSize DESCRIPTOR_TYPE_UNIFORM_BUFFER - (numDescriptorSets * numUniformBuffersPerSet) - ] - } - - -- Allocate a descriptor set from the pool with that layout - -- Don't use `withDescriptorSets` here as the set will be cleaned up when - -- the pool is destroyed. - sets <- allocateDescriptorSets' zero - { descriptorPool = descriptorPool - , setLayouts = V.replicate (fromIntegral numDescriptorSets) - descriptorSetLayout - } - - -- Put the static accelerationStructure into the set - for_ sets $ \set -> updateDescriptorSets' + (_, descriptorPool) <- withDescriptorPool + dev + zero + { maxSets = numDescriptorSets + , poolSizes = + [ DescriptorPoolSize DESCRIPTOR_TYPE_STORAGE_IMAGE + (numDescriptorSets * numImagesPerSet) + , DescriptorPoolSize + DESCRIPTOR_TYPE_ACCELERATION_STRUCTURE_KHR + (numDescriptorSets * numAccelerationStructuresPerSet) + , DescriptorPoolSize DESCRIPTOR_TYPE_STORAGE_BUFFER + (numDescriptorSets * numStorageBuffersPerSet) + , DescriptorPoolSize DESCRIPTOR_TYPE_UNIFORM_BUFFER + (numDescriptorSets * numUniformBuffersPerSet) + ] + } + Nothing + allocate + + sets <- allocateDescriptorSets + dev + zero { descriptorPool = descriptorPool + , setLayouts = V.replicate (fromIntegral numDescriptorSets) + descriptorSetLayout + } + + for_ sets $ \set -> updateDescriptorSets + dev [ SomeStruct $ zero { dstSet = set , dstBinding = 0 @@ -186,8 +207,8 @@ createRTDescriptorSets descriptorSetLayout tlas SceneBuffers {..} numDescriptorS pure sets createRayGenerationShader - :: V (ReleaseKey, SomeStruct PipelineShaderStageCreateInfo) -createRayGenerationShader = do + :: MonadResource m => Device -> m (ReleaseKey, SomeStruct PipelineShaderStageCreateInfo) +createRayGenerationShader dev = do let code = $(compileShaderQ (Just "spirv1.4") "rgen" Nothing [glsl| #version 460 #extension GL_EXT_ray_tracing : require @@ -233,13 +254,14 @@ createRayGenerationShader = do } |]) - (key, module') <- withShaderModule' zero { code } + (key, module') <- withShaderModule dev zero { code } Nothing allocate let shaderStageCreateInfo = zero { stage = SHADER_STAGE_RAYGEN_BIT_KHR, module', name = "main" } pure (key, SomeStruct shaderStageCreateInfo) -createRayHitShader :: V (ReleaseKey, SomeStruct PipelineShaderStageCreateInfo) -createRayHitShader = do +createRayHitShader + :: MonadResource m => Device -> m (ReleaseKey, SomeStruct PipelineShaderStageCreateInfo) +createRayHitShader dev = do let code = $(compileShaderQ (Just "spirv1.4") "rchit" Nothing [glsl| #version 460 #extension GL_EXT_ray_tracing : require @@ -264,13 +286,14 @@ createRayHitShader = do } |]) - (key, module') <- withShaderModule' zero { code } + (key, module') <- withShaderModule dev zero { code } Nothing allocate let shaderStageCreateInfo = zero { stage = SHADER_STAGE_CLOSEST_HIT_BIT_KHR, module', name = "main" } pure (key, SomeStruct shaderStageCreateInfo) -createRayIntShader :: V (ReleaseKey, SomeStruct PipelineShaderStageCreateInfo) -createRayIntShader = do +createRayIntShader + :: MonadResource m => Device -> m (ReleaseKey, SomeStruct PipelineShaderStageCreateInfo) +createRayIntShader dev = do let code = $(compileShaderQ (Just "spirv1.4") "rint" Nothing [glsl| #version 460 #extension GL_EXT_ray_tracing : require @@ -306,13 +329,14 @@ createRayIntShader = do } |]) - (key, module') <- withShaderModule' zero { code } + (key, module') <- withShaderModule dev zero { code } Nothing allocate let shaderStageCreateInfo = zero { stage = SHADER_STAGE_INTERSECTION_BIT_KHR, module', name = "main" } pure (key, SomeStruct shaderStageCreateInfo) -createRayMissShader :: V (ReleaseKey, SomeStruct PipelineShaderStageCreateInfo) -createRayMissShader = do +createRayMissShader + :: MonadResource m => Device -> m (ReleaseKey, SomeStruct PipelineShaderStageCreateInfo) +createRayMissShader dev = do let code = $(compileShaderQ (Just "spirv1.4") "rmiss" Nothing [glsl| #version 460 #extension GL_EXT_ray_tracing : require @@ -325,52 +349,53 @@ createRayMissShader = do } |]) - (key, module') <- withShaderModule' zero { code } + (key, module') <- withShaderModule dev zero { code } Nothing allocate let shaderStageCreateInfo = zero { stage = SHADER_STAGE_MISS_BIT_KHR, module', name = "main" } pure (key, SomeStruct shaderStageCreateInfo) + ---------------------------------------------------------------- -- Shader binding table ---------------------------------------------------------------- -createShaderBindingTable :: Pipeline -> Word32 -> V (ReleaseKey, Buffer) -createShaderBindingTable pipeline numGroups = do - RTInfo {..} <- getRTInfo +createShaderBindingTable + :: MonadResource m + => Device + -> Allocator + -> RTInfo + -> Pipeline + -> Word32 + -> m (ReleaseKey, Buffer) +createShaderBindingTable dev vma RTInfo {..} pipeline numGroups = do let handleSize = rtiShaderGroupHandleSize baseAlignment = rtiShaderGroupBaseAlignment handleStride = max handleSize baseAlignment - -- Make the buffer big enough for all the groups, with spacing between - -- them equal to their alignment sbtSize = fromIntegral $ handleStride * (numGroups - 1) + handleSize - sayErrShow (handleStride, rtiShaderGroupBaseAlignment) + sayErrShow (handleStride, baseAlignment) - (bufferReleaseKey, (sbtBuffer, sbtAllocation, _sbtAllocationInfo)) <- - withBuffer' - zero { usage = BUFFER_USAGE_SHADER_DEVICE_ADDRESS_BIT, size = sbtSize } - zero - { requiredFlags = MEMORY_PROPERTY_HOST_VISIBLE_BIT - .|. MEMORY_PROPERTY_HOST_COHERENT_BIT - } - nameObject' sbtBuffer "SBT" + (bufferReleaseKey, (sbtBuffer, sbtAllocation, _)) <- VMA.withBuffer + vma + zero { usage = BUFFER_USAGE_SHADER_DEVICE_ADDRESS_BIT, size = sbtSize } + zero + { requiredFlags = MEMORY_PROPERTY_HOST_VISIBLE_BIT + .|. MEMORY_PROPERTY_HOST_COHERENT_BIT + } + allocate + nameObject dev sbtBuffer "SBT" - (memKey, mem) <- withMappedMemory' sbtAllocation - getRayTracingShaderGroupHandlesKHR' pipeline 0 numGroups sbtSize mem + (memKey, mem) <- VMA.withMappedMemory vma sbtAllocation allocate + getRayTracingShaderGroupHandlesKHR dev pipeline 0 numGroups sbtSize mem unpackObjects numGroups handleSize handleStride mem release memKey pure (bufferReleaseKey, sbtBuffer) --- | Move densely packed objects so that they have a desired stride unpackObjects :: MonadIO m => Word32 - -- ^ Num objects -> Word32 - -- ^ Object size, the initial stride -> Word32 - -- ^ Desired stride -> Ptr () - -- ^ Initial, packed data, in a buffer big enough for the unpacked data -> m () unpackObjects numObjs size desiredStride buf = do let @@ -379,6 +404,5 @@ unpackObjects numObjs size desiredStride buf = do moveObject n = moveBytes (objectFinalPosition n) (objectInitalPosition n) (fromIntegral size) - -- Move the object last to first indicesToMove = drop 1 [numObjs, numObjs - 1 .. 1] liftIO $ traverse_ moveObject indicesToMove diff --git a/examples/rays/Render.hs b/examples/rays/Render.hs index 05100e686..c9ded1e4f 100644 --- a/examples/rays/Render.hs +++ b/examples/rays/Render.hs @@ -1,87 +1,115 @@ {-# LANGUAGE OverloadedLists #-} module Render - ( renderFrame + ( RenderState(..) + , renderFrame ) where import Camera import Control.Exception ( throwIO ) import Control.Monad.IO.Class -import Control.Monad.Trans.Class ( MonadTrans(lift) ) +import Control.Monad.Trans.Resource import Data.Vector ( (!) ) +import qualified Data.Vector as V import Data.Word -import Foreign.Ptr ( plusPtr ) +import Foreign.Ptr ( Ptr + , plusPtr + ) import Foreign.Storable -import Frame +import Frame ( Frame(..) + , numConcurrentFrames + , queueSubmitFrame + ) import GHC.Clock ( getMonotonicTime ) import GHC.IO.Exception ( IOErrorType(TimeExpired) , IOException(IOError) ) -import HasVulkan +import Init ( RTInfo(..) ) import Linear.Matrix import Linear.Quaternion import Linear.V3 -import MonadFrame -import MonadVulkan -import Swapchain +import Swapchain ( Swapchain(..) ) import UnliftIO.Exception ( throwString ) +import VkResources ( Queues(..) + , RecycledResources(..) + , VkResources(..) + ) import Vulkan.CStruct.Extends import Vulkan.Core10 as Core10 import qualified Vulkan.Core10 as Extent2D (Extent2D(..)) import qualified Vulkan.Core10 as CommandBufferBeginInfo (CommandBufferBeginInfo(..)) import Vulkan.Core12.Promoted_From_VK_KHR_timeline_semaphore +import Vulkan.Exception ( VulkanException(..) ) import Vulkan.Extensions.VK_KHR_ray_tracing_pipeline import Vulkan.Extensions.VK_KHR_swapchain as Swap +import VulkanMemoryAllocator as VMA + hiding ( getPhysicalDeviceProperties ) import Vulkan.Zero -import InstrumentDecs ( withSpan_ ) -renderFrame :: F () -renderFrame = withSpan_ "renderFrame" $ do - f@Frame {..} <- askFrame - let RecycledResources {..} = fRecycledResources - oneSecond = 1e9 - SwapchainResources {..} = fSwapchainResources - SwapchainInfo {..} = srInfo +-- | Long-lived per-app render state. Built once during setup; threaded into +-- 'renderFrame' each frame. +data RenderState = RenderState + { rsPipeline :: Pipeline + , rsPipelineLayout :: PipelineLayout + , rsDescriptorSets :: V.Vector DescriptorSet + -- ^ One per concurrent-frame slot. Picked by @fIndex `mod` numConcurrentFrames@. + , rsShaderBindingTableAddress :: DeviceAddress + , rsCameraMatricesBuffer :: Buffer + , rsCameraMatricesAllocation :: Allocation + , rsCameraMatricesBufferData :: Ptr CameraMatrices + , rsRTInfo :: RTInfo + } - -- Ensure that the swapchain survives for the duration of this frame - frameRefCount srRelease +renderFrame + :: VkResources + -> RenderState + -> Frame + -> ResourceT IO () +renderFrame vr rs f = do + let RecycledResources {..} = fRecycled f + sc = fSwapchain f + dev = vrDevice vr + Queues (_, gQ) = vrQueues vr + RTInfo {..} = rsRTInfo rs + slot = fromIntegral (fIndex f) `mod` numConcurrentFrames + descriptorSet = rsDescriptorSets rs ! slot + cameraMatricesOffset = fromIntegral slot + * fromIntegral (sizeOf (undefined :: CameraMatrices)) + oneSecond = 1e9 - -- Make sure we'll have an image to render to - imageIndex <- - withSpan_ "acquire" - $ acquireNextImageKHRSafe' siSwapchain - oneSecond - fImageAvailableSemaphore - NULL_HANDLE - >>= \case - (SUCCESS, imageIndex) -> pure imageIndex - (TIMEOUT, _) -> - timeoutError "Timed out (1s) trying to acquire next image" - _ -> throwString "Unexpected Result from acquireNextImageKHR" + -- Acquire next image + (acquireResult, imageIndex) <- + acquireNextImageKHRSafe dev (sSwapchain sc) oneSecond rrImageAvailable NULL_HANDLE + >>= \case + r@(SUCCESS, _) -> pure r + r@(SUBOPTIMAL_KHR, _) -> pure r + (TIMEOUT, _) -> timeoutError "Timed out (1s) acquiring next image" + _ -> throwString "Unexpected Result from acquireNextImageKHR" - -- Update the necessary descriptor sets - withSpan_ "update" $ updateDescriptorSets' + -- Bind the per-slot descriptor set's image view + camera buffer slot. + updateDescriptorSets + dev [ SomeStruct zero - { dstSet = fDescriptorSet + { dstSet = descriptorSet , dstBinding = 1 , descriptorType = DESCRIPTOR_TYPE_STORAGE_IMAGE , descriptorCount = 1 , imageInfo = [ DescriptorImageInfo - { sampler = NULL_HANDLE - , imageView = srImageViews ! fromIntegral imageIndex + { sampler = NULL_HANDLE + , imageView = sImageViews sc ! fromIntegral imageIndex , imageLayout = IMAGE_LAYOUT_GENERAL } ] } - , SomeStruct zero -- TODO, only set this once - { dstSet = fDescriptorSet + , SomeStruct zero + { dstSet = descriptorSet , dstBinding = 3 , descriptorType = DESCRIPTOR_TYPE_UNIFORM_BUFFER , descriptorCount = 1 , bufferInfo = [ DescriptorBufferInfo - { buffer = fCameraMatricesBuffer - , offset = fCameraMatricesOffset + { buffer = rsCameraMatricesBuffer rs + , offset = cameraMatricesOffset , range = fromIntegral (sizeOf (undefined :: CameraMatrices)) } @@ -90,6 +118,7 @@ renderFrame = withSpan_ "renderFrame" $ do ] [] + -- Update camera matrices for this frame. time <- realToFrac <$> liftIO getMonotonicTime let spin = axisAngle (V3 0 1 0) (sin time + 1) forwards = axisAngle (V3 0 0 1) 0 @@ -99,71 +128,78 @@ renderFrame = withSpan_ "renderFrame" $ do , cmProjInverse = transpose $ inv44 (projectionMatrix camera) } liftIO $ poke - (fCameraMatricesBufferData `plusPtr` fromIntegral fCameraMatricesOffset) + (rsCameraMatricesBufferData rs `plusPtr` fromIntegral cameraMatricesOffset) cameraMats - withSpan_ "flush" $ flushAllocation' - fCameraMatricesAllocation - fCameraMatricesOffset + flushAllocation + (vrAllocator vr) + (rsCameraMatricesAllocation rs) + cameraMatricesOffset (fromIntegral (sizeOf (undefined :: CameraMatrices))) - -- Allocate a command buffer and populate it - let commandBufferAllocateInfo = zero { commandPool = fCommandPool - , level = COMMAND_BUFFER_LEVEL_PRIMARY - , commandBufferCount = 1 - } - (_, ~[commandBuffer]) <- withCommandBuffers' commandBufferAllocateInfo - withSpan_ "record" - $ useCommandBuffer' - commandBuffer - zero { CommandBufferBeginInfo.flags = COMMAND_BUFFER_USAGE_ONE_TIME_SUBMIT_BIT } - $ myRecordCommandBuffer f imageIndex + -- Allocate per-frame command buffer from the recycled pool. + let commandBufferAllocateInfo = zero + { commandPool = rrCommandPool + , level = COMMAND_BUFFER_LEVEL_PRIMARY + , commandBufferCount = 1 + } + (_, ~[commandBuffer]) <- withCommandBuffers dev commandBufferAllocateInfo allocate - -- Submit the work - let -- Wait for the 'imageAvailableSemaphore' before outputting to the color - -- attachment - submitInfo = - zero - { Core10.waitSemaphores = [fImageAvailableSemaphore] - , waitDstStageMask = [PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT] - , commandBuffers = [commandBufferHandle commandBuffer] - , signalSemaphores = [ fRenderFinishedSemaphore - , fRenderFinishedHostSemaphore - ] - } - ::& zero { waitSemaphoreValues = [1] - , signalSemaphoreValues = [1, fIndex] - } - :& () - graphicsQueue <- getGraphicsQueue + useCommandBuffer + commandBuffer + zero { CommandBufferBeginInfo.flags = COMMAND_BUFFER_USAGE_ONE_TIME_SUBMIT_BIT } + $ recordCommandBuffer + commandBuffer + rs + sc + descriptorSet + imageIndex - withSpan_ "submit" $ finalQueueSubmitFrame [SomeStruct submitInfo] + -- Submit and record GPU work for the frame's wait thread. + let submitInfo = + zero { Core10.waitSemaphores = [rrImageAvailable] + , waitDstStageMask = [PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT] + , commandBuffers = [commandBufferHandle commandBuffer] + , signalSemaphores = [rrRenderFinished, fHostTimeline f] + } + ::& zero { waitSemaphoreValues = [1] + , signalSemaphoreValues = [1, fIndex f] + } + :& () + liftIO $ queueSubmitFrame gQ + f + [SomeStruct submitInfo] + (fHostTimeline f) + (fIndex f) - -- Present the frame when the render is finished - -- The return code here could be SUBOPTIMAL_KHR - -- TODO, check for that - _ <- withSpan_ "present" $ queuePresentKHR' - graphicsQueue - zero { Swap.waitSemaphores = [fRenderFinishedSemaphore] - , swapchains = [siSwapchain] + presentResult <- queuePresentKHR + gQ + zero { Swap.waitSemaphores = [rrRenderFinished] + , swapchains = [sSwapchain sc] , imageIndices = [imageIndex] } - pure () + + case (acquireResult, presentResult) of + (SUBOPTIMAL_KHR, _) -> liftIO . throwIO $ VulkanException ERROR_OUT_OF_DATE_KHR + (_, SUBOPTIMAL_KHR) -> liftIO . throwIO $ VulkanException ERROR_OUT_OF_DATE_KHR + _ -> pure () ---------------------------------------------------------------- -- Command buffer recording ---------------------------------------------------------------- --- | Clear and render a triangle -myRecordCommandBuffer :: Frame -> Word32 -> CmdT F () -myRecordCommandBuffer Frame {..} imageIndex = do - -- TODO: neaten - RTInfo {..} <- CmdT . lift . liftV $ getRTInfo - let RecycledResources {..} = fRecycledResources - SwapchainResources {..} = fSwapchainResources - SwapchainInfo {..} = srInfo - image = srImages ! fromIntegral imageIndex - imageWidth = Extent2D.width siImageExtent - imageHeight = Extent2D.height siImageExtent +recordCommandBuffer + :: MonadIO m + => CommandBuffer + -> RenderState + -> Swapchain + -> DescriptorSet + -> Word32 + -> m () +recordCommandBuffer commandBuffer rs sc descriptorSet imageIndex = do + let RTInfo {..} = rsRTInfo rs + image = sImages sc ! fromIntegral imageIndex + imageWidth = Extent2D.width (sExtent sc) + imageHeight = Extent2D.height (sExtent sc) imageSubresourceRange = ImageSubresourceRange { aspectMask = IMAGE_ASPECT_COLOR_BIT , baseMipLevel = 0 @@ -173,94 +209,93 @@ myRecordCommandBuffer Frame {..} imageIndex = do } numRayGenShaderGroups = 1 rayGenRegion = StridedDeviceAddressRegionKHR - { deviceAddress = fShaderBindingTableAddress + { deviceAddress = rsShaderBindingTableAddress rs , stride = fromIntegral rtiShaderGroupBaseAlignment , size = fromIntegral rtiShaderGroupBaseAlignment * numRayGenShaderGroups } numHitShaderGroups = 1 hitRegion = StridedDeviceAddressRegionKHR - { deviceAddress = fShaderBindingTableAddress + { deviceAddress = rsShaderBindingTableAddress rs + (1 * fromIntegral rtiShaderGroupBaseAlignment) , stride = fromIntegral rtiShaderGroupBaseAlignment , size = fromIntegral rtiShaderGroupBaseAlignment * numHitShaderGroups } numMissShaderGroups = 1 missRegion = StridedDeviceAddressRegionKHR - { deviceAddress = fShaderBindingTableAddress + { deviceAddress = rsShaderBindingTableAddress rs + (2 * fromIntegral rtiShaderGroupBaseAlignment) , stride = fromIntegral rtiShaderGroupBaseAlignment , size = fromIntegral rtiShaderGroupBaseAlignment * numMissShaderGroups } callableRegion = zero - do - -- Transition image to general, to write from the ray tracing shader - cmdPipelineBarrier' - PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT - PIPELINE_STAGE_RAY_TRACING_SHADER_BIT_KHR - zero - [] - [] - [ SomeStruct zero { srcAccessMask = zero - , dstAccessMask = ACCESS_SHADER_WRITE_BIT - , oldLayout = IMAGE_LAYOUT_UNDEFINED - , newLayout = IMAGE_LAYOUT_GENERAL - , image = image - , subresourceRange = imageSubresourceRange - } - ] - -- Bind descriptor sets - cmdBindPipeline' PIPELINE_BIND_POINT_RAY_TRACING_KHR fPipeline - cmdBindDescriptorSets' PIPELINE_BIND_POINT_RAY_TRACING_KHR - fPipelineLayout - 0 - [fDescriptorSet] - [] + -- Transition image to general (write target for raygen). + cmdPipelineBarrier + commandBuffer + PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT + PIPELINE_STAGE_RAY_TRACING_SHADER_BIT_KHR + zero + [] + [] + [ SomeStruct zero { srcAccessMask = zero + , dstAccessMask = ACCESS_SHADER_WRITE_BIT + , oldLayout = IMAGE_LAYOUT_UNDEFINED + , newLayout = IMAGE_LAYOUT_GENERAL + , image = image + , subresourceRange = imageSubresourceRange + } + ] + + cmdBindPipeline commandBuffer PIPELINE_BIND_POINT_RAY_TRACING_KHR (rsPipeline rs) + cmdBindDescriptorSets + commandBuffer + PIPELINE_BIND_POINT_RAY_TRACING_KHR + (rsPipelineLayout rs) + 0 + [descriptorSet] + [] - cmdPipelineBarrier' - PIPELINE_STAGE_TOP_OF_PIPE_BIT - PIPELINE_STAGE_RAY_TRACING_SHADER_BIT_KHR - zero - [] - [ SomeStruct - zero { srcAccessMask = ACCESS_HOST_WRITE_BIT - , dstAccessMask = ACCESS_SHADER_READ_BIT - , buffer = fCameraMatricesBuffer - , offset = fCameraMatricesOffset - , size = fromIntegral (sizeOf (undefined :: CameraMatrices)) - } - ] - [] + cmdPipelineBarrier + commandBuffer + PIPELINE_STAGE_TOP_OF_PIPE_BIT + PIPELINE_STAGE_RAY_TRACING_SHADER_BIT_KHR + zero + [] + [ SomeStruct + zero { srcAccessMask = ACCESS_HOST_WRITE_BIT + , dstAccessMask = ACCESS_SHADER_READ_BIT + , buffer = rsCameraMatricesBuffer rs + , offset = 0 -- TODO: per-slot + , size = WHOLE_SIZE + } + ] + [] - -- - -- The actual ray tracing - -- - cmdTraceRaysKHR' rayGenRegion - missRegion - hitRegion - callableRegion - imageWidth - imageHeight - 1 + cmdTraceRaysKHR commandBuffer + rayGenRegion + missRegion + hitRegion + callableRegion + imageWidth + imageHeight + 1 - -- Transition image back to present - cmdPipelineBarrier' - PIPELINE_STAGE_RAY_TRACING_SHADER_BIT_KHR - -- No need to get anything to wait because we're synchronizing with - -- the semaphore - PIPELINE_STAGE_BOTTOM_OF_PIPE_BIT - zero - [] - [] - [ SomeStruct zero { srcAccessMask = ACCESS_SHADER_WRITE_BIT - , dstAccessMask = zero - , oldLayout = IMAGE_LAYOUT_GENERAL - , newLayout = IMAGE_LAYOUT_PRESENT_SRC_KHR - , image = image - , subresourceRange = imageSubresourceRange - } - ] + cmdPipelineBarrier + commandBuffer + PIPELINE_STAGE_RAY_TRACING_SHADER_BIT_KHR + PIPELINE_STAGE_BOTTOM_OF_PIPE_BIT + zero + [] + [] + [ SomeStruct zero { srcAccessMask = ACCESS_SHADER_WRITE_BIT + , dstAccessMask = zero + , oldLayout = IMAGE_LAYOUT_GENERAL + , newLayout = IMAGE_LAYOUT_PRESENT_SRC_KHR + , image = image + , subresourceRange = imageSubresourceRange + } + ] ---------------------------------------------------------------- -- Utils diff --git a/examples/rays/Scene.hs b/examples/rays/Scene.hs index 2c9e02825..d7b0b7695 100644 --- a/examples/rays/Scene.hs +++ b/examples/rays/Scene.hs @@ -4,8 +4,7 @@ {-# OPTIONS_GHC -fplugin=Foreign.Storable.Generic.Plugin #-} {-# OPTIONS_GHC -fplugin-opt=Foreign.Storable.Generic.Plugin:-v0 #-} -module Scene - where +module Scene where import Control.Lens import Control.Monad.IO.Class @@ -20,12 +19,12 @@ import Foreign.Storable.Generic import GHC.Generics ( Generic ) import Linear.V3 import Linear.V4 -import MonadVulkan import System.Random import Vulkan.Core10 import Vulkan.Extensions.VK_KHR_acceleration_structure import Vulkan.Zero -import VulkanMemoryAllocator +import VulkanMemoryAllocator as VMA + hiding ( getPhysicalDeviceProperties ) scene :: [Sphere] scene = @@ -60,15 +59,15 @@ data SceneBuffers = SceneBuffers , sceneSize :: Word32 } -makeSceneBuffers :: V SceneBuffers -makeSceneBuffers = do - sceneAabbs <- initBuffer +makeSceneBuffers :: MonadResource m => Allocator -> m SceneBuffers +makeSceneBuffers vma = do + sceneAabbs <- initBuffer vma ( BUFFER_USAGE_ACCELERATION_STRUCTURE_BUILD_INPUT_READ_ONLY_BIT_KHR .|. BUFFER_USAGE_SHADER_DEVICE_ADDRESS_BIT ) (sphereAABB <$> scene) - sceneSpheres <- initBuffer BUFFER_USAGE_STORAGE_BUFFER_BIT scene + sceneSpheres <- initBuffer vma BUFFER_USAGE_STORAGE_BUFFER_BIT scene let sceneSize = fromIntegral (length scene) @@ -78,17 +77,20 @@ makeSceneBuffers = do -- Buffer tools ---------------------------------------------------------------- -initBuffer :: forall a . Storable a => BufferUsageFlags -> [a] -> V Buffer -initBuffer usage xs = do +initBuffer :: forall a m . (Storable a, MonadResource m) + => Allocator -> BufferUsageFlags -> [a] -> m Buffer +initBuffer vma usage xs = do let bufferSize = sizeOf (head xs) * length xs - (_, (buf, allocation, _)) <- withBuffer' + (_, (buf, allocation, _)) <- VMA.withBuffer + vma zero { flags = zero, size = fromIntegral bufferSize, usage } zero { requiredFlags = MEMORY_PROPERTY_HOST_VISIBLE_BIT .|. MEMORY_PROPERTY_HOST_COHERENT_BIT } - (unmapKey, p) <- withMappedMemory' allocation + allocate + (unmapKey, p) <- VMA.withMappedMemory vma allocation allocate liftIO $ pokeArray (castPtr @() @a p) xs release unmapKey diff --git a/examples/readme.md b/examples/readme.md index 40f107510..c2a0f475f 100644 --- a/examples/readme.md +++ b/examples/readme.md @@ -10,18 +10,15 @@ devices. ### `resize` -A nice example of rendering into a window which can be resized. It's not a -single file `triangle` like `triangle-sdl2`, but rather builds a couple of nice -abstractions to make the code a little nicer. +A nice example of rendering into a window which can be resized. It uses the +recycling `Frame` machinery from `lib/` (timeline semaphores + a recycle +channel for binary semaphores and command pools). It renders a Julia set according the mouse position in the window. The [`resourcet` package](https://hackage.haskell.org/package/resourcet) is used to ensure resources are deallocated. -An internal `AutoApply` module is used to write the boilerplate of passing some global handles to vulkan -functions. - ### `hlsl` A nicer example of rendering into a window which can be resized, the shaders @@ -31,15 +28,8 @@ are written in HLSL and compiled with the `glslc` tool from If you don't have this tool installed then you might want to turn off the Cabal flag `have-shaderc` to stop this example from building. -It's very similar to *resize* but has been tidied up in a few places. - -It renders a triangle. - -The [`resourcet` package](https://hackage.haskell.org/package/resourcet) is -used to ensure resources are deallocated. - -An internal `AutoApply` module is used to write the boilerplate of passing some global handles to vulkan -functions. +It renders a triangle, sharing the `lib/` recycling `Frame` infrastructure +with `resize`, `rays`, `triangle-sdl2`, and `triangle-glfw`. ### `rays` @@ -54,12 +44,9 @@ This example: - Copies the image contents to a CPU-mapped image - Writes that image to "triangle.png" -It is a pretty minimal example of rendering something. - -Like the `resize` example, -[`resourcet`](https://hackage.haskell.org/package/resourcet) and -an internal `AutoApply` module are used to make -resource and global management less painful. +It is a pretty minimal example of rendering something. Single-shot, no +recycling Frame needed — just plain `ResourceT IO` with handles threaded as +explicit args. ### `compute` @@ -75,10 +62,7 @@ This program includes examples of: - Compute shader dipatch - Convenient shader creation using the `Vulkan.Utils.ShaderQQ.comp` QuasiQuoter -Like the `resize` example, -[`resourcet`](https://hackage.haskell.org/package/resourcet) and -an internal `AutoApply` module are used to make -resource and global management less painful. +Single-shot like `triangle-headless`; uses plain `ResourceT IO`. ### `triangle-sdl2` diff --git a/examples/resize/Frame.hs b/examples/resize/Frame.hs deleted file mode 100644 index 03eaa1a78..000000000 --- a/examples/resize/Frame.hs +++ /dev/null @@ -1,174 +0,0 @@ -{-# LANGUAGE OverloadedLists #-} -{-# OPTIONS_GHC -Wno-missing-signatures #-} - --- | This module defines the 'Frame' data type, as well as functions for using --- it easily. The 'F' monad is a reader for a 'Frame' and can be consumed by --- 'runFrame'. -module Frame where - -import Control.Monad.IO.Class -import Control.Monad.Trans.Class ( lift ) -import Control.Monad.Trans.Reader -import Control.Monad.Trans.Resource as ResourceT -import qualified SDL -import UnliftIO ( MonadUnliftIO(..) - , askRunInIO - , toIO - ) -import UnliftIO.Exception ( finally - , throwString - ) -import UnliftIO.MVar - -import Data.IORef -import Data.Vector ( Vector - , cons - ) -import Data.Word - -import HasVulkan -import MonadVulkan -import RefCounted -import Vulkan.CStruct.Extends ( SomeStruct ) -import Vulkan.Core10 as Vk - hiding ( createDevice - , createFramebuffer - , createImageView - , createInstance - , withBuffer - , withImage - ) -import Vulkan.Extensions.VK_KHR_surface -import Vulkan.Extensions.VK_KHR_swapchain -import Vulkan.Zero - --- | A record of everything required to render a single frame of the --- application. -data Frame = Frame - { fIndex :: Word64 - , -- SDL Stuff - fWindow :: SDL.Window - -- Vulkan items - , fSurface :: SurfaceKHR - , fSwapchain :: SwapchainKHR - , fSwapchainFormat :: Format - , fRenderPass :: RenderPass - , fImageExtent :: Extent2D - , fImageAvailableSemaphore :: Semaphore - , fRenderFinishedSemaphore :: Semaphore - , fPipeline :: Pipeline - , fJuliaPipeline :: Pipeline - , fJuliaPipelineLayout :: PipelineLayout - , fJuliaDescriptorSets :: Word32 -> DescriptorSet - , fImages :: Word32 -> Image - , fImageViews :: Word32 -> ImageView - , fFramebuffers :: Word32 -> Framebuffer - , fReleaseSwapchain :: RefCounted - -- Scheduling. TODO, abstract this - , -- | This 'MVar' will be signaled when this frame has finished rendering on - -- the GPU - fCurrentPresented :: MVar () - , -- | These 'MVar's track when previous frames have finished executing on - -- the GPU - fLastPresented :: MVar () - , fSecondLastPresented :: MVar () - , fThirdLastPresented :: MVar () - -- | When did we start rendering this frame, in ns - , fStartTime :: Word64 - -- | The 'InternalState' for tracking frame-only resources. - , fResources :: (ReleaseKey, ResourceT.InternalState) - -- | A list of 'Fences' of GPU work submitted for this frame. - , fGPUWork :: IORef (Vector Fence) - } - -numConcurrentFrames :: Int -numConcurrentFrames = 3 - --- | A monad for running a single frame -newtype F a = F { unF :: ReaderT Frame V a } - deriving newtype ( Functor - , Applicative - , Monad - , MonadFail - , MonadIO - , HasVulkan - ) - -instance MonadUnliftIO F where - withRunInIO a = F $ withRunInIO (\r -> a (r . unF)) - --- | By default resources allocated will only last until the frame is retired. --- --- To allocate something globally use 'allocateGlobal' -instance MonadResource F where - liftResourceT r = do - i <- asksFrame (snd . fResources) - liftIO $ runInternalState r i - --- | Allocate a resource in the 'V' scope -allocateGlobal :: F a -> (a -> F ()) -> F (ReleaseKey, a) -allocateGlobal create destroy = do - createIO <- toIO create - run <- askRunInIO - F $ allocate createIO (run . destroy) - --- | c.f. 'bracket' and 'bracket_' -allocateGlobal_ :: F a -> F () -> F (ReleaseKey, a) -allocateGlobal_ create destroy = allocateGlobal create (const destroy) - --- | Run a frame --- --- The frame will be retired by another thread when all the fences added by --- 'queueSubmitFrame' have been signaled. -runFrame :: Frame -> F a -> V a -runFrame f (F r) = runReaderT r f `finally` do - fences <- liftIO $ readIORef (fGPUWork f) - -- Wait in another thread for this frame to be presented before retiring - spawn_ $ do - waitForFencesSafe' fences True 1e9 >>= \case - TIMEOUT -> do - -- Give the frame one last chance to complete, - -- It could be that the program was suspended during the preceding - -- wait causing it to timeout, this will check if it actually - -- finished. - waitForFencesSafe' fences True 0 >>= \case - TIMEOUT -> - throwString "Timed out waiting for frame to finish on the GPU" - _ -> pure () - _ -> pure () - commandPool <- getCommandPool (commandPoolIndex f) - resetCommandPool' commandPool zero - - putMVar (fCurrentPresented f) () - retireFrame f - -askFrame :: F Frame -askFrame = F ask - -asksFrame :: (Frame -> a) -> F a -asksFrame = F . asks - --- | Get a fresh command pool for this frame, it will be reset upon frame --- retirement -frameCommandPool :: F CommandPool -frameCommandPool = do - poolIndex <- commandPoolIndex <$> askFrame - F . lift . getCommandPool $ fromIntegral poolIndex - -commandPoolIndex :: Frame -> Int -commandPoolIndex Frame {..} = fromIntegral fIndex `mod` numConcurrentFrames - --- | Free frame resources, the frame must have finished GPU execution first. -retireFrame :: MonadIO m => Frame -> m () -retireFrame Frame {..} = release (fst fResources) - --- | 'queueSubmit' and add wait for the 'Fence' before retiring the frame. -queueSubmitFrame :: Queue -> Vector (SomeStruct SubmitInfo) -> Fence -> F () -queueSubmitFrame q ss fence = do - queueSubmit q ss fence - gpuWork <- asksFrame fGPUWork - liftIO $ atomicModifyIORef' gpuWork ((, ()) . cons fence) - --- | Make sure a reference is held until this frame is retired -frameRefCount :: RefCounted -> F () -frameRefCount = resourceTRefCount diff --git a/examples/resize/Init.hs b/examples/resize/Init.hs index 466bd223e..031822db3 100644 --- a/examples/resize/Init.hs +++ b/examples/resize/Init.hs @@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE QuasiQuotes #-} module Init ( Init.createDevice @@ -12,12 +13,13 @@ import Control.Monad ( guard ) import Control.Monad.IO.Class import Control.Monad.Trans.Maybe ( MaybeT(..) ) import Control.Monad.Trans.Resource -import Data.Bits import Data.Text ( Text ) import qualified Data.Vector as V import Data.Word import UnliftIO.Exception +import Frame ( frameDeviceRequirements ) +import qualified Vma import Vulkan.CStruct.Extends import Vulkan.Core10 as Vk hiding ( withBuffer @@ -26,26 +28,14 @@ import Vulkan.Core10 as Vk import qualified Vulkan.Core10 as MemoryHeap (MemoryHeap(..)) import Vulkan.Extensions.VK_KHR_surface import Vulkan.Extensions.VK_KHR_swapchain -import Vulkan.Utils.Initialization ( physicalDeviceName +import Vulkan.Utils.Initialization ( createDeviceFromRequirements + , physicalDeviceName , pickPhysicalDevice ) +import Vulkan.Utils.Misc ( (.&&.) ) +import qualified Vulkan.Utils.Requirements.TH as U import Vulkan.Zero -import VulkanMemoryAllocator ( Allocator - , AllocatorCreateInfo(..) - , VulkanFunctions(..) - , withAllocator - ) - -import Foreign.Ptr ( castFunPtr ) -import Vulkan.Dynamic ( DeviceCmds - ( DeviceCmds - , pVkGetDeviceProcAddr - ) - , InstanceCmds - ( InstanceCmds - , pVkGetInstanceProcAddr - ) - ) +import VulkanMemoryAllocator ( Allocator ) myApiVersion :: Word32 myApiVersion = API_VERSION_1_0 @@ -82,14 +72,17 @@ createDevice inst surf = do -- let graphicsQueueFamilyIndex = pdiGraphicsQueueFamilyIndex pdi deviceCreateInfo = zero - { queueCreateInfos = [ SomeStruct zero - { queueFamilyIndex = graphicsQueueFamilyIndex - , queuePriorities = [1] - } - ] - , enabledExtensionNames = [KHR_SWAPCHAIN_EXTENSION_NAME] + { queueCreateInfos = [ SomeStruct zero + { queueFamilyIndex = graphicsQueueFamilyIndex + , queuePriorities = [1] + } + ] } - (_, dev) <- withDevice phys deviceCreateInfo Nothing allocate + deviceReqs = [U.reqs| + 1.0 + VK_KHR_swapchain + |] ++ frameDeviceRequirements + dev <- createDeviceFromRequirements deviceReqs [] phys deviceCreateInfo graphicsQueue <- getDeviceQueue dev graphicsQueueFamilyIndex 0 pure $ DeviceParams devName phys dev graphicsQueue graphicsQueueFamilyIndex @@ -144,27 +137,4 @@ deviceHasSwapchain dev = do createVMA :: MonadResource m => Instance -> PhysicalDevice -> Device -> m Allocator -createVMA inst phys dev = - snd - <$> withAllocator - zero - { flags = zero - , physicalDevice = physicalDeviceHandle phys - , device = deviceHandle dev - , instance' = instanceHandle inst - , vulkanApiVersion = myApiVersion - , vulkanFunctions = Just $ case inst of - Instance _ InstanceCmds {..} -> case dev of - Device _ DeviceCmds {..} -> zero - { vkGetInstanceProcAddr = castFunPtr pVkGetInstanceProcAddr - , vkGetDeviceProcAddr = castFunPtr pVkGetDeviceProcAddr - } - } - allocate ----------------------------------------------------------------- --- Bit utils ----------------------------------------------------------------- - -infixl 4 .&&. -(.&&.) :: Bits a => a -> a -> Bool -x .&&. y = (/= zeroBits) (x .&. y) +createVMA = Vma.createVMA zero myApiVersion diff --git a/examples/resize/Julia.hs b/examples/resize/Julia.hs index df8f593e5..dd5280ce9 100644 --- a/examples/resize/Julia.hs +++ b/examples/resize/Julia.hs @@ -2,14 +2,18 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE CPP #-} +-- | Julia-set compute shader pipeline. The pipeline + descriptor set layout +-- are created once and never re-created; the descriptor sets are bound to +-- swapchain image views, so they need to be recreated whenever the swapchain +-- changes. module Julia - ( juliaPipeline + ( JuliaPipeline(..) + , createJuliaPipeline + , createJuliaDescriptorSets , juliaWorkgroupX , juliaWorkgroupY - ) -where + ) where import Control.Monad.Trans.Resource import qualified Data.Vector as V @@ -21,63 +25,86 @@ import Vulkan.Utils.ShaderQQ.GLSL.Glslang import Vulkan.Zero import Julia.Constants -import MonadVulkan - -juliaPipeline - :: Vector ImageView -> V (Pipeline, PipelineLayout, Vector DescriptorSet) -juliaPipeline imageViews = do - descriptorSetLayout <- juliaDescriptorSetLayout - descriptorSets <- juliaDescriptorSet descriptorSetLayout imageViews - (releaseShader, shader ) <- juliaShader - (_ , pipelineLayout) <- withPipelineLayout' zero - { setLayouts = [descriptorSetLayout] - , pushConstantRanges = [ PushConstantRange SHADER_STAGE_COMPUTE_BIT - 0 - ((2 + 2 + 2 + 1) * 4) - ] - } + +data JuliaPipeline = JuliaPipeline + { jpPipeline :: Pipeline + , jpPipelineLayout :: PipelineLayout + , jpDescriptorSetLayout :: DescriptorSetLayout + } + +createJuliaPipeline + :: (MonadResource m, MonadFail m) => Device -> m JuliaPipeline +createJuliaPipeline dev = do + (_, descriptorSetLayout) <- withDescriptorSetLayout + dev + zero + { bindings = [ zero { binding = 0 + , descriptorType = DESCRIPTOR_TYPE_STORAGE_IMAGE + , descriptorCount = 1 + , stageFlags = SHADER_STAGE_COMPUTE_BIT + } + ] + } + Nothing + allocate + (releaseShader, shader) <- juliaShader dev + (_, pipelineLayout ) <- withPipelineLayout + dev + zero + { setLayouts = [descriptorSetLayout] + , pushConstantRanges = [ PushConstantRange SHADER_STAGE_COMPUTE_BIT + 0 + ((2 + 2 + 2 + 1) * 4) + ] + } + Nothing + allocate let pipelineCreateInfo :: ComputePipelineCreateInfo '[] pipelineCreateInfo = zero { layout = pipelineLayout , stage = shader , basePipelineHandle = zero } - (_, (_, [computePipeline])) <- withComputePipelines' + (_, (_, [computePipeline])) <- withComputePipelines + dev zero [SomeStruct pipelineCreateInfo] + Nothing + allocate release releaseShader - pure (computePipeline, pipelineLayout, descriptorSets) - -juliaDescriptorSetLayout :: V DescriptorSetLayout -juliaDescriptorSetLayout = snd <$> withDescriptorSetLayout' zero - { bindings = [ zero { binding = 0 - , descriptorType = DESCRIPTOR_TYPE_STORAGE_IMAGE - , descriptorCount = 1 - , stageFlags = SHADER_STAGE_COMPUTE_BIT - } - ] - } - -juliaDescriptorSet - :: DescriptorSetLayout -> Vector ImageView -> V (Vector DescriptorSet) -juliaDescriptorSet descriptorSetLayout imageViews = do - -- Create a descriptor pool - (_, descriptorPool) <- withDescriptorPool' zero - { maxSets = fromIntegral (V.length imageViews) - , poolSizes = [ DescriptorPoolSize DESCRIPTOR_TYPE_STORAGE_IMAGE - (fromIntegral (V.length imageViews)) - ] - } - - -- Allocate a descriptor set from the pool with that layout - -- Don't use `withDescriptorSets` here as the set will be cleaned up when - -- the pool is destroyed. - descriptorSets <- allocateDescriptorSets' zero - { descriptorPool = descriptorPool - , setLayouts = V.replicate (V.length imageViews) descriptorSetLayout - } - - -- Assign the buffer in this descriptor set - updateDescriptorSets' + pure JuliaPipeline { jpPipeline = computePipeline + , jpPipelineLayout = pipelineLayout + , jpDescriptorSetLayout = descriptorSetLayout + } + +-- | One descriptor set per swapchain image, bound to its image view. Allocated +-- from a fresh descriptor pool so that releasing this scope frees the lot. +createJuliaDescriptorSets + :: MonadResource m + => Device + -> DescriptorSetLayout + -> Vector ImageView + -> m (Vector DescriptorSet) +createJuliaDescriptorSets dev descriptorSetLayout imageViews = do + (_, descriptorPool) <- withDescriptorPool + dev + zero + { maxSets = fromIntegral (V.length imageViews) + , poolSizes = [ DescriptorPoolSize DESCRIPTOR_TYPE_STORAGE_IMAGE + (fromIntegral (V.length imageViews)) + ] + } + Nothing + allocate + + -- Sets are freed automatically when the pool is destroyed. + descriptorSets <- allocateDescriptorSets + dev + zero { descriptorPool = descriptorPool + , setLayouts = V.replicate (V.length imageViews) descriptorSetLayout + } + + updateDescriptorSets + dev (V.zipWith (\set view -> SomeStruct zero { dstSet = set @@ -98,8 +125,11 @@ juliaDescriptorSet descriptorSetLayout imageViews = do pure descriptorSets -juliaShader :: V (ReleaseKey, SomeStruct PipelineShaderStageCreateInfo) -juliaShader = do +juliaShader + :: MonadResource m + => Device + -> m (ReleaseKey, SomeStruct PipelineShaderStageCreateInfo) +juliaShader dev = do let compCode = $(compileShaderQ (Just "vulkan1.0") "comp" Nothing [glsl| #version 450 #extension GL_ARB_separate_shader_objects : enable @@ -153,25 +183,6 @@ juliaShader = do return smooth_ / float(max_iteration); } - // const int num_samples = 16; - // const vec2 samples[num_samples] = - // { vec2(0.0, 0.0) - // , vec2(0.0, 0.25) - // , vec2(0.0, 0.5) - // , vec2(0.0, 0.75) - // , vec2(0.25, 0.0) - // , vec2(0.25, 0.25) - // , vec2(0.25, 0.5) - // , vec2(0.25, 0.75) - // , vec2(0.5, 0.0) - // , vec2(0.5, 0.25) - // , vec2(0.5, 0.5) - // , vec2(0.5, 0.75) - // , vec2(0.75, 0.0) - // , vec2(0.75, 0.25) - // , vec2(0.75, 0.5) - // , vec2(0.75, 0.75) - // }; const int num_samples = 4; const vec2 samples[num_samples] = { vec2(0.0, 0.0) @@ -192,7 +203,7 @@ juliaShader = do imageStore(img, ivec2(gl_GlobalInvocationID.xy), vec4(res, 1)); } |]) - (releaseKey, compModule) <- withShaderModule' zero { code = compCode } + (releaseKey, compModule) <- withShaderModule dev zero { code = compCode } Nothing allocate let compShaderStageCreateInfo = zero { stage = SHADER_STAGE_COMPUTE_BIT , module' = compModule , name = "main" diff --git a/examples/resize/Main.hs b/examples/resize/Main.hs index df763c1c2..d6f84c479 100644 --- a/examples/resize/Main.hs +++ b/examples/resize/Main.hs @@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} module Main @@ -8,19 +9,51 @@ module Main import Control.Exception ( handle ) import Control.Lens.Getter -import Control.Monad.Extra ( unlessM - , when - ) +import Control.Monad ( when ) import Control.Monad.IO.Class import Control.Monad.Trans.Resource -import Data.Bool ( bool ) +import Data.Bits ( (.|.) ) +import Data.Foldable ( traverse_ ) +import Data.IORef import qualified Data.Vector as V +import Data.Vector ( Vector ) +import Frame ( Frame(..) + , advanceFrame + , frameInstanceRequirements + , initialFrame + , queueSubmitFrame + , runFrame + ) +import qualified Framebuffer import GHC.Clock ( getMonotonicTimeNSec ) +import Init ( DeviceParams(..) + , createDevice + , createVMA + , myApiVersion + ) +import Julia ( JuliaPipeline(..) + , createJuliaDescriptorSets + , createJuliaPipeline + , juliaWorkgroupX + , juliaWorkgroupY + ) import Linear.Affine ( Point(..) ) import Linear.Metric ( norm ) import Linear.V2 +import qualified Pipeline +import RefCounted ( RefCounted + , newRefCounted + , releaseRefCounted + ) import qualified SDL +import qualified SDL.Video.Vulkan as SDL import Say +import Data.Word ( Word64 ) +import Swapchain ( Swapchain(..) + , allocSwapchain + , recreateSwapchain + , threwSwapchainError + ) import UnliftIO.Exception ( displayException , throwIO , throwString @@ -29,11 +62,17 @@ import UnliftIO.Foreign ( allocaBytes , plusPtr , poke ) -import UnliftIO.IORef -import UnliftIO.MVar -import Utils +import Utils ( loopJust ) +import VkResources ( Queues(..) + , RecycledResources(..) + , VkResources(..) + , mkVkResources + ) -import Vulkan.CStruct.Extends ( SomeStruct(..) ) +import Vulkan.CStruct.Extends ( SomeStruct(..) + , pattern (:&) + , pattern (::&) + ) import Vulkan.Core10 as Vk hiding ( createDevice , createFramebuffer @@ -43,27 +82,23 @@ import Vulkan.Core10 as Vk , withImage ) import qualified Vulkan.Core10 as CommandBufferBeginInfo (CommandBufferBeginInfo(..)) -import qualified Vulkan.Core10 as CommandPoolCreateInfo (CommandPoolCreateInfo(..)) +import Vulkan.Core12.Promoted_From_VK_KHR_timeline_semaphore import Vulkan.Exception -import Vulkan.Extensions.VK_KHR_surface +import Vulkan.Extensions.VK_KHR_surface as SurfaceFormatKHR (SurfaceFormatKHR(..)) import Vulkan.Extensions.VK_KHR_swapchain + as Swap +import Vulkan.Utils.QueueAssignment ( QueueFamilyIndex(..) ) import Vulkan.Zero - -import Frame -import HasVulkan -import Init -import Julia -import MonadVulkan -import Pipeline -import Swapchain import qualified Vulkan.Utils.Init.SDL2 as Init -import Window.SDL2 +import Window.SDL2 ( RefreshLimit(..) + , createSurface + , createWindow + , shouldQuit + , withSDL + ) ---------------------------------------------------------------- --- Main performs some one time initialization of the windowing system and --- Vulkan, then it loops generating frames --- --- It's bound to an OS thread so SDL.pumpEvents can work properly. +-- Main ---------------------------------------------------------------- main :: IO () main = prettyError . runResourceT $ do @@ -72,216 +107,171 @@ main = prettyError . runResourceT $ do let initWidth = 1280 initHeight = 720 - -- Create everything up to the device - sdlWindow <- createWindow "Haskell ❤️ Vulkan" initWidth initHeight - inst <- Init.withInstance + sdlWindow <- createWindow "Haskell ❤️ Vulkan" initWidth initHeight + inst <- Init.withInstance sdlWindow (Just zero { applicationName = Nothing, apiVersion = myApiVersion }) + frameInstanceRequirements [] - [] - surface <- createSurface inst sdlWindow + (_, surface) <- createSurface inst sdlWindow DeviceParams devName phys dev graphicsQueue graphicsQueueFamilyIndex <- - createDevice inst (snd surface) - let commandPoolCreateInfo = zero { CommandPoolCreateInfo.queueFamilyIndex = graphicsQueueFamilyIndex } - commandPools <- V.replicateM - numConcurrentFrames - (snd <$> withCommandPool dev commandPoolCreateInfo Nothing allocate) - - allocator <- createVMA inst phys dev - + createDevice inst surface + vma <- createVMA inst phys dev sayErr $ "Using device: " <> devName - -- Now all the globals are initialized - runV inst - phys - dev - graphicsQueue - graphicsQueueFamilyIndex - commandPools - allocator - $ do - i <- initialFrame sdlWindow - (Just surface) - (Extent2D initWidth initHeight) - - SDL.showWindow sdlWindow - loopJust frame i + let qs = Queues (QueueFamilyIndex graphicsQueueFamilyIndex, graphicsQueue) + vr <- liftIO $ mkVkResources inst phys dev vma qs + + -- Initial swapchain at the requested size. + let initialSize = Extent2D initWidth initHeight + initialSC <- allocSwapchain vr NULL_HANDLE initialSize surface + + -- Long-lived render setup. Both the graphics pipeline (currently dormant) + -- and the Julia compute pipeline are created up front. + (_, renderPass) <- Pipeline.createRenderPass dev (SurfaceFormatKHR.format (sFormat initialSC)) + (_, pipeline) <- Pipeline.createPipeline dev renderPass + juliaPL <- createJuliaPipeline dev + + -- Per-swapchain bindings: framebuffers + Julia descriptor sets, both pinned + -- to the current swapchain images. + initialBindings <- createBindings dev renderPass juliaPL initialSC + + scRef <- liftIO $ newIORef initialSC + bindingsRef <- liftIO $ newIORef initialBindings + + initial <- initialFrame vr initialSC + SDL.showWindow sdlWindow + + let + perFrame f = do + currentSC <- liftIO $ readIORef scRef + bindings <- liftIO $ readIORef bindingsRef + let f' = f { fSwapchain = currentSC } + startNs <- liftIO getMonotonicTimeNSec + needsNew <- threwSwapchainError $ liftIO $ runFrame vr f' $ + renderJulia vr juliaPL bindings f' + sc' <- if needsNew + then do + newSize <- liftIO $ drawableSize sdlWindow + sc' <- recreateSwapchain vr newSize currentSC + newBindings <- createBindings dev renderPass juliaPL sc' + liftIO $ writeIORef scRef sc' + dropBindings =<< liftIO (readIORef bindingsRef) + liftIO $ writeIORef bindingsRef newBindings + pure sc' + else pure currentSC + endNs <- liftIO getMonotonicTimeNSec + reportFrameTime (endNs - startNs) + advanceFrame vr sc' f' + + loop f = shouldQuit (TimeLimit 6) >>= \case + True -> pure Nothing + False -> Just <$> perFrame f + + loopJust loop initial prettyError :: IO () -> IO () prettyError = handle (\e@(VulkanException _) -> sayErrString (displayException e)) -initialFrame - :: SDL.Window - -> Maybe (ReleaseKey, SurfaceKHR) - -- ^ existing surface for window - -> Extent2D - -> V Frame -initialFrame window surfaceM windowSize = do - inst <- getInstance - (_, surface) <- maybe (createSurface inst window) pure surfaceM - - graphicsQueueFamilyIndex <- getGraphicsQueueFamilyIndex - phys <- getPhysicalDevice - unlessM - (getPhysicalDeviceSurfaceSupportKHR phys graphicsQueueFamilyIndex surface) - $ throwString "Device isn't able to present to the new surface" - - (swapchain, imageExtent, framebuffers, imageViews, images, swapchainFormat, releaseSwapchain) <- - allocSwapchainResources windowSize NULL_HANDLE surface - - renderPass <- snd <$> Pipeline.createRenderPass swapchainFormat - pipeline <- snd <$> createPipeline renderPass - (juliaPipeline, juliaPipelineLayout, juliaDSets) <- juliaPipeline imageViews - - (_, imageAvailableSemaphore) <- withSemaphore' zero - (_, renderFinishedSemaphore) <- withSemaphore' zero - - currentPresented <- newEmptyMVar - lastPresented <- newMVar () - secondLastPresented <- newMVar () - thirdLastPresented <- newMVar () - - start <- liftIO getMonotonicTimeNSec - - frameResources <- allocate createInternalState closeInternalState - fences <- newIORef mempty - - pure - (Frame 0 - window - surface - swapchain - swapchainFormat - renderPass - imageExtent - imageAvailableSemaphore - renderFinishedSemaphore - pipeline - juliaPipeline - juliaPipelineLayout - ((juliaDSets V.!) . fromIntegral) - ((images V.!) . fromIntegral) - ((imageViews V.!) . fromIntegral) - ((framebuffers V.!) . fromIntegral) - releaseSwapchain - currentPresented - lastPresented - secondLastPresented - thirdLastPresented - start - frameResources - fences - ) - --- | Process a single frame, returning Nothing if we should exit. -frame :: Frame -> V (Maybe Frame) -frame f = shouldQuit (TimeLimit 6) >>= \case - True -> pure Nothing - False -> do - -- Wait for the second previous frame to have finished presenting so the - -- CPU doesn't get too far ahead. - readMVar (fSecondLastPresented f) - - f <- startFrame f - - -- Render this frame - needsNewSwapchain <- threwSwapchainError $ runFrame f draw - - -- Advance the frame, recreating the swapchain if necessary - f' <- advanceFrame =<< bool pure recreateSwapchain needsNewSwapchain f - - -- Print out frame timing info - endTime <- liftIO getMonotonicTimeNSec - let - frameTimeNSec = realToFrac (endTime - fStartTime f) :: Double - targetHz = 60 - frameTimeBudgetMSec = recip targetHz * 1e3 - frameTimeMSec = frameTimeNSec / 1e6 - frameBudgetPercent = - ceiling (100 * frameTimeMSec / frameTimeBudgetMSec) :: Int - when (frameBudgetPercent > 50) $ sayErrString - (show frameTimeMSec <> "ms \t" <> show frameBudgetPercent <> "%") - - pure $ Just f' - --- | Set the frame start time -startFrame :: Frame -> V Frame -startFrame f = do - start <- liftIO getMonotonicTimeNSec - pure f { fStartTime = start } - --- | Shuffle along previous frames's info and make per-frame resources -advanceFrame :: Frame -> V Frame -advanceFrame f = do - nextPresented <- newEmptyMVar - resources <- allocate createInternalState closeInternalState - fences <- newIORef mempty - pure f { fIndex = succ (fIndex f) - , fCurrentPresented = nextPresented - , fLastPresented = fCurrentPresented f - , fSecondLastPresented = fLastPresented f - , fThirdLastPresented = fSecondLastPresented f - , fResources = resources - , fGPUWork = fences - } +---------------------------------------------------------------- +-- Per-swapchain bindings +---------------------------------------------------------------- --- | Submit GPU commands for a frame -draw :: F (Fence, ()) -draw = do - Frame {..} <- askFrame +data Bindings = Bindings + { bFramebuffers :: Vector Framebuffer + , bReleaseFramebuffers :: RefCounted + , bJuliaDescriptorSets :: Vector DescriptorSet + , bReleaseJuliaDescSets :: RefCounted + } + +createBindings + :: MonadResource m + => Device + -> RenderPass + -> JuliaPipeline + -> Swapchain + -> m Bindings +createBindings dev renderPass jp sc = do + -- Framebuffers (one per swapchain image) for the dormant graphics pipeline. + (fbKeys, framebuffers) <- fmap V.unzip . V.forM (sImageViews sc) $ \iv -> + Framebuffer.createFramebuffer dev renderPass iv (sExtent sc) + fbRel <- newRefCounted (traverse_ release fbKeys) + + -- Julia descriptor sets (one per swapchain image). + juliaSets <- createJuliaDescriptorSets + dev + (jpDescriptorSetLayout jp) + (sImageViews sc) + -- The whole pool is freed when its allocate-frame closes; mirror that with + -- a dummy refcount so swapping bindings releases the previous pool. + (poolKey, _) <- allocate (pure ()) (\_ -> pure ()) + poolRel <- newRefCounted (release poolKey) + + pure Bindings + { bFramebuffers = framebuffers + , bReleaseFramebuffers = fbRel + , bJuliaDescriptorSets = juliaSets + , bReleaseJuliaDescSets = poolRel + } + +dropBindings :: MonadIO m => Bindings -> m () +dropBindings b = do + releaseRefCounted (bReleaseFramebuffers b) + releaseRefCounted (bReleaseJuliaDescSets b) - (acquireResult, imageIndex) <- - acquireNextImageKHR' fSwapchain 1e9 fImageAvailableSemaphore zero >>= \case - r@(SUCCESS, _) -> pure r - r@(SUBOPTIMAL_KHR, _) -> pure r - (TIMEOUT, _) -> throwString "Couldn't acquire next image after 1 second" - _ -> throwString "Unexpected Result from acquireNextImageKHR" - - let image = fImages imageIndex - let imageSubresourceRange = ImageSubresourceRange +---------------------------------------------------------------- +-- Per-frame rendering +---------------------------------------------------------------- + +renderJulia + :: VkResources + -> JuliaPipeline + -> Bindings + -> Frame + -> ResourceT IO () +renderJulia vr jp bindings f = do + let RecycledResources {..} = fRecycled f + sc = fSwapchain f + Queues (_, gQ) = vrQueues vr + dev = vrDevice vr + oneSecond = 1e9 + Extent2D imageWidth imageHeight = sExtent sc + imageSubresourceRange = ImageSubresourceRange { aspectMask = IMAGE_ASPECT_COLOR_BIT , baseMipLevel = 0 , levelCount = 1 , baseArrayLayer = 0 , layerCount = 1 } - let Extent2D imageWidth imageHeight = fImageExtent - - -- Make sure we don't destroy the swapchain until at least this frame has - -- finished GPU execution. - frameRefCount fReleaseSwapchain - - commandPool <- frameCommandPool - let commandBufferAllocateInfo = zero { commandPool = commandPool - , level = COMMAND_BUFFER_LEVEL_PRIMARY - , commandBufferCount = 1 - } - - -- The command buffer will be freed when the frame is retired - (_, [commandBuffer]) <- withCommandBuffers' commandBufferAllocateInfo - - updateDescriptorSets' - [ SomeStruct zero - { dstSet = fJuliaDescriptorSets imageIndex - , dstBinding = 0 - , descriptorType = DESCRIPTOR_TYPE_STORAGE_IMAGE - , descriptorCount = 1 - , imageInfo = [ DescriptorImageInfo { sampler = NULL_HANDLE - , imageView = fImageViews imageIndex - , imageLayout = IMAGE_LAYOUT_GENERAL - } - ] - } - ] - [] + + (acquireResult, imageIndex) <- + acquireNextImageKHRSafe dev (sSwapchain sc) oneSecond rrImageAvailable NULL_HANDLE + >>= \case + r@(SUCCESS, _) -> pure r + r@(SUBOPTIMAL_KHR, _) -> pure r + (TIMEOUT, _) -> throwString "Couldn't acquire next image after 1 second" + _ -> throwString "Unexpected Result from acquireNextImageKHR" + + let image = sImages sc V.! fromIntegral imageIndex + descriptorSet = bJuliaDescriptorSets bindings V.! fromIntegral imageIndex + + -- Allocate a per-frame command buffer from the recycled pool. + (_, ~[commandBuffer]) <- withCommandBuffers + dev + zero { commandPool = rrCommandPool + , level = COMMAND_BUFFER_LEVEL_PRIMARY + , commandBufferCount = 1 + } + allocate let julia = True - useCommandBuffer' commandBuffer - zero { CommandBufferBeginInfo.flags = COMMAND_BUFFER_USAGE_ONE_TIME_SUBMIT_BIT } + useCommandBuffer + commandBuffer + zero { CommandBufferBeginInfo.flags = COMMAND_BUFFER_USAGE_ONE_TIME_SUBMIT_BIT } $ if julia then do - -- Transition image to general, to write from the compute shader + -- Transition image to general (compute write target). cmdPipelineBarrier commandBuffer PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT @@ -298,10 +288,9 @@ draw = do } ] - cmdBindPipeline' PIPELINE_BIND_POINT_COMPUTE fJuliaPipeline + cmdBindPipeline commandBuffer PIPELINE_BIND_POINT_COMPUTE (jpPipeline jp) - -- Get the mouse position in the window (in [-1..1]) and send it as a - -- push constant. + -- Mouse-driven push constants. P m <- SDL.getAbsoluteMouseLocation let m' :: V2 Float m' = fmap realToFrac m @@ -320,27 +309,28 @@ draw = do liftIO $ poke (p `plusPtr` 8) frameOffset liftIO $ poke (p `plusPtr` 16) c liftIO $ poke (p `plusPtr` 24) escapeRadius - cmdPushConstants' fJuliaPipelineLayout - SHADER_STAGE_COMPUTE_BIT - 0 - constantBytes - p - cmdBindDescriptorSets' PIPELINE_BIND_POINT_COMPUTE - fJuliaPipelineLayout - 0 - [fJuliaDescriptorSets imageIndex] - [] - cmdDispatch' + cmdPushConstants commandBuffer + (jpPipelineLayout jp) + SHADER_STAGE_COMPUTE_BIT + 0 + (fromIntegral constantBytes) + p + cmdBindDescriptorSets commandBuffer + PIPELINE_BIND_POINT_COMPUTE + (jpPipelineLayout jp) + 0 + [descriptorSet] + [] + cmdDispatch + commandBuffer ((imageWidth + juliaWorkgroupX - 1) `quot` juliaWorkgroupX) ((imageHeight + juliaWorkgroupY - 1) `quot` juliaWorkgroupY) 1 - -- Transition image back to present + -- Transition image back to present. cmdPipelineBarrier commandBuffer PIPELINE_STAGE_COMPUTE_SHADER_BIT - -- No need to get anything to wait because we're synchronizing with - -- the semaphore PIPELINE_STAGE_BOTTOM_OF_PIPE_BIT zero [] @@ -354,14 +344,14 @@ draw = do } ] else do + -- Dormant graphics pipeline path; preserved for reference. let renderPassBeginInfo = zero - { renderPass = fRenderPass - , framebuffer = fFramebuffers imageIndex - , renderArea = Rect2D zero fImageExtent + { renderPass = NULL_HANDLE -- intentionally invalid; see note + , framebuffer = bFramebuffers bindings V.! fromIntegral imageIndex + , renderArea = Rect2D zero (sExtent sc) , clearValues = [Color (Float32 0.1 0.1 0.1 1)] } - cmdSetViewport' - 0 + cmdSetViewport commandBuffer 0 [ Viewport { x = 0 , y = 0 , width = realToFrac imageWidth @@ -370,51 +360,60 @@ draw = do , maxDepth = 1 } ] - cmdSetScissor' - 0 - [Rect2D { offset = Offset2D 0 0, extent = fImageExtent }] - cmdUseRenderPass' renderPassBeginInfo SUBPASS_CONTENTS_INLINE $ do - cmdBindPipeline' PIPELINE_BIND_POINT_GRAPHICS fPipeline - cmdDraw' 3 1 0 0 - - let submitInfo = zero - { waitSemaphores = [fImageAvailableSemaphore] - , waitDstStageMask = [PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT] - , commandBuffers = [commandBufferHandle commandBuffer] - , signalSemaphores = [fRenderFinishedSemaphore] - } - graphicsQueue <- getGraphicsQueue - (_, renderFence) <- withFence' zero - queueSubmitFrame graphicsQueue [SomeStruct submitInfo] renderFence - - let presentInfo = zero { waitSemaphores = [fRenderFinishedSemaphore] - , swapchains = [fSwapchain] - , imageIndices = [imageIndex] - } - presentResult <- queuePresentKHR graphicsQueue presentInfo - - -- A SUBOPTIMAL_KHR from either acquire or present means the swapchain no - -- longer matches the surface (typically because the window was resized). - -- Re-throw it as ERROR_OUT_OF_DATE_KHR so 'threwSwapchainError' in the - -- frame loop triggers 'recreateSwapchain'. + cmdSetScissor commandBuffer 0 + [Rect2D { offset = Offset2D 0 0, extent = sExtent sc }] + cmdUseRenderPass commandBuffer renderPassBeginInfo SUBPASS_CONTENTS_INLINE $ do + cmdBindPipeline commandBuffer PIPELINE_BIND_POINT_GRAPHICS NULL_HANDLE + cmdDraw commandBuffer 3 1 0 0 + + -- Submit (and record GPU work for the wait thread). + let submitInfo = + zero { Vk.waitSemaphores = [rrImageAvailable] + , waitDstStageMask = [PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT] + , commandBuffers = [commandBufferHandle commandBuffer] + , signalSemaphores = [rrRenderFinished, fHostTimeline f] + } + ::& zero { waitSemaphoreValues = [1] + , signalSemaphoreValues = [1, fIndex f] + } + :& () + liftIO $ queueSubmitFrame gQ + f + [SomeStruct submitInfo] + (fHostTimeline f) + (fIndex f) + + presentResult <- queuePresentKHR + gQ + zero { Swap.waitSemaphores = [rrRenderFinished] + , swapchains = [sSwapchain sc] + , imageIndices = [imageIndex] + } + case (acquireResult, presentResult) of - (SUBOPTIMAL_KHR, _) -> throwIO (VulkanException ERROR_OUT_OF_DATE_KHR) - (_, SUBOPTIMAL_KHR) -> throwIO (VulkanException ERROR_OUT_OF_DATE_KHR) + (SUBOPTIMAL_KHR, _) -> liftIO . throwIO $ VulkanException ERROR_OUT_OF_DATE_KHR + (_, SUBOPTIMAL_KHR) -> liftIO . throwIO $ VulkanException ERROR_OUT_OF_DATE_KHR _ -> pure () - pure (renderFence, ()) +---------------------------------------------------------------- +-- Frame timing +---------------------------------------------------------------- + +reportFrameTime :: MonadIO m => Word64 -> m () +reportFrameTime nsec = do + let frameTimeNSec = realToFrac nsec :: Double + targetHz = 60 + frameTimeBudgetMSec = recip targetHz * 1e3 + frameTimeMSec = frameTimeNSec / 1e6 + frameBudgetPercent = ceiling (100 * frameTimeMSec / frameTimeBudgetMSec) :: Int + when (frameBudgetPercent > 50) $ + sayErrString (show frameTimeMSec <> "ms \t" <> show frameBudgetPercent <> "%") ---------------------------------------------------------------- --- Utils +-- Helpers ---------------------------------------------------------------- --- | Print a string if something is slow -_time :: MonadIO m => String -> m a -> m a -_time n a = do - t1 <- liftIO getMonotonicTimeNSec - r <- a - t2 <- liftIO getMonotonicTimeNSec - let d = t2 - t1 - t = 3e6 - when (d >= t) $ sayErrString (n <> ": " <> show (realToFrac d / 1e6 :: Float)) - pure r +drawableSize :: SDL.Window -> IO Extent2D +drawableSize win = do + SDL.V2 w h <- SDL.vkGetDrawableSize win + pure $ Extent2D (fromIntegral w) (fromIntegral h) diff --git a/examples/resize/MonadVulkan.hs b/examples/resize/MonadVulkan.hs deleted file mode 100644 index f54e82c55..000000000 --- a/examples/resize/MonadVulkan.hs +++ /dev/null @@ -1,188 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE OverloadedLists #-} -{-# OPTIONS_GHC -Wno-missing-signatures #-} - -module MonadVulkan where - -import AutoApply -import Control.Monad ( void ) -import Control.Monad.IO.Class -import Control.Monad.Trans.Reader -import Control.Monad.Trans.Resource -import Data.Vector ( Vector ) -import qualified Data.Vector as V -import Data.Word -import HasVulkan -import UnliftIO -import Vulkan.CStruct.Extends -import Vulkan.Core10 as Vk - hiding ( withBuffer - , withImage - ) -import Vulkan.Extensions.VK_KHR_surface -import Vulkan.Extensions.VK_KHR_swapchain -import VulkanMemoryAllocator as VMA - hiding ( getPhysicalDeviceProperties ) - - ----------------------------------------------------------------- --- Define the monad in which most of the program will run ----------------------------------------------------------------- - --- | @V@ keeps track of a bunch of "global" handles and performs resource --- management. -newtype V a = V { unV :: ReaderT GlobalHandles (ResourceT IO) a } - deriving newtype ( Functor - , Applicative - , Monad - , MonadFail - , MonadIO - , MonadResource - ) - -instance MonadUnliftIO V where - withRunInIO a = V $ withRunInIO (\r -> a (r . unV)) - -newtype CmdT m a = CmdT { unCmdT :: ReaderT CommandBuffer m a } - deriving newtype ( Functor - , Applicative - , Monad - , MonadFail - , MonadIO - , MonadResource - , HasVulkan - ) - -instance MonadUnliftIO m => MonadUnliftIO (CmdT m) where - withRunInIO a = CmdT $ withRunInIO (\r -> a (r . unCmdT)) - -instance HasVulkan V where - getInstance = V (asks ghInstance) - getGraphicsQueue = V (asks ghGraphicsQueue) - getPhysicalDevice = V (asks ghPhysicalDevice) - getDevice = V (asks ghDevice) - getAllocator = V (asks ghAllocator) - -getGraphicsQueueFamilyIndex :: V Word32 -getGraphicsQueueFamilyIndex = V (asks ghGraphicsQueueFamilyIndex) - -getCommandBuffer :: Monad m => CmdT m CommandBuffer -getCommandBuffer = CmdT ask - -getCommandPool :: Int -> V CommandPool -getCommandPool i = V (asks ((V.! i) . ghCommandPools)) - -useCommandBuffer' - :: forall a m r - . (Extendss CommandBufferBeginInfo a, PokeChain a, MonadIO m) - => CommandBuffer - -> CommandBufferBeginInfo a - -> CmdT m r - -> m r -useCommandBuffer' commandBuffer beginInfo (CmdT a) = - useCommandBuffer commandBuffer beginInfo (runReaderT a commandBuffer) - -runV - :: Instance - -> PhysicalDevice - -> Device - -> Queue - -> Word32 - -> Vector CommandPool - -> Allocator - -> V a - -> ResourceT IO a -runV ghInstance ghPhysicalDevice ghDevice ghGraphicsQueue ghGraphicsQueueFamilyIndex ghCommandPools ghAllocator - = flip runReaderT GlobalHandles { .. } . unV - --- Start an async thread which will be cancelled at the end of the ResourceT --- block -spawn :: V a -> V (Async a) -spawn a = do - aIO <- toIO a - -- If we don't remove the release key when the thread is done it'll leak, - -- remove it at the end of the async action when the thread is going to die - -- anyway. - -- - -- Mask this so there's no chance we're inturrupted before writing the mvar. - kv <- liftIO newEmptyMVar - UnliftIO.mask $ \_ -> do - (k, r) <- allocate - (asyncWithUnmask - (\unmask -> unmask $ aIO <* (unprotect =<< liftIO (readMVar kv))) - ) - uninterruptibleCancel - liftIO $ putMVar kv k - pure r - - -spawn_ :: V () -> V () -spawn_ = void . spawn - -data GlobalHandles = GlobalHandles - { ghInstance :: Instance - , ghPhysicalDevice :: PhysicalDevice - , ghDevice :: Device - , ghAllocator :: Allocator - , ghGraphicsQueue :: Queue - , ghGraphicsQueueFamilyIndex :: Word32 - , ghCommandPools :: Vector CommandPool - } - --- --- Wrap a bunch of Vulkan commands so that they automatically pull global --- handles from any `HasVulkan` instance. --- --- Wrapped functions are suffixed with "'" --- -autoapplyDecs - (<> "'") - [ 'getDevice - , 'getPhysicalDevice - , 'getInstance - , 'getAllocator - , 'noAllocationCallbacks - , 'getCommandBuffer - ] - -- Allocate doesn't subsume the continuation type on the "with" commands, so - -- put it in the unifying group. - ['allocate] - [ 'invalidateAllocation - , 'withBuffer - , 'deviceWaitIdle - , 'getDeviceQueue - , 'waitForFences - , 'waitForFencesSafe - , 'withCommandBuffers - , 'withCommandPool - , 'withFence - , 'withComputePipelines - , 'withInstance - , 'withPipelineLayout - , 'withShaderModule - , 'withDescriptorPool - , 'allocateDescriptorSets - , 'withDescriptorSetLayout - , 'updateDescriptorSets - , 'cmdBindPipeline - , 'cmdBindDescriptorSets - , 'cmdDispatch - , 'withSwapchainKHR - , 'getPhysicalDeviceSurfaceCapabilitiesKHR - , 'getPhysicalDeviceSurfacePresentModesKHR - , 'getPhysicalDeviceSurfaceFormatsKHR - , 'withGraphicsPipelines - , 'withRenderPass - , 'getSwapchainImagesKHR - , 'withImageView - , 'withFramebuffer - , 'acquireNextImageKHR - , 'withSemaphore - , 'deviceWaitIdleSafe - , 'resetCommandPool - , 'cmdSetViewport - , 'cmdSetScissor - , 'cmdUseRenderPass - , 'cmdDraw - , 'cmdPushConstants - ] diff --git a/examples/resize/Pipeline.hs b/examples/resize/Pipeline.hs index 42bba32a8..20f3ffa6a 100644 --- a/examples/resize/Pipeline.hs +++ b/examples/resize/Pipeline.hs @@ -9,8 +9,8 @@ module Pipeline import Control.Monad.Trans.Resource import Data.Bits -import qualified Data.Vector as V import Data.Foldable ( traverse_ ) +import qualified Data.Vector as V import Vulkan.CStruct.Extends import Vulkan.Core10 as Vk @@ -20,112 +20,120 @@ import Vulkan.Core10 as Vk import Vulkan.Utils.ShaderQQ.GLSL.Glslang import Vulkan.Zero -import MonadVulkan - --- Create the most vanilla rendering pipeline -createPipeline :: RenderPass -> V (ReleaseKey, Pipeline) -createPipeline renderPass = do - (shaderKeys, shaderStages ) <- V.unzip <$> createShaders - (layoutKey , pipelineLayout) <- withPipelineLayout' zero - let - pipelineCreateInfo :: GraphicsPipelineCreateInfo '[] - pipelineCreateInfo = zero - { stages = shaderStages - , vertexInputState = Just zero - , inputAssemblyState = Just zero - { topology = PRIMITIVE_TOPOLOGY_TRIANGLE_LIST - , primitiveRestartEnable = False - } - , viewportState = Just - $ SomeStruct zero { viewportCount = 1, scissorCount = 1 } - , rasterizationState = Just . SomeStruct $ zero - { depthClampEnable = False - , rasterizerDiscardEnable = False - , lineWidth = 1 - , polygonMode = POLYGON_MODE_FILL - , cullMode = CULL_MODE_NONE - , frontFace = FRONT_FACE_CLOCKWISE - , depthBiasEnable = False - } - , multisampleState = Just . SomeStruct $ zero - { sampleShadingEnable = False - , rasterizationSamples = SAMPLE_COUNT_1_BIT - , minSampleShading = 1 - , sampleMask = [maxBound] - } - , depthStencilState = Nothing - , colorBlendState = Just . SomeStruct $ zero - { logicOpEnable = False - , attachments = [ zero - { colorWriteMask = - COLOR_COMPONENT_R_BIT - .|. COLOR_COMPONENT_G_BIT - .|. COLOR_COMPONENT_B_BIT - .|. COLOR_COMPONENT_A_BIT - , blendEnable = False - } - ] - } - , dynamicState = Just zero - { dynamicStates = [ DYNAMIC_STATE_VIEWPORT - , DYNAMIC_STATE_SCISSOR - ] - } - , layout = pipelineLayout - , renderPass = renderPass - , subpass = 0 - , basePipelineHandle = zero - } - (key, (_, [graphicsPipeline])) <- withGraphicsPipelines' +createPipeline + :: (MonadResource m, MonadFail m) + => Device + -> RenderPass + -> m (ReleaseKey, Pipeline) +createPipeline dev renderPass = do + (shaderKeys, shaderStages ) <- V.unzip <$> createShaders dev + (layoutKey , pipelineLayout) <- withPipelineLayout dev zero Nothing allocate + let pipelineCreateInfo :: GraphicsPipelineCreateInfo '[] + pipelineCreateInfo = zero + { stages = shaderStages + , vertexInputState = Just zero + , inputAssemblyState = Just zero + { topology = PRIMITIVE_TOPOLOGY_TRIANGLE_LIST + , primitiveRestartEnable = False + } + , viewportState = Just + $ SomeStruct zero { viewportCount = 1, scissorCount = 1 } + , rasterizationState = Just . SomeStruct $ zero + { depthClampEnable = False + , rasterizerDiscardEnable = False + , lineWidth = 1 + , polygonMode = POLYGON_MODE_FILL + , cullMode = CULL_MODE_NONE + , frontFace = FRONT_FACE_CLOCKWISE + , depthBiasEnable = False + } + , multisampleState = Just . SomeStruct $ zero + { sampleShadingEnable = False + , rasterizationSamples = SAMPLE_COUNT_1_BIT + , minSampleShading = 1 + , sampleMask = [maxBound] + } + , depthStencilState = Nothing + , colorBlendState = Just . SomeStruct $ zero + { logicOpEnable = False + , attachments = + [ zero + { colorWriteMask = + COLOR_COMPONENT_R_BIT + .|. COLOR_COMPONENT_G_BIT + .|. COLOR_COMPONENT_B_BIT + .|. COLOR_COMPONENT_A_BIT + , blendEnable = False + } + ] + } + , dynamicState = Just zero + { dynamicStates = [ DYNAMIC_STATE_VIEWPORT + , DYNAMIC_STATE_SCISSOR + ] + } + , layout = pipelineLayout + , renderPass = renderPass + , subpass = 0 + , basePipelineHandle = zero + } + (key, (_, [graphicsPipeline])) <- withGraphicsPipelines + dev zero [SomeStruct pipelineCreateInfo] + Nothing + allocate release layoutKey traverse_ release shaderKeys pure (key, graphicsPipeline) --- | Create a renderpass with a single subpass -createRenderPass :: Format -> V (ReleaseKey, RenderPass) -createRenderPass imageFormat = do - let - attachmentDescription :: AttachmentDescription - attachmentDescription = zero - { format = imageFormat - , samples = SAMPLE_COUNT_1_BIT - , loadOp = ATTACHMENT_LOAD_OP_CLEAR - , storeOp = ATTACHMENT_STORE_OP_STORE - , stencilLoadOp = ATTACHMENT_LOAD_OP_DONT_CARE - , stencilStoreOp = ATTACHMENT_STORE_OP_DONT_CARE - , initialLayout = IMAGE_LAYOUT_UNDEFINED - , finalLayout = IMAGE_LAYOUT_PRESENT_SRC_KHR - } - subpass :: SubpassDescription - subpass = zero - { pipelineBindPoint = PIPELINE_BIND_POINT_GRAPHICS - , colorAttachments = - [ zero { attachment = 0 - , layout = IMAGE_LAYOUT_COLOR_ATTACHMENT_OPTIMAL - } - ] - } - subpassDependency :: SubpassDependency - subpassDependency = zero - { srcSubpass = SUBPASS_EXTERNAL - , dstSubpass = 0 - , srcStageMask = PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT - , srcAccessMask = zero - , dstStageMask = PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT - , dstAccessMask = ACCESS_COLOR_ATTACHMENT_READ_BIT - .|. ACCESS_COLOR_ATTACHMENT_WRITE_BIT - } - withRenderPass' zero { attachments = [attachmentDescription] - , subpasses = [subpass] - , dependencies = [subpassDependency] - } +createRenderPass + :: MonadResource m => Device -> Format -> m (ReleaseKey, RenderPass) +createRenderPass dev imageFormat = withRenderPass + dev + zero { attachments = [attachmentDescription] + , subpasses = [subpass] + , dependencies = [subpassDependency] + } + Nothing + allocate + where + attachmentDescription :: AttachmentDescription + attachmentDescription = zero + { format = imageFormat + , samples = SAMPLE_COUNT_1_BIT + , loadOp = ATTACHMENT_LOAD_OP_CLEAR + , storeOp = ATTACHMENT_STORE_OP_STORE + , stencilLoadOp = ATTACHMENT_LOAD_OP_DONT_CARE + , stencilStoreOp = ATTACHMENT_STORE_OP_DONT_CARE + , initialLayout = IMAGE_LAYOUT_UNDEFINED + , finalLayout = IMAGE_LAYOUT_PRESENT_SRC_KHR + } + subpass :: SubpassDescription + subpass = zero + { pipelineBindPoint = PIPELINE_BIND_POINT_GRAPHICS + , colorAttachments = + [ zero { attachment = 0 + , layout = IMAGE_LAYOUT_COLOR_ATTACHMENT_OPTIMAL + } + ] + } + subpassDependency :: SubpassDependency + subpassDependency = zero + { srcSubpass = SUBPASS_EXTERNAL + , dstSubpass = 0 + , srcStageMask = PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT + , srcAccessMask = zero + , dstStageMask = PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT + , dstAccessMask = ACCESS_COLOR_ATTACHMENT_READ_BIT + .|. ACCESS_COLOR_ATTACHMENT_WRITE_BIT + } --- | Create a vertex and fragment shader which render a colored triangle createShaders - :: V (V.Vector (ReleaseKey, SomeStruct PipelineShaderStageCreateInfo)) -createShaders = do + :: MonadResource m + => Device + -> m (V.Vector (ReleaseKey, SomeStruct PipelineShaderStageCreateInfo)) +createShaders dev = do let fragCode = [frag| #version 450 #extension GL_ARB_separate_shader_objects : enable @@ -160,8 +168,8 @@ createShaders = do fragColor = colors[gl_VertexIndex]; } |] - (fragKey, fragModule) <- withShaderModule' zero { code = fragCode } - (vertKey, vertModule) <- withShaderModule' zero { code = vertCode } + (fragKey, fragModule) <- withShaderModule dev zero { code = fragCode } Nothing allocate + (vertKey, vertModule) <- withShaderModule dev zero { code = vertCode } Nothing allocate let vertShaderStageCreateInfo = zero { stage = SHADER_STAGE_VERTEX_BIT , module' = vertModule , name = "main" diff --git a/examples/resize/Swapchain.hs b/examples/resize/Swapchain.hs deleted file mode 100644 index 4bc3519c4..000000000 --- a/examples/resize/Swapchain.hs +++ /dev/null @@ -1,199 +0,0 @@ -module Swapchain - ( createSwapchain - , threwSwapchainError - , recreateSwapchain - , allocSwapchainResources - ) where - -import Control.Monad ( unless ) -import Control.Monad.Trans.Resource -import Data.Bits -import Data.Either ( isLeft ) -import Data.Foldable ( traverse_ ) -import qualified Data.Vector as V -import RefCounted -import qualified SDL -import qualified SDL.Video.Vulkan as SDL -import Say -import UnliftIO.Exception ( throwString - , tryJust - ) -import Vulkan.Core10 hiding ( createFramebuffer - , createImageView - ) -import Vulkan.Exception -import Vulkan.Extensions.VK_KHR_surface -import Vulkan.Extensions.VK_KHR_surface as SurfaceCapabilitiesKHR (SurfaceCapabilitiesKHR(..)) -import Vulkan.Extensions.VK_KHR_surface as SurfaceFormatKHR (SurfaceFormatKHR(..)) -import Vulkan.Extensions.VK_KHR_swapchain -import Vulkan.Zero - -import Frame -import Framebuffer -import HasVulkan ( getPhysicalDevice ) -import MonadVulkan -import Pipeline - --- | Create a swapchain from a surface -createSwapchain - :: SwapchainKHR - -- ^ Old swapchain, can be NULL_HANDLE - -> Extent2D - -- ^ If the swapchain size determines the surface size, use this size - -> SurfaceKHR - -> V (ReleaseKey, SwapchainKHR, SurfaceFormatKHR, Extent2D) -createSwapchain oldSwapchain explicitSize surf = do - surfaceCaps <- getPhysicalDeviceSurfaceCapabilitiesKHR' surf - - unless (supportedUsageFlags surfaceCaps .&&. IMAGE_USAGE_STORAGE_BIT) - $ throwString "Surface images do not support IMAGE_USAGE_STORAGE_BIT" - unless (supportedUsageFlags surfaceCaps .&&. IMAGE_USAGE_COLOR_ATTACHMENT_BIT) - $ throwString - "Surface images do not support IMAGE_USAGE_COLOR_ATTACHMENT_BIT" - - (_, availablePresentModes) <- getPhysicalDeviceSurfacePresentModesKHR' surf - let desiredPresentModes = - [ PRESENT_MODE_MAILBOX_KHR - , PRESENT_MODE_FIFO_KHR - , PRESENT_MODE_IMMEDIATE_KHR - ] - presentMode <- - case filter (`V.elem` availablePresentModes) desiredPresentModes of - [] -> throwString "Unable to find a suitable present mode for swapchain" - x : _ -> pure x - sayErrString $ "Using present mode " <> show presentMode - - (_, availableFormats) <- getPhysicalDeviceSurfaceFormatsKHR' surf - -- Pick the first format whose 'optimalTilingFeatures' supports the usages - -- we'll need on the swapchain images (notably 'IMAGE_USAGE_STORAGE_BIT'), - -- falling back to the first one offered. SRGB formats normally lack - -- storage support and would crash @vkCreateSwapchainKHR@. - phys <- getPhysicalDevice - let suitable f = do - props <- getPhysicalDeviceFormatProperties phys (SurfaceFormatKHR.format f) - pure $ all (optimalTilingFeatures props .&&.) requiredFormatFeatures - good <- V.filterM suitable availableFormats - let surfaceFormat = if V.null good then V.head availableFormats else V.head good - sayErrString $ "Using surface format " <> show surfaceFormat - - let imageExtent = - case SurfaceCapabilitiesKHR.currentExtent surfaceCaps of - Extent2D w h | w == maxBound, h == maxBound -> explicitSize - e -> e - - let - swapchainCreateInfo = zero - { surface = surf - , minImageCount = SurfaceCapabilitiesKHR.minImageCount surfaceCaps + 1 - , imageFormat = SurfaceFormatKHR.format surfaceFormat - , imageColorSpace = colorSpace surfaceFormat - , imageExtent = imageExtent - , imageArrayLayers = 1 - , imageUsage = IMAGE_USAGE_STORAGE_BIT - .|. IMAGE_USAGE_COLOR_ATTACHMENT_BIT - , imageSharingMode = SHARING_MODE_EXCLUSIVE - , preTransform = SurfaceCapabilitiesKHR.currentTransform surfaceCaps - , compositeAlpha = COMPOSITE_ALPHA_OPAQUE_BIT_KHR - , presentMode = presentMode - , clipped = True - , oldSwapchain = oldSwapchain - } - - (key, swapchain) <- withSwapchainKHR' swapchainCreateInfo - pure (key, swapchain, surfaceFormat, imageExtent) - - ----------------------------------------------------------------- --- Utils for recreating a swapchain ----------------------------------------------------------------- - --- | Catch an ERROR_OUT_OF_DATE_KHR exception and return 'True' if that happened -threwSwapchainError :: V a -> V Bool -threwSwapchainError = fmap isLeft . tryJust swapchainError - where - swapchainError = \case - VulkanException e@ERROR_OUT_OF_DATE_KHR -> Just e - -- TODO handle this case - -- VulkanException e@ERROR_SURFACE_LOST_KHR -> Just e - VulkanException _ -> Nothing - --- | -recreateSwapchain :: Frame -> V Frame -recreateSwapchain f@Frame {..} = do - SDL.V2 width height <- SDL.vkGetDrawableSize fWindow - (swapchain, imageExtent, framebuffers, imageViews, images, newFormat, releaseSwapchain) <- - allocSwapchainResources - (Extent2D (fromIntegral width) (fromIntegral height)) - fSwapchain - fSurface - - unless (newFormat == fSwapchainFormat) - $ throwString "New swapchain has a different (unhandled) format" - - releaseRefCounted fReleaseSwapchain - - pure f { fSwapchain = swapchain - , fImageExtent = imageExtent - , fFramebuffers = (framebuffers V.!) . fromIntegral - , fImages = (images V.!) . fromIntegral - , fImageViews = (imageViews V.!) . fromIntegral - , fReleaseSwapchain = releaseSwapchain - } - -allocSwapchainResources - :: Extent2D - -> SwapchainKHR - -- ^ Previous swapchain, can be NULL_HANDLE - -> SurfaceKHR - -> V - ( SwapchainKHR - , Extent2D - , V.Vector Framebuffer - , V.Vector ImageView - , V.Vector Image - , Format - , RefCounted - ) -allocSwapchainResources windowSize oldSwapchain surface = do - (swapchainKey, swapchain, surfaceFormat, imageExtent) <- createSwapchain - oldSwapchain - windowSize - surface - - (renderPassKey, renderPass) <- Pipeline.createRenderPass (SurfaceFormatKHR.format surfaceFormat) - (_ , swapchainImages) <- getSwapchainImagesKHR' swapchain - (imageViewKeys, imageViews ) <- - fmap V.unzip . V.forM swapchainImages $ \image -> - createImageView (SurfaceFormatKHR.format surfaceFormat) image - - (framebufferKeys, framebuffers) <- - fmap V.unzip . V.forM imageViews $ \imageView -> - createFramebuffer renderPass imageView imageExtent - - releaseSwapchain <- newRefCounted $ do - traverse_ release framebufferKeys - traverse_ release imageViewKeys - release renderPassKey - release swapchainKey - - pure - ( swapchain - , imageExtent - , framebuffers - , imageViews - , swapchainImages - , SurfaceFormatKHR.format surfaceFormat - , releaseSwapchain - ) - ----------------------------------------------------------------- --- Bit utils ----------------------------------------------------------------- - -infixl 4 .&&. -(.&&.) :: Bits a => a -> a -> Bool -x .&&. y = (/= zeroBits) (x .&. y) - -requiredFormatFeatures :: [FormatFeatureFlagBits] -requiredFormatFeatures = - [FORMAT_FEATURE_COLOR_ATTACHMENT_BIT, FORMAT_FEATURE_STORAGE_IMAGE_BIT] diff --git a/examples/timeline-semaphore/Main.hs b/examples/timeline-semaphore/Main.hs deleted file mode 100644 index 71f47596d..000000000 --- a/examples/timeline-semaphore/Main.hs +++ /dev/null @@ -1,178 +0,0 @@ -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -Wno-missing-signatures #-} - -module Main - ( main - ) where - -import Control.Applicative -import Control.Exception ( throwIO ) -import Control.Monad ( unless ) -import Control.Monad.IO.Class -import Control.Monad.Trans.Maybe -import Control.Monad.Trans.Resource -import Data.Vector ( Vector ) -import Data.Word -import GHC.Exception ( SomeException ) -import GHC.IO.Exception ( IOErrorType(NoSuchThing) - , IOException(..) - ) -import Say -import UnliftIO ( Exception(displayException) - , catch - ) -import Vulkan.CStruct.Extends -import Vulkan.Core10 -import qualified Vulkan.Core10.DeviceInitialization as DI -import Vulkan.Core12.Promoted_From_VK_KHR_timeline_semaphore - as Timeline -import Vulkan.Exception -import Vulkan.Extensions.VK_KHR_get_physical_device_properties2 -import Vulkan.Requirement -import qualified Vulkan.Utils.Init.Headless as Init -import Vulkan.Utils.Initialization -import Vulkan.Utils.QueueAssignment -import qualified Vulkan.Utils.Requirements.TH as U -import Vulkan.Zero - -main :: IO () -main = runResourceT . traceException $ do - inst <- Main.createInstance - (_phys, dev, MyQueues computeQueue) <- Main.createDevice inst - timelineTest dev computeQueue - -timelineTest :: (MonadResource m) => Device -> Queue -> m () -timelineTest dev computeQueue = do - sem <- withTimelineSemaphore dev 1 - - -- Create some GPU work which waits for the semaphore to be '2' and then - -- bumps it to '3' - queueSubmit - computeQueue - [ SomeStruct - ( zero { Vulkan.Core10.waitSemaphores = [sem] - , signalSemaphores = [sem] - , commandBuffers = [] - , waitDstStageMask = [PIPELINE_STAGE_TOP_OF_PIPE_BIT] - } - ::& zero { waitSemaphoreValues = [2], signalSemaphoreValues = [3] } - :& () - ) - ] - zero - - -- Bump the semaphore to '2' to start the GPU work - signalSemaphore dev zero { semaphore = sem, value = 2 } - - -- Wait for the GPU to set it to '3' - Timeline.waitSemaphores dev zero { semaphores = [sem], values = [3] } 1e9 - >>= \case - TIMEOUT -> sayErr "Timed out waiting for semaphore" - SUCCESS -> sayErr "Waited for semaphore" - e -> do - sayErrShow e - liftIO $ throwIO (VulkanException e) - - deviceWaitIdle dev - ----------------------------------------------------------------- --- Vulkan utils ----------------------------------------------------------------- - -createInstance :: MonadResource m => m Instance -createInstance = Init.withInstance - (Just zero { applicationName = Nothing, apiVersion = API_VERSION_1_0 }) - [ RequireInstanceExtension - Nothing - KHR_GET_PHYSICAL_DEVICE_PROPERTIES_2_EXTENSION_NAME - minBound - ] - [] - -createDevice - :: forall m - . (MonadResource m) - => Instance - -> m (PhysicalDevice, Device, MyQueues Queue) -createDevice inst = do - (pdi, phys) <- - maybe (noSuchThing "Unable to find appropriate PhysicalDevice") pure - =<< pickPhysicalDevice inst physicalDeviceInfo pdiScore - sayErr . ("Using device: " <>) =<< physicalDeviceName phys - let deviceCreateInfo = - zero { queueCreateInfos = SomeStruct <$> pdiQueueCreateInfos pdi } - reqs = [U.reqs| - 1.0 - VK_KHR_timeline_semaphore - PhysicalDeviceTimelineSemaphoreFeatures.timelineSemaphore - PhysicalDeviceTimelineSemaphoreProperties.maxTimelineSemaphoreValueDifference >= 1 - |] - dev <- createDeviceFromRequirements reqs [] phys deviceCreateInfo - queues <- liftIO $ pdiGetQueues pdi dev - pure (phys, dev, queues) - -withTimelineSemaphore - :: MonadResource m - => Device - -> Word64 - -- ^ Initial value - -> m Semaphore -withTimelineSemaphore dev i = do - let ci = zero ::& SemaphoreTypeCreateInfo SEMAPHORE_TYPE_TIMELINE i :& () - (_, sem) <- withSemaphore dev ci Nothing allocate - pure sem - ----------------------------------------------------------------- --- Physical device tools ----------------------------------------------------------------- - --- | The Ord instance prioritises devices with more memory -data PhysicalDeviceInfo = PhysicalDeviceInfo - { pdiTotalMemory :: Word64 - , pdiQueueCreateInfos :: Vector (DeviceQueueCreateInfo '[]) - , pdiGetQueues :: Device -> IO (MyQueues Queue) - } - -pdiScore :: PhysicalDeviceInfo -> Word64 -pdiScore = pdiTotalMemory - -newtype MyQueues a = MyQueues { _myComputeQueue :: a } - deriving (Functor, Foldable, Traversable) - -physicalDeviceInfo - :: MonadIO m => PhysicalDevice -> m (Maybe PhysicalDeviceInfo) -physicalDeviceInfo phys = runMaybeT $ do - _ ::& (PhysicalDeviceTimelineSemaphoreFeatures hasTimelineSemaphores :& ()) <- - getPhysicalDeviceFeatures2KHR phys - unless hasTimelineSemaphores $ do - deviceName <- physicalDeviceName phys - sayErr - $ "Not using physical device " - <> deviceName - <> " because it doesn't support timeline semaphores" - empty - pdiTotalMemory <- do - heaps <- memoryHeaps <$> getPhysicalDeviceMemoryProperties phys - pure $ sum (DI.size <$> heaps) - (pdiQueueCreateInfos, getQueues) <- MaybeT $ assignQueues - phys - (MyQueues (QueueSpec 1 (const (pure . isComputeQueueFamily)))) - let pdiGetQueues = fmap (fmap snd) <$> getQueues - pure PhysicalDeviceInfo { .. } - ----------------------------------------------------------------- --- Utils ----------------------------------------------------------------- - -noSuchThing :: MonadIO m => String -> m a -noSuchThing message = - liftIO . throwIO $ IOError Nothing NoSuchThing "" message Nothing Nothing - -traceException :: MonadUnliftIO m => m a -> m a -traceException m = - m - `catch` (\(e :: SomeException) -> - sayErrString (displayException e) >> liftIO (throwIO e) - ) diff --git a/examples/triangle-glfw/Main.hs b/examples/triangle-glfw/Main.hs index 7c1ecf73b..f488d23e4 100644 --- a/examples/triangle-glfw/Main.hs +++ b/examples/triangle-glfw/Main.hs @@ -3,240 +3,116 @@ module Main where -import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Trans.Maybe -import Control.Monad.Trans.Resource -import qualified Data.Text as Text -import Data.String (IsString) -import Data.Text.Encoding -import Data.Traversable -import Data.Functor.Identity (Identity (..)) -import qualified Data.Vector as V -import Data.Word -import qualified Graphics.UI.GLFW as GLFW -import Say -import System.Exit -import Vulkan.CStruct.Extends -import Vulkan.Core10 -import qualified Vulkan.Core10.DeviceInitialization as DI -import Vulkan.Extensions.VK_KHR_surface -import qualified Vulkan.Extensions.VK_KHR_surface as SF -import Vulkan.Extensions.VK_KHR_swapchain -import qualified Vulkan.Extensions.VK_KHR_swapchain as SW -import Vulkan.Requirement (DeviceRequirement (..)) -import qualified Vulkan.Utils.Init.GLFW as Init -import Vulkan.Utils.Initialization (createDeviceFromRequirements, pickPhysicalDevice) -import Vulkan.Utils.QueueAssignment - ( QueueFamilyIndex (..) - , QueueSpec (..) - , assignQueues - , isGraphicsQueueFamily - , isPresentQueueFamily - ) -import Vulkan.Zero +import Control.Monad.IO.Class +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Resource +import qualified Data.Text as Text +import Data.Functor.Identity ( Identity(..) ) +import Data.String ( IsString ) +import Data.Word ( Word32 ) +import Data.Text.Encoding ( decodeUtf8 ) +import qualified Data.Vector as V +import qualified Graphics.UI.GLFW as GLFW +import Say import qualified Triangle -import Window ( VulkanWindow(..) ) +import qualified Vma +import VkResources ( Queues(..) + , mkVkResources + ) +import Vulkan.CStruct.Extends +import Vulkan.Core10 +import qualified Vulkan.Core10.DeviceInitialization as DI +import Vulkan.Extensions.VK_KHR_surface +import Vulkan.Requirement ( DeviceRequirement(..) ) +import qualified Vulkan.Utils.Init.GLFW as Init +import Vulkan.Utils.Initialization ( createDeviceFromRequirements + , pickPhysicalDevice + ) +import Vulkan.Utils.QueueAssignment ( QueueFamilyIndex(..) + , QueueSpec(..) + , assignQueues + , isGraphicsQueueFamily + , isPresentQueueFamily + ) +import Vulkan.Zero +import Frame ( frameDeviceRequirements + , frameInstanceRequirements + ) +import Swapchain ( allocSwapchain ) import qualified Window.GLFW as Window main :: IO () main = runResourceT $ do Window.withGLFW - vw <- withVulkanWindow windowWidth windowHeight - liftIO $ Window.showWindow (vwWindow vw) - Triangle.runTriangle vw (Window.shouldQuit (vwWindow vw)) - -withVulkanWindow :: Int -> Int -> ResourceT IO (VulkanWindow GLFW.Window) -withVulkanWindow width height = do - window <- Window.createWindow (Text.pack appName) width height - inst <- Init.withInstance + window <- Window.createWindow (Text.pack appName) windowWidth windowHeight + inst <- Init.withInstance window - (Just zero{applicationName = Just appName, apiVersion = API_VERSION_1_0}) + (Just zero { applicationName = Just appName, apiVersion = API_VERSION_1_0 }) + frameInstanceRequirements [] - [] - surface <- Init.withSurface inst window - (dev, graphicsQueue, graphicsQueueFamilyIndex, presentQueue, swapchainFormat, swapchainExtent, swapchain) <- - createGraphicalDevice inst surface width height - (_, images) <- getSwapchainImagesKHR dev swapchain - let imageViewCreateInfo i = - zero - { image = i - , viewType = IMAGE_VIEW_TYPE_2D - , format = swapchainFormat - , components = - zero - { r = COMPONENT_SWIZZLE_IDENTITY - , g = COMPONENT_SWIZZLE_IDENTITY - , b = COMPONENT_SWIZZLE_IDENTITY - , a = COMPONENT_SWIZZLE_IDENTITY - } - , subresourceRange = - zero - { aspectMask = IMAGE_ASPECT_COLOR_BIT - , baseMipLevel = 0 - , levelCount = 1 - , baseArrayLayer = 0 - , layerCount = 1 - } - } - imageViews <- for images $ \i -> - snd <$> withImageView dev (imageViewCreateInfo i) Nothing allocate - pure $ VulkanWindow - window dev surface swapchain swapchainExtent swapchainFormat imageViews - graphicsQueue graphicsQueueFamilyIndex presentQueue + surface <- Init.withSurface inst window + (phys, dev, qfi, gQueue) <- createGraphicalDevice inst surface + vma <- Vma.createVMA zero API_VERSION_1_0 inst phys dev + props <- getPhysicalDeviceProperties phys + sayErr $ "Using device: " <> decodeUtf8 (deviceName props) -appName :: (IsString a) => a + let qs = Queues (QueueFamilyIndex qfi, gQueue) + vr <- liftIO $ mkVkResources inst phys dev vma qs + + initialSize <- liftIO $ drawableSize window + initialSC <- allocSwapchain vr NULL_HANDLE initialSize surface + + liftIO $ Window.showWindow window + Triangle.runTriangle vr initialSC (drawableSize window) (Window.shouldQuit window) + +appName :: IsString a => a appName = "Haskell Vulkan triangle example (GLFW)" windowWidth, windowHeight :: Int windowWidth = 800 windowHeight = 600 -createGraphicalDevice - :: Instance - -> SurfaceKHR - -> Int - -> Int - -> ResourceT IO (Device, Queue, Word32, Queue, Format, Extent2D, SwapchainKHR) -createGraphicalDevice inst surface width height = do - let desiredFormat = - SurfaceFormatKHR FORMAT_B8G8R8_UNORM COLOR_SPACE_SRGB_NONLINEAR_KHR - (physicalDevice, graphicsQueueFamilyIndex, presentQueueFamilyIndex, surfaceFormat, presentMode, surfaceCaps, graphicsQueue, presentQueue, dev) <- - pickGraphicalPhysicalDevice inst surface desiredFormat - props <- getPhysicalDeviceProperties physicalDevice - sayErr $ "Using device: " <> decodeUtf8 (deviceName props) - let - swapchainCreateInfo :: SwapchainCreateInfoKHR '[] - swapchainCreateInfo = - let (sharingMode, queueFamilyIndices) = - if graphicsQueue == presentQueue - then (SHARING_MODE_EXCLUSIVE, []) - else - ( SHARING_MODE_CONCURRENT - , [graphicsQueueFamilyIndex, presentQueueFamilyIndex] - ) - in zero - { surface = surface - , minImageCount = SF.minImageCount surfaceCaps + 1 - , imageFormat = SF.format surfaceFormat - , imageColorSpace = SF.colorSpace surfaceFormat - , imageExtent = case currentExtent (surfaceCaps :: SurfaceCapabilitiesKHR) of - Extent2D w h - | w == maxBound, h == maxBound -> - Extent2D (fromIntegral width) (fromIntegral height) - e -> e - , imageArrayLayers = 1 - , imageUsage = IMAGE_USAGE_COLOR_ATTACHMENT_BIT - , imageSharingMode = sharingMode - , queueFamilyIndices = queueFamilyIndices - , preTransform = currentTransform (surfaceCaps :: SurfaceCapabilitiesKHR) - , compositeAlpha = COMPOSITE_ALPHA_OPAQUE_BIT_KHR - , presentMode = presentMode - , clipped = True - } - swapchain <- snd <$> withSwapchainKHR dev swapchainCreateInfo Nothing allocate - pure - ( dev - , graphicsQueue - , graphicsQueueFamilyIndex - , presentQueue - , SF.format surfaceFormat - , SW.imageExtent swapchainCreateInfo - , swapchain - ) +drawableSize :: GLFW.Window -> IO Extent2D +drawableSize win = do + (w, h) <- GLFW.getFramebufferSize win + pure $ Extent2D (fromIntegral w) (fromIntegral h) + +---------------------------------------------------------------- +-- Pick a device with a unified graphics+present queue. +---------------------------------------------------------------- -pickGraphicalPhysicalDevice - :: Instance +createGraphicalDevice + :: (MonadResource m, MonadFail m) + => Instance -> SurfaceKHR - -> SurfaceFormatKHR - -> ResourceT - IO - ( PhysicalDevice - , Word32 - , Word32 - , SurfaceFormatKHR - , PresentModeKHR - , SurfaceCapabilitiesKHR - , Queue - , Queue - , Device - ) -pickGraphicalPhysicalDevice inst surface desiredFormat = do + -> m (PhysicalDevice, Device, Word32, Queue) +createGraphicalDevice inst surface = do mPd <- pickPhysicalDevice inst suitable id - (_, phys) <- case mPd of - Just x -> pure x - Nothing -> sayErr "No suitable devices found" >> liftIO exitFailure - bestFormat <- getFormat phys - presentMode <- getPresentMode phys - surfaceCaps <- getPhysicalDeviceSurfaceCapabilitiesKHR phys surface + (_, phys) <- maybe (sayErr "No suitable devices found" >> error "no GPU") pure mPd + let queueSpec = QueueSpec 1 $ \i q -> if isGraphicsQueueFamily q then isPresentQueueFamily phys surface i else pure False Just (qInfos, getQs) <- assignQueues phys (Identity queueSpec) + let deviceReqs = [ RequireDeviceExtension Nothing e minBound | e <- Init.getRequiredDeviceExtensions - ] + ] ++ frameDeviceRequirements dev <- createDeviceFromRequirements deviceReqs [] phys - zero{queueCreateInfos = SomeStruct <$> qInfos} + zero { queueCreateInfos = SomeStruct <$> qInfos } Identity (QueueFamilyIndex familyIdx, queue) <- liftIO (getQs dev) - pure - ( phys - , familyIdx - , familyIdx - , bestFormat - , presentMode - , surfaceCaps - , queue - , queue - , dev - ) + pure (phys, dev, familyIdx, queue) where - suitable :: PhysicalDevice -> ResourceT IO (Maybe Word64) suitable phys = runMaybeT $ do (_, exts) <- enumerateDeviceExtensionProperties phys Nothing - guard (V.any ((KHR_SWAPCHAIN_EXTENSION_NAME ==) . extensionName) exts) + True <- pure $ V.any ((Init.getRequiredDeviceExtensions !! 0 ==) . extensionName) exts qProps <- getPhysicalDeviceQueueFamilyProperties phys - guard (V.any isGraphicsQueueFamily qProps) + True <- pure $ V.any isGraphicsQueueFamily qProps let presentSupport i = isPresentQueueFamily phys surface (QueueFamilyIndex (fromIntegral i)) hasPresent <- V.or <$> V.imapM (\i _ -> presentSupport i) qProps - guard hasPresent + True <- pure hasPresent heaps <- memoryHeaps <$> getPhysicalDeviceMemoryProperties phys pure (sum $ DI.size <$> heaps) - - headMay = \case - [] -> Nothing - xs -> Just (V.unsafeHead xs) - - getFormat :: (MonadIO m) => PhysicalDevice -> m SurfaceFormatKHR - getFormat dev = do - (_, formats) <- getPhysicalDeviceSurfaceFormatsKHR dev surface - pure $ case formats of - [] -> desiredFormat - [SurfaceFormatKHR FORMAT_UNDEFINED _] -> desiredFormat - _ - | V.any - ( \f -> - SF.format f == SF.format desiredFormat - && SF.colorSpace f == SF.colorSpace desiredFormat - ) - formats -> - desiredFormat - _ -> V.head formats - - getPresentMode :: (MonadIO m) => PhysicalDevice -> m PresentModeKHR - getPresentMode dev = do - (_, presentModes) <- getPhysicalDeviceSurfacePresentModesKHR dev surface - let desiredPresentModes = - [ PRESENT_MODE_MAILBOX_KHR - , PRESENT_MODE_FIFO_KHR - , PRESENT_MODE_IMMEDIATE_KHR - ] - match = V.filter (`V.elem` presentModes) desiredPresentModes - pure $ case headMay match of - Just m -> m - Nothing -> case presentModes V.!? 0 of - Just m -> m - Nothing -> PRESENT_MODE_FIFO_KHR diff --git a/examples/triangle-headless/Main.hs b/examples/triangle-headless/Main.hs index b67cf9c0b..be41de5a0 100644 --- a/examples/triangle-headless/Main.hs +++ b/examples/triangle-headless/Main.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedLists #-} @@ -10,19 +9,17 @@ module Main ) where -import AutoApply import qualified Codec.Picture as JP import qualified Codec.Picture.Types as JP import Control.Exception.Safe import Control.Monad.IO.Class -import Control.Monad.Trans.Reader import Control.Monad.Trans.Resource import Data.Bits import qualified Data.ByteString.Lazy as BSL import Data.Functor.Identity ( Identity(..) ) import qualified Data.Vector as V import Data.Word -import Foreign.Ptr +import Foreign.Ptr ( Ptr, plusPtr ) import Foreign.Storable ( peek , sizeOf ) @@ -30,28 +27,21 @@ import Say #if defined(RENDERDOC) import Control.Monad ( when ) +import Foreign.Ptr ( nullPtr ) import qualified Data.Map.Strict as Map import qualified Language.C.Inline as C import qualified Language.C.Inline.Context as C import qualified Language.C.Types as C #endif +import qualified Vma import Vulkan.CStruct.Extends import Vulkan.Core10 as Vk hiding ( withImage ) import qualified Vulkan.Core10 as CommandBufferBeginInfo (CommandBufferBeginInfo(..)) -import qualified Vulkan.Core10 as CommandPoolCreateInfo (CommandPoolCreateInfo(..)) +import qualified Vulkan.Core10 as CommandPoolCreateInfo (CommandPoolCreateInfo(..)) import qualified Vulkan.Core10.DeviceInitialization as DI import qualified Vulkan.Core10.Image as SL -import Vulkan.Dynamic ( DeviceCmds - ( DeviceCmds - , pVkGetDeviceProcAddr - ) - , InstanceCmds - ( InstanceCmds - , pVkGetInstanceProcAddr - ) - ) import Vulkan.Extensions.VK_EXT_debug_utils import Vulkan.Requirement ( InstanceRequirement(..) ) import Vulkan.Utils.Debug ( debugCallbackPtr @@ -88,120 +78,15 @@ C.include "" C.include "" #endif ----------------------------------------------------------------- --- Define the monad in which most of the program will run ----------------------------------------------------------------- - --- | @V@ keeps track of a bunch of "global" handles and performs resource --- management. -newtype V a = V { unV :: ReaderT GlobalHandles (ResourceT IO) a } - deriving newtype ( Functor - , Applicative - , Monad - , MonadFail - , MonadThrow - , MonadCatch - , MonadMask - , MonadIO - , MonadResource - ) - -runV - :: Instance - -> PhysicalDevice - -> Word32 - -> Device - -> Allocator - -> V a - -> ResourceT IO a -runV ghInstance ghPhysicalDevice ghGraphicsQueueFamilyIndex ghDevice ghAllocator - = flip runReaderT GlobalHandles { .. } . unV - -data GlobalHandles = GlobalHandles - { ghInstance :: Instance - , ghPhysicalDevice :: PhysicalDevice - , ghDevice :: Device - , ghAllocator :: Allocator - , ghGraphicsQueueFamilyIndex :: Word32 - } - --- Getters for global handles - -getInstance :: V Instance -getInstance = V (asks ghInstance) - -getGraphicsQueueFamilyIndex :: V Word32 -getGraphicsQueueFamilyIndex = V (asks ghGraphicsQueueFamilyIndex) - -getPhysicalDevice :: V PhysicalDevice -getPhysicalDevice = V (asks ghPhysicalDevice) - -getDevice :: V Device -getDevice = V (asks ghDevice) - -getAllocator :: V Allocator -getAllocator = V (asks ghAllocator) - -noAllocationCallbacks :: Maybe AllocationCallbacks -noAllocationCallbacks = Nothing - --- --- Wrap a bunch of Vulkan commands so that they automatically pull global --- handles from 'V' --- --- Wrapped functions are suffixed with "'" --- -autoapplyDecs - (<> "'") - [ 'getDevice - , 'getPhysicalDevice - , 'getInstance - , 'getAllocator - , 'noAllocationCallbacks - ] - ['allocate] - [ 'invalidateAllocation - , 'withImage - , 'deviceWaitIdle - , 'getDeviceQueue - , 'getImageSubresourceLayout - , 'waitForFences - , 'withCommandBuffers - , 'withCommandPool - , 'withFence - , 'withFramebuffer - , 'withGraphicsPipelines - , 'withImageView - , 'withPipelineLayout - , 'withRenderPass - , 'withShaderModule - , 'nameObject - ] - ---------------------------------------------------------------- -- The program ---------------------------------------------------------------- main :: IO () main = runResourceT $ do - -- Create Instance, PhysicalDevice, Device and Allocator - inst <- Main.createInstance - (phys, pdi, dev) <- Main.createDevice inst - (_, allocator) <- withAllocator - zero - { flags = zero - , physicalDevice = physicalDeviceHandle phys - , device = deviceHandle dev - , instance' = instanceHandle inst - , vulkanApiVersion = myApiVersion - , vulkanFunctions = Just $ case inst of - Instance _ InstanceCmds {..} -> case dev of - Device _ DeviceCmds {..} -> zero - { vkGetInstanceProcAddr = castFunPtr pVkGetInstanceProcAddr - , vkGetDeviceProcAddr = castFunPtr pVkGetDeviceProcAddr - } - } - allocate + inst <- Main.createInstance + (phys, graphicsQueueFamilyIndex, dev) <- Main.createDevice inst + allocator <- Vma.createVMA zero myApiVersion inst phys dev #if defined(RENDERDOC) -- We need to mark the beginning and end of the capture explicitly as this @@ -224,18 +109,15 @@ main = runResourceT $ do sayErr "Running under RenderDoc" let rdBegin = liftIO [C.exp| void { if($(RENDERDOC_API_1_1_2* rdoc_api)) $(RENDERDOC_API_1_1_2* rdoc_api)->StartFrameCapture(NULL, NULL); } |] - rdEnd = liftIO [C.exp| void { if($(RENDERDOC_API_1_1_2* rdoc_api)) $(RENDERDOC_API_1_1_2* rdoc_api)->EndFrameCapture(NULL, NULL); } |] + rdEnd = liftIO [C.exp| void { if($(RENDERDOC_API_1_1_2* rdoc_api)) $(RENDERDOC_API_1_1_2* rdoc_api)->EndFrameCapture(NULL, NULL); } |] _ <- allocate rdBegin (const rdEnd) #endif - -- Run our application - runV inst phys (pdiGraphicsQueueFamilyIndex pdi) dev allocator - . (`finally` deviceWaitIdle') - $ do - image <- render - let filename = "triangle.png" - sayErr $ "Writing " <> filename - liftIO $ BSL.writeFile filename (JP.encodePng image) + image <- render allocator dev graphicsQueueFamilyIndex + `finally` deviceWaitIdle dev + let filename = "triangle.png" + sayErr $ "Writing " <> filename + liftIO $ BSL.writeFile filename (JP.encodePng image) -- | This function renders a triangle and reads the image on the CPU -- @@ -255,52 +137,61 @@ main = runResourceT $ do -- - Submits and waits for the command buffer to finish executing -- - Invalidates the CPU image allocation (if it isn't HOST_COHERENT) -- - Copies the data from the CPU image and returns it -render :: V (JP.Image JP.PixelRGBA8) -render = do - -- Some things to reuse +render + :: Allocator + -> Device + -> Word32 + -> ResourceT IO (JP.Image JP.PixelRGBA8) +render allocator dev graphicsQueueFamilyIndex = do let imageFormat = FORMAT_R8G8B8A8_UNORM width = 256 height = 256 -- Create an image to be our render target - let - imageCreateInfo = zero - { imageType = IMAGE_TYPE_2D - , format = imageFormat - , extent = Extent3D width height 1 - , mipLevels = 1 - , arrayLayers = 1 - , samples = SAMPLE_COUNT_1_BIT - , tiling = IMAGE_TILING_OPTIMAL - , usage = IMAGE_USAGE_COLOR_ATTACHMENT_BIT - .|. IMAGE_USAGE_TRANSFER_SRC_BIT - , initialLayout = IMAGE_LAYOUT_UNDEFINED - } - allocationCreateInfo = zero { AllocationCreateInfo.flags = ALLOCATION_CREATE_MAPPED_BIT - , usage = MEMORY_USAGE_GPU_ONLY - } - -- Allocate the image with VMA - (_, (image, _, _)) <- withImage' imageCreateInfo allocationCreateInfo - nameObject' image "GPU side image" + let imageCreateInfo = zero + { imageType = IMAGE_TYPE_2D + , format = imageFormat + , extent = Extent3D width height 1 + , mipLevels = 1 + , arrayLayers = 1 + , samples = SAMPLE_COUNT_1_BIT + , tiling = IMAGE_TILING_OPTIMAL + , usage = IMAGE_USAGE_COLOR_ATTACHMENT_BIT + .|. IMAGE_USAGE_TRANSFER_SRC_BIT + , initialLayout = IMAGE_LAYOUT_UNDEFINED + } + allocationCreateInfo = zero + { AllocationCreateInfo.flags = ALLOCATION_CREATE_MAPPED_BIT + , usage = MEMORY_USAGE_GPU_ONLY + } + (_, (image, _, _)) <- VMA.withImage allocator + imageCreateInfo + allocationCreateInfo + allocate + nameObject dev image "GPU side image" -- Create an image to read on the CPU - let cpuImageCreateInfo = zero { imageType = IMAGE_TYPE_2D - , format = imageFormat - , extent = Extent3D width height 1 - , mipLevels = 1 - , arrayLayers = 1 - , samples = SAMPLE_COUNT_1_BIT - , tiling = IMAGE_TILING_LINEAR - , usage = IMAGE_USAGE_TRANSFER_DST_BIT - , initialLayout = IMAGE_LAYOUT_UNDEFINED - } - cpuAllocationCreateInfo = zero { AllocationCreateInfo.flags = ALLOCATION_CREATE_MAPPED_BIT - , usage = MEMORY_USAGE_GPU_TO_CPU - } - (_, (cpuImage, cpuImageAllocation, cpuImageAllocationInfo)) <- withImage' + let cpuImageCreateInfo = zero + { imageType = IMAGE_TYPE_2D + , format = imageFormat + , extent = Extent3D width height 1 + , mipLevels = 1 + , arrayLayers = 1 + , samples = SAMPLE_COUNT_1_BIT + , tiling = IMAGE_TILING_LINEAR + , usage = IMAGE_USAGE_TRANSFER_DST_BIT + , initialLayout = IMAGE_LAYOUT_UNDEFINED + } + cpuAllocationCreateInfo = zero + { AllocationCreateInfo.flags = ALLOCATION_CREATE_MAPPED_BIT + , usage = MEMORY_USAGE_GPU_TO_CPU + } + (_, (cpuImage, cpuImageAllocation, cpuImageAllocationInfo)) <- VMA.withImage + allocator cpuImageCreateInfo cpuAllocationCreateInfo - nameObject' cpuImage "CPU side image" + allocate + nameObject dev cpuImage "CPU side image" -- Create an image view let imageSubresourceRange = ImageSubresourceRange @@ -320,7 +211,7 @@ render = do COMPONENT_SWIZZLE_IDENTITY , subresourceRange = imageSubresourceRange } - (_, imageView) <- withImageView' imageViewCreateInfo + (_, imageView) <- withImageView dev imageViewCreateInfo Nothing allocate -- Create a renderpass with a single subpass let @@ -354,11 +245,14 @@ render = do , dstAccessMask = ACCESS_COLOR_ATTACHMENT_READ_BIT .|. ACCESS_COLOR_ATTACHMENT_WRITE_BIT } - (_, renderPass) <- withRenderPass' zero - { attachments = [attachmentDescription] - , subpasses = [subpass] - , dependencies = [subpassDependency] - } + (_, renderPass) <- withRenderPass + dev + zero { attachments = [attachmentDescription] + , subpasses = [subpass] + , dependencies = [subpassDependency] + } + Nothing + allocate -- Create a framebuffer let framebufferCreateInfo :: FramebufferCreateInfo '[] @@ -368,34 +262,35 @@ render = do , height = height , layers = 1 } - (_, framebuffer) <- withFramebuffer' framebufferCreateInfo + (_, framebuffer) <- withFramebuffer dev framebufferCreateInfo Nothing allocate -- Create the most vanilla rendering pipeline - shaderStages <- createShaders - (_, pipelineLayout) <- withPipelineLayout' zero + shaderStages <- createShaders dev + (_, pipelineLayout) <- withPipelineLayout dev zero Nothing allocate let pipelineCreateInfo :: GraphicsPipelineCreateInfo '[] pipelineCreateInfo = zero { stages = shaderStages , vertexInputState = Just zero , inputAssemblyState = Just zero - { topology = PRIMITIVE_TOPOLOGY_TRIANGLE_LIST + { topology = PRIMITIVE_TOPOLOGY_TRIANGLE_LIST , primitiveRestartEnable = False } , viewportState = Just . SomeStruct $ zero - { viewports = - [ Viewport { x = 0 - , y = 0 - , width = realToFrac (width :: Word32) - , height = realToFrac (height :: Word32) - , minDepth = 0 - , maxDepth = 1 - } - ] - , scissors = [ Rect2D { offset = Offset2D 0 0 - , extent = Extent2D width height - } - ] + { viewports = [ Viewport + { x = 0 + , y = 0 + , width = realToFrac (width :: Word32) + , height = realToFrac (height :: Word32) + , minDepth = 0 + , maxDepth = 1 + } + ] + , scissors = [ Rect2D + { offset = Offset2D 0 0 + , extent = Extent2D width height + } + ] } , rasterizationState = Just . SomeStruct $ zero { depthClampEnable = False @@ -417,10 +312,10 @@ render = do { logicOpEnable = False , attachments = [ zero { colorWriteMask = - COLOR_COMPONENT_R_BIT - .|. COLOR_COMPONENT_G_BIT - .|. COLOR_COMPONENT_B_BIT - .|. COLOR_COMPONENT_A_BIT + COLOR_COMPONENT_R_BIT + .|. COLOR_COMPONENT_G_BIT + .|. COLOR_COMPONENT_B_BIT + .|. COLOR_COMPONENT_A_BIT , blendEnable = False } ] @@ -431,27 +326,33 @@ render = do , subpass = 0 , basePipelineHandle = zero } - (_, (_, [graphicsPipeline])) <- withGraphicsPipelines' + (_, (_, [graphicsPipeline])) <- withGraphicsPipelines + dev zero [SomeStruct pipelineCreateInfo] + Nothing + allocate -- Create a command buffer - graphicsQueueFamilyIndex <- getGraphicsQueueFamilyIndex - let commandPoolCreateInfo = zero { CommandPoolCreateInfo.queueFamilyIndex = graphicsQueueFamilyIndex } - (_, commandPool) <- withCommandPool' commandPoolCreateInfo - let commandBufferAllocateInfo = zero { commandPool = commandPool - , level = COMMAND_BUFFER_LEVEL_PRIMARY - , commandBufferCount = 1 - } - (_, [commandBuffer]) <- withCommandBuffers' commandBufferAllocateInfo + let commandPoolCreateInfo = zero + { CommandPoolCreateInfo.queueFamilyIndex = graphicsQueueFamilyIndex + } + (_, commandPool) <- withCommandPool dev commandPoolCreateInfo Nothing allocate + let commandBufferAllocateInfo = zero + { commandPool = commandPool + , level = COMMAND_BUFFER_LEVEL_PRIMARY + , commandBufferCount = 1 + } + (_, [commandBuffer]) <- withCommandBuffers dev commandBufferAllocateInfo allocate -- Fill command buffer -- -- - Execute the renderpass -- - Transition the images to be able to perform the copy -- - Copy the image to CPU mapped memory - useCommandBuffer commandBuffer - zero { CommandBufferBeginInfo.flags = COMMAND_BUFFER_USAGE_ONE_TIME_SUBMIT_BIT } + useCommandBuffer + commandBuffer + zero { CommandBufferBeginInfo.flags = COMMAND_BUFFER_USAGE_ONE_TIME_SUBMIT_BIT } $ do let renderPassBeginInfo = zero { renderPass = renderPass @@ -476,11 +377,11 @@ render = do zero [] [] - [ SomeStruct zero { srcAccessMask = ACCESS_COLOR_ATTACHMENT_WRITE_BIT - , dstAccessMask = ACCESS_TRANSFER_READ_BIT - , oldLayout = IMAGE_LAYOUT_COLOR_ATTACHMENT_OPTIMAL - , newLayout = IMAGE_LAYOUT_TRANSFER_SRC_OPTIMAL - , image = image + [ SomeStruct zero { srcAccessMask = ACCESS_COLOR_ATTACHMENT_WRITE_BIT + , dstAccessMask = ACCESS_TRANSFER_READ_BIT + , oldLayout = IMAGE_LAYOUT_COLOR_ATTACHMENT_OPTIMAL + , newLayout = IMAGE_LAYOUT_TRANSFER_SRC_OPTIMAL + , image = image , subresourceRange = imageSubresourceRange } ] @@ -496,7 +397,7 @@ render = do [ SomeStruct zero { srcAccessMask = zero , dstAccessMask = ACCESS_TRANSFER_WRITE_BIT , oldLayout = IMAGE_LAYOUT_UNDEFINED - , newLayout = IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL + , newLayout = IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL , image = cpuImage , subresourceRange = imageSubresourceRange } @@ -538,7 +439,7 @@ render = do [] [ SomeStruct zero { srcAccessMask = ACCESS_TRANSFER_WRITE_BIT , dstAccessMask = ACCESS_HOST_READ_BIT - , oldLayout = IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL + , oldLayout = IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL , newLayout = IMAGE_LAYOUT_GENERAL , image = cpuImage , subresourceRange = imageSubresourceRange @@ -546,7 +447,7 @@ render = do ] -- Create a fence so we can know when render is finished - (_, fence) <- withFence' zero + (_, fence) <- withFence dev zero Nothing allocate -- Submit the command buffer and wait for it to execute let submitInfo = zero { waitSemaphores = [] @@ -554,19 +455,20 @@ render = do , commandBuffers = [commandBufferHandle commandBuffer] , signalSemaphores = [] } - graphicsQueue <- getDeviceQueue' graphicsQueueFamilyIndex 0 + graphicsQueue <- getDeviceQueue dev graphicsQueueFamilyIndex 0 queueSubmit graphicsQueue [SomeStruct submitInfo] fence let fenceTimeout = 1e9 -- 1 second - waitForFences' [fence] True fenceTimeout >>= \case + waitForFences dev [fence] True fenceTimeout >>= \case TIMEOUT -> throwString "Timed out waiting for image render and copy" _ -> pure () -- If the cpu image allocation is not HOST_COHERENT this will ensure the -- changes are present on the CPU. - invalidateAllocation' cpuImageAllocation 0 WHOLE_SIZE + invalidateAllocation allocator cpuImageAllocation 0 WHOLE_SIZE -- Find the image layout and read it into a JuicyPixels Image - cpuImageLayout <- getImageSubresourceLayout' + cpuImageLayout <- getImageSubresourceLayout + dev cpuImage ImageSubresource { aspectMask = IMAGE_ASPECT_COLOR_BIT , mipLevel = 0 @@ -586,8 +488,10 @@ render = do (\x y -> JP.unpackPixel @JP.PixelRGBA8 <$> peek (pixelAddr x y)) -- | Create a vertex and fragment shader which render a colored triangle -createShaders :: V (V.Vector (SomeStruct PipelineShaderStageCreateInfo)) -createShaders = do +createShaders + :: Device + -> ResourceT IO (V.Vector (SomeStruct PipelineShaderStageCreateInfo)) +createShaders dev = do let fragCode = [frag| #version 450 #extension GL_ARB_separate_shader_objects : enable @@ -622,8 +526,8 @@ createShaders = do fragColor = colors[gl_VertexIndex]; } |] - (_, fragModule) <- withShaderModule' zero { code = fragCode } - (_, vertModule) <- withShaderModule' zero { code = vertCode } + (_, fragModule) <- withShaderModule dev zero { code = fragCode } Nothing allocate + (_, vertModule) <- withShaderModule dev zero { code = vertCode } Nothing allocate let vertShaderStageCreateInfo = zero { stage = SHADER_STAGE_VERTEX_BIT , module' = vertModule , name = "main" @@ -663,8 +567,8 @@ createInstance = do { messageSeverity = DEBUG_UTILS_MESSAGE_SEVERITY_WARNING_BIT_EXT .|. DEBUG_UTILS_MESSAGE_SEVERITY_ERROR_BIT_EXT , messageType = DEBUG_UTILS_MESSAGE_TYPE_GENERAL_BIT_EXT - .|. DEBUG_UTILS_MESSAGE_TYPE_VALIDATION_BIT_EXT - .|. DEBUG_UTILS_MESSAGE_TYPE_PERFORMANCE_BIT_EXT + .|. DEBUG_UTILS_MESSAGE_TYPE_VALIDATION_BIT_EXT + .|. DEBUG_UTILS_MESSAGE_TYPE_PERFORMANCE_BIT_EXT , pfnUserCallback = debugCallbackPtr } _ <- withDebugUtilsMessengerEXT inst debugMessengerCreateInfo Nothing allocate @@ -673,9 +577,9 @@ createInstance = do createDevice :: (MonadResource m, MonadThrow m) => Instance - -> m (PhysicalDevice, PhysicalDeviceInfo, Device) + -> m (PhysicalDevice, Word32, Device) createDevice inst = do - mPd <- pickPhysicalDevice inst hasGraphicsQueue id + mPd <- pickPhysicalDevice inst hasGraphicsQueue id (_, phys) <- maybe (throwString "Unable to find appropriate PhysicalDevice") pure mPd @@ -693,7 +597,7 @@ createDevice inst = do phys zero { queueCreateInfos = SomeStruct <$> qInfos } Identity (QueueFamilyIndex graphicsFamilyIdx, _q) <- liftIO (getQs dev) - pure (phys, PhysicalDeviceInfo graphicsFamilyIdx, dev) + pure (phys, graphicsFamilyIdx, dev) where hasGraphicsQueue :: MonadIO m => PhysicalDevice -> m (Maybe Word64) hasGraphicsQueue phys = do @@ -703,8 +607,3 @@ createDevice inst = do heaps <- memoryHeaps <$> getPhysicalDeviceMemoryProperties phys pure (Just (sum (DI.size <$> heaps))) else pure Nothing - -newtype PhysicalDeviceInfo = PhysicalDeviceInfo - { pdiGraphicsQueueFamilyIndex :: Word32 - } - deriving (Eq, Ord) diff --git a/examples/triangle-sdl2/Main.hs b/examples/triangle-sdl2/Main.hs index 4364b30ae..5fc875150 100644 --- a/examples/triangle-sdl2/Main.hs +++ b/examples/triangle-sdl2/Main.hs @@ -3,244 +3,117 @@ module Main where -import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Trans.Maybe -import Control.Monad.Trans.Resource -import Data.String (IsString) -import Data.Text.Encoding -import Data.Traversable -import Data.Functor.Identity (Identity (..)) -import qualified Data.Vector as V -import Data.Word +import Control.Monad.IO.Class +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Resource +import Data.Functor.Identity ( Identity(..) ) +import Data.String ( IsString ) +import Data.Word ( Word32 ) +import Data.Text.Encoding ( decodeUtf8 ) +import qualified Data.Vector as V import qualified SDL -import Say -import System.Exit -import Vulkan.CStruct.Extends -import Vulkan.Core10 -import qualified Vulkan.Core10.DeviceInitialization as DI -import Vulkan.Extensions.VK_KHR_surface -import qualified Vulkan.Extensions.VK_KHR_surface as SF -import Vulkan.Extensions.VK_KHR_swapchain -import qualified Vulkan.Extensions.VK_KHR_swapchain as SW -import Vulkan.Requirement (DeviceRequirement (..)) -import qualified Vulkan.Utils.Init.SDL2 as Init -import Vulkan.Utils.Initialization (createDeviceFromRequirements, pickPhysicalDevice) -import Vulkan.Utils.QueueAssignment - ( QueueFamilyIndex (..) - , QueueSpec (..) - , assignQueues - , isGraphicsQueueFamily - , isPresentQueueFamily - ) -import Vulkan.Zero +import qualified SDL.Video.Vulkan as SDL +import Say import qualified Triangle -import Window ( VulkanWindow(..) ) +import qualified Vma +import VkResources ( Queues(..) + , mkVkResources + ) +import Vulkan.CStruct.Extends +import Vulkan.Core10 +import qualified Vulkan.Core10.DeviceInitialization as DI +import Vulkan.Extensions.VK_KHR_surface +import Vulkan.Requirement ( DeviceRequirement(..) ) +import qualified Vulkan.Utils.Init.SDL2 as Init +import Vulkan.Utils.Initialization ( createDeviceFromRequirements + , pickPhysicalDevice + ) +import Vulkan.Utils.QueueAssignment ( QueueFamilyIndex(..) + , QueueSpec(..) + , assignQueues + , isGraphicsQueueFamily + , isPresentQueueFamily + ) +import Vulkan.Zero +import Frame ( frameDeviceRequirements + , frameInstanceRequirements + ) +import Swapchain ( allocSwapchain ) import qualified Window.SDL2 as Window main :: IO () main = runResourceT $ do Window.withSDL - vw <- withVulkanWindow windowWidth windowHeight - SDL.showWindow (vwWindow vw) - Triangle.runTriangle vw (Window.shouldQuit Window.NoLimit) - -withVulkanWindow :: Int -> Int -> ResourceT IO (VulkanWindow SDL.Window) -withVulkanWindow width height = do - window <- Window.createWindow appName width height - inst <- Init.withInstance + window <- Window.createWindow appName windowWidth windowHeight + inst <- Init.withInstance window - (Just zero{applicationName = Just appName, apiVersion = API_VERSION_1_0}) + (Just zero { applicationName = Just appName, apiVersion = API_VERSION_1_0 }) + frameInstanceRequirements [] - [] - surface <- Init.withSurface inst window - (dev, graphicsQueue, graphicsQueueFamilyIndex, presentQueue, swapchainFormat, swapchainExtent, swapchain) <- - createGraphicalDevice inst surface width height - (_, images) <- getSwapchainImagesKHR dev swapchain - let imageViewCreateInfo i = - zero - { image = i - , viewType = IMAGE_VIEW_TYPE_2D - , format = swapchainFormat - , components = - zero - { r = COMPONENT_SWIZZLE_IDENTITY - , g = COMPONENT_SWIZZLE_IDENTITY - , b = COMPONENT_SWIZZLE_IDENTITY - , a = COMPONENT_SWIZZLE_IDENTITY - } - , subresourceRange = - zero - { aspectMask = IMAGE_ASPECT_COLOR_BIT - , baseMipLevel = 0 - , levelCount = 1 - , baseArrayLayer = 0 - , layerCount = 1 - } - } - imageViews <- for images $ \i -> - snd <$> withImageView dev (imageViewCreateInfo i) Nothing allocate - pure $ VulkanWindow - window dev surface swapchain swapchainExtent swapchainFormat imageViews - graphicsQueue graphicsQueueFamilyIndex presentQueue + surface <- Init.withSurface inst window + (phys, dev, qfi, gQueue) <- createGraphicalDevice inst surface + vma <- Vma.createVMA zero API_VERSION_1_0 inst phys dev + props <- getPhysicalDeviceProperties phys + sayErr $ "Using device: " <> decodeUtf8 (deviceName props) -appName :: (IsString a) => a + let qs = Queues (QueueFamilyIndex qfi, gQueue) + vr <- liftIO $ mkVkResources inst phys dev vma qs + + initialSize <- liftIO $ drawableSize window + initialSC <- allocSwapchain vr NULL_HANDLE initialSize surface + + SDL.showWindow window + Triangle.runTriangle vr initialSC (drawableSize window) (Window.shouldQuit Window.NoLimit) + +appName :: IsString a => a appName = "Haskell Vulkan triangle example" windowWidth, windowHeight :: Int windowWidth = 800 windowHeight = 600 -createGraphicalDevice - :: Instance - -> SurfaceKHR - -> Int - -> Int - -> ResourceT IO (Device, Queue, Word32, Queue, Format, Extent2D, SwapchainKHR) -createGraphicalDevice inst surface width height = do - let desiredFormat = - SurfaceFormatKHR FORMAT_B8G8R8_UNORM COLOR_SPACE_SRGB_NONLINEAR_KHR - (physicalDevice, graphicsQueueFamilyIndex, presentQueueFamilyIndex, surfaceFormat, presentMode, surfaceCaps, graphicsQueue, presentQueue, dev) <- - pickGraphicalPhysicalDevice inst surface desiredFormat - props <- getPhysicalDeviceProperties physicalDevice - sayErr $ "Using device: " <> decodeUtf8 (deviceName props) - let - swapchainCreateInfo :: SwapchainCreateInfoKHR '[] - swapchainCreateInfo = - let (sharingMode, queueFamilyIndices) = - if graphicsQueue == presentQueue - then (SHARING_MODE_EXCLUSIVE, []) - else - ( SHARING_MODE_CONCURRENT - , [graphicsQueueFamilyIndex, presentQueueFamilyIndex] - ) - in zero - { surface = surface - , minImageCount = SF.minImageCount surfaceCaps + 1 - , imageFormat = SF.format surfaceFormat - , imageColorSpace = SF.colorSpace surfaceFormat - , imageExtent = case currentExtent (surfaceCaps :: SurfaceCapabilitiesKHR) of - Extent2D w h - | w == maxBound, h == maxBound -> - Extent2D (fromIntegral width) (fromIntegral height) - e -> e - , imageArrayLayers = 1 - , imageUsage = IMAGE_USAGE_COLOR_ATTACHMENT_BIT - , imageSharingMode = sharingMode - , queueFamilyIndices = queueFamilyIndices - , preTransform = currentTransform (surfaceCaps :: SurfaceCapabilitiesKHR) - , compositeAlpha = COMPOSITE_ALPHA_OPAQUE_BIT_KHR - , presentMode = presentMode - , clipped = True - } - swapchain <- snd <$> withSwapchainKHR dev swapchainCreateInfo Nothing allocate - pure - ( dev - , graphicsQueue - , graphicsQueueFamilyIndex - , presentQueue - , SF.format surfaceFormat - , SW.imageExtent swapchainCreateInfo - , swapchain - ) +drawableSize :: SDL.Window -> IO Extent2D +drawableSize win = do + SDL.V2 w h <- SDL.vkGetDrawableSize win + pure $ Extent2D (fromIntegral w) (fromIntegral h) + +---------------------------------------------------------------- +-- Pick a device with a unified graphics+present queue. +---------------------------------------------------------------- -pickGraphicalPhysicalDevice - :: Instance +createGraphicalDevice + :: (MonadResource m, MonadFail m) + => Instance -> SurfaceKHR - -> SurfaceFormatKHR - -> ResourceT - IO - ( PhysicalDevice - , Word32 - , Word32 - , SurfaceFormatKHR - , PresentModeKHR - , SurfaceCapabilitiesKHR - , Queue - , Queue - , Device - ) -pickGraphicalPhysicalDevice inst surface desiredFormat = do + -> m (PhysicalDevice, Device, Word32, Queue) +createGraphicalDevice inst surface = do mPd <- pickPhysicalDevice inst suitable id - (_, phys) <- case mPd of - Just x -> pure x - Nothing -> sayErr "No suitable devices found" >> liftIO exitFailure - bestFormat <- getFormat phys - presentMode <- getPresentMode phys - surfaceCaps <- getPhysicalDeviceSurfaceCapabilitiesKHR phys surface - -- Ask for one queue that can do both graphics and present. Most drivers - -- expose a universal queue family; this avoids issues when graphics-only - -- families have queueCount = 1. + (_, phys) <- maybe (sayErr "No suitable devices found" >> error "no GPU") pure mPd + + -- One queue family with both graphics and present capability. let queueSpec = QueueSpec 1 $ \i q -> if isGraphicsQueueFamily q then isPresentQueueFamily phys surface i else pure False Just (qInfos, getQs) <- assignQueues phys (Identity queueSpec) + let deviceReqs = [ RequireDeviceExtension Nothing e minBound | e <- Init.getRequiredDeviceExtensions - ] + ] ++ frameDeviceRequirements dev <- createDeviceFromRequirements deviceReqs [] phys - zero{queueCreateInfos = SomeStruct <$> qInfos} + zero { queueCreateInfos = SomeStruct <$> qInfos } Identity (QueueFamilyIndex familyIdx, queue) <- liftIO (getQs dev) - pure - ( phys - , familyIdx - , familyIdx - , bestFormat - , presentMode - , surfaceCaps - , queue - , queue - , dev - ) + pure (phys, dev, familyIdx, queue) where - suitable :: PhysicalDevice -> ResourceT IO (Maybe Word64) suitable phys = runMaybeT $ do (_, exts) <- enumerateDeviceExtensionProperties phys Nothing - guard (V.any ((KHR_SWAPCHAIN_EXTENSION_NAME ==) . extensionName) exts) + True <- pure $ V.any ((Init.getRequiredDeviceExtensions !! 0 ==) . extensionName) exts qProps <- getPhysicalDeviceQueueFamilyProperties phys - guard (V.any isGraphicsQueueFamily qProps) + True <- pure $ V.any isGraphicsQueueFamily qProps let presentSupport i = isPresentQueueFamily phys surface (QueueFamilyIndex (fromIntegral i)) hasPresent <- V.or <$> V.imapM (\i _ -> presentSupport i) qProps - guard hasPresent + True <- pure hasPresent heaps <- memoryHeaps <$> getPhysicalDeviceMemoryProperties phys pure (sum $ DI.size <$> heaps) - - headMay = \case - [] -> Nothing - xs -> Just (V.unsafeHead xs) - - getFormat :: (MonadIO m) => PhysicalDevice -> m SurfaceFormatKHR - getFormat dev = do - (_, formats) <- getPhysicalDeviceSurfaceFormatsKHR dev surface - pure $ case formats of - [] -> desiredFormat - [SurfaceFormatKHR FORMAT_UNDEFINED _] -> desiredFormat - _ - | V.any - ( \f -> - SF.format f == SF.format desiredFormat - && SF.colorSpace f == SF.colorSpace desiredFormat - ) - formats -> - desiredFormat - _ -> V.head formats - - -- Returns the first preferred present mode the driver supports, falling - -- back to whatever it offers (FIFO_KHR is guaranteed by the spec). - getPresentMode :: (MonadIO m) => PhysicalDevice -> m PresentModeKHR - getPresentMode dev = do - (_, presentModes) <- getPhysicalDeviceSurfacePresentModesKHR dev surface - let desiredPresentModes = - [ PRESENT_MODE_MAILBOX_KHR - , PRESENT_MODE_FIFO_KHR - , PRESENT_MODE_IMMEDIATE_KHR - ] - match = V.filter (`V.elem` presentModes) desiredPresentModes - pure $ case headMay match of - Just m -> m - Nothing -> case presentModes V.!? 0 of - Just m -> m - Nothing -> PRESENT_MODE_FIFO_KHR diff --git a/examples/vulkan-examples.cabal b/examples/vulkan-examples.cabal index 2b602748f..4f2912039 100644 --- a/examples/vulkan-examples.cabal +++ b/examples/vulkan-examples.cabal @@ -43,16 +43,16 @@ flag vr library exposed-modules: - AutoApply Camera + Frame Framebuffer - HasVulkan - InstrumentDecs Orphans RefCounted Swapchain Triangle Utils + VkResources + Vma Window Window.GLFW Window.SDL2 @@ -105,17 +105,15 @@ library , derive-storable-plugin >=0.2.3.3 , lens , linear - , logict , mtl , nothunks >=0.1.2 - , opentelemetry , resourcet >=1.2.4 + , say , sdl2 >=2.5.0 , template-haskell , text - , th-desugar <2 , transformers - , unification-fd + , unagi-chan , unliftio , vector , vulkan @@ -189,10 +187,7 @@ executable compute executable hlsl main-is: Main.hs other-modules: - Frame Init - MonadFrame - MonadVulkan Pipeline Render RenderPass @@ -241,14 +236,12 @@ executable hlsl , base <5 , bytestring , containers - , opentelemetry , resourcet >=1.2.4 , say , sdl2 , template-haskell , text , transformers - , unagi-chan , unliftio , vector , vulkan @@ -316,11 +309,7 @@ executable rays main-is: Main.hs other-modules: AccelerationStructure - Cleanup - Frame Init - MonadFrame - MonadVulkan Pipeline Render Scene @@ -369,13 +358,10 @@ executable rays , base <5 , bytestring , colour - , containers , derive-storable >=0.3 , derive-storable-plugin >=0.2.3.3 , lens , linear - , nothunks >=0.1.2 - , opentelemetry , random , resourcet >=1.2.4 , say @@ -383,7 +369,6 @@ executable rays , template-haskell , text , transformers - , unagi-chan , unliftio , vector , vulkan >=3.7 @@ -399,13 +384,10 @@ executable rays executable resize main-is: Main.hs other-modules: - Frame Init Julia Julia.Constants - MonadVulkan Pipeline - Swapchain Paths_vulkan_examples autogen-modules: Paths_vulkan_examples @@ -468,63 +450,6 @@ executable resize if os(windows) ghc-options: -optl-mconsole -executable timeline-semaphore - main-is: Main.hs - other-modules: - Paths_vulkan_examples - autogen-modules: - Paths_vulkan_examples - hs-source-dirs: - timeline-semaphore - default-extensions: - 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: - base <5 - , resourcet - , say - , transformers - , unliftio - , vector - , vulkan - , vulkan-examples - , vulkan-utils >=0.3 - default-language: Haskell2010 - if os(windows) - ghc-options: -optl-mconsole - executable triangle-glfw main-is: Main.hs other-modules: From da7c038bb5310f11623517f65f89594df700247d Mon Sep 17 00:00:00 2001 From: IC Rainbow Date: Tue, 5 May 2026 01:23:29 +0300 Subject: [PATCH 2/5] Squeeze a little more --- examples/hlsl/Main.hs | 41 ++--------- examples/lib/Framebuffer.hs | 22 ++++++ examples/lib/InitDevice.hs | 75 +++++++++++++++++++ examples/lib/Triangle.hs | 24 +----- examples/lib/Window.hs | 29 -------- examples/lib/Window/GLFW.hs | 10 ++- examples/lib/Window/SDL2.hs | 13 ++++ examples/rays/Main.hs | 11 +-- examples/resize/Init.hs | 129 +++------------------------------ examples/resize/Main.hs | 36 ++++----- examples/triangle-glfw/Main.hs | 85 ++++------------------ examples/triangle-sdl2/Main.hs | 89 ++++------------------- examples/vulkan-examples.cabal | 2 +- 13 files changed, 183 insertions(+), 383 deletions(-) create mode 100644 examples/lib/InitDevice.hs delete mode 100644 examples/lib/Window.hs diff --git a/examples/hlsl/Main.hs b/examples/hlsl/Main.hs index 5a8aee4c6..7a7242128 100644 --- a/examples/hlsl/Main.hs +++ b/examples/hlsl/Main.hs @@ -4,10 +4,7 @@ module Main where import Control.Monad.IO.Class import Control.Monad.Trans.Resource -import Data.Foldable ( traverse_ ) import Data.IORef -import qualified Data.Vector as V -import Data.Vector ( Vector ) import Frame ( Frame(..) , advanceFrame , initialFrame @@ -18,17 +15,12 @@ import Init ( createDevice , createInstance , createVMA ) -import RefCounted ( RefCounted - , newRefCounted - , releaseRefCounted - ) +import RefCounted ( releaseRefCounted ) import Render ( renderFrame ) import qualified RenderPass import SDL ( showWindow , time ) -import qualified SDL -import qualified SDL.Video.Vulkan as SDL import Swapchain ( Swapchain(..) , allocSwapchain , recreateSwapchain @@ -37,16 +29,12 @@ import Swapchain ( Swapchain(..) import Utils ( loopJust ) import VkResources ( mkVkResources ) import qualified Pipeline -import Vulkan.Core10 ( Device - , Extent2D(..) - , Framebuffer - , RenderPass - , pattern NULL_HANDLE - ) +import Vulkan.Core10 ( pattern NULL_HANDLE ) import Vulkan.Extensions.VK_KHR_surface as SurfaceFormatKHR ( SurfaceFormatKHR(..) ) import Window.SDL2 ( RefreshLimit(..) , createWindow + , drawableSize , shouldQuit , withSDL ) @@ -68,7 +56,7 @@ main = runResourceT $ do initialSC <- allocSwapchain vr NULL_HANDLE initialSize surf (_, renderPass) <- RenderPass.createRenderPass dev (SurfaceFormatKHR.format (sFormat initialSC)) (_, pipeline) <- Pipeline.createPipeline dev renderPass - initialFBs <- createFramebuffers dev renderPass initialSC + initialFBs <- Framebuffer.createFramebuffers dev renderPass (sImageViews initialSC) (sExtent initialSC) scRef <- liftIO $ newIORef initialSC fbsRef <- liftIO $ newIORef initialFBs @@ -89,7 +77,7 @@ main = runResourceT $ do then do newSize <- liftIO $ drawableSize win sc' <- recreateSwapchain vr newSize currentSC - newFBs <- createFramebuffers dev renderPass sc' + newFBs <- Framebuffer.createFramebuffers dev renderPass (sImageViews sc') (sExtent sc') (_oldFbs, oldRel) <- liftIO $ readIORef fbsRef releaseRefCounted oldRel liftIO $ writeIORef scRef sc' @@ -107,22 +95,3 @@ main = runResourceT $ do False -> Just <$> perFrame f loopJust loop initial - -drawableSize :: SDL.Window -> IO Extent2D -drawableSize win = do - SDL.V2 w h <- SDL.vkGetDrawableSize win - pure $ Extent2D (fromIntegral w) (fromIntegral h) - --- | Build a framebuffer per swapchain image; bundle a 'RefCounted' that --- frees them all when no in-flight frame still uses them. -createFramebuffers - :: MonadResource m - => Device - -> RenderPass - -> Swapchain - -> m (Vector Framebuffer, RefCounted) -createFramebuffers dev rp sc = do - (keys, fbs) <- fmap V.unzip . V.forM (sImageViews sc) $ \iv -> - Framebuffer.createFramebuffer dev rp iv (sExtent sc) - rel <- newRefCounted (traverse_ release keys) - pure (fbs, rel) diff --git a/examples/lib/Framebuffer.hs b/examples/lib/Framebuffer.hs index c1c18761f..ed5869763 100644 --- a/examples/lib/Framebuffer.hs +++ b/examples/lib/Framebuffer.hs @@ -5,12 +5,18 @@ module Framebuffer ( Framebuffer.createFramebuffer , Framebuffer.createImageView + , Framebuffer.createFramebuffers ) where import Control.Monad.Trans.Resource ( MonadResource , ReleaseKey , allocate + , release ) +import Data.Foldable ( traverse_ ) +import qualified Data.Vector as V +import Data.Vector ( Vector ) +import RefCounted ( RefCounted, newRefCounted ) import Vulkan.Core10 as Vk hiding ( withImage ) import Vulkan.Core10 as Extent2D (Extent2D(..)) @@ -36,6 +42,22 @@ createFramebuffer dev renderPass imageView imageSize = } in withFramebuffer dev framebufferCreateInfo Nothing allocate +-- | Build one framebuffer per image view at the given extent. The returned +-- 'RefCounted' frees them all when no in-flight frame still uses them — call +-- 'releaseRefCounted' after a swapchain swap. +createFramebuffers + :: MonadResource m + => Device + -> RenderPass + -> Vector ImageView + -> Extent2D + -> m (Vector Framebuffer, RefCounted) +createFramebuffers dev rp ivs imageSize = do + (keys, fbs) <- fmap V.unzip . V.forM ivs $ \iv -> + Framebuffer.createFramebuffer dev rp iv imageSize + rel <- newRefCounted (traverse_ release keys) + pure (fbs, rel) + -- | Vanilla 2D color image view covering the whole image. createImageView :: MonadResource m diff --git a/examples/lib/InitDevice.hs b/examples/lib/InitDevice.hs new file mode 100644 index 000000000..e5ebc9397 --- /dev/null +++ b/examples/lib/InitDevice.hs @@ -0,0 +1,75 @@ +-- | Helpers shared by the windowed examples for picking a physical device +-- and creating a logical device with one unified graphics+present queue. +module InitDevice + ( withGraphicsPresentDevice + ) where + +import Control.Monad.IO.Class +import Control.Monad.Trans.Maybe ( runMaybeT ) +import Control.Monad.Trans.Resource +import Data.Functor.Identity ( Identity(..) ) +import qualified Data.Vector as V +import Data.Word ( Word64 ) +import Say ( sayErr ) +import Utils ( noSuchThing ) +import Vulkan.CStruct.Extends ( SomeStruct(..) ) +import Vulkan.Core10 +import qualified Vulkan.Core10.DeviceInitialization + as DI +import Vulkan.Extensions.VK_KHR_surface + ( SurfaceKHR ) +import Vulkan.Requirement ( DeviceRequirement ) +import Vulkan.Utils.Initialization ( createDeviceFromRequirements + , pickPhysicalDevice + ) +import Vulkan.Utils.QueueAssignment ( QueueFamilyIndex(..) + , QueueSpec(..) + , assignQueues + , isGraphicsQueueFamily + , isPresentQueueFamily + ) +import Vulkan.Zero ( zero ) + +-- | Pick a physical device that has a graphics queue family that can also +-- present to the given surface, then create a logical device exposing one +-- queue from that family. Devices are scored by total memory. +-- +-- Pass any extra device requirements (extensions, features, API version) in +-- @extraReqs@; they are forwarded to 'createDeviceFromRequirements', which +-- will fail loudly if the chosen device cannot satisfy them. +withGraphicsPresentDevice + :: (MonadResource m, MonadFail m) + => Instance + -> SurfaceKHR + -> [DeviceRequirement] + -> m (PhysicalDevice, Device, QueueFamilyIndex, Queue) +withGraphicsPresentDevice inst surface extraReqs = do + mPd <- pickPhysicalDevice inst (suitable surface) id + (_, phys) <- case mPd of + Just x -> pure x + Nothing -> sayErr "No suitable physical device found" + >> noSuchThing "No physical device with graphics+present queue" + + let queueSpec = QueueSpec 1 $ \i q -> + if isGraphicsQueueFamily q + then isPresentQueueFamily phys surface i + else pure False + Just (qInfos, getQs) <- assignQueues phys (Identity queueSpec) + + dev <- createDeviceFromRequirements + extraReqs + [] + phys + zero { queueCreateInfos = SomeStruct <$> qInfos } + Identity (qfi, queue) <- liftIO (getQs dev) + pure (phys, dev, qfi, queue) + where + suitable surf phys = runMaybeT $ do + qProps <- getPhysicalDeviceQueueFamilyProperties phys + True <- pure $ V.any isGraphicsQueueFamily qProps + let presentSupport i = + isPresentQueueFamily phys surf (QueueFamilyIndex (fromIntegral i)) + hasPresent <- V.or <$> V.imapM (\i _ -> presentSupport i) qProps + True <- pure hasPresent + heaps <- memoryHeaps <$> getPhysicalDeviceMemoryProperties phys + pure (sum $ DI.size <$> heaps :: Word64) diff --git a/examples/lib/Triangle.hs b/examples/lib/Triangle.hs index 53b4b6fe2..e772e00b0 100644 --- a/examples/lib/Triangle.hs +++ b/examples/lib/Triangle.hs @@ -27,10 +27,7 @@ import Frame ( Frame(..) ) import qualified Framebuffer import Data.IORef -import RefCounted ( RefCounted - , newRefCounted - , releaseRefCounted - ) +import RefCounted ( releaseRefCounted ) import Swapchain ( Swapchain(..) , recreateSwapchain , threwSwapchainError @@ -67,7 +64,7 @@ runTriangle vr initialSC getDrawableSize shouldQuit = do let dev = vrDevice vr (_, renderPass) <- createRenderPass dev (SurfaceFormatKHR.format (sFormat initialSC)) (_, pipeline) <- createGraphicsPipeline dev renderPass - initialFBs <- createFramebuffers dev renderPass initialSC + initialFBs <- Framebuffer.createFramebuffers dev renderPass (sImageViews initialSC) (sExtent initialSC) scRef <- liftIO $ newIORef initialSC fbsRef <- liftIO $ newIORef initialFBs @@ -84,7 +81,7 @@ runTriangle vr initialSC getDrawableSize shouldQuit = do then do newSize <- liftIO getDrawableSize sc' <- recreateSwapchain vr newSize currentSC - newFBs <- createFramebuffers dev renderPass sc' + newFBs <- Framebuffer.createFramebuffers dev renderPass (sImageViews sc') (sExtent sc') (_oldFbs, oldRel) <- liftIO $ readIORef fbsRef releaseRefCounted oldRel liftIO $ writeIORef scRef sc' @@ -353,18 +350,3 @@ createShaders dev = do , (fragKey, SomeStruct fragShaderStageCreateInfo) ] ----------------------------------------------------------------- --- Framebuffers ----------------------------------------------------------------- - -createFramebuffers - :: MonadResource m - => Device - -> RenderPass - -> Swapchain - -> m (Vector Framebuffer, RefCounted) -createFramebuffers dev rp sc = do - (keys, fbs) <- fmap V.unzip . V.forM (sImageViews sc) $ \iv -> - Framebuffer.createFramebuffer dev rp iv (sExtent sc) - rel <- newRefCounted (traverse_ release keys) - pure (fbs, rel) diff --git a/examples/lib/Window.hs b/examples/lib/Window.hs deleted file mode 100644 index 38a4388e5..000000000 --- a/examples/lib/Window.hs +++ /dev/null @@ -1,29 +0,0 @@ -module Window - ( VulkanWindow(..) - ) where - -import Data.Word ( Word32 ) -import qualified Data.Vector as V -import Vulkan.Core10 ( Device - , Extent2D - , Format - , ImageView - , Queue - ) -import Vulkan.Extensions.VK_KHR_surface - ( SurfaceKHR ) -import Vulkan.Extensions.VK_KHR_swapchain - ( SwapchainKHR ) - -data VulkanWindow w = VulkanWindow - { vwWindow :: w - , vwDevice :: Device - , vwSurface :: SurfaceKHR - , vwSwapchain :: SwapchainKHR - , vwExtent :: Extent2D - , vwFormat :: Format - , vwImageViews :: V.Vector ImageView - , vwGraphicsQueue :: Queue - , vwGraphicsQueueFamilyIndex :: Word32 - , vwPresentQueue :: Queue - } diff --git a/examples/lib/Window/GLFW.hs b/examples/lib/Window/GLFW.hs index 74577bfdc..f7387b3aa 100644 --- a/examples/lib/Window/GLFW.hs +++ b/examples/lib/Window/GLFW.hs @@ -4,11 +4,12 @@ module Window.GLFW ( withGLFW , createWindow , showWindow + , drawableSize , shouldQuit ) where import Control.Monad ( unless, void ) -import Control.Monad.IO.Class ( liftIO ) +import Control.Monad.IO.Class ( MonadIO, liftIO ) import Control.Monad.Trans.Resource ( MonadResource , allocate , allocate_ @@ -16,6 +17,7 @@ import Control.Monad.Trans.Resource ( MonadResource import qualified Data.Text as T import Data.Text ( Text ) import qualified Graphics.UI.GLFW as GLFW +import Vulkan.Core10 ( Extent2D(..) ) -- | Initialise GLFW and tear it down with the resource scope. withGLFW :: MonadResource m => m () @@ -49,6 +51,12 @@ createWindow title width height = do showWindow :: GLFW.Window -> IO () showWindow = GLFW.showWindow +-- | Current framebuffer size, suitable as the swapchain extent fallback. +drawableSize :: MonadIO m => GLFW.Window -> m Extent2D +drawableSize win = do + (w, h) <- liftIO $ GLFW.getFramebufferSize win + pure $ Extent2D (fromIntegral w) (fromIntegral h) + -- | Poll events and report whether the user requested to close the window -- (X button, Q, or Escape). shouldQuit :: GLFW.Window -> IO Bool diff --git a/examples/lib/Window/SDL2.hs b/examples/lib/Window/SDL2.hs index acd0819bd..9d719768e 100644 --- a/examples/lib/Window/SDL2.hs +++ b/examples/lib/Window/SDL2.hs @@ -2,6 +2,8 @@ module Window.SDL2 ( withSDL , createWindow , createSurface + , drawableSize + , showWindow , RefreshLimit(..) , shouldQuit ) where @@ -55,6 +57,17 @@ createSurface inst window = allocate (SurfaceKHR <$> SDL.vkCreateSurface window (castPtr (instanceHandle inst))) (\s -> destroySurfaceKHR inst s Nothing) +-- | Current drawable size, suitable as the swapchain extent fallback. +drawableSize :: MonadIO m => SDL.Window -> m Extent2D +drawableSize win = do + SDL.V2 w h <- SDL.vkGetDrawableSize win + pure $ Extent2D (fromIntegral w) (fromIntegral h) + +-- | Make the window visible. The window is created hidden so the swapchain +-- can be brought up first. +showWindow :: MonadIO m => SDL.Window -> m () +showWindow = SDL.showWindow + ---------------------------------------------------------------- -- SDL helpers ---------------------------------------------------------------- diff --git a/examples/rays/Main.hs b/examples/rays/Main.hs index 7060209de..aabd5acf2 100644 --- a/examples/rays/Main.hs +++ b/examples/rays/Main.hs @@ -9,7 +9,6 @@ import Control.Monad.Trans.Resource import Data.Foldable ( for_ ) import Data.IORef import Data.Word ( Word64 ) -import qualified Data.Vector as V import Foreign.Ptr ( castPtr ) import Foreign.Storable ( sizeOf ) import Frame ( Frame(..) @@ -28,10 +27,8 @@ import Render ( RenderState(..) , renderFrame ) import qualified SDL -import qualified SDL.Video.Vulkan as SDL import Scene ( makeSceneBuffers ) -import Swapchain ( Swapchain(..) - , allocSwapchain +import Swapchain ( allocSwapchain , recreateSwapchain , threwSwapchainError ) @@ -47,6 +44,7 @@ import VulkanMemoryAllocator as VMA hiding ( getPhysicalDeviceProperties ) import Window.SDL2 ( RefreshLimit(..) , createWindow + , drawableSize , shouldQuit , withSDL ) @@ -142,8 +140,3 @@ main = runResourceT $ do False -> Just <$> perFrame f loopJust loop initial - -drawableSize :: SDL.Window -> IO Extent2D -drawableSize win = do - SDL.V2 w h <- SDL.vkGetDrawableSize win - pure $ Extent2D (fromIntegral w) (fromIntegral h) diff --git a/examples/resize/Init.hs b/examples/resize/Init.hs index 031822db3..a3a595df8 100644 --- a/examples/resize/Init.hs +++ b/examples/resize/Init.hs @@ -1,38 +1,18 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE QuasiQuotes #-} module Init - ( Init.createDevice - , DeviceParams(..) - , myApiVersion + ( myApiVersion + , deviceRequirements , createVMA ) where -import Control.Monad ( guard ) -import Control.Monad.IO.Class -import Control.Monad.Trans.Maybe ( MaybeT(..) ) import Control.Monad.Trans.Resource -import Data.Text ( Text ) -import qualified Data.Vector as V import Data.Word -import UnliftIO.Exception import Frame ( frameDeviceRequirements ) import qualified Vma -import Vulkan.CStruct.Extends -import Vulkan.Core10 as Vk - hiding ( withBuffer - , withImage - ) -import qualified Vulkan.Core10 as MemoryHeap (MemoryHeap(..)) -import Vulkan.Extensions.VK_KHR_surface -import Vulkan.Extensions.VK_KHR_swapchain -import Vulkan.Utils.Initialization ( createDeviceFromRequirements - , physicalDeviceName - , pickPhysicalDevice - ) -import Vulkan.Utils.Misc ( (.&&.) ) +import Vulkan.Core10 +import Vulkan.Requirement ( DeviceRequirement ) import qualified Vulkan.Utils.Requirements.TH as U import Vulkan.Zero import VulkanMemoryAllocator ( Allocator ) @@ -40,100 +20,13 @@ import VulkanMemoryAllocator ( Allocator ) myApiVersion :: Word32 myApiVersion = API_VERSION_1_0 ----------------------------------------------------------------- --- Device Creation ----------------------------------------------------------------- - -data DeviceParams = DeviceParams - { dpDeviceName :: Text - , dpPhysicalDevice :: PhysicalDevice - , dpDevice :: Device - , dpGraphicsQueue :: Queue - -- ^ Also the present queue - , dpGraphicsQueueFamilyIndex :: Word32 - } - deriving Show - --- | Creates a device with swapchain support -createDevice - :: (MonadResource m, MonadThrow m) => Instance -> SurfaceKHR -> m DeviceParams -createDevice inst surf = do - - -- - -- Get a physical device - -- - (pdi, phys) <- pickPhysicalDevice inst (physicalDeviceInfo surf) id >>= \case - Nothing -> throwString "Unable to find suitable physical device" - Just x -> pure x - devName <- physicalDeviceName phys - - -- - -- Get a logical device - -- - let graphicsQueueFamilyIndex = pdiGraphicsQueueFamilyIndex pdi - deviceCreateInfo = zero - { queueCreateInfos = [ SomeStruct zero - { queueFamilyIndex = graphicsQueueFamilyIndex - , queuePriorities = [1] - } - ] - } - deviceReqs = [U.reqs| - 1.0 - VK_KHR_swapchain - |] ++ frameDeviceRequirements - dev <- createDeviceFromRequirements deviceReqs [] phys deviceCreateInfo - graphicsQueue <- getDeviceQueue dev graphicsQueueFamilyIndex 0 - - pure $ DeviceParams devName phys dev graphicsQueue graphicsQueueFamilyIndex - ----------------------------------------------------------------- --- Physical device tools ----------------------------------------------------------------- - --- | The Ord instance prioritises devices with more memory -data PhysicalDeviceInfo = PhysicalDeviceInfo - { pdiTotalMemory :: Word64 - , pdiGraphicsQueueFamilyIndex :: Word32 - } - deriving (Eq, Ord) - --- | Requires the device to have a graphics queue --- --- The graphics queue index will be able to present to the specified surface -physicalDeviceInfo - :: MonadIO m => SurfaceKHR -> PhysicalDevice -> m (Maybe PhysicalDeviceInfo) -physicalDeviceInfo surf phys = runMaybeT $ do - -- We must be able to use the swapchain extension - guard =<< deviceHasSwapchain phys - - -- It must have a graphics and present queue - pdiGraphicsQueueFamilyIndex <- do - queueFamilyProperties <- getPhysicalDeviceQueueFamilyProperties phys - let isGraphicsQueue q = - (QUEUE_GRAPHICS_BIT .&&. queueFlags q) && (queueCount q > 0) - graphicsQueueIndices = fromIntegral . fst <$> V.filter - (isGraphicsQueue . snd) - (V.indexed queueFamilyProperties) - let isPresentQueue i = getPhysicalDeviceSurfaceSupportKHR phys i surf - presentQueueIndices <- V.filterM isPresentQueue graphicsQueueIndices - MaybeT (pure $ presentQueueIndices V.!? 0) - - -- Score based on the total memory - pdiTotalMemory <- do - heaps <- memoryHeaps <$> getPhysicalDeviceMemoryProperties phys - pure $ sum (MemoryHeap.size <$> heaps) - - pure PhysicalDeviceInfo { .. } - -deviceHasSwapchain :: MonadIO m => PhysicalDevice -> m Bool -deviceHasSwapchain dev = do - (_, extensions) <- enumerateDeviceExtensionProperties dev Nothing - pure $ V.any ((KHR_SWAPCHAIN_EXTENSION_NAME ==) . extensionName) extensions - ----------------------------------------------------------------- --- VulkanMemoryAllocator ----------------------------------------------------------------- +-- | Device requirements: API version, swapchain, and the timeline-semaphore +-- bits the recycling 'Frame' machinery needs. +deviceRequirements :: [DeviceRequirement] +deviceRequirements = [U.reqs| + 1.0 + VK_KHR_swapchain + |] ++ frameDeviceRequirements createVMA :: MonadResource m => Instance -> PhysicalDevice -> Device -> m Allocator diff --git a/examples/resize/Main.hs b/examples/resize/Main.hs index d6f84c479..f4cc00125 100644 --- a/examples/resize/Main.hs +++ b/examples/resize/Main.hs @@ -12,8 +12,6 @@ import Control.Lens.Getter import Control.Monad ( when ) import Control.Monad.IO.Class import Control.Monad.Trans.Resource -import Data.Bits ( (.|.) ) -import Data.Foldable ( traverse_ ) import Data.IORef import qualified Data.Vector as V import Data.Vector ( Vector ) @@ -26,11 +24,12 @@ import Frame ( Frame(..) ) import qualified Framebuffer import GHC.Clock ( getMonotonicTimeNSec ) -import Init ( DeviceParams(..) - , createDevice - , createVMA +import Init ( createVMA + , deviceRequirements , myApiVersion ) +import InitDevice ( withGraphicsPresentDevice ) +import Data.Text.Encoding ( decodeUtf8 ) import Julia ( JuliaPipeline(..) , createJuliaDescriptorSets , createJuliaPipeline @@ -46,7 +45,6 @@ import RefCounted ( RefCounted , releaseRefCounted ) import qualified SDL -import qualified SDL.Video.Vulkan as SDL import Say import Data.Word ( Word64 ) import Swapchain ( Swapchain(..) @@ -87,12 +85,12 @@ import Vulkan.Exception import Vulkan.Extensions.VK_KHR_surface as SurfaceFormatKHR (SurfaceFormatKHR(..)) import Vulkan.Extensions.VK_KHR_swapchain as Swap -import Vulkan.Utils.QueueAssignment ( QueueFamilyIndex(..) ) import Vulkan.Zero import qualified Vulkan.Utils.Init.SDL2 as Init import Window.SDL2 ( RefreshLimit(..) , createSurface , createWindow + , drawableSize , shouldQuit , withSDL ) @@ -114,12 +112,13 @@ main = prettyError . runResourceT $ do frameInstanceRequirements [] (_, surface) <- createSurface inst sdlWindow - DeviceParams devName phys dev graphicsQueue graphicsQueueFamilyIndex <- - createDevice inst surface - vma <- createVMA inst phys dev - sayErr $ "Using device: " <> devName + (phys, dev, qfi, graphicsQueue) <- + withGraphicsPresentDevice inst surface deviceRequirements + vma <- createVMA inst phys dev + props <- getPhysicalDeviceProperties phys + sayErr $ "Using device: " <> decodeUtf8 (deviceName props) - let qs = Queues (QueueFamilyIndex graphicsQueueFamilyIndex, graphicsQueue) + let qs = Queues (qfi, graphicsQueue) vr <- liftIO $ mkVkResources inst phys dev vma qs -- Initial swapchain at the requested size. @@ -194,9 +193,8 @@ createBindings -> m Bindings createBindings dev renderPass jp sc = do -- Framebuffers (one per swapchain image) for the dormant graphics pipeline. - (fbKeys, framebuffers) <- fmap V.unzip . V.forM (sImageViews sc) $ \iv -> - Framebuffer.createFramebuffer dev renderPass iv (sExtent sc) - fbRel <- newRefCounted (traverse_ release fbKeys) + (framebuffers, fbRel) <- + Framebuffer.createFramebuffers dev renderPass (sImageViews sc) (sExtent sc) -- Julia descriptor sets (one per swapchain image). juliaSets <- createJuliaDescriptorSets @@ -409,11 +407,3 @@ reportFrameTime nsec = do when (frameBudgetPercent > 50) $ sayErrString (show frameTimeMSec <> "ms \t" <> show frameBudgetPercent <> "%") ----------------------------------------------------------------- --- Helpers ----------------------------------------------------------------- - -drawableSize :: SDL.Window -> IO Extent2D -drawableSize win = do - SDL.V2 w h <- SDL.vkGetDrawableSize win - pure $ Extent2D (fromIntegral w) (fromIntegral h) diff --git a/examples/triangle-glfw/Main.hs b/examples/triangle-glfw/Main.hs index f488d23e4..a20fd8c80 100644 --- a/examples/triangle-glfw/Main.hs +++ b/examples/triangle-glfw/Main.hs @@ -1,40 +1,23 @@ {-# LANGUAGE OverloadedLists #-} -{-# OPTIONS_GHC -Wno-name-shadowing #-} module Main where import Control.Monad.IO.Class -import Control.Monad.Trans.Maybe import Control.Monad.Trans.Resource import qualified Data.Text as Text -import Data.Functor.Identity ( Identity(..) ) import Data.String ( IsString ) -import Data.Word ( Word32 ) import Data.Text.Encoding ( decodeUtf8 ) -import qualified Data.Vector as V -import qualified Graphics.UI.GLFW as GLFW +import InitDevice ( withGraphicsPresentDevice ) import Say import qualified Triangle import qualified Vma import VkResources ( Queues(..) , mkVkResources ) -import Vulkan.CStruct.Extends import Vulkan.Core10 -import qualified Vulkan.Core10.DeviceInitialization as DI -import Vulkan.Extensions.VK_KHR_surface import Vulkan.Requirement ( DeviceRequirement(..) ) +import Vulkan.Zero ( zero ) import qualified Vulkan.Utils.Init.GLFW as Init -import Vulkan.Utils.Initialization ( createDeviceFromRequirements - , pickPhysicalDevice - ) -import Vulkan.Utils.QueueAssignment ( QueueFamilyIndex(..) - , QueueSpec(..) - , assignQueues - , isGraphicsQueueFamily - , isPresentQueueFamily - ) -import Vulkan.Zero import Frame ( frameDeviceRequirements , frameInstanceRequirements ) @@ -50,20 +33,25 @@ main = runResourceT $ do (Just zero { applicationName = Just appName, apiVersion = API_VERSION_1_0 }) frameInstanceRequirements [] - surface <- Init.withSurface inst window - (phys, dev, qfi, gQueue) <- createGraphicalDevice inst surface - vma <- Vma.createVMA zero API_VERSION_1_0 inst phys dev - props <- getPhysicalDeviceProperties phys + surface <- Init.withSurface inst window + let deviceReqs = + [ RequireDeviceExtension Nothing e minBound + | e <- Init.getRequiredDeviceExtensions + ] ++ frameDeviceRequirements + (phys, dev, qfi, gQueue) <- + withGraphicsPresentDevice inst surface deviceReqs + vma <- Vma.createVMA zero API_VERSION_1_0 inst phys dev + props <- getPhysicalDeviceProperties phys sayErr $ "Using device: " <> decodeUtf8 (deviceName props) - let qs = Queues (QueueFamilyIndex qfi, gQueue) + let qs = Queues (qfi, gQueue) vr <- liftIO $ mkVkResources inst phys dev vma qs - initialSize <- liftIO $ drawableSize window + initialSize <- Window.drawableSize window initialSC <- allocSwapchain vr NULL_HANDLE initialSize surface liftIO $ Window.showWindow window - Triangle.runTriangle vr initialSC (drawableSize window) (Window.shouldQuit window) + Triangle.runTriangle vr initialSC (Window.drawableSize window) (Window.shouldQuit window) appName :: IsString a => a appName = "Haskell Vulkan triangle example (GLFW)" @@ -71,48 +59,3 @@ appName = "Haskell Vulkan triangle example (GLFW)" windowWidth, windowHeight :: Int windowWidth = 800 windowHeight = 600 - -drawableSize :: GLFW.Window -> IO Extent2D -drawableSize win = do - (w, h) <- GLFW.getFramebufferSize win - pure $ Extent2D (fromIntegral w) (fromIntegral h) - ----------------------------------------------------------------- --- Pick a device with a unified graphics+present queue. ----------------------------------------------------------------- - -createGraphicalDevice - :: (MonadResource m, MonadFail m) - => Instance - -> SurfaceKHR - -> m (PhysicalDevice, Device, Word32, Queue) -createGraphicalDevice inst surface = do - mPd <- pickPhysicalDevice inst suitable id - (_, phys) <- maybe (sayErr "No suitable devices found" >> error "no GPU") pure mPd - - let queueSpec = QueueSpec 1 $ \i q -> - if isGraphicsQueueFamily q - then isPresentQueueFamily phys surface i - else pure False - Just (qInfos, getQs) <- assignQueues phys (Identity queueSpec) - - let deviceReqs = - [ RequireDeviceExtension Nothing e minBound - | e <- Init.getRequiredDeviceExtensions - ] ++ frameDeviceRequirements - dev <- createDeviceFromRequirements deviceReqs [] phys - zero { queueCreateInfos = SomeStruct <$> qInfos } - Identity (QueueFamilyIndex familyIdx, queue) <- liftIO (getQs dev) - pure (phys, dev, familyIdx, queue) - where - suitable phys = runMaybeT $ do - (_, exts) <- enumerateDeviceExtensionProperties phys Nothing - True <- pure $ V.any ((Init.getRequiredDeviceExtensions !! 0 ==) . extensionName) exts - qProps <- getPhysicalDeviceQueueFamilyProperties phys - True <- pure $ V.any isGraphicsQueueFamily qProps - let presentSupport i = - isPresentQueueFamily phys surface (QueueFamilyIndex (fromIntegral i)) - hasPresent <- V.or <$> V.imapM (\i _ -> presentSupport i) qProps - True <- pure hasPresent - heaps <- memoryHeaps <$> getPhysicalDeviceMemoryProperties phys - pure (sum $ DI.size <$> heaps) diff --git a/examples/triangle-sdl2/Main.hs b/examples/triangle-sdl2/Main.hs index 5fc875150..6898a51b4 100644 --- a/examples/triangle-sdl2/Main.hs +++ b/examples/triangle-sdl2/Main.hs @@ -1,40 +1,22 @@ {-# LANGUAGE OverloadedLists #-} -{-# OPTIONS_GHC -Wno-name-shadowing #-} module Main where import Control.Monad.IO.Class -import Control.Monad.Trans.Maybe import Control.Monad.Trans.Resource -import Data.Functor.Identity ( Identity(..) ) import Data.String ( IsString ) -import Data.Word ( Word32 ) import Data.Text.Encoding ( decodeUtf8 ) -import qualified Data.Vector as V -import qualified SDL -import qualified SDL.Video.Vulkan as SDL +import InitDevice ( withGraphicsPresentDevice ) import Say import qualified Triangle import qualified Vma import VkResources ( Queues(..) , mkVkResources ) -import Vulkan.CStruct.Extends import Vulkan.Core10 -import qualified Vulkan.Core10.DeviceInitialization as DI -import Vulkan.Extensions.VK_KHR_surface import Vulkan.Requirement ( DeviceRequirement(..) ) +import Vulkan.Zero ( zero ) import qualified Vulkan.Utils.Init.SDL2 as Init -import Vulkan.Utils.Initialization ( createDeviceFromRequirements - , pickPhysicalDevice - ) -import Vulkan.Utils.QueueAssignment ( QueueFamilyIndex(..) - , QueueSpec(..) - , assignQueues - , isGraphicsQueueFamily - , isPresentQueueFamily - ) -import Vulkan.Zero import Frame ( frameDeviceRequirements , frameInstanceRequirements ) @@ -50,20 +32,25 @@ main = runResourceT $ do (Just zero { applicationName = Just appName, apiVersion = API_VERSION_1_0 }) frameInstanceRequirements [] - surface <- Init.withSurface inst window - (phys, dev, qfi, gQueue) <- createGraphicalDevice inst surface - vma <- Vma.createVMA zero API_VERSION_1_0 inst phys dev - props <- getPhysicalDeviceProperties phys + surface <- Init.withSurface inst window + let deviceReqs = + [ RequireDeviceExtension Nothing e minBound + | e <- Init.getRequiredDeviceExtensions + ] ++ frameDeviceRequirements + (phys, dev, qfi, gQueue) <- + withGraphicsPresentDevice inst surface deviceReqs + vma <- Vma.createVMA zero API_VERSION_1_0 inst phys dev + props <- getPhysicalDeviceProperties phys sayErr $ "Using device: " <> decodeUtf8 (deviceName props) - let qs = Queues (QueueFamilyIndex qfi, gQueue) + let qs = Queues (qfi, gQueue) vr <- liftIO $ mkVkResources inst phys dev vma qs - initialSize <- liftIO $ drawableSize window + initialSize <- Window.drawableSize window initialSC <- allocSwapchain vr NULL_HANDLE initialSize surface - SDL.showWindow window - Triangle.runTriangle vr initialSC (drawableSize window) (Window.shouldQuit Window.NoLimit) + Window.showWindow window + Triangle.runTriangle vr initialSC (Window.drawableSize window) (Window.shouldQuit Window.NoLimit) appName :: IsString a => a appName = "Haskell Vulkan triangle example" @@ -71,49 +58,3 @@ appName = "Haskell Vulkan triangle example" windowWidth, windowHeight :: Int windowWidth = 800 windowHeight = 600 - -drawableSize :: SDL.Window -> IO Extent2D -drawableSize win = do - SDL.V2 w h <- SDL.vkGetDrawableSize win - pure $ Extent2D (fromIntegral w) (fromIntegral h) - ----------------------------------------------------------------- --- Pick a device with a unified graphics+present queue. ----------------------------------------------------------------- - -createGraphicalDevice - :: (MonadResource m, MonadFail m) - => Instance - -> SurfaceKHR - -> m (PhysicalDevice, Device, Word32, Queue) -createGraphicalDevice inst surface = do - mPd <- pickPhysicalDevice inst suitable id - (_, phys) <- maybe (sayErr "No suitable devices found" >> error "no GPU") pure mPd - - -- One queue family with both graphics and present capability. - let queueSpec = QueueSpec 1 $ \i q -> - if isGraphicsQueueFamily q - then isPresentQueueFamily phys surface i - else pure False - Just (qInfos, getQs) <- assignQueues phys (Identity queueSpec) - - let deviceReqs = - [ RequireDeviceExtension Nothing e minBound - | e <- Init.getRequiredDeviceExtensions - ] ++ frameDeviceRequirements - dev <- createDeviceFromRequirements deviceReqs [] phys - zero { queueCreateInfos = SomeStruct <$> qInfos } - Identity (QueueFamilyIndex familyIdx, queue) <- liftIO (getQs dev) - pure (phys, dev, familyIdx, queue) - where - suitable phys = runMaybeT $ do - (_, exts) <- enumerateDeviceExtensionProperties phys Nothing - True <- pure $ V.any ((Init.getRequiredDeviceExtensions !! 0 ==) . extensionName) exts - qProps <- getPhysicalDeviceQueueFamilyProperties phys - True <- pure $ V.any isGraphicsQueueFamily qProps - let presentSupport i = - isPresentQueueFamily phys surface (QueueFamilyIndex (fromIntegral i)) - hasPresent <- V.or <$> V.imapM (\i _ -> presentSupport i) qProps - True <- pure hasPresent - heaps <- memoryHeaps <$> getPhysicalDeviceMemoryProperties phys - pure (sum $ DI.size <$> heaps) diff --git a/examples/vulkan-examples.cabal b/examples/vulkan-examples.cabal index 4f2912039..e939b5754 100644 --- a/examples/vulkan-examples.cabal +++ b/examples/vulkan-examples.cabal @@ -46,6 +46,7 @@ library Camera Frame Framebuffer + InitDevice Orphans RefCounted Swapchain @@ -53,7 +54,6 @@ library Utils VkResources Vma - Window Window.GLFW Window.SDL2 other-modules: From d5436572b39f9bc434c803379b5a3bb3bc58f049 Mon Sep 17 00:00:00 2001 From: IC Rainbow Date: Tue, 5 May 2026 01:56:24 +0300 Subject: [PATCH 3/5] Meta-cleanup --- examples/hlsl/Init.hs | 8 ++++---- examples/lib/Utils.hs | 7 ------- examples/package.yaml | 3 --- examples/rays/Init.hs | 5 ++--- examples/resize/Main.hs | 3 +-- examples/vulkan-examples.cabal | 6 +++--- 6 files changed, 10 insertions(+), 22 deletions(-) diff --git a/examples/hlsl/Init.hs b/examples/hlsl/Init.hs index d12636712..529644567 100644 --- a/examples/hlsl/Init.hs +++ b/examples/hlsl/Init.hs @@ -18,7 +18,7 @@ import Vulkan.Core12.Promoted_From_VK_KHR_timeline_semaphore import Vulkan.Extensions.VK_KHR_timeline_semaphore import qualified SDL.Video as SDL -import Utils ( noSuchThing, (<&&>) ) +import Utils ( noSuchThing ) import VkResources ( Queues(..) ) import qualified Vma import Vulkan.CStruct.Extends @@ -141,8 +141,8 @@ queueRequirements queueRequirements phys surf = Queues (QueueSpec 1 isGraphicsPresentQueue) where isGraphicsPresentQueue queueFamilyIndex queueFamilyProperties = - pure (isGraphicsQueueFamily queueFamilyProperties) - <&&> isPresentQueueFamily phys surf queueFamilyIndex + (&& isGraphicsQueueFamily queueFamilyProperties) + <$> isPresentQueueFamily phys surf queueFamilyIndex deviceHasSwapchain :: MonadIO m => PhysicalDevice -> m Bool deviceHasSwapchain dev = do @@ -164,7 +164,7 @@ deviceHasTimelineSemaphores phys = do = feats pure hasTimelineSemaphores - hasExt <&&> hasFeat + (&&) <$> hasExt <*> hasFeat ---------------------------------------------------------------- -- VulkanMemoryAllocator diff --git a/examples/lib/Utils.hs b/examples/lib/Utils.hs index e169005e8..eb8c893ac 100644 --- a/examples/lib/Utils.hs +++ b/examples/lib/Utils.hs @@ -2,7 +2,6 @@ module Utils ( loopJust , loopUntilM , noSuchThing - , (<&&>) ) where import Control.Concurrent ( ) @@ -28,9 +27,3 @@ loopUntilM m = do noSuchThing :: MonadIO m => String -> m a noSuchThing message = liftIO . throwIO $ IOError Nothing NoSuchThing "" message Nothing Nothing - --- | Short-circuiting applicative @&&@ — evaluates the right action only if --- the left one yielded 'True'… well, actually 'liftA2' evaluates both, but --- this matches the original pre-existing helper used in hlsl/rays. -(<&&>) :: Applicative f => f Bool -> f Bool -> f Bool -(<&&>) = liftA2 (&&) diff --git a/examples/package.yaml b/examples/package.yaml index d401414e1..8ca011f27 100644 --- a/examples/package.yaml +++ b/examples/package.yaml @@ -166,7 +166,6 @@ executables: when: - condition: '!flag(have-shaderc)' buildable: false - ghc-options: -eventlog rays: main: Main.hs @@ -196,7 +195,6 @@ executables: when: - condition: '!flag(raytracing)' buildable: false - ghc-options: -eventlog vrcube: main: Main.hs @@ -231,7 +229,6 @@ executables: when: - condition: '!flag(vr)' buildable: false - ghc-options: -eventlog when: - condition: os(windows) diff --git a/examples/rays/Init.hs b/examples/rays/Init.hs index f67ea6756..40c4b2f0a 100644 --- a/examples/rays/Init.hs +++ b/examples/rays/Init.hs @@ -18,7 +18,6 @@ import Data.Word import qualified SDL.Video as SDL import Say import Utils ( noSuchThing - , (<&&>) ) import VkResources ( Queues(..) ) import qualified Vma @@ -172,8 +171,8 @@ queueRequirements queueRequirements phys surf = Queues (QueueSpec 1 isGraphicsPresentQueue) where isGraphicsPresentQueue queueFamilyIndex queueFamilyProperties = - pure (isGraphicsQueueFamily queueFamilyProperties) - <&&> isPresentQueueFamily phys surf queueFamilyIndex + (&& isGraphicsQueueFamily queueFamilyProperties) + <$> isPresentQueueFamily phys surf queueFamilyIndex getDeviceRTProps :: MonadIO m => PhysicalDevice -> m RTInfo getDeviceRTProps phys = do diff --git a/examples/resize/Main.hs b/examples/resize/Main.hs index f4cc00125..fb278a32a 100644 --- a/examples/resize/Main.hs +++ b/examples/resize/Main.hs @@ -128,7 +128,7 @@ main = prettyError . runResourceT $ do -- Long-lived render setup. Both the graphics pipeline (currently dormant) -- and the Julia compute pipeline are created up front. (_, renderPass) <- Pipeline.createRenderPass dev (SurfaceFormatKHR.format (sFormat initialSC)) - (_, pipeline) <- Pipeline.createPipeline dev renderPass + -- (_, pipeline) <- Pipeline.createPipeline dev renderPass juliaPL <- createJuliaPipeline dev -- Per-swapchain bindings: framebuffers + Julia descriptor sets, both pinned @@ -406,4 +406,3 @@ reportFrameTime nsec = do frameBudgetPercent = ceiling (100 * frameTimeMSec / frameTimeBudgetMSec) :: Int when (frameBudgetPercent > 50) $ sayErrString (show frameTimeMSec <> "ms \t" <> show frameBudgetPercent <> "%") - diff --git a/examples/vulkan-examples.cabal b/examples/vulkan-examples.cabal index e939b5754..d731e3328 100644 --- a/examples/vulkan-examples.cabal +++ b/examples/vulkan-examples.cabal @@ -230,7 +230,7 @@ executable hlsl TypeOperators TypeSynonymInstances ViewPatterns - ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -eventlog + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N build-depends: VulkanMemoryAllocator , base <5 @@ -352,7 +352,7 @@ executable rays TypeOperators TypeSynonymInstances ViewPatterns - ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -eventlog + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N build-depends: VulkanMemoryAllocator , base <5 @@ -678,7 +678,7 @@ executable vrcube TypeOperators TypeSynonymInstances ViewPatterns - ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -eventlog + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N build-depends: VulkanMemoryAllocator , base <5 From 08bb876971874d27bc024e2a8243cff629b5d1d3 Mon Sep 17 00:00:00 2001 From: IC Rainbow Date: Tue, 5 May 2026 02:14:11 +0300 Subject: [PATCH 4/5] Ueniversal Queue --- examples/hlsl/Init.hs | 168 ++------------------- examples/hlsl/Main.hs | 32 ++-- examples/hlsl/Render.hs | 2 +- examples/lib/Frame.hs | 2 +- examples/lib/InitDevice.hs | 109 +++++++++----- examples/lib/Triangle.hs | 2 +- examples/lib/VkResources.hs | 25 +++- examples/rays/AccelerationStructure.hs | 4 +- examples/rays/Init.hs | 195 +++++++------------------ examples/rays/Main.hs | 35 +++-- examples/rays/Render.hs | 2 +- examples/resize/Main.hs | 11 +- examples/triangle-glfw/Main.hs | 18 +-- examples/triangle-sdl2/Main.hs | 18 +-- 14 files changed, 232 insertions(+), 391 deletions(-) diff --git a/examples/hlsl/Init.hs b/examples/hlsl/Init.hs index 529644567..f7208b520 100644 --- a/examples/hlsl/Init.hs +++ b/examples/hlsl/Init.hs @@ -1,174 +1,32 @@ {-# LANGUAGE QuasiQuotes #-} + module Init - ( Init.createInstance - , Init.createDevice + ( myApiVersion + , deviceRequirements , createVMA ) where -import Control.Applicative ( empty ) -import Control.Monad ( unless ) -import Control.Monad.IO.Class -import Control.Monad.Trans.Maybe ( MaybeT(..) ) import Control.Monad.Trans.Resource -import qualified Data.Vector as V -import Data.Vector ( Vector ) import Data.Word -import Say -import Vulkan.Core12.Promoted_From_VK_KHR_timeline_semaphore -import Vulkan.Extensions.VK_KHR_timeline_semaphore -import qualified SDL.Video as SDL -import Utils ( noSuchThing ) -import VkResources ( Queues(..) ) +import Frame ( frameDeviceRequirements ) import qualified Vma -import Vulkan.CStruct.Extends -import Vulkan.Core10 as Vk - hiding ( withBuffer - , withImage - ) -import qualified Vulkan.Core10 as MemoryHeap (MemoryHeap(..)) -import Vulkan.Extensions.VK_KHR_get_physical_device_properties2 -import Vulkan.Extensions.VK_KHR_surface -import Vulkan.Extensions.VK_KHR_swapchain -import Vulkan.Requirement -import qualified Vulkan.Utils.Init.SDL2 as VkInit -import Vulkan.Utils.Initialization -import Vulkan.Utils.QueueAssignment +import Vulkan.Core10 +import Vulkan.Requirement ( DeviceRequirement ) import qualified Vulkan.Utils.Requirements.TH as U import Vulkan.Zero import VulkanMemoryAllocator ( Allocator ) -import Window.SDL2 myApiVersion :: Word32 myApiVersion = API_VERSION_1_0 ----------------------------------------------------------------- --- Instance Creation ----------------------------------------------------------------- - -createInstance :: MonadResource m => SDL.Window -> m Instance -createInstance win = VkInit.withInstance - win - (Just zero { applicationName = Nothing, apiVersion = myApiVersion }) - [ RequireInstanceExtension - Nothing - KHR_GET_PHYSICAL_DEVICE_PROPERTIES_2_EXTENSION_NAME - minBound - ] - [] - ----------------------------------------------------------------- --- Device creation ----------------------------------------------------------------- - -createDevice - :: forall m - . (MonadResource m) - => Instance - -> SDL.Window - -> m - ( PhysicalDevice - , Device - , Queues (QueueFamilyIndex, Queue) - , SurfaceKHR - ) -createDevice inst win = do - (_ , surf) <- createSurface inst win - (pdi, phys) <- - maybe (noSuchThing "Unable to find appropriate PhysicalDevice") pure - =<< pickPhysicalDevice inst (physicalDeviceInfo surf) pdiScore - sayErr . ("Using device: " <>) =<< physicalDeviceName phys - let deviceCreateInfo = - zero { queueCreateInfos = SomeStruct <$> pdiQueueCreateInfos pdi } - reqs = [U.reqs| - 1.0 - VK_KHR_swapchain - VK_KHR_timeline_semaphore - PhysicalDeviceTimelineSemaphoreFeatures.timelineSemaphore - |] - dev <- createDeviceFromRequirements reqs [] phys deviceCreateInfo - queues <- liftIO $ pdiGetQueues pdi dev - pure (phys, dev, queues, surf) - ----------------------------------------------------------------- --- Physical device tools ----------------------------------------------------------------- - --- | The Ord instance prioritises devices with more memory -data PhysicalDeviceInfo = PhysicalDeviceInfo - { pdiTotalMemory :: Word64 - , pdiQueueCreateInfos :: Vector (DeviceQueueCreateInfo '[]) - , pdiGetQueues :: Device -> IO (Queues (QueueFamilyIndex, Queue)) - } - -pdiScore :: PhysicalDeviceInfo -> Word64 -pdiScore = pdiTotalMemory - -physicalDeviceInfo - :: MonadIO m => SurfaceKHR -> PhysicalDevice -> m (Maybe PhysicalDeviceInfo) -physicalDeviceInfo surf phys = runMaybeT $ do - deviceName <- physicalDeviceName phys - - hasTimelineSemaphores <- deviceHasTimelineSemaphores phys - unless hasTimelineSemaphores $ do - sayErr - $ "Not using physical device " - <> deviceName - <> " because it doesn't support timeline semaphores" - empty - - hasSwapchainSupport <- deviceHasSwapchain phys - unless hasSwapchainSupport $ do - sayErr - $ "Not using physical device " - <> deviceName - <> " because it doesn't support swapchains" - empty - - (pdiQueueCreateInfos, pdiGetQueues) <- MaybeT - $ assignQueues phys (queueRequirements phys surf) - - -- Score by total device memory. - pdiTotalMemory <- do - heaps <- memoryHeaps <$> getPhysicalDeviceMemoryProperties phys - pure $ sum (MemoryHeap.size <$> heaps) - - pure PhysicalDeviceInfo { .. } - --- | A graphics queue that can also present to the given surface. -queueRequirements - :: MonadIO m => PhysicalDevice -> SurfaceKHR -> Queues (QueueSpec m) -queueRequirements phys surf = Queues (QueueSpec 1 isGraphicsPresentQueue) - where - isGraphicsPresentQueue queueFamilyIndex queueFamilyProperties = - (&& isGraphicsQueueFamily queueFamilyProperties) - <$> isPresentQueueFamily phys surf queueFamilyIndex - -deviceHasSwapchain :: MonadIO m => PhysicalDevice -> m Bool -deviceHasSwapchain dev = do - (_, extensions) <- enumerateDeviceExtensionProperties dev Nothing - pure $ V.any ((KHR_SWAPCHAIN_EXTENSION_NAME ==) . extensionName) extensions - -deviceHasTimelineSemaphores :: MonadIO m => PhysicalDevice -> m Bool -deviceHasTimelineSemaphores phys = do - let - hasExt = do - (_, extensions) <- enumerateDeviceExtensionProperties phys Nothing - pure $ V.any - ((KHR_TIMELINE_SEMAPHORE_EXTENSION_NAME ==) . extensionName) - extensions - - hasFeat = do - feats <- getPhysicalDeviceFeatures2KHR phys - let _ ::& (PhysicalDeviceTimelineSemaphoreFeatures hasTimelineSemaphores :& ()) - = feats - pure hasTimelineSemaphores - - (&&) <$> hasExt <*> hasFeat - ----------------------------------------------------------------- --- VulkanMemoryAllocator ----------------------------------------------------------------- +-- | Device requirements: API version, swapchain, plus the timeline-semaphore +-- bits the recycling 'Frame' machinery needs. +deviceRequirements :: [DeviceRequirement] +deviceRequirements = [U.reqs| + 1.0 + VK_KHR_swapchain + |] ++ frameDeviceRequirements createVMA :: MonadResource m => Instance -> PhysicalDevice -> Device -> m Allocator diff --git a/examples/hlsl/Main.hs b/examples/hlsl/Main.hs index 7a7242128..a1f3c4a96 100644 --- a/examples/hlsl/Main.hs +++ b/examples/hlsl/Main.hs @@ -5,19 +5,23 @@ module Main where import Control.Monad.IO.Class import Control.Monad.Trans.Resource import Data.IORef +import Data.Text.Encoding ( decodeUtf8 ) import Frame ( Frame(..) , advanceFrame + , frameInstanceRequirements , initialFrame , runFrame ) import qualified Framebuffer -import Init ( createDevice - , createInstance - , createVMA +import Init ( createVMA + , deviceRequirements + , myApiVersion ) +import InitDevice ( withDevice ) import RefCounted ( releaseRefCounted ) import Render ( renderFrame ) import qualified RenderPass +import Say ( sayErr ) import SDL ( showWindow , time ) @@ -29,10 +33,13 @@ import Swapchain ( Swapchain(..) import Utils ( loopJust ) import VkResources ( mkVkResources ) import qualified Pipeline -import Vulkan.Core10 ( pattern NULL_HANDLE ) +import Vulkan.Core10 hiding ( withDevice ) import Vulkan.Extensions.VK_KHR_surface as SurfaceFormatKHR ( SurfaceFormatKHR(..) ) +import qualified Vulkan.Utils.Init.SDL2 as VkInit +import Vulkan.Zero ( zero ) import Window.SDL2 ( RefreshLimit(..) + , createSurface , createWindow , drawableSize , shouldQuit @@ -45,11 +52,18 @@ main = runResourceT $ do -- Initialization -- withSDL - win <- createWindow "Vulkan 🚀 Haskell" 1280 720 - inst <- Init.createInstance win - (phys, dev, qs, surf) <- Init.createDevice inst win - vma <- createVMA inst phys dev - vr <- liftIO $ mkVkResources inst phys dev vma qs + win <- createWindow "Vulkan 🚀 Haskell" 1280 720 + inst <- VkInit.withInstance + win + (Just zero { applicationName = Nothing, apiVersion = myApiVersion }) + frameInstanceRequirements + [] + (_, surf) <- createSurface inst win + (phys, dev, qs) <- withDevice inst surf deviceRequirements + vma <- createVMA inst phys dev + props <- getPhysicalDeviceProperties phys + sayErr $ "Using device: " <> decodeUtf8 (deviceName props) + vr <- liftIO $ mkVkResources inst phys dev vma qs -- Initial swapchain initialSize <- liftIO $ drawableSize win diff --git a/examples/hlsl/Render.hs b/examples/hlsl/Render.hs index 6ba5acadf..53ec4c3e6 100644 --- a/examples/hlsl/Render.hs +++ b/examples/hlsl/Render.hs @@ -45,7 +45,7 @@ renderFrame vr renderPass pipeline framebuffers f = do let RecycledResources {..} = fRecycled f sc = fSwapchain f dev = vrDevice vr - Queues (_, gQ) = vrQueues vr + gQ = snd (qGraphics (vrQueues vr)) oneSecond = 1e9 -- Hold a refcount on the swapchain release group so it survives this frame diff --git a/examples/lib/Frame.hs b/examples/lib/Frame.hs index ffe224e04..ba9158dd7 100644 --- a/examples/lib/Frame.hs +++ b/examples/lib/Frame.hs @@ -237,7 +237,7 @@ withTimelineSemaphore dev initial = mkRecycledResources :: MonadResource m => VkResources -> m RecycledResources mkRecycledResources vr = do let dev = vrDevice vr - QueueFamilyIndex qfi = fst (graphicsQueue (vrQueues vr)) + QueueFamilyIndex qfi = fst (qGraphics (vrQueues vr)) (_, rrImageAvailable) <- withSemaphore dev (zero ::& SemaphoreTypeCreateInfo SEMAPHORE_TYPE_BINARY 0 :& ()) diff --git a/examples/lib/InitDevice.hs b/examples/lib/InitDevice.hs index e5ebc9397..5f70c2b85 100644 --- a/examples/lib/InitDevice.hs +++ b/examples/lib/InitDevice.hs @@ -1,19 +1,19 @@ -- | Helpers shared by the windowed examples for picking a physical device --- and creating a logical device with one unified graphics+present queue. +-- and creating a logical device with a uniform G/C/T queue kit (graphics+ +-- present, compute, transfer). module InitDevice - ( withGraphicsPresentDevice + ( withDevice ) where import Control.Monad.IO.Class -import Control.Monad.Trans.Maybe ( runMaybeT ) import Control.Monad.Trans.Resource -import Data.Functor.Identity ( Identity(..) ) import qualified Data.Vector as V import Data.Word ( Word64 ) import Say ( sayErr ) import Utils ( noSuchThing ) +import VkResources ( Queues(..) ) import Vulkan.CStruct.Extends ( SomeStruct(..) ) -import Vulkan.Core10 +import Vulkan.Core10 hiding ( withDevice ) import qualified Vulkan.Core10.DeviceInitialization as DI import Vulkan.Extensions.VK_KHR_surface @@ -25,51 +25,94 @@ import Vulkan.Utils.Initialization ( createDeviceFromRequirements import Vulkan.Utils.QueueAssignment ( QueueFamilyIndex(..) , QueueSpec(..) , assignQueues + , isComputeQueueFamily , isGraphicsQueueFamily , isPresentQueueFamily + , isTransferOnlyQueueFamily ) import Vulkan.Zero ( zero ) --- | Pick a physical device that has a graphics queue family that can also --- present to the given surface, then create a logical device exposing one --- queue from that family. Devices are scored by total memory. +-- | Pick a physical device that has a graphics+present queue family AND a +-- compute queue family, then create a logical device exposing one queue per +-- G/C/T slot. Devices are scored by total memory. +-- +-- Each capability prefers its own dedicated family (async compute, DMA-only +-- transfer); falls back to aliasing graphics+present when the hardware +-- doesn't expose one. When two slots target the same family, two distinct +-- 'Queue' handles are still allocated within that family with the requested +-- priorities (1.0 / 0.5 / 0.2). -- -- Pass any extra device requirements (extensions, features, API version) in --- @extraReqs@; they are forwarded to 'createDeviceFromRequirements', which --- will fail loudly if the chosen device cannot satisfy them. -withGraphicsPresentDevice +-- @extraReqs@; they are forwarded to 'createDeviceFromRequirements'. +withDevice :: (MonadResource m, MonadFail m) => Instance -> SurfaceKHR -> [DeviceRequirement] - -> m (PhysicalDevice, Device, QueueFamilyIndex, Queue) -withGraphicsPresentDevice inst surface extraReqs = do - mPd <- pickPhysicalDevice inst (suitable surface) id - (_, phys) <- case mPd of + -> m (PhysicalDevice, Device, Queues (QueueFamilyIndex, Queue)) +withDevice inst surface extraReqs = do + mPd <- pickPhysicalDevice inst (discoverFamilies surface) + (snd :: (Queues QueueFamilyIndex, Word64) -> Word64) + ((qFams, _score), phys) <- case mPd of Just x -> pure x Nothing -> sayErr "No suitable physical device found" - >> noSuchThing "No physical device with graphics+present queue" + >> noSuchThing "No physical device with graphics+present and compute" + + let mkSpec target prio = QueueSpec prio (\i _ -> pure (i == target)) + specs = mkSpec <$> qFams <*> Queues 1.0 0.5 0.2 - let queueSpec = QueueSpec 1 $ \i q -> - if isGraphicsQueueFamily q - then isPresentQueueFamily phys surface i - else pure False - Just (qInfos, getQs) <- assignQueues phys (Identity queueSpec) + Just (qInfos, getQs) <- assignQueues phys specs dev <- createDeviceFromRequirements extraReqs [] phys zero { queueCreateInfos = SomeStruct <$> qInfos } - Identity (qfi, queue) <- liftIO (getQs dev) - pure (phys, dev, qfi, queue) - where - suitable surf phys = runMaybeT $ do - qProps <- getPhysicalDeviceQueueFamilyProperties phys - True <- pure $ V.any isGraphicsQueueFamily qProps - let presentSupport i = - isPresentQueueFamily phys surf (QueueFamilyIndex (fromIntegral i)) - hasPresent <- V.or <$> V.imapM (\i _ -> presentSupport i) qProps - True <- pure hasPresent - heaps <- memoryHeaps <$> getPhysicalDeviceMemoryProperties phys - pure (sum $ DI.size <$> heaps :: Word64) + qs <- liftIO (getQs dev) + pure (phys, dev, qs) + +-- | Suitability probe used by 'pickPhysicalDevice'. Returns the discovered +-- @(graphics+present, compute, transfer)@ family triple plus a memory score. +discoverFamilies + :: MonadIO m + => SurfaceKHR + -> PhysicalDevice + -> m (Maybe (Queues QueueFamilyIndex, Word64)) +discoverFamilies surf phys = do + qProps <- getPhysicalDeviceQueueFamilyProperties phys + let withIndex = V.toList (V.indexed qProps) + asQfi i = QueueFamilyIndex (fromIntegral i) + + graphicsFamilies = + [ asQfi i | (i, q) <- withIndex, isGraphicsQueueFamily q ] + asyncCompute = + [ asQfi i + | (i, q) <- withIndex + , isComputeQueueFamily q && not (isGraphicsQueueFamily q) + ] + anyCompute = + [ asQfi i | (i, q) <- withIndex, isComputeQueueFamily q ] + dedicatedTransfer = + [ asQfi i | (i, q) <- withIndex, isTransferOnlyQueueFamily q ] + + presentResults <- mapM + (\qfi -> (qfi, ) <$> isPresentQueueFamily phys surf qfi) + graphicsFamilies + let mGp = case [ qfi | (qfi, True) <- presentResults ] of + qfi : _ -> Just qfi + [] -> Nothing + mCp = case asyncCompute of + qfi : _ -> Just qfi + [] -> case anyCompute of + qfi : _ -> Just qfi + [] -> Nothing + + case (mGp, mCp) of + (Just gp, Just cp) -> do + let tf = case dedicatedTransfer of + qfi : _ -> qfi + [] -> cp + heaps <- memoryHeaps <$> getPhysicalDeviceMemoryProperties phys + let score = sum (DI.size <$> heaps) :: Word64 + pure (Just (Queues gp cp tf, score)) + _ -> pure Nothing diff --git a/examples/lib/Triangle.hs b/examples/lib/Triangle.hs index e772e00b0..94f35d203 100644 --- a/examples/lib/Triangle.hs +++ b/examples/lib/Triangle.hs @@ -113,7 +113,7 @@ drawTriangle vr renderPass pipeline framebuffers f = do let RecycledResources {..} = fRecycled f sc = fSwapchain f dev = vrDevice vr - Queues (_, gQ) = vrQueues vr + gQ = snd (qGraphics (vrQueues vr)) oneSecond = 1e9 (acquireResult, imageIndex) <- diff --git a/examples/lib/VkResources.hs b/examples/lib/VkResources.hs index 5ae201e0e..ed4c171b5 100644 --- a/examples/lib/VkResources.hs +++ b/examples/lib/VkResources.hs @@ -12,10 +12,10 @@ import Vulkan.Core10 ( CommandPool , Device , Instance , PhysicalDevice + , Queue , Semaphore ) import Vulkan.Utils.QueueAssignment ( QueueFamilyIndex ) -import Vulkan.Core10 ( Queue ) import VulkanMemoryAllocator ( Allocator ) -- | A bunch of long-lived handles that the application carries around. @@ -34,12 +34,27 @@ data VkResources = VkResources -- 'Left' is a blocking read. } --- | The shape of the queues each example needs. Single graphics queue covers --- every windowed example here; parameterised over the queue type so the same --- shape works with 'Vulkan.Utils.QueueAssignment.assignQueues'. -newtype Queues q = Queues { graphicsQueue :: q } +-- | The full G/C/T queue kit each windowed example gets. Fields are filled +-- from 'InitDevice.withDevice' with priorities 1.0/0.5/0.2; on hardware that +-- exposes dedicated families they target async-compute and DMA-only families, +-- otherwise they alias the graphics+present family (with distinct 'Queue' +-- handles allocated within that shared family). +-- +-- The same shape is used internally by 'InitDevice' to feed +-- 'Vulkan.Utils.QueueAssignment.assignQueues' (as @Queues (QueueSpec m)@). +data Queues a = Queues + { qGraphics :: a -- ^ graphics + present, priority 1.0 + , qCompute :: a -- ^ compute (prefers compute-only family), priority 0.5 + , qTransfer :: a -- ^ transfer (prefers transfer-only family), priority 0.2 + } deriving (Functor, Foldable, Traversable) +-- | Elementwise zip — handy for combining priorities with predicates when +-- building a @Queues (QueueSpec m)@. +instance Applicative Queues where + pure x = Queues x x x + Queues f g h <*> Queues x y z = Queues (f x) (g y) (h z) + -- | The bits of state recycled between frames: two binary semaphores used -- for image-acquire / render-done synchronisation, and the command pool the -- frame's commands are recorded into. diff --git a/examples/rays/AccelerationStructure.hs b/examples/rays/AccelerationStructure.hs index a8eb2c716..e91307570 100644 --- a/examples/rays/AccelerationStructure.hs +++ b/examples/rays/AccelerationStructure.hs @@ -231,8 +231,8 @@ oneShotComputeCommands -> m () oneShotComputeCommands vr cmds = do let dev = vrDevice vr - Queues (QueueFamilyIndex graphicsQueueFamilyIndex, graphicsQueue) = - vrQueues vr + (QueueFamilyIndex graphicsQueueFamilyIndex, graphicsQueue) = + qGraphics (vrQueues vr) (poolKey, commandPool) <- withCommandPool dev zero { queueFamilyIndex = graphicsQueueFamilyIndex } diff --git a/examples/rays/Init.hs b/examples/rays/Init.hs index 40c4b2f0a..406786a61 100644 --- a/examples/rays/Init.hs +++ b/examples/rays/Init.hs @@ -1,79 +1,83 @@ {-# LANGUAGE QuasiQuotes #-} module Init - ( Init.createInstance - , Init.createDevice - , PhysicalDeviceInfo(..) + ( myApiVersion + , instanceRequirements + , deviceRequirements , RTInfo(..) + , getDeviceRTProps , createVMA ) where -import Control.Applicative ( empty ) import Control.Monad.IO.Class -import Control.Monad.Trans.Maybe ( MaybeT(..) ) import Control.Monad.Trans.Resource -import Data.Foldable ( traverse_ ) -import Data.Vector ( Vector ) import Data.Word -import qualified SDL.Video as SDL -import Say -import Utils ( noSuchThing + +import Frame ( frameDeviceRequirements + , frameInstanceRequirements ) -import VkResources ( Queues(..) ) import qualified Vma -import Vulkan.CStruct.Extends -import Vulkan.Core10 as Vk - hiding ( withBuffer - , withImage +import Vulkan.CStruct.Extends ( pattern (:&) + , pattern (::&) ) -import qualified Vulkan.Core10 as MemoryHeap (MemoryHeap(..)) +import Vulkan.Core10 import Vulkan.Core11 ( pattern API_VERSION_1_1 ) import Vulkan.Core12.Promoted_From_VK_KHR_buffer_device_address -import Vulkan.Core12.Promoted_From_VK_KHR_timeline_semaphore - ( PhysicalDeviceTimelineSemaphoreFeatures(..) + ( PhysicalDeviceBufferDeviceAddressFeatures(..) ) import Vulkan.Extensions.VK_EXT_debug_utils ( pattern EXT_DEBUG_UTILS_EXTENSION_NAME ) import Vulkan.Extensions.VK_KHR_acceleration_structure + ( PhysicalDeviceAccelerationStructureFeaturesKHR(..) + ) import Vulkan.Extensions.VK_KHR_get_physical_device_properties2 + ( getPhysicalDeviceProperties2KHR + ) import Vulkan.Extensions.VK_KHR_ray_tracing_pipeline -import Vulkan.Extensions.VK_KHR_surface -import Vulkan.Requirement -import qualified Vulkan.Utils.Init.SDL2 as VkInit -import Vulkan.Utils.Initialization -import Vulkan.Utils.QueueAssignment -import Vulkan.Utils.Requirements -import Vulkan.Utils.Requirements.TH ( reqs ) -import Vulkan.Zero + ( PhysicalDeviceRayTracingPipelineFeaturesKHR(..) + , PhysicalDeviceRayTracingPipelinePropertiesKHR(..) + ) +import Vulkan.Requirement ( DeviceRequirement + , InstanceRequirement(..) + ) +import qualified Vulkan.Utils.Requirements.TH as U import VulkanMemoryAllocator ( Allocator , AllocatorCreateFlagBits(..) ) -import Window.SDL2 myApiVersion :: Word32 myApiVersion = API_VERSION_1_1 ----------------------------------------------------------------- --- Instance Creation ----------------------------------------------------------------- - -createInstance :: MonadResource m => SDL.Window -> m Instance -createInstance win = VkInit.withInstance - win - (Just zero { applicationName = Nothing, apiVersion = myApiVersion }) - [ RequireInstanceExtension - Nothing - KHR_GET_PHYSICAL_DEVICE_PROPERTIES_2_EXTENSION_NAME - minBound - -- Required so the @nameObject@ calls scattered through the example can load - -- their function pointer; we don't enable the messenger though. - , RequireInstanceExtension Nothing EXT_DEBUG_UTILS_EXTENSION_NAME minBound - ] - [] +-- | Instance requirements: Frame's bits plus debug-utils so the @nameObject@ +-- calls scattered through the example can load their function pointer (we +-- don't enable the messenger though). +instanceRequirements :: [InstanceRequirement] +instanceRequirements = + frameInstanceRequirements + ++ [RequireInstanceExtension Nothing EXT_DEBUG_UTILS_EXTENSION_NAME minBound] ----------------------------------------------------------------- --- Device creation ----------------------------------------------------------------- +-- | Device requirements: API version, swapchain, Frame's timeline-semaphore +-- bits, plus the full ray-tracing extension family. +deviceRequirements :: [DeviceRequirement] +deviceRequirements = + [U.reqs| + 1.0 + VK_KHR_swapchain + + -- Ray tracing + 1.2.162 + PhysicalDeviceRayTracingPipelineFeaturesKHR.rayTracingPipeline + PhysicalDeviceAccelerationStructureFeaturesKHR.accelerationStructure + PhysicalDeviceBufferDeviceAddressFeatures.bufferDeviceAddress + VK_KHR_ray_tracing_pipeline + VK_KHR_acceleration_structure + VK_EXT_descriptor_indexing + VK_KHR_buffer_device_address + VK_KHR_deferred_host_operations + VK_KHR_get_memory_requirements2 + VK_KHR_maintenance3 + VK_KHR_pipeline_library + |] ++ frameDeviceRequirements -- | Information for ray tracing (queried from device properties). data RTInfo = RTInfo @@ -81,99 +85,6 @@ data RTInfo = RTInfo , rtiShaderGroupBaseAlignment :: Word32 } -createDevice - :: forall m - . (MonadResource m) - => Instance - -> SDL.Window - -> m - ( PhysicalDevice - , PhysicalDeviceInfo - , Device - , Queues (QueueFamilyIndex, Queue) - , SurfaceKHR - ) -createDevice inst win = do - (_ , surf) <- createSurface inst win - - ((pdi, SomeStruct dci), phys) <- - maybe (noSuchThing "Unable to find appropriate PhysicalDevice") pure - =<< pickPhysicalDevice inst (physicalDeviceInfo surf) (pdiScore . fst) - sayErr . ("Using device: " <>) =<< physicalDeviceName phys - - (_, dev) <- withDevice phys dci Nothing allocate - - queues <- liftIO $ pdiGetQueues pdi dev - - pure (phys, pdi, dev, queues, surf) - -deviceRequirements :: [DeviceRequirement] -deviceRequirements = [reqs| - VK_KHR_swapchain - - VK_KHR_timeline_semaphore - PhysicalDeviceTimelineSemaphoreFeatures.timelineSemaphore - - -- Ray tracing - 1.2.162 - PhysicalDeviceRayTracingPipelineFeaturesKHR.rayTracingPipeline - PhysicalDeviceAccelerationStructureFeaturesKHR.accelerationStructure - PhysicalDeviceBufferDeviceAddressFeatures.bufferDeviceAddress - VK_KHR_ray_tracing_pipeline - VK_KHR_acceleration_structure - VK_EXT_descriptor_indexing - VK_KHR_buffer_device_address - VK_KHR_deferred_host_operations - VK_KHR_get_memory_requirements2 - VK_KHR_maintenance3 - VK_KHR_pipeline_library -|] - ----------------------------------------------------------------- --- Physical device tools ----------------------------------------------------------------- - -data PhysicalDeviceInfo = PhysicalDeviceInfo - { pdiTotalMemory :: Word64 - , pdiRTInfo :: RTInfo - , pdiQueueCreateInfos :: Vector (DeviceQueueCreateInfo '[]) - , pdiGetQueues :: Device -> IO (Queues (QueueFamilyIndex, Queue)) - } - -pdiScore :: PhysicalDeviceInfo -> Word64 -pdiScore = pdiTotalMemory - -physicalDeviceInfo - :: MonadIO m - => SurfaceKHR - -> PhysicalDevice - -> m (Maybe (PhysicalDeviceInfo, SomeStruct DeviceCreateInfo)) -physicalDeviceInfo surf phys = runMaybeT $ do - (mbDCI, rs, os) <- checkDeviceRequirements deviceRequirements [] phys zero - traverse_ sayErrString (requirementReport rs os) - SomeStruct dciNoQueues <- maybe empty pure mbDCI - - (pdiQueueCreateInfos, pdiGetQueues) <- MaybeT - $ assignQueues phys (queueRequirements phys surf) - let dci = - dciNoQueues { queueCreateInfos = SomeStruct <$> pdiQueueCreateInfos } - - pdiRTInfo <- getDeviceRTProps phys - - pdiTotalMemory <- do - heaps <- memoryHeaps <$> getPhysicalDeviceMemoryProperties phys - pure $ sum (MemoryHeap.size <$> heaps) - - pure (PhysicalDeviceInfo { .. }, SomeStruct dci) - -queueRequirements - :: MonadIO m => PhysicalDevice -> SurfaceKHR -> Queues (QueueSpec m) -queueRequirements phys surf = Queues (QueueSpec 1 isGraphicsPresentQueue) - where - isGraphicsPresentQueue queueFamilyIndex queueFamilyProperties = - (&& isGraphicsQueueFamily queueFamilyProperties) - <$> isPresentQueueFamily phys surf queueFamilyIndex - getDeviceRTProps :: MonadIO m => PhysicalDevice -> m RTInfo getDeviceRTProps phys = do props <- getPhysicalDeviceProperties2KHR phys @@ -182,10 +93,6 @@ getDeviceRTProps phys = do , rtiShaderGroupBaseAlignment = shaderGroupBaseAlignment } ----------------------------------------------------------------- --- VulkanMemoryAllocator ----------------------------------------------------------------- - createVMA :: MonadResource m => Instance -> PhysicalDevice -> Device -> m Allocator createVMA = Vma.createVMA ALLOCATOR_CREATE_BUFFER_DEVICE_ADDRESS_BIT myApiVersion diff --git a/examples/rays/Main.hs b/examples/rays/Main.hs index aabd5acf2..478322fa6 100644 --- a/examples/rays/Main.hs +++ b/examples/rays/Main.hs @@ -8,6 +8,7 @@ import Control.Monad.IO.Class import Control.Monad.Trans.Resource import Data.Foldable ( for_ ) import Data.IORef +import Data.Text.Encoding ( decodeUtf8 ) import Data.Word ( Word64 ) import Foreign.Ptr ( castPtr ) import Foreign.Storable ( sizeOf ) @@ -17,15 +18,18 @@ import Frame ( Frame(..) , numConcurrentFrames , runFrame ) -import Init ( PhysicalDeviceInfo(..) - , createDevice - , createInstance - , createVMA +import Init ( createVMA + , deviceRequirements + , getDeviceRTProps + , instanceRequirements + , myApiVersion ) +import InitDevice ( withDevice ) import qualified Pipeline import Render ( RenderState(..) , renderFrame ) +import Say ( sayErr ) import qualified SDL import Scene ( makeSceneBuffers ) import Swapchain ( allocSwapchain @@ -34,15 +38,17 @@ import Swapchain ( allocSwapchain ) import Utils ( loopJust ) import VkResources ( mkVkResources ) -import Vulkan.Core10 +import Vulkan.Core10 hiding ( withDevice ) import Vulkan.Zero ( zero ) import Vulkan.Core12.Promoted_From_VK_KHR_buffer_device_address ( BufferDeviceAddressInfo(..) , getBufferDeviceAddress ) +import qualified Vulkan.Utils.Init.SDL2 as VkInit import VulkanMemoryAllocator as VMA hiding ( getPhysicalDeviceProperties ) import Window.SDL2 ( RefreshLimit(..) + , createSurface , createWindow , drawableSize , shouldQuit @@ -52,11 +58,18 @@ import Window.SDL2 ( RefreshLimit(..) main :: IO () main = runResourceT $ do withSDL - win <- createWindow "Vulkan ⚡ Haskell" 1280 720 - inst <- Init.createInstance win - (phys, pdi, dev, qs, surf) <- Init.createDevice inst win - vma <- createVMA inst phys dev - vr <- liftIO $ mkVkResources inst phys dev vma qs + win <- createWindow "Vulkan ⚡ Haskell" 1280 720 + inst <- VkInit.withInstance + win + (Just zero { applicationName = Nothing, apiVersion = myApiVersion }) + instanceRequirements + [] + (_, surf) <- createSurface inst win + (phys, dev, qs) <- withDevice inst surf deviceRequirements + vma <- createVMA inst phys dev + props <- getPhysicalDeviceProperties phys + sayErr $ "Using device: " <> decodeUtf8 (deviceName props) + vr <- liftIO $ mkVkResources inst phys dev vma qs -- Initial swapchain initialSize <- liftIO $ drawableSize win @@ -67,7 +80,7 @@ main = runResourceT $ do (_, tlas) <- createTLAS vr sceneBuffers -- RT pipeline + descriptor sets - let rtInfo = pdiRTInfo pdi + rtInfo <- getDeviceRTProps phys (_, descSetLayout) <- Pipeline.createRTDescriptorSetLayout dev (_, pipelineLayout) <- Pipeline.createRTPipelineLayout dev descSetLayout (_, pipeline, numGroups) <- Pipeline.createPipeline dev pipelineLayout diff --git a/examples/rays/Render.hs b/examples/rays/Render.hs index c9ded1e4f..03b97f26e 100644 --- a/examples/rays/Render.hs +++ b/examples/rays/Render.hs @@ -70,7 +70,7 @@ renderFrame vr rs f = do let RecycledResources {..} = fRecycled f sc = fSwapchain f dev = vrDevice vr - Queues (_, gQ) = vrQueues vr + gQ = snd (qGraphics (vrQueues vr)) RTInfo {..} = rsRTInfo rs slot = fromIntegral (fIndex f) `mod` numConcurrentFrames descriptorSet = rsDescriptorSets rs ! slot diff --git a/examples/resize/Main.hs b/examples/resize/Main.hs index fb278a32a..c51094251 100644 --- a/examples/resize/Main.hs +++ b/examples/resize/Main.hs @@ -28,7 +28,7 @@ import Init ( createVMA , deviceRequirements , myApiVersion ) -import InitDevice ( withGraphicsPresentDevice ) +import InitDevice ( withDevice ) import Data.Text.Encoding ( decodeUtf8 ) import Julia ( JuliaPipeline(..) , createJuliaDescriptorSets @@ -77,6 +77,7 @@ import Vulkan.Core10 as Vk , createImageView , createInstance , withBuffer + , withDevice , withImage ) import qualified Vulkan.Core10 as CommandBufferBeginInfo (CommandBufferBeginInfo(..)) @@ -111,14 +112,12 @@ main = prettyError . runResourceT $ do (Just zero { applicationName = Nothing, apiVersion = myApiVersion }) frameInstanceRequirements [] - (_, surface) <- createSurface inst sdlWindow - (phys, dev, qfi, graphicsQueue) <- - withGraphicsPresentDevice inst surface deviceRequirements + (_, surface) <- createSurface inst sdlWindow + (phys, dev, qs) <- withDevice inst surface deviceRequirements vma <- createVMA inst phys dev props <- getPhysicalDeviceProperties phys sayErr $ "Using device: " <> decodeUtf8 (deviceName props) - let qs = Queues (qfi, graphicsQueue) vr <- liftIO $ mkVkResources inst phys dev vma qs -- Initial swapchain at the requested size. @@ -231,7 +230,7 @@ renderJulia renderJulia vr jp bindings f = do let RecycledResources {..} = fRecycled f sc = fSwapchain f - Queues (_, gQ) = vrQueues vr + gQ = snd (qGraphics (vrQueues vr)) dev = vrDevice vr oneSecond = 1e9 Extent2D imageWidth imageHeight = sExtent sc diff --git a/examples/triangle-glfw/Main.hs b/examples/triangle-glfw/Main.hs index a20fd8c80..16e012e88 100644 --- a/examples/triangle-glfw/Main.hs +++ b/examples/triangle-glfw/Main.hs @@ -7,14 +7,12 @@ import Control.Monad.Trans.Resource import qualified Data.Text as Text import Data.String ( IsString ) import Data.Text.Encoding ( decodeUtf8 ) -import InitDevice ( withGraphicsPresentDevice ) +import InitDevice ( withDevice ) import Say import qualified Triangle import qualified Vma -import VkResources ( Queues(..) - , mkVkResources - ) -import Vulkan.Core10 +import VkResources ( mkVkResources ) +import Vulkan.Core10 hiding ( withDevice ) import Vulkan.Requirement ( DeviceRequirement(..) ) import Vulkan.Zero ( zero ) import qualified Vulkan.Utils.Init.GLFW as Init @@ -33,18 +31,16 @@ main = runResourceT $ do (Just zero { applicationName = Just appName, apiVersion = API_VERSION_1_0 }) frameInstanceRequirements [] - surface <- Init.withSurface inst window + surface <- Init.withSurface inst window let deviceReqs = [ RequireDeviceExtension Nothing e minBound | e <- Init.getRequiredDeviceExtensions ] ++ frameDeviceRequirements - (phys, dev, qfi, gQueue) <- - withGraphicsPresentDevice inst surface deviceReqs - vma <- Vma.createVMA zero API_VERSION_1_0 inst phys dev - props <- getPhysicalDeviceProperties phys + (phys, dev, qs) <- withDevice inst surface deviceReqs + vma <- Vma.createVMA zero API_VERSION_1_0 inst phys dev + props <- getPhysicalDeviceProperties phys sayErr $ "Using device: " <> decodeUtf8 (deviceName props) - let qs = Queues (qfi, gQueue) vr <- liftIO $ mkVkResources inst phys dev vma qs initialSize <- Window.drawableSize window diff --git a/examples/triangle-sdl2/Main.hs b/examples/triangle-sdl2/Main.hs index 6898a51b4..d97e502d4 100644 --- a/examples/triangle-sdl2/Main.hs +++ b/examples/triangle-sdl2/Main.hs @@ -6,14 +6,12 @@ import Control.Monad.IO.Class import Control.Monad.Trans.Resource import Data.String ( IsString ) import Data.Text.Encoding ( decodeUtf8 ) -import InitDevice ( withGraphicsPresentDevice ) +import InitDevice ( withDevice ) import Say import qualified Triangle import qualified Vma -import VkResources ( Queues(..) - , mkVkResources - ) -import Vulkan.Core10 +import VkResources ( mkVkResources ) +import Vulkan.Core10 hiding ( withDevice ) import Vulkan.Requirement ( DeviceRequirement(..) ) import Vulkan.Zero ( zero ) import qualified Vulkan.Utils.Init.SDL2 as Init @@ -32,18 +30,16 @@ main = runResourceT $ do (Just zero { applicationName = Just appName, apiVersion = API_VERSION_1_0 }) frameInstanceRequirements [] - surface <- Init.withSurface inst window + surface <- Init.withSurface inst window let deviceReqs = [ RequireDeviceExtension Nothing e minBound | e <- Init.getRequiredDeviceExtensions ] ++ frameDeviceRequirements - (phys, dev, qfi, gQueue) <- - withGraphicsPresentDevice inst surface deviceReqs - vma <- Vma.createVMA zero API_VERSION_1_0 inst phys dev - props <- getPhysicalDeviceProperties phys + (phys, dev, qs) <- withDevice inst surface deviceReqs + vma <- Vma.createVMA zero API_VERSION_1_0 inst phys dev + props <- getPhysicalDeviceProperties phys sayErr $ "Using device: " <> decodeUtf8 (deviceName props) - let qs = Queues (qfi, gQueue) vr <- liftIO $ mkVkResources inst phys dev vma qs initialSize <- Window.drawableSize window From 3c5ca637ebe22881c9793d0e365d487ae02aa4e7 Mon Sep 17 00:00:00 2001 From: IC Rainbow Date: Tue, 5 May 2026 02:17:45 +0300 Subject: [PATCH 5/5] Fourmalize --- examples/compute/Main.hs | 440 ++++++++++-------- examples/hlsl/Init.hs | 29 +- examples/hlsl/Main.hs | 172 +++---- examples/hlsl/Pipeline.hs | 189 ++++---- examples/hlsl/Render.hs | 199 +++++---- examples/hlsl/RenderPass.hs | 94 ++-- examples/info/Main.hs | 23 +- examples/lib/Camera.hs | 52 ++- examples/lib/Frame.hs | 371 ++++++++------- examples/lib/Framebuffer.hs | 110 +++-- examples/lib/InitDevice.hs | 174 ++++---- examples/lib/Orphans.hs | 42 +- examples/lib/RefCounted.hs | 74 +-- examples/lib/Swapchain.hs | 187 ++++---- examples/lib/Triangle.hs | 510 +++++++++++---------- examples/lib/Utils.hs | 33 +- examples/lib/VkResources.hs | 115 ++--- examples/lib/Vma.hs | 78 ++-- examples/lib/Window/GLFW.hs | 74 +-- examples/lib/Window/SDL2.hs | 115 ++--- examples/rays/AccelerationStructure.hs | 345 +++++++------- examples/rays/Init.hs | 104 +++-- examples/rays/Main.hs | 249 ++++++----- examples/rays/Pipeline.hs | 445 ++++++++++-------- examples/rays/Render.hs | 400 +++++++++-------- examples/rays/Scene.hs | 148 +++--- examples/resize/Init.hs | 29 +- examples/resize/Julia.hs | 225 ++++++---- examples/resize/Julia/Constants.hs | 4 +- examples/resize/Main.hs | 594 +++++++++++++------------ examples/resize/Pipeline.hs | 272 ++++++----- examples/triangle-glfw/Main.hs | 57 +-- examples/triangle-sdl2/Main.hs | 55 +-- 33 files changed, 3302 insertions(+), 2706 deletions(-) diff --git a/examples/compute/Main.hs b/examples/compute/Main.hs index 31a0783ce..de9bbdba8 100644 --- a/examples/compute/Main.hs +++ b/examples/compute/Main.hs @@ -1,6 +1,6 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} {-# OPTIONS_GHC -Wno-missing-signatures #-} module Main @@ -8,51 +8,55 @@ module Main ) where -import qualified Codec.Picture as JP -import Control.Exception.Safe -import Control.Monad.IO.Class -import Control.Monad.Trans.Resource -import Data.Bits -import qualified Data.ByteString.Lazy as BSL -import Data.Functor.Identity ( Identity(..) ) -import qualified Data.Vector as V -import Data.Word -import Foreign.Marshal.Array ( peekArray ) -import Foreign.Ptr ( Ptr, plusPtr ) -import Foreign.Storable ( sizeOf ) -import Say +import qualified Codec.Picture as JP +import Control.Exception.Safe +import Control.Monad.IO.Class +import Control.Monad.Trans.Resource +import Data.Bits +import qualified Data.ByteString.Lazy as BSL +import Data.Functor.Identity (Identity (..)) +import qualified Data.Vector as V +import Data.Word +import Foreign.Marshal.Array (peekArray) +import Foreign.Ptr (Ptr, plusPtr) +import Foreign.Storable (sizeOf) +import Say import qualified Vma -import Vulkan.CStruct.Extends -import Vulkan.CStruct.Utils ( FixedArray - , lowerArrayPtr - ) -import Vulkan.Core10 as Vk - hiding ( withBuffer - , withImage - ) -import qualified Vulkan.Core10 as CommandBufferBeginInfo (CommandBufferBeginInfo(..)) -import qualified Vulkan.Core10 as CommandPoolCreateInfo (CommandPoolCreateInfo(..)) -import qualified Vulkan.Core10 as PipelineLayoutCreateInfo (PipelineLayoutCreateInfo(..)) +import Vulkan.CStruct.Extends +import Vulkan.CStruct.Utils + ( FixedArray + , lowerArrayPtr + ) +import Vulkan.Core10 as Vk hiding + ( withBuffer + , withImage + ) +import qualified Vulkan.Core10 as CommandBufferBeginInfo (CommandBufferBeginInfo (..)) +import qualified Vulkan.Core10 as CommandPoolCreateInfo (CommandPoolCreateInfo (..)) +import qualified Vulkan.Core10 as PipelineLayoutCreateInfo (PipelineLayoutCreateInfo (..)) import qualified Vulkan.Core10.DeviceInitialization as DI -import Vulkan.Extensions.VK_EXT_debug_utils -import Vulkan.Requirement ( InstanceRequirement(..) ) -import Vulkan.Utils.Debug ( debugCallbackPtr ) -import qualified Vulkan.Utils.Init.Headless as Init -import Vulkan.Utils.Initialization ( createDeviceFromRequirements - , physicalDeviceName - , pickPhysicalDevice - ) -import Vulkan.Utils.QueueAssignment ( QueueFamilyIndex(..) - , QueueSpec(..) - , assignQueues - , isComputeQueueFamily - ) -import Vulkan.Utils.ShaderQQ.GLSL.Glslang -import Vulkan.Zero -import VulkanMemoryAllocator as VMA - hiding ( getPhysicalDeviceProperties ) -import qualified VulkanMemoryAllocator as AllocationCreateInfo (AllocationCreateInfo(..)) +import Vulkan.Extensions.VK_EXT_debug_utils +import Vulkan.Requirement (InstanceRequirement (..)) +import Vulkan.Utils.Debug (debugCallbackPtr) +import qualified Vulkan.Utils.Init.Headless as Init +import Vulkan.Utils.Initialization + ( createDeviceFromRequirements + , physicalDeviceName + , pickPhysicalDevice + ) +import Vulkan.Utils.QueueAssignment + ( QueueFamilyIndex (..) + , QueueSpec (..) + , assignQueues + , isComputeQueueFamily + ) +import Vulkan.Utils.ShaderQQ.GLSL.Glslang +import Vulkan.Zero +import VulkanMemoryAllocator as VMA hiding + ( getPhysicalDeviceProperties + ) +import qualified VulkanMemoryAllocator as AllocationCreateInfo (AllocationCreateInfo (..)) ---------------------------------------------------------------- -- The program @@ -64,8 +68,9 @@ main = runResourceT $ do (phys, computeQueueFamilyIndex, dev) <- Main.createDevice inst allocator <- Vma.createVMA zero myApiVersion inst phys dev - image <- render allocator dev computeQueueFamilyIndex - `finally` deviceWaitIdle dev + image <- + render allocator dev computeQueueFamilyIndex + `finally` deviceWaitIdle dev let filename = "julia.png" sayErr $ "Writing " <> filename liftIO $ BSL.writeFile filename (JP.encodePng image) @@ -77,150 +82,179 @@ render -> Word32 -> ResourceT IO (JP.Image JP.PixelRGBA8) render allocator dev computeQueueFamilyIndex = do - let width, height, workgroupX, workgroupY :: Int - width = 512 - height = width - workgroupX = 32 - workgroupY = 4 + let + width, height, workgroupX, workgroupY :: Int + width = 512 + height = width + workgroupX = 32 + workgroupY = 4 -- Create a buffer into which to render. Mapped + GPU_TO_CPU so the host can -- read the image back. - (_, (buffer, bufferAllocation, bufferAllocationInfo)) <- VMA.withBuffer - allocator - zero { size = fromIntegral $ width * height * 4 * sizeOf (0 :: Float) - , usage = BUFFER_USAGE_STORAGE_BUFFER_BIT - } - zero { AllocationCreateInfo.flags = ALLOCATION_CREATE_MAPPED_BIT - , usage = MEMORY_USAGE_GPU_TO_CPU - } - allocate + (_, (buffer, bufferAllocation, bufferAllocationInfo)) <- + VMA.withBuffer + allocator + zero + { size = fromIntegral $ width * height * 4 * sizeOf (0 :: Float) + , usage = BUFFER_USAGE_STORAGE_BUFFER_BIT + } + zero + { AllocationCreateInfo.flags = ALLOCATION_CREATE_MAPPED_BIT + , usage = MEMORY_USAGE_GPU_TO_CPU + } + allocate -- Create a descriptor set and layout for this buffer (descriptorSet, descriptorSetLayout) <- do - (_, descriptorPool) <- withDescriptorPool - dev - zero { maxSets = 1 - , poolSizes = [DescriptorPoolSize DESCRIPTOR_TYPE_STORAGE_BUFFER 1] - } - Nothing - allocate - - (_, descriptorSetLayout) <- withDescriptorSetLayout - dev - zero { bindings = [ zero { binding = 0 - , descriptorType = DESCRIPTOR_TYPE_STORAGE_BUFFER - , descriptorCount = 1 - , stageFlags = SHADER_STAGE_COMPUTE_BIT - } - ] - } - Nothing - allocate + (_, descriptorPool) <- + withDescriptorPool + dev + zero + { maxSets = 1 + , poolSizes = [DescriptorPoolSize DESCRIPTOR_TYPE_STORAGE_BUFFER 1] + } + Nothing + allocate + + (_, descriptorSetLayout) <- + withDescriptorSetLayout + dev + zero + { bindings = + [ zero + { binding = 0 + , descriptorType = DESCRIPTOR_TYPE_STORAGE_BUFFER + , descriptorCount = 1 + , stageFlags = SHADER_STAGE_COMPUTE_BIT + } + ] + } + Nothing + allocate -- Don't use `withDescriptorSets`: the set is freed when the pool is. - [descriptorSet] <- allocateDescriptorSets - dev - zero { descriptorPool = descriptorPool - , setLayouts = [descriptorSetLayout] - } + [descriptorSet] <- + allocateDescriptorSets + dev + zero + { descriptorPool = descriptorPool + , setLayouts = [descriptorSetLayout] + } pure (descriptorSet, descriptorSetLayout) updateDescriptorSets dev - [ SomeStruct zero { dstSet = descriptorSet - , dstBinding = 0 - , descriptorType = DESCRIPTOR_TYPE_STORAGE_BUFFER - , descriptorCount = 1 - , bufferInfo = [DescriptorBufferInfo buffer 0 WHOLE_SIZE] - } + [ SomeStruct + zero + { dstSet = descriptorSet + , dstBinding = 0 + , descriptorType = DESCRIPTOR_TYPE_STORAGE_BUFFER + , descriptorCount = 1 + , bufferInfo = [DescriptorBufferInfo buffer 0 WHOLE_SIZE] + } ] [] -- Create our shader and compute pipeline - shader <- createShader dev - (_, pipelineLayout) <- withPipelineLayout - dev - zero { PipelineLayoutCreateInfo.setLayouts = [descriptorSetLayout] } - Nothing - allocate - let pipelineCreateInfo :: ComputePipelineCreateInfo '[] - pipelineCreateInfo = zero { layout = pipelineLayout - , stage = shader - , basePipelineHandle = zero - } - (_, (_, [computePipeline])) <- withComputePipelines - dev - zero - [SomeStruct pipelineCreateInfo] - Nothing - allocate + shader <- createShader dev + (_, pipelineLayout) <- + withPipelineLayout + dev + zero{PipelineLayoutCreateInfo.setLayouts = [descriptorSetLayout]} + Nothing + allocate + let + pipelineCreateInfo :: ComputePipelineCreateInfo '[] + pipelineCreateInfo = + zero + { layout = pipelineLayout + , stage = shader + , basePipelineHandle = zero + } + (_, (_, [computePipeline])) <- + withComputePipelines + dev + zero + [SomeStruct pipelineCreateInfo] + Nothing + allocate -- Create a command buffer - let commandPoolCreateInfo = zero - { CommandPoolCreateInfo.queueFamilyIndex = computeQueueFamilyIndex - } + let commandPoolCreateInfo = + zero + { CommandPoolCreateInfo.queueFamilyIndex = computeQueueFamilyIndex + } (_, commandPool) <- withCommandPool dev commandPoolCreateInfo Nothing allocate - let commandBufferAllocateInfo = zero - { commandPool = commandPool - , level = COMMAND_BUFFER_LEVEL_PRIMARY - , commandBufferCount = 1 - } + let commandBufferAllocateInfo = + zero + { commandPool = commandPool + , level = COMMAND_BUFFER_LEVEL_PRIMARY + , commandBufferCount = 1 + } (_, [commandBuffer]) <- withCommandBuffers dev commandBufferAllocateInfo allocate -- Fill command buffer useCommandBuffer - commandBuffer - zero { CommandBufferBeginInfo.flags = COMMAND_BUFFER_USAGE_ONE_TIME_SUBMIT_BIT } + commandBuffer + zero{CommandBufferBeginInfo.flags = COMMAND_BUFFER_USAGE_ONE_TIME_SUBMIT_BIT} $ do - cmdBindPipeline commandBuffer - PIPELINE_BIND_POINT_COMPUTE - computePipeline - cmdBindDescriptorSets commandBuffer - PIPELINE_BIND_POINT_COMPUTE - pipelineLayout - 0 - [descriptorSet] - [] - cmdDispatch - commandBuffer - (ceiling (realToFrac width / realToFrac @_ @Float workgroupX)) - (ceiling (realToFrac height / realToFrac @_ @Float workgroupY)) - 1 + cmdBindPipeline + commandBuffer + PIPELINE_BIND_POINT_COMPUTE + computePipeline + cmdBindDescriptorSets + commandBuffer + PIPELINE_BIND_POINT_COMPUTE + pipelineLayout + 0 + [descriptorSet] + [] + cmdDispatch + commandBuffer + (ceiling (realToFrac width / realToFrac @_ @Float workgroupX)) + (ceiling (realToFrac height / realToFrac @_ @Float workgroupY)) + 1 -- Create a fence so we can know when render is finished (_, fence) <- withFence dev zero Nothing allocate - let submitInfo = zero { commandBuffers = [commandBufferHandle commandBuffer] } + let submitInfo = zero{commandBuffers = [commandBufferHandle commandBuffer]} computeQueue <- getDeviceQueue dev computeQueueFamilyIndex 0 queueSubmit computeQueue [SomeStruct submitInfo] fence let fenceTimeout = 1e9 -- 1 second waitForFences dev [fence] True fenceTimeout >>= \case TIMEOUT -> throwString "Timed out waiting for compute" - _ -> pure () + _ -> pure () -- If the buffer allocation is not HOST_COHERENT this will ensure the changes -- are present on the CPU. invalidateAllocation allocator bufferAllocation 0 WHOLE_SIZE -- TODO: speed this bit up, it's hopelessly slow - let pixelAddr :: Int -> Int -> Ptr (FixedArray 4 Float) - pixelAddr x y = plusPtr (mappedData bufferAllocationInfo) - (((y * width) + x) * 4 * sizeOf (0 :: Float)) - liftIO $ JP.withImage - 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 - ) + let + pixelAddr :: Int -> Int -> Ptr (FixedArray 4 Float) + pixelAddr x y = + plusPtr + (mappedData bufferAllocationInfo) + (((y * width) + x) * 4 * sizeOf (0 :: Float)) + liftIO $ + JP.withImage + 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 + ) -- | Create a compute shader createShader :: Device -> ResourceT IO (SomeStruct PipelineShaderStageCreateInfo) createShader dev = do - let compCode = [comp| + let compCode = + [comp| #version 450 #extension GL_ARB_separate_shader_objects : enable @@ -283,11 +317,13 @@ createShader dev = do } } |] - (_, compModule) <- withShaderModule dev zero { code = compCode } Nothing allocate - let compShaderStageCreateInfo = zero { stage = SHADER_STAGE_COMPUTE_BIT - , module' = compModule - , name = "main" - } + (_, compModule) <- withShaderModule dev zero{code = compCode} Nothing allocate + let compShaderStageCreateInfo = + zero + { stage = SHADER_STAGE_COMPUTE_BIT + , module' = compModule + , name = "main" + } pure $ SomeStruct compShaderStageCreateInfo ---------------------------------------------------------------- @@ -298,29 +334,33 @@ myApiVersion :: Word32 myApiVersion = API_VERSION_1_0 -- | Create an instance with a debug messenger and validation layer. -createInstance :: MonadResource m => m Instance +createInstance :: (MonadResource m) => m Instance createInstance = do - inst <- Init.withInstance - (Just zero { applicationName = Nothing, apiVersion = myApiVersion }) - [ RequireInstanceExtension - { instanceExtensionLayerName = Nothing - , instanceExtensionName = EXT_DEBUG_UTILS_EXTENSION_NAME - , instanceExtensionMinVersion = minBound - } - ] - [ RequireInstanceLayer - { instanceLayerName = "VK_LAYER_KHRONOS_validation" - , instanceLayerMinVersion = minBound - } - ] - let debugMessengerCreateInfo = zero - { messageSeverity = DEBUG_UTILS_MESSAGE_SEVERITY_WARNING_BIT_EXT - .|. DEBUG_UTILS_MESSAGE_SEVERITY_ERROR_BIT_EXT - , messageType = DEBUG_UTILS_MESSAGE_TYPE_GENERAL_BIT_EXT - .|. DEBUG_UTILS_MESSAGE_TYPE_VALIDATION_BIT_EXT - .|. DEBUG_UTILS_MESSAGE_TYPE_PERFORMANCE_BIT_EXT - , pfnUserCallback = debugCallbackPtr - } + inst <- + Init.withInstance + (Just zero{applicationName = Nothing, apiVersion = myApiVersion}) + [ RequireInstanceExtension + { instanceExtensionLayerName = Nothing + , instanceExtensionName = EXT_DEBUG_UTILS_EXTENSION_NAME + , instanceExtensionMinVersion = minBound + } + ] + [ RequireInstanceLayer + { instanceLayerName = "VK_LAYER_KHRONOS_validation" + , instanceLayerMinVersion = minBound + } + ] + let debugMessengerCreateInfo = + zero + { messageSeverity = + DEBUG_UTILS_MESSAGE_SEVERITY_WARNING_BIT_EXT + .|. DEBUG_UTILS_MESSAGE_SEVERITY_ERROR_BIT_EXT + , messageType = + DEBUG_UTILS_MESSAGE_TYPE_GENERAL_BIT_EXT + .|. DEBUG_UTILS_MESSAGE_TYPE_VALIDATION_BIT_EXT + .|. DEBUG_UTILS_MESSAGE_TYPE_PERFORMANCE_BIT_EXT + , pfnUserCallback = debugCallbackPtr + } _ <- withDebugUtilsMessengerEXT inst debugMessengerCreateInfo Nothing allocate pure inst @@ -329,31 +369,37 @@ createDevice => Instance -> m (PhysicalDevice, Word32, Device) createDevice inst = do - mPd <- pickPhysicalDevice inst hasComputeQueue id - (_, phys) <- maybe (throwString "Unable to find appropriate PhysicalDevice") - pure - mPd + mPd <- pickPhysicalDevice inst hasComputeQueue id + (_, phys) <- + maybe + (throwString "Unable to find appropriate PhysicalDevice") + pure + mPd sayErr . ("Using device: " <>) =<< physicalDeviceName phys - mAssign <- assignQueues - phys - (Identity (QueueSpec 1 (\_ q -> pure (isComputeQueueFamily q)))) - (qInfos, getQs) <- maybe (throwString "Unable to assign compute queue") - pure - mAssign - dev <- createDeviceFromRequirements - [] - [] - phys - zero { queueCreateInfos = SomeStruct <$> qInfos } + mAssign <- + assignQueues + phys + (Identity (QueueSpec 1 (\_ q -> pure (isComputeQueueFamily q)))) + (qInfos, getQs) <- + maybe + (throwString "Unable to assign compute queue") + pure + mAssign + dev <- + createDeviceFromRequirements + [] + [] + phys + zero{queueCreateInfos = SomeStruct <$> qInfos} Identity (QueueFamilyIndex computeFamilyIdx, _q) <- liftIO (getQs dev) pure (phys, computeFamilyIdx, dev) - where - hasComputeQueue :: MonadIO m => PhysicalDevice -> m (Maybe Word64) - hasComputeQueue phys = do - qProps <- getPhysicalDeviceQueueFamilyProperties phys - if V.any isComputeQueueFamily qProps - then do - heaps <- memoryHeaps <$> getPhysicalDeviceMemoryProperties phys - pure (Just (sum (DI.size <$> heaps))) - else pure Nothing + where + hasComputeQueue :: (MonadIO m) => PhysicalDevice -> m (Maybe Word64) + hasComputeQueue phys = do + qProps <- getPhysicalDeviceQueueFamilyProperties phys + if V.any isComputeQueueFamily qProps + then do + heaps <- memoryHeaps <$> getPhysicalDeviceMemoryProperties phys + pure (Just (sum (DI.size <$> heaps))) + else pure Nothing diff --git a/examples/hlsl/Init.hs b/examples/hlsl/Init.hs index f7208b520..df5ea74af 100644 --- a/examples/hlsl/Init.hs +++ b/examples/hlsl/Init.hs @@ -6,28 +6,31 @@ module Init , createVMA ) where -import Control.Monad.Trans.Resource -import Data.Word +import Control.Monad.Trans.Resource +import Data.Word -import Frame ( frameDeviceRequirements ) +import Frame (frameDeviceRequirements) import qualified Vma -import Vulkan.Core10 -import Vulkan.Requirement ( DeviceRequirement ) -import qualified Vulkan.Utils.Requirements.TH as U -import Vulkan.Zero -import VulkanMemoryAllocator ( Allocator ) +import Vulkan.Core10 +import Vulkan.Requirement (DeviceRequirement) +import qualified Vulkan.Utils.Requirements.TH as U +import Vulkan.Zero +import VulkanMemoryAllocator (Allocator) myApiVersion :: Word32 myApiVersion = API_VERSION_1_0 --- | Device requirements: API version, swapchain, plus the timeline-semaphore --- bits the recycling 'Frame' machinery needs. +{- | Device requirements: API version, swapchain, plus the timeline-semaphore +bits the recycling 'Frame' machinery needs. +-} deviceRequirements :: [DeviceRequirement] -deviceRequirements = [U.reqs| +deviceRequirements = + [U.reqs| 1.0 VK_KHR_swapchain - |] ++ frameDeviceRequirements + |] + ++ frameDeviceRequirements createVMA - :: MonadResource m => Instance -> PhysicalDevice -> Device -> m Allocator + :: (MonadResource m) => Instance -> PhysicalDevice -> Device -> m Allocator createVMA = Vma.createVMA zero myApiVersion diff --git a/examples/hlsl/Main.hs b/examples/hlsl/Main.hs index a1f3c4a96..d8b644c71 100644 --- a/examples/hlsl/Main.hs +++ b/examples/hlsl/Main.hs @@ -2,49 +2,55 @@ module Main where -import Control.Monad.IO.Class -import Control.Monad.Trans.Resource -import Data.IORef -import Data.Text.Encoding ( decodeUtf8 ) -import Frame ( Frame(..) - , advanceFrame - , frameInstanceRequirements - , initialFrame - , runFrame - ) +import Control.Monad.IO.Class +import Control.Monad.Trans.Resource +import Data.IORef +import Data.Text.Encoding (decodeUtf8) +import Frame + ( Frame (..) + , advanceFrame + , frameInstanceRequirements + , initialFrame + , runFrame + ) import qualified Framebuffer -import Init ( createVMA - , deviceRequirements - , myApiVersion - ) -import InitDevice ( withDevice ) -import RefCounted ( releaseRefCounted ) -import Render ( renderFrame ) -import qualified RenderPass -import Say ( sayErr ) -import SDL ( showWindow - , time - ) -import Swapchain ( Swapchain(..) - , allocSwapchain - , recreateSwapchain - , threwSwapchainError - ) -import Utils ( loopJust ) -import VkResources ( mkVkResources ) +import Init + ( createVMA + , deviceRequirements + , myApiVersion + ) +import InitDevice (withDevice) import qualified Pipeline -import Vulkan.Core10 hiding ( withDevice ) -import Vulkan.Extensions.VK_KHR_surface as SurfaceFormatKHR - ( SurfaceFormatKHR(..) ) -import qualified Vulkan.Utils.Init.SDL2 as VkInit -import Vulkan.Zero ( zero ) -import Window.SDL2 ( RefreshLimit(..) - , createSurface - , createWindow - , drawableSize - , shouldQuit - , withSDL - ) +import RefCounted (releaseRefCounted) +import Render (renderFrame) +import qualified RenderPass +import SDL + ( showWindow + , time + ) +import Say (sayErr) +import Swapchain + ( Swapchain (..) + , allocSwapchain + , recreateSwapchain + , threwSwapchainError + ) +import Utils (loopJust) +import VkResources (mkVkResources) +import Vulkan.Core10 hiding (withDevice) +import Vulkan.Extensions.VK_KHR_surface as SurfaceFormatKHR + ( SurfaceFormatKHR (..) + ) +import qualified Vulkan.Utils.Init.SDL2 as VkInit +import Vulkan.Zero (zero) +import Window.SDL2 + ( RefreshLimit (..) + , createSurface + , createWindow + , drawableSize + , shouldQuit + , withSDL + ) main :: IO () main = runResourceT $ do @@ -52,60 +58,66 @@ main = runResourceT $ do -- Initialization -- withSDL - win <- createWindow "Vulkan 🚀 Haskell" 1280 720 - inst <- VkInit.withInstance - win - (Just zero { applicationName = Nothing, apiVersion = myApiVersion }) - frameInstanceRequirements - [] - (_, surf) <- createSurface inst win + win <- createWindow "Vulkan 🚀 Haskell" 1280 720 + inst <- + VkInit.withInstance + win + (Just zero{applicationName = Nothing, apiVersion = myApiVersion}) + frameInstanceRequirements + [] + (_, surf) <- createSurface inst win (phys, dev, qs) <- withDevice inst surf deviceRequirements - vma <- createVMA inst phys dev - props <- getPhysicalDeviceProperties phys + vma <- createVMA inst phys dev + props <- getPhysicalDeviceProperties phys sayErr $ "Using device: " <> decodeUtf8 (deviceName props) vr <- liftIO $ mkVkResources inst phys dev vma qs -- Initial swapchain - initialSize <- liftIO $ drawableSize win - initialSC <- allocSwapchain vr NULL_HANDLE initialSize surf - (_, renderPass) <- RenderPass.createRenderPass dev (SurfaceFormatKHR.format (sFormat initialSC)) - (_, pipeline) <- Pipeline.createPipeline dev renderPass - initialFBs <- Framebuffer.createFramebuffers dev renderPass (sImageViews initialSC) (sExtent initialSC) + initialSize <- liftIO $ drawableSize win + initialSC <- allocSwapchain vr NULL_HANDLE initialSize surf + (_, renderPass) <- RenderPass.createRenderPass dev (SurfaceFormatKHR.format (sFormat initialSC)) + (_, pipeline) <- Pipeline.createPipeline dev renderPass + initialFBs <- Framebuffer.createFramebuffers dev renderPass (sImageViews initialSC) (sExtent initialSC) - scRef <- liftIO $ newIORef initialSC - fbsRef <- liftIO $ newIORef initialFBs + scRef <- liftIO $ newIORef initialSC + fbsRef <- liftIO $ newIORef initialFBs - initial <- initialFrame vr initialSC + initial <- initialFrame vr initialSC showWindow win start <- SDL.time @Double let perFrame f = do - currentSC <- liftIO $ readIORef scRef + currentSC <- liftIO $ readIORef scRef (currentFBs, _rel) <- liftIO $ readIORef fbsRef - let f' = f { fSwapchain = currentSC } - needsNew <- threwSwapchainError $ liftIO $ runFrame vr f' $ - renderFrame vr renderPass pipeline currentFBs f' - sc' <- if needsNew - then do - newSize <- liftIO $ drawableSize win - sc' <- recreateSwapchain vr newSize currentSC - newFBs <- Framebuffer.createFramebuffers dev renderPass (sImageViews sc') (sExtent sc') - (_oldFbs, oldRel) <- liftIO $ readIORef fbsRef - releaseRefCounted oldRel - liftIO $ writeIORef scRef sc' - liftIO $ writeIORef fbsRef newFBs - pure sc' - else pure currentSC + let f' = f{fSwapchain = currentSC} + needsNew <- + threwSwapchainError $ + liftIO $ + runFrame vr f' $ + renderFrame vr renderPass pipeline currentFBs f' + sc' <- + if needsNew + then do + newSize <- liftIO $ drawableSize win + sc' <- recreateSwapchain vr newSize currentSC + newFBs <- Framebuffer.createFramebuffers dev renderPass (sImageViews sc') (sExtent sc') + (_oldFbs, oldRel) <- liftIO $ readIORef fbsRef + releaseRefCounted oldRel + liftIO $ writeIORef scRef sc' + liftIO $ writeIORef fbsRef newFBs + pure sc' + else pure currentSC advanceFrame vr sc' f' - loop f = shouldQuit (TimeLimit 6) >>= \case - True -> do - end <- SDL.time - let fps = realToFrac (fIndex f) / (end - start) :: Double - liftIO $ putStrLn $ "Average: " <> show fps - pure Nothing - False -> Just <$> perFrame f + loop f = + shouldQuit (TimeLimit 6) >>= \case + True -> do + end <- SDL.time + let fps = realToFrac (fIndex f) / (end - start) :: Double + liftIO $ putStrLn $ "Average: " <> show fps + pure Nothing + False -> Just <$> perFrame f loopJust loop initial diff --git a/examples/hlsl/Pipeline.hs b/examples/hlsl/Pipeline.hs index 29b30acec..1add01af4 100644 --- a/examples/hlsl/Pipeline.hs +++ b/examples/hlsl/Pipeline.hs @@ -1,25 +1,25 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} module Pipeline ( createPipeline ) where -import Control.Monad.Trans.Resource -import Data.Bits -import Data.Foldable ( traverse_ ) -import qualified Data.Vector as V -import Vulkan.CStruct.Extends -import Vulkan.Core10 as Vk - hiding ( withBuffer - , withImage - ) -import Vulkan.Utils.ShaderQQ.HLSL.Shaderc - ( frag - , vert - ) -import Vulkan.Zero +import Control.Monad.Trans.Resource +import Data.Bits +import Data.Foldable (traverse_) +import qualified Data.Vector as V +import Vulkan.CStruct.Extends +import Vulkan.Core10 as Vk hiding + ( withBuffer + , withImage + ) +import Vulkan.Utils.ShaderQQ.HLSL.Shaderc + ( frag + , vert + ) +import Vulkan.Zero -- | The most vanilla rendering pipeline; draws three vertices. createPipeline @@ -29,78 +29,96 @@ createPipeline -> m (ReleaseKey, Pipeline) createPipeline dev renderPass = do (shaderKeys, shaderStages) <- V.unzip <$> createShaders dev - (layoutKey , pipelineLayout) <- withPipelineLayout dev zero Nothing allocate - let pipelineCreateInfo :: GraphicsPipelineCreateInfo '[] - pipelineCreateInfo = zero - { stages = shaderStages - , vertexInputState = Just zero - , inputAssemblyState = Just zero - { topology = PRIMITIVE_TOPOLOGY_TRIANGLE_LIST - , primitiveRestartEnable = False - } - , viewportState = Just - $ SomeStruct zero { viewportCount = 1, scissorCount = 1 } - , rasterizationState = Just . SomeStruct $ zero - { depthClampEnable = False - , rasterizerDiscardEnable = False - , lineWidth = 1 - , polygonMode = POLYGON_MODE_FILL - , cullMode = CULL_MODE_NONE - , frontFace = FRONT_FACE_CLOCKWISE - , depthBiasEnable = False - } - , multisampleState = Just . SomeStruct $ zero - { sampleShadingEnable = False - , rasterizationSamples = SAMPLE_COUNT_1_BIT - , minSampleShading = 1 - , sampleMask = [maxBound] - } - , depthStencilState = Nothing - , colorBlendState = Just . SomeStruct $ zero - { logicOpEnable = False - , attachments = - [ zero - { colorWriteMask = - COLOR_COMPONENT_R_BIT - .|. COLOR_COMPONENT_G_BIT - .|. COLOR_COMPONENT_B_BIT - .|. COLOR_COMPONENT_A_BIT - , blendEnable = False - } - ] - } - , dynamicState = Just zero - { dynamicStates = [ DYNAMIC_STATE_VIEWPORT - , DYNAMIC_STATE_SCISSOR - ] - } - , layout = pipelineLayout - , renderPass = renderPass - , subpass = 0 + (layoutKey, pipelineLayout) <- withPipelineLayout dev zero Nothing allocate + let + pipelineCreateInfo :: GraphicsPipelineCreateInfo '[] + pipelineCreateInfo = + zero + { stages = shaderStages + , vertexInputState = Just zero + , inputAssemblyState = + Just + zero + { topology = PRIMITIVE_TOPOLOGY_TRIANGLE_LIST + , primitiveRestartEnable = False + } + , viewportState = + Just $ + SomeStruct zero{viewportCount = 1, scissorCount = 1} + , rasterizationState = + Just . SomeStruct $ + zero + { depthClampEnable = False + , rasterizerDiscardEnable = False + , lineWidth = 1 + , polygonMode = POLYGON_MODE_FILL + , cullMode = CULL_MODE_NONE + , frontFace = FRONT_FACE_CLOCKWISE + , depthBiasEnable = False + } + , multisampleState = + Just . SomeStruct $ + zero + { sampleShadingEnable = False + , rasterizationSamples = SAMPLE_COUNT_1_BIT + , minSampleShading = 1 + , sampleMask = [maxBound] + } + , depthStencilState = Nothing + , colorBlendState = + Just . SomeStruct $ + zero + { logicOpEnable = False + , attachments = + [ zero + { colorWriteMask = + COLOR_COMPONENT_R_BIT + .|. COLOR_COMPONENT_G_BIT + .|. COLOR_COMPONENT_B_BIT + .|. COLOR_COMPONENT_A_BIT + , blendEnable = False + } + ] + } + , dynamicState = + Just + zero + { dynamicStates = + [ DYNAMIC_STATE_VIEWPORT + , DYNAMIC_STATE_SCISSOR + ] + } + , layout = pipelineLayout + , renderPass = renderPass + , subpass = 0 , basePipelineHandle = zero } - (key, (_, ~[graphicsPipeline])) <- withGraphicsPipelines - dev - zero - [SomeStruct pipelineCreateInfo] - Nothing - allocate + (key, (_, ~[graphicsPipeline])) <- + withGraphicsPipelines + dev + zero + [SomeStruct pipelineCreateInfo] + Nothing + allocate release layoutKey traverse_ release shaderKeys pure (key, graphicsPipeline) createShaders - :: MonadResource m + :: (MonadResource m) => Device -> m (V.Vector (ReleaseKey, SomeStruct PipelineShaderStageCreateInfo)) createShaders dev = do - let fragCode = [frag| + let + fragCode = + [frag| float4 main([[vk::location(0)]] const float3 col) : SV_TARGET { return float4(col, 1); } |] - vertCode = [vert| + vertCode = + [vert| const static float2 positions[3] = { {0.0, -0.5}, {0.5, 0.5}, @@ -127,16 +145,21 @@ createShaders dev = do return output; } |] - (fragKey, fragModule) <- withShaderModule dev zero { code = fragCode } Nothing allocate - (vertKey, vertModule) <- withShaderModule dev zero { code = vertCode } Nothing allocate - let vertShaderStageCreateInfo = zero { stage = SHADER_STAGE_VERTEX_BIT - , module' = vertModule - , name = "main" - } - fragShaderStageCreateInfo = zero { stage = SHADER_STAGE_FRAGMENT_BIT - , module' = fragModule - , name = "main" - } + (fragKey, fragModule) <- withShaderModule dev zero{code = fragCode} Nothing allocate + (vertKey, vertModule) <- withShaderModule dev zero{code = vertCode} Nothing allocate + let + vertShaderStageCreateInfo = + zero + { stage = SHADER_STAGE_VERTEX_BIT + , module' = vertModule + , name = "main" + } + fragShaderStageCreateInfo = + zero + { stage = SHADER_STAGE_FRAGMENT_BIT + , module' = fragModule + , name = "main" + } pure [ (vertKey, SomeStruct vertShaderStageCreateInfo) , (fragKey, SomeStruct fragShaderStageCreateInfo) diff --git a/examples/hlsl/Render.hs b/examples/hlsl/Render.hs index 53ec4c3e6..dfde9541d 100644 --- a/examples/hlsl/Render.hs +++ b/examples/hlsl/Render.hs @@ -4,34 +4,37 @@ module Render ( renderFrame ) where -import Control.Exception ( throwIO ) -import Control.Monad.IO.Class -import Control.Monad.Trans.Resource ( ResourceT - , allocate - ) -import Data.Vector ( (!), Vector ) -import Frame ( Frame(..) - , queueSubmitFrame - ) -import GHC.IO.Exception ( IOErrorType(TimeExpired) - , IOException(IOError) - ) -import RefCounted ( resourceTRefCount ) -import Swapchain ( Swapchain(..) ) -import UnliftIO.Exception ( throwString ) -import VkResources ( Queues(..) - , RecycledResources(..) - , VkResources(..) - ) -import Vulkan.CStruct.Extends -import Vulkan.Exception ( VulkanException(..) ) -import Vulkan.Core10 as Core10 -import qualified Vulkan.Core10 as CommandBufferBeginInfo (CommandBufferBeginInfo(..)) -import qualified Vulkan.Core10 as Extent2D (Extent2D(..)) -import Vulkan.Core12.Promoted_From_VK_KHR_timeline_semaphore -import Vulkan.Extensions.VK_KHR_swapchain - as Swap -import Vulkan.Zero +import Control.Exception (throwIO) +import Control.Monad.IO.Class +import Control.Monad.Trans.Resource + ( ResourceT + , allocate + ) +import Data.Vector (Vector, (!)) +import Frame + ( Frame (..) + , queueSubmitFrame + ) +import GHC.IO.Exception + ( IOErrorType (TimeExpired) + , IOException (IOError) + ) +import RefCounted (resourceTRefCount) +import Swapchain (Swapchain (..)) +import UnliftIO.Exception (throwString) +import VkResources + ( Queues (..) + , RecycledResources (..) + , VkResources (..) + ) +import Vulkan.CStruct.Extends +import Vulkan.Core10 as Core10 +import qualified Vulkan.Core10 as CommandBufferBeginInfo (CommandBufferBeginInfo (..)) +import qualified Vulkan.Core10 as Extent2D (Extent2D (..)) +import Vulkan.Core12.Promoted_From_VK_KHR_timeline_semaphore +import Vulkan.Exception (VulkanException (..)) +import Vulkan.Extensions.VK_KHR_swapchain as Swap +import Vulkan.Zero -- | Acquire an image, record a clear+draw, submit, and present. renderFrame @@ -42,11 +45,12 @@ renderFrame -> Frame -> ResourceT IO () renderFrame vr renderPass pipeline framebuffers f = do - let RecycledResources {..} = fRecycled f - sc = fSwapchain f - dev = vrDevice vr - gQ = snd (qGraphics (vrQueues vr)) - oneSecond = 1e9 + let + RecycledResources{..} = fRecycled f + sc = fSwapchain f + dev = vrDevice vr + gQ = snd (qGraphics (vrQueues vr)) + oneSecond = 1e9 -- Hold a refcount on the swapchain release group so it survives this frame -- if the window resizes mid-flight. @@ -56,84 +60,95 @@ renderFrame vr renderPass pipeline framebuffers f = do (acquireResult, imageIndex) <- acquireNextImageKHRSafe dev (sSwapchain sc) oneSecond rrImageAvailable NULL_HANDLE >>= \case - r@(SUCCESS, _) -> pure r - r@(SUBOPTIMAL_KHR, _) -> pure r - (TIMEOUT, _) -> timeoutError "Timed out (1s) acquiring next image" - _ -> throwString "Unexpected Result from acquireNextImageKHR" + r@(SUCCESS, _) -> pure r + r@(SUBOPTIMAL_KHR, _) -> pure r + (TIMEOUT, _) -> timeoutError "Timed out (1s) acquiring next image" + _ -> throwString "Unexpected Result from acquireNextImageKHR" -- Allocate a per-frame command buffer from the recycled pool. - (_, ~[commandBuffer]) <- withCommandBuffers - dev - zero { commandPool = rrCommandPool - , level = COMMAND_BUFFER_LEVEL_PRIMARY - , commandBufferCount = 1 - } - allocate - - let renderPassBeginInfo = zero - { renderPass = renderPass - , framebuffer = framebuffers ! fromIntegral imageIndex - , renderArea = Rect2D { offset = zero, extent = sExtent sc } - , clearValues = [Color (Float32 0.3 0.4 0.8 1)] + (_, ~[commandBuffer]) <- + withCommandBuffers + dev + zero + { commandPool = rrCommandPool + , level = COMMAND_BUFFER_LEVEL_PRIMARY + , commandBufferCount = 1 } + allocate + + let renderPassBeginInfo = + zero + { renderPass = renderPass + , framebuffer = framebuffers ! fromIntegral imageIndex + , renderArea = Rect2D{offset = zero, extent = sExtent sc} + , clearValues = [Color (Float32 0.3 0.4 0.8 1)] + } useCommandBuffer - commandBuffer - zero { CommandBufferBeginInfo.flags = COMMAND_BUFFER_USAGE_ONE_TIME_SUBMIT_BIT } + commandBuffer + zero{CommandBufferBeginInfo.flags = COMMAND_BUFFER_USAGE_ONE_TIME_SUBMIT_BIT} $ do - cmdUseRenderPass commandBuffer renderPassBeginInfo SUBPASS_CONTENTS_INLINE - $ do - cmdSetViewport commandBuffer - 0 - [ Viewport - { x = 0 - , y = 0 - , width = realToFrac (Extent2D.width (sExtent sc)) - , height = realToFrac (Extent2D.height (sExtent sc)) - , minDepth = 0 - , maxDepth = 1 - } - ] - cmdSetScissor commandBuffer - 0 - [Rect2D { offset = Offset2D 0 0, extent = sExtent sc }] - cmdBindPipeline commandBuffer PIPELINE_BIND_POINT_GRAPHICS pipeline - cmdDraw commandBuffer 3 1 0 0 + cmdUseRenderPass commandBuffer renderPassBeginInfo SUBPASS_CONTENTS_INLINE $ + do + cmdSetViewport + commandBuffer + 0 + [ Viewport + { x = 0 + , y = 0 + , width = realToFrac (Extent2D.width (sExtent sc)) + , height = realToFrac (Extent2D.height (sExtent sc)) + , minDepth = 0 + , maxDepth = 1 + } + ] + cmdSetScissor + commandBuffer + 0 + [Rect2D{offset = Offset2D 0 0, extent = sExtent sc}] + cmdBindPipeline commandBuffer PIPELINE_BIND_POINT_GRAPHICS pipeline + cmdDraw commandBuffer 3 1 0 0 let submitInfo = - zero { Core10.waitSemaphores = [rrImageAvailable] - , waitDstStageMask = [PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT] - , commandBuffers = [commandBufferHandle commandBuffer] - , signalSemaphores = [rrRenderFinished, fHostTimeline f] - } - ::& zero { waitSemaphoreValues = [1] - , signalSemaphoreValues = [1, fIndex f] - } - :& () - liftIO $ queueSubmitFrame gQ - f - [SomeStruct submitInfo] - (fHostTimeline f) - (fIndex f) + zero + { Core10.waitSemaphores = [rrImageAvailable] + , waitDstStageMask = [PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT] + , commandBuffers = [commandBufferHandle commandBuffer] + , signalSemaphores = [rrRenderFinished, fHostTimeline f] + } + ::& zero + { waitSemaphoreValues = [1] + , signalSemaphoreValues = [1, fIndex f] + } + :& () + liftIO $ + queueSubmitFrame + gQ + f + [SomeStruct submitInfo] + (fHostTimeline f) + (fIndex f) - presentResult <- queuePresentKHR - gQ - zero { Swap.waitSemaphores = [rrRenderFinished] - , swapchains = [sSwapchain sc] - , imageIndices = [imageIndex] - } + presentResult <- + queuePresentKHR + gQ + zero + { Swap.waitSemaphores = [rrRenderFinished] + , swapchains = [sSwapchain sc] + , imageIndices = [imageIndex] + } -- Surface either reported SUBOPTIMAL on acquire or present — bubble it up -- as an OUT_OF_DATE so the main loop will recreate the swapchain. case (acquireResult, presentResult) of (SUBOPTIMAL_KHR, _) -> liftIO . throwIO $ VulkanException ERROR_OUT_OF_DATE_KHR (_, SUBOPTIMAL_KHR) -> liftIO . throwIO $ VulkanException ERROR_OUT_OF_DATE_KHR - _ -> pure () + _ -> pure () ---------------------------------------------------------------- -- Utils ---------------------------------------------------------------- -timeoutError :: MonadIO m => String -> m a +timeoutError :: (MonadIO m) => String -> m a timeoutError message = liftIO . throwIO $ IOError Nothing TimeExpired "" message Nothing Nothing diff --git a/examples/hlsl/RenderPass.hs b/examples/hlsl/RenderPass.hs index 8afb0246a..8da5c810b 100644 --- a/examples/hlsl/RenderPass.hs +++ b/examples/hlsl/RenderPass.hs @@ -4,53 +4,59 @@ module RenderPass ( RenderPass.createRenderPass ) where -import Control.Monad.Trans.Resource -import Data.Bits -import Vulkan.Core10 as Vk - hiding ( withBuffer - , withImage - ) -import Vulkan.Zero +import Control.Monad.Trans.Resource +import Data.Bits +import Vulkan.Core10 as Vk hiding + ( withBuffer + , withImage + ) +import Vulkan.Zero -- | Create a renderpass with a single subpass that clears + presents. createRenderPass - :: MonadResource m + :: (MonadResource m) => Device -> Format -> m (ReleaseKey, RenderPass) -createRenderPass dev imageFormat = withRenderPass - dev - zero { attachments = [attachmentDescription] - , subpasses = [subpass] - , dependencies = [subpassDependency] - } - Nothing - allocate - where - attachmentDescription :: AttachmentDescription - attachmentDescription = zero - { format = imageFormat - , samples = SAMPLE_COUNT_1_BIT - , loadOp = ATTACHMENT_LOAD_OP_CLEAR - , storeOp = ATTACHMENT_STORE_OP_STORE - , stencilLoadOp = ATTACHMENT_LOAD_OP_DONT_CARE - , stencilStoreOp = ATTACHMENT_STORE_OP_DONT_CARE - , initialLayout = IMAGE_LAYOUT_UNDEFINED - , finalLayout = IMAGE_LAYOUT_PRESENT_SRC_KHR - } - subpass :: SubpassDescription - subpass = zero - { pipelineBindPoint = PIPELINE_BIND_POINT_GRAPHICS - , colorAttachments = - [zero { attachment = 0, layout = IMAGE_LAYOUT_COLOR_ATTACHMENT_OPTIMAL }] - } - subpassDependency :: SubpassDependency - subpassDependency = zero - { srcSubpass = SUBPASS_EXTERNAL - , dstSubpass = 0 - , srcStageMask = PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT - , srcAccessMask = zero - , dstStageMask = PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT - , dstAccessMask = ACCESS_COLOR_ATTACHMENT_READ_BIT - .|. ACCESS_COLOR_ATTACHMENT_WRITE_BIT - } +createRenderPass dev imageFormat = + withRenderPass + dev + zero + { attachments = [attachmentDescription] + , subpasses = [subpass] + , dependencies = [subpassDependency] + } + Nothing + allocate + where + attachmentDescription :: AttachmentDescription + attachmentDescription = + zero + { format = imageFormat + , samples = SAMPLE_COUNT_1_BIT + , loadOp = ATTACHMENT_LOAD_OP_CLEAR + , storeOp = ATTACHMENT_STORE_OP_STORE + , stencilLoadOp = ATTACHMENT_LOAD_OP_DONT_CARE + , stencilStoreOp = ATTACHMENT_STORE_OP_DONT_CARE + , initialLayout = IMAGE_LAYOUT_UNDEFINED + , finalLayout = IMAGE_LAYOUT_PRESENT_SRC_KHR + } + subpass :: SubpassDescription + subpass = + zero + { pipelineBindPoint = PIPELINE_BIND_POINT_GRAPHICS + , colorAttachments = + [zero{attachment = 0, layout = IMAGE_LAYOUT_COLOR_ATTACHMENT_OPTIMAL}] + } + subpassDependency :: SubpassDependency + subpassDependency = + zero + { srcSubpass = SUBPASS_EXTERNAL + , dstSubpass = 0 + , srcStageMask = PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT + , srcAccessMask = zero + , dstStageMask = PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT + , dstAccessMask = + ACCESS_COLOR_ATTACHMENT_READ_BIT + .|. ACCESS_COLOR_ATTACHMENT_WRITE_BIT + } diff --git a/examples/info/Main.hs b/examples/info/Main.hs index 58dc555c6..169fc4ad8 100644 --- a/examples/info/Main.hs +++ b/examples/info/Main.hs @@ -1,15 +1,15 @@ module Main where -import Control.Exception -import Data.Foldable -import Text.Pretty.Simple -import Vulkan.Core10 -import Vulkan.Zero +import Control.Exception +import Data.Foldable +import Text.Pretty.Simple +import Vulkan.Core10 +import Vulkan.Zero main :: IO () main = withInstance zero Nothing bracket $ \i -> do myPrint i - (_, layers ) <- enumerateInstanceLayerProperties + (_, layers) <- enumerateInstanceLayerProperties (_, extensions) <- enumerateInstanceExtensionProperties Nothing myPrint layers myPrint extensions @@ -19,14 +19,15 @@ main = withInstance zero Nothing bracket $ \i -> do deviceInfo :: PhysicalDevice -> IO () deviceInfo p = do (_, extensions) <- enumerateDeviceExtensionProperties p Nothing - (_, layers ) <- enumerateDeviceLayerProperties p + (_, layers) <- enumerateDeviceLayerProperties p traverse_ myPrint extensions traverse_ myPrint layers myPrint =<< getPhysicalDeviceFeatures p myPrint =<< getPhysicalDeviceProperties p myPrint =<< getPhysicalDeviceMemoryProperties p -myPrint :: Show a => a -> IO () -myPrint = pPrintOpt - CheckColorTty - defaultOutputOptionsDarkBg { outputOptionsStringStyle = Literal } +myPrint :: (Show a) => a -> IO () +myPrint = + pPrintOpt + CheckColorTty + defaultOutputOptionsDarkBg{outputOptionsStringStyle = Literal} diff --git a/examples/lib/Camera.hs b/examples/lib/Camera.hs index 0cb860765..a8392e52b 100644 --- a/examples/lib/Camera.hs +++ b/examples/lib/Camera.hs @@ -1,21 +1,21 @@ -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveAnyClass #-} -{-# OPTIONS_GHC -fplugin=Foreign.Storable.Generic.Plugin #-} +{-# LANGUAGE DeriveGeneric #-} {-# OPTIONS_GHC -fplugin-opt=Foreign.Storable.Generic.Plugin:-v0 #-} +{-# OPTIONS_GHC -fplugin=Foreign.Storable.Generic.Plugin #-} module Camera where -import Control.Lens -import Foreign.Storable.Generic -import GHC.Generics ( Generic ) -import Linear +import Control.Lens +import Foreign.Storable.Generic +import GHC.Generics (Generic) +import Linear data Camera = Camera - { camPosition :: V3 Float + { camPosition :: V3 Float , camOrientation :: Quaternion Float - , camAspect :: Float - , camFOV :: Float - -- ^ Vertical field of view in Radians + , camAspect :: Float + , camFOV :: Float + -- ^ Vertical field of view in Radians } data CameraMatrices = CameraMatrices @@ -31,7 +31,7 @@ initialCamera = -- >>> viewMatrix initialCamera -- V4 (V4 1.0 0.0 0.0 0.0) (V4 0.0 1.0 0.0 0.0) (V4 0.0 0.0 1.0 10.0) (V4 0.0 0.0 0.0 1.0) viewMatrix :: Camera -> M44 Float -viewMatrix Camera {..} = inv44 $ mkTransformation camOrientation camPosition +viewMatrix Camera{..} = inv44 $ mkTransformation camOrientation camPosition -- >>> projectionMatrix initialCamera -- V4 (V4 0.3611771 0.0 0.0 0.0) (V4 0.0 0.6420926 0.0 0.0) (V4 0.0 0.0 0.0 0.1) (V4 0.0 0.0 1.0 0.0) @@ -39,12 +39,14 @@ viewMatrix Camera {..} = inv44 $ mkTransformation camOrientation camPosition -- >>> tan (1.5 / 2) -- 0.9315964599440725 projectionMatrix :: Camera -> M44 Float -projectionMatrix Camera {..} = - let cotFoV = 1 / tan (camFOV / 2) - dx = cotFoV / camAspect - dy = cotFoV - zNear = 0.1 - in V4 (V4 dx 0 0 0) (V4 0 dy 0 0) (V4 0 0 0 zNear) (V4 0 0 1 0) +projectionMatrix Camera{..} = + let + cotFoV = 1 / tan (camFOV / 2) + dx = cotFoV / camAspect + dy = cotFoV + zNear = 0.1 + in + V4 (V4 dx 0 0 0) (V4 0 dy 0 0) (V4 0 0 0 zNear) (V4 0 0 1 0) -- >>> projectRay initialCamera (V2 0 0) -- (V3 0.0 0.0 (-10.0),V3 0.0 0.0 1.0) @@ -61,13 +63,15 @@ projectRay -> (V3 Float, V3 Float) -- ^ Origin, Direction projectRay c scr2 = - let viewInverse = inv44 $ viewMatrix c - projInverse = inv44 $ projectionMatrix c - origin = (viewInverse !* point (V3 0 0 0)) ^. _xyz - targetScreenSpace = V4 (scr2 ^. _x) (scr2 ^. _y) 1 1 - target = projInverse !* targetScreenSpace - dir = normalize ((viewInverse !* vector (target ^. _xyz)) ^. _xyz) - in (origin, dir) + let + viewInverse = inv44 $ viewMatrix c + projInverse = inv44 $ projectionMatrix c + origin = (viewInverse !* point (V3 0 0 0)) ^. _xyz + targetScreenSpace = V4 (scr2 ^. _x) (scr2 ^. _y) 1 1 + target = projInverse !* targetScreenSpace + dir = normalize ((viewInverse !* vector (target ^. _xyz)) ^. _xyz) + in + (origin, dir) -- >>> projectToScreen initialCamera (V3 0 0 (-9.8)) -- V3 0.0 0.0 0.5000005 diff --git a/examples/lib/Frame.hs b/examples/lib/Frame.hs index ba9158dd7..a141aa623 100644 --- a/examples/lib/Frame.hs +++ b/examples/lib/Frame.hs @@ -2,16 +2,17 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} --- | Per-frame state and the recycling-Frame loop. Each frame owns a binary --- image-available semaphore, a binary render-finished semaphore, and a --- command pool — those three are 'RecycledResources' that get handed back --- to a channel in 'VkResources' once the frame's GPU work has completed. --- --- The host-side timeline semaphore (@fHostTimeline@) lives across frames: --- each frame increments it to its own 'fIndex' on the GPU, and the host --- waits on it inside the spawned wait-and-recycle thread. +{-| Per-frame state and the recycling-Frame loop. Each frame owns a binary +image-available semaphore, a binary render-finished semaphore, and a +command pool — those three are 'RecycledResources' that get handed back +to a channel in 'VkResources' once the frame's GPU work has completed. + +The host-side timeline semaphore (@fHostTimeline@) lives across frames: +each frame increments it to its own 'fIndex' on the GPU, and the host +waits on it inside the spawned wait-and-recycle thread. +-} module Frame - ( Frame(..) + ( Frame (..) , numConcurrentFrames , initialFrame , advanceFrame @@ -22,63 +23,72 @@ module Frame , frameDeviceRequirements ) where -import Control.Concurrent ( forkIO ) -import Control.Monad ( replicateM_ - , unless - , void - ) -import Control.Monad.IO.Class ( liftIO ) -import Control.Monad.Trans.Resource ( InternalState - , MonadResource - , ReleaseKey - , ResourceT - , allocate - , closeInternalState - , createInternalState - , release - , runInternalState - ) -import qualified Data.Vector as V -import Data.IORef ( IORef - , newIORef - , readIORef - ) -import Data.Word -import Say ( sayErr ) -import Swapchain ( Swapchain ) -import UnliftIO ( atomicModifyIORef' - , finally - , mask_ - ) -import VkResources ( Queues(..) - , RecycledResources(..) - , VkResources(..) - ) -import Vulkan.CStruct.Extends ( SomeStruct - , pattern (:&) - , pattern (::&) - ) -import Vulkan.Core10 -import qualified Vulkan.Core10 as CommandPoolCreateInfo - ( CommandPoolCreateInfo(..) ) -import Vulkan.Core12.Promoted_From_VK_KHR_timeline_semaphore - as Timeline -import Vulkan.Extensions.VK_KHR_get_physical_device_properties2 - ( pattern KHR_GET_PHYSICAL_DEVICE_PROPERTIES_2_EXTENSION_NAME ) -import Vulkan.Requirement ( DeviceRequirement - , InstanceRequirement(..) - ) -import Vulkan.Utils.QueueAssignment ( QueueFamilyIndex(..) ) -import qualified Vulkan.Utils.Requirements.TH as U -import Vulkan.Zero ( zero ) +import Control.Concurrent (forkIO) +import Control.Monad + ( replicateM_ + , unless + , void + ) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Resource + ( InternalState + , MonadResource + , ReleaseKey + , ResourceT + , allocate + , closeInternalState + , createInternalState + , release + , runInternalState + ) +import Data.IORef + ( IORef + , newIORef + , readIORef + ) +import qualified Data.Vector as V +import Data.Word +import Say (sayErr) +import Swapchain (Swapchain) +import UnliftIO + ( atomicModifyIORef' + , finally + , mask_ + ) +import VkResources + ( Queues (..) + , RecycledResources (..) + , VkResources (..) + ) +import Vulkan.CStruct.Extends + ( SomeStruct + , pattern (:&) + , pattern (::&) + ) +import Vulkan.Core10 +import qualified Vulkan.Core10 as CommandPoolCreateInfo + ( CommandPoolCreateInfo (..) + ) +import Vulkan.Core12.Promoted_From_VK_KHR_timeline_semaphore as Timeline +import Vulkan.Extensions.VK_KHR_get_physical_device_properties2 + ( pattern KHR_GET_PHYSICAL_DEVICE_PROPERTIES_2_EXTENSION_NAME + ) +import Vulkan.Requirement + ( DeviceRequirement + , InstanceRequirement (..) + ) +import Vulkan.Utils.QueueAssignment (QueueFamilyIndex (..)) +import qualified Vulkan.Utils.Requirements.TH as U +import Vulkan.Zero (zero) + +{- | Instance-level requirements for the recycling 'Frame' machinery. Merge +with your example's other 'InstanceRequirement's when calling +'Vulkan.Utils.Init.SDL2.withInstance' (or equivalent). --- | Instance-level requirements for the recycling 'Frame' machinery. Merge --- with your example's other 'InstanceRequirement's when calling --- 'Vulkan.Utils.Init.SDL2.withInstance' (or equivalent). --- --- Required because checking @PhysicalDeviceTimelineSemaphoreFeatures@ at --- physical-device pick time goes through @VkPhysicalDeviceFeatures2@, which --- needs either Vulkan 1.1+ or this extension. +Required because checking @PhysicalDeviceTimelineSemaphoreFeatures@ at +physical-device pick time goes through @VkPhysicalDeviceFeatures2@, which +needs either Vulkan 1.1+ or this extension. +-} frameInstanceRequirements :: [InstanceRequirement] frameInstanceRequirements = [ RequireInstanceExtension @@ -87,90 +97,107 @@ frameInstanceRequirements = minBound ] --- | The device-level requirements needed by 'runFrame' / 'queueSubmitFrame' / --- 'withTimelineSemaphore'. Merge into your example's other 'DeviceRequirement's --- when calling 'createDeviceFromRequirements'. +{- | The device-level requirements needed by 'runFrame' / 'queueSubmitFrame' / +'withTimelineSemaphore'. Merge into your example's other 'DeviceRequirement's +when calling 'createDeviceFromRequirements'. +-} frameDeviceRequirements :: [DeviceRequirement] -frameDeviceRequirements = [U.reqs| +frameDeviceRequirements = + [U.reqs| VK_KHR_timeline_semaphore PhysicalDeviceTimelineSemaphoreFeatures.timelineSemaphore |] --- | How many frames to keep in flight. Determines how many spare --- 'RecycledResources' get pre-populated into the recycle channel at startup. +{- | How many frames to keep in flight. Determines how many spare +'RecycledResources' get pre-populated into the recycle channel at startup. +-} numConcurrentFrames :: Int numConcurrentFrames = 3 -- | Per-frame state. data Frame = Frame - { fIndex :: Word64 - -- ^ Monotonic, used as the timeline-semaphore signal value for this frame. - , fSwapchain :: Swapchain - -- ^ The swapchain this frame targets. Held by reference so a frame - -- in flight keeps its swapchain alive across recreation. - , fRecycled :: RecycledResources - -- ^ This frame's image-available / render-finished / command-pool — all - -- borrowed from the recycle channel; returned at retire time. + { fIndex :: Word64 + -- ^ Monotonic, used as the timeline-semaphore signal value for this frame. + , fSwapchain :: Swapchain + {- ^ The swapchain this frame targets. Held by reference so a frame + in flight keeps its swapchain alive across recreation. + -} + , fRecycled :: RecycledResources + {- ^ This frame's image-available / render-finished / command-pool — all + borrowed from the recycle channel; returned at retire time. + -} , fHostTimeline :: Semaphore - -- ^ Long-lived timeline semaphore. Each frame increments it to 'fIndex' - -- on the GPU; the host wait thread blocks on this. - , fGPUWork :: IORef [(Semaphore, Word64)] - -- ^ (Timeline semaphore, value) pairs the host wait thread will block on. - -- Appended to by 'queueSubmitFrame'. - , fResources :: (ReleaseKey, InternalState) - -- ^ ResourceT scope for frame-local allocations; closed when the frame - -- retires. The 'ReleaseKey' lives in the outer ResourceT so the - -- scope is freed cleanly even on early shutdown. + {- ^ Long-lived timeline semaphore. Each frame increments it to 'fIndex' + on the GPU; the host wait thread blocks on this. + -} + , fGPUWork :: IORef [(Semaphore, Word64)] + {- ^ (Timeline semaphore, value) pairs the host wait thread will block on. + Appended to by 'queueSubmitFrame'. + -} + , fResources :: (ReleaseKey, InternalState) + {- ^ ResourceT scope for frame-local allocations; closed when the frame + retires. The 'ReleaseKey' lives in the outer ResourceT so the + scope is freed cleanly even on early shutdown. + -} } ---------------------------------------------------------------- -- Construction ---------------------------------------------------------------- --- | Build the initial frame and pre-populate the recycle channel with --- @'numConcurrentFrames' - 1@ spare 'RecycledResources'. -initialFrame :: MonadResource m => VkResources -> Swapchain -> m Frame +{- | Build the initial frame and pre-populate the recycle channel with +@'numConcurrentFrames' - 1@ spare 'RecycledResources'. +-} +initialFrame :: (MonadResource m) => VkResources -> Swapchain -> m Frame initialFrame vr fSwapchain = do replicateM_ (numConcurrentFrames - 1) $ do rr <- mkRecycledResources vr liftIO (vrRecycleBin vr rr) - fRecycled <- mkRecycledResources vr + fRecycled <- mkRecycledResources vr (_, fHostTimeline) <- withTimelineSemaphore (vrDevice vr) 0 - fGPUWork <- liftIO $ newIORef mempty - fResources <- allocate createInternalState closeInternalState - pure Frame { fIndex = 1, .. } + fGPUWork <- liftIO $ newIORef mempty + fResources <- allocate createInternalState closeInternalState + pure Frame{fIndex = 1, ..} --- | Build the next frame, taking one set of recycled resources from the bin. --- Caller passes the (possibly-recreated) 'Swapchain'. +{- | Build the next frame, taking one set of recycled resources from the bin. +Caller passes the (possibly-recreated) 'Swapchain'. +-} advanceFrame - :: MonadResource m + :: (MonadResource m) => VkResources - -> Swapchain -- ^ Same as old, or freshly recreated - -> Frame -- ^ The just-finished frame + -> Swapchain + -- ^ Same as old, or freshly recreated + -> Frame + -- ^ The just-finished frame -> m Frame advanceFrame vr sc f = do - fRecycled <- liftIO $ vrRecycleNib vr >>= \case - Left block -> block - Right rr -> pure rr - fGPUWork <- liftIO $ newIORef mempty + fRecycled <- + liftIO $ + vrRecycleNib vr >>= \case + Left block -> block + Right rr -> pure rr + fGPUWork <- liftIO $ newIORef mempty fResources <- allocate createInternalState closeInternalState - pure Frame { fIndex = succ (fIndex f) - , fSwapchain = sc - , fRecycled - , fHostTimeline = fHostTimeline f - , fGPUWork - , fResources - } + pure + Frame + { fIndex = succ (fIndex f) + , fSwapchain = sc + , fRecycled + , fHostTimeline = fHostTimeline f + , fGPUWork + , fResources + } ---------------------------------------------------------------- -- Loop ---------------------------------------------------------------- --- | Run a per-frame action against this frame's per-frame ResourceT scope, --- then asynchronously wait for the GPU work and recycle. The wait/recycle --- runs in a forked thread so the next frame can begin recording immediately. --- --- Anything 'allocate'd inside @action@ is freed when the frame retires. +{- | Run a per-frame action against this frame's per-frame ResourceT scope, +then asynchronously wait for the GPU work and recycle. The wait/recycle +runs in a forked thread so the next frame can begin recording immediately. + +Anything 'allocate'd inside @action@ is freed when the frame retires. +-} runFrame :: VkResources -> Frame -> ResourceT IO a -> IO a runFrame vr f action = runInternalState action (snd (fResources f)) @@ -181,39 +208,45 @@ waitAndRecycle vr f = do waits <- readIORef (fGPUWork f) void . forkIO $ do unless (null waits) $ do - let waitInfo = zero { semaphores = V.fromList (fst <$> waits) - , values = V.fromList (snd <$> waits) - } + let waitInfo = + zero + { semaphores = V.fromList (fst <$> waits) + , values = V.fromList (snd <$> waits) + } r <- waitTwice (vrDevice vr) waitInfo oneSecond case r of TIMEOUT -> sayErr "Frame wait timed out (1s) — GPU may be hung" - _ -> pure () + _ -> pure () -- Pool reuse: reset, dropping all recorded buffers. - resetCommandPool (vrDevice vr) - (rrCommandPool (fRecycled f)) - COMMAND_POOL_RESET_RELEASE_RESOURCES_BIT + resetCommandPool + (vrDevice vr) + (rrCommandPool (fRecycled f)) + COMMAND_POOL_RESET_RELEASE_RESOURCES_BIT -- Hand the borrowed resources back to whoever's waiting on them. vrRecycleBin vr (fRecycled f) -- Free the per-frame ResourceT scope. release (fst (fResources f)) - where - oneSecond :: Word64 - oneSecond = 1000000000 + where + oneSecond :: Word64 + oneSecond = 1000000000 + +{- | Submit GPU work for this frame and record the timeline semaphore + value +the wait thread will block on. --- | Submit GPU work for this frame and record the timeline semaphore + value --- the wait thread will block on. --- --- Wraps 'queueSubmit' to keep the submit and the bookkeeping atomic. +Wraps 'queueSubmit' to keep the submit and the bookkeeping atomic. +-} queueSubmitFrame :: Queue -> Frame -> V.Vector (SomeStruct SubmitInfo) - -> Semaphore -- ^ Timeline semaphore that will be signalled to @value@ - -> Word64 -- ^ Value the timeline reaches once this submit completes + -> Semaphore + -- ^ Timeline semaphore that will be signalled to @value@ + -> Word64 + -- ^ Value the timeline reaches once this submit completes -> IO () queueSubmitFrame q f ss sem value = mask_ $ do queueSubmit q ss NULL_HANDLE - atomicModifyIORef' (fGPUWork f) ((, ()) . ((sem, value) :)) + atomicModifyIORef' (fGPUWork f) ((,()) . ((sem, value) :)) ---------------------------------------------------------------- -- Small helpers @@ -221,44 +254,52 @@ queueSubmitFrame q f ss sem value = mask_ $ do -- | Allocate a timeline semaphore initialised to the given value. withTimelineSemaphore - :: MonadResource m => Device -> Word64 -> m (ReleaseKey, Semaphore) + :: (MonadResource m) => Device -> Word64 -> m (ReleaseKey, Semaphore) withTimelineSemaphore dev initial = - withSemaphore dev - (zero ::& SemaphoreTypeCreateInfo SEMAPHORE_TYPE_TIMELINE initial :& ()) - Nothing - allocate + withSemaphore + dev + (zero ::& SemaphoreTypeCreateInfo SEMAPHORE_TYPE_TIMELINE initial :& ()) + Nothing + allocate ---------------------------------------------------------------- -- Internals ---------------------------------------------------------------- --- | Build one set of recycled resources: two binary semaphores + a --- command pool keyed to the graphics queue family. -mkRecycledResources :: MonadResource m => VkResources -> m RecycledResources +{- | Build one set of recycled resources: two binary semaphores + a +command pool keyed to the graphics queue family. +-} +mkRecycledResources :: (MonadResource m) => VkResources -> m RecycledResources mkRecycledResources vr = do - let dev = vrDevice vr - QueueFamilyIndex qfi = fst (qGraphics (vrQueues vr)) - (_, rrImageAvailable) <- withSemaphore - dev - (zero ::& SemaphoreTypeCreateInfo SEMAPHORE_TYPE_BINARY 0 :& ()) - Nothing - allocate - (_, rrRenderFinished) <- withSemaphore - dev - (zero ::& SemaphoreTypeCreateInfo SEMAPHORE_TYPE_BINARY 0 :& ()) - Nothing - allocate - (_, rrCommandPool) <- withCommandPool - dev - zero { CommandPoolCreateInfo.queueFamilyIndex = qfi } - Nothing - allocate - pure RecycledResources { .. } + let + dev = vrDevice vr + QueueFamilyIndex qfi = fst (qGraphics (vrQueues vr)) + (_, rrImageAvailable) <- + withSemaphore + dev + (zero ::& SemaphoreTypeCreateInfo SEMAPHORE_TYPE_BINARY 0 :& ()) + Nothing + allocate + (_, rrRenderFinished) <- + withSemaphore + dev + (zero ::& SemaphoreTypeCreateInfo SEMAPHORE_TYPE_BINARY 0 :& ()) + Nothing + allocate + (_, rrCommandPool) <- + withCommandPool + dev + zero{CommandPoolCreateInfo.queueFamilyIndex = qfi} + Nothing + allocate + pure RecycledResources{..} --- | Wait for some semaphores; if the wait times out, give the device one --- more chance with a zero timeout. Catches the case where the host was --- suspended during the wait and the GPU has actually finished. +{- | Wait for some semaphores; if the wait times out, give the device one +more chance with a zero timeout. Catches the case where the host was +suspended during the wait and the GPU has actually finished. +-} waitTwice :: Device -> SemaphoreWaitInfo -> Word64 -> IO Result -waitTwice dev waitInfo t = Timeline.waitSemaphoresSafe dev waitInfo t >>= \case - TIMEOUT -> Timeline.waitSemaphores dev waitInfo 0 - r -> pure r +waitTwice dev waitInfo t = + Timeline.waitSemaphoresSafe dev waitInfo t >>= \case + TIMEOUT -> Timeline.waitSemaphores dev waitInfo 0 + r -> pure r diff --git a/examples/lib/Framebuffer.hs b/examples/lib/Framebuffer.hs index ed5869763..bd69bef44 100644 --- a/examples/lib/Framebuffer.hs +++ b/examples/lib/Framebuffer.hs @@ -1,52 +1,61 @@ {-# LANGUAGE OverloadedLists #-} --- | Tiny helpers for the boilerplate that each rendering example needs: --- a framebuffer over a single image view, and a vanilla 2D color image view. +{-| Tiny helpers for the boilerplate that each rendering example needs: +a framebuffer over a single image view, and a vanilla 2D color image view. +-} module Framebuffer ( Framebuffer.createFramebuffer , Framebuffer.createImageView , Framebuffer.createFramebuffers ) where -import Control.Monad.Trans.Resource ( MonadResource - , ReleaseKey - , allocate - , release - ) -import Data.Foldable ( traverse_ ) -import qualified Data.Vector as V -import Data.Vector ( Vector ) -import RefCounted ( RefCounted, newRefCounted ) -import Vulkan.Core10 as Vk - hiding ( withImage ) -import Vulkan.Core10 as Extent2D (Extent2D(..)) -import Vulkan.Core10 as ImageViewCreateInfo - ( ImageViewCreateInfo(..) ) -import Vulkan.Zero +import Control.Monad.Trans.Resource + ( MonadResource + , ReleaseKey + , allocate + , release + ) +import Data.Foldable (traverse_) +import Data.Vector (Vector) +import qualified Data.Vector as V +import RefCounted (RefCounted, newRefCounted) +import Vulkan.Core10 as Extent2D (Extent2D (..)) +import Vulkan.Core10 as ImageViewCreateInfo + ( ImageViewCreateInfo (..) + ) +import Vulkan.Core10 as Vk hiding + ( withImage + ) +import Vulkan.Zero -- | Create a framebuffer covering the whole image with a single attachment. createFramebuffer - :: MonadResource m + :: (MonadResource m) => Device -> RenderPass -> ImageView -> Extent2D -> m (ReleaseKey, Framebuffer) createFramebuffer dev renderPass imageView imageSize = - let framebufferCreateInfo :: FramebufferCreateInfo '[] - framebufferCreateInfo = zero { renderPass = renderPass - , attachments = [imageView] - , width = Extent2D.width imageSize - , height = Extent2D.height imageSize - , layers = 1 - } - in withFramebuffer dev framebufferCreateInfo Nothing allocate + let + framebufferCreateInfo :: FramebufferCreateInfo '[] + framebufferCreateInfo = + zero + { renderPass = renderPass + , attachments = [imageView] + , width = Extent2D.width imageSize + , height = Extent2D.height imageSize + , layers = 1 + } + in + withFramebuffer dev framebufferCreateInfo Nothing allocate --- | Build one framebuffer per image view at the given extent. The returned --- 'RefCounted' frees them all when no in-flight frame still uses them — call --- 'releaseRefCounted' after a swapchain swap. +{- | Build one framebuffer per image view at the given extent. The returned +'RefCounted' frees them all when no in-flight frame still uses them — call +'releaseRefCounted' after a swapchain swap. +-} createFramebuffers - :: MonadResource m + :: (MonadResource m) => Device -> RenderPass -> Vector ImageView @@ -60,27 +69,32 @@ createFramebuffers dev rp ivs imageSize = do -- | Vanilla 2D color image view covering the whole image. createImageView - :: MonadResource m + :: (MonadResource m) => Device -> Format -> Image -> m (ReleaseKey, ImageView) createImageView dev format image = withImageView dev imageViewCreateInfo Nothing allocate - where - imageViewCreateInfo = zero - { ImageViewCreateInfo.image = image - , viewType = IMAGE_VIEW_TYPE_2D - , format = format - , components = zero { r = COMPONENT_SWIZZLE_IDENTITY - , g = COMPONENT_SWIZZLE_IDENTITY - , b = COMPONENT_SWIZZLE_IDENTITY - , a = COMPONENT_SWIZZLE_IDENTITY - } - , subresourceRange = zero { aspectMask = IMAGE_ASPECT_COLOR_BIT - , baseMipLevel = 0 - , levelCount = 1 - , baseArrayLayer = 0 - , layerCount = 1 - } - } + where + imageViewCreateInfo = + zero + { ImageViewCreateInfo.image = image + , viewType = IMAGE_VIEW_TYPE_2D + , format = format + , components = + zero + { r = COMPONENT_SWIZZLE_IDENTITY + , g = COMPONENT_SWIZZLE_IDENTITY + , b = COMPONENT_SWIZZLE_IDENTITY + , a = COMPONENT_SWIZZLE_IDENTITY + } + , subresourceRange = + zero + { aspectMask = IMAGE_ASPECT_COLOR_BIT + , baseMipLevel = 0 + , levelCount = 1 + , baseArrayLayer = 0 + , layerCount = 1 + } + } diff --git a/examples/lib/InitDevice.hs b/examples/lib/InitDevice.hs index 5f70c2b85..511599440 100644 --- a/examples/lib/InitDevice.hs +++ b/examples/lib/InitDevice.hs @@ -1,49 +1,53 @@ --- | Helpers shared by the windowed examples for picking a physical device --- and creating a logical device with a uniform G/C/T queue kit (graphics+ --- present, compute, transfer). +{-| Helpers shared by the windowed examples for picking a physical device +and creating a logical device with a uniform G/C/T queue kit (graphics+ +present, compute, transfer). +-} module InitDevice ( withDevice ) where -import Control.Monad.IO.Class -import Control.Monad.Trans.Resource -import qualified Data.Vector as V -import Data.Word ( Word64 ) -import Say ( sayErr ) -import Utils ( noSuchThing ) -import VkResources ( Queues(..) ) -import Vulkan.CStruct.Extends ( SomeStruct(..) ) -import Vulkan.Core10 hiding ( withDevice ) -import qualified Vulkan.Core10.DeviceInitialization - as DI -import Vulkan.Extensions.VK_KHR_surface - ( SurfaceKHR ) -import Vulkan.Requirement ( DeviceRequirement ) -import Vulkan.Utils.Initialization ( createDeviceFromRequirements - , pickPhysicalDevice - ) -import Vulkan.Utils.QueueAssignment ( QueueFamilyIndex(..) - , QueueSpec(..) - , assignQueues - , isComputeQueueFamily - , isGraphicsQueueFamily - , isPresentQueueFamily - , isTransferOnlyQueueFamily - ) -import Vulkan.Zero ( zero ) +import Control.Monad.IO.Class +import Control.Monad.Trans.Resource +import qualified Data.Vector as V +import Data.Word (Word64) +import Say (sayErr) +import Utils (noSuchThing) +import VkResources (Queues (..)) +import Vulkan.CStruct.Extends (SomeStruct (..)) +import Vulkan.Core10 hiding (withDevice) +import qualified Vulkan.Core10.DeviceInitialization as DI +import Vulkan.Extensions.VK_KHR_surface + ( SurfaceKHR + ) +import Vulkan.Requirement (DeviceRequirement) +import Vulkan.Utils.Initialization + ( createDeviceFromRequirements + , pickPhysicalDevice + ) +import Vulkan.Utils.QueueAssignment + ( QueueFamilyIndex (..) + , QueueSpec (..) + , assignQueues + , isComputeQueueFamily + , isGraphicsQueueFamily + , isPresentQueueFamily + , isTransferOnlyQueueFamily + ) +import Vulkan.Zero (zero) --- | Pick a physical device that has a graphics+present queue family AND a --- compute queue family, then create a logical device exposing one queue per --- G/C/T slot. Devices are scored by total memory. --- --- Each capability prefers its own dedicated family (async compute, DMA-only --- transfer); falls back to aliasing graphics+present when the hardware --- doesn't expose one. When two slots target the same family, two distinct --- 'Queue' handles are still allocated within that family with the requested --- priorities (1.0 / 0.5 / 0.2). --- --- Pass any extra device requirements (extensions, features, API version) in --- @extraReqs@; they are forwarded to 'createDeviceFromRequirements'. +{- | Pick a physical device that has a graphics+present queue family AND a +compute queue family, then create a logical device exposing one queue per +G/C/T slot. Devices are scored by total memory. + +Each capability prefers its own dedicated family (async compute, DMA-only +transfer); falls back to aliasing graphics+present when the hardware +doesn't expose one. When two slots target the same family, two distinct +'Queue' handles are still allocated within that family with the requested +priorities (1.0 / 0.5 / 0.2). + +Pass any extra device requirements (extensions, features, API version) in +@extraReqs@; they are forwarded to 'createDeviceFromRequirements'. +-} withDevice :: (MonadResource m, MonadFail m) => Instance @@ -51,67 +55,77 @@ withDevice -> [DeviceRequirement] -> m (PhysicalDevice, Device, Queues (QueueFamilyIndex, Queue)) withDevice inst surface extraReqs = do - mPd <- pickPhysicalDevice inst (discoverFamilies surface) - (snd :: (Queues QueueFamilyIndex, Word64) -> Word64) + mPd <- + pickPhysicalDevice + inst + (discoverFamilies surface) + (snd :: (Queues QueueFamilyIndex, Word64) -> Word64) ((qFams, _score), phys) <- case mPd of - Just x -> pure x - Nothing -> sayErr "No suitable physical device found" - >> noSuchThing "No physical device with graphics+present and compute" + Just x -> pure x + Nothing -> + sayErr "No suitable physical device found" + >> noSuchThing "No physical device with graphics+present and compute" - let mkSpec target prio = QueueSpec prio (\i _ -> pure (i == target)) - specs = mkSpec <$> qFams <*> Queues 1.0 0.5 0.2 + let + mkSpec target prio = QueueSpec prio (\i _ -> pure (i == target)) + specs = mkSpec <$> qFams <*> Queues 1.0 0.5 0.2 Just (qInfos, getQs) <- assignQueues phys specs - dev <- createDeviceFromRequirements - extraReqs - [] - phys - zero { queueCreateInfos = SomeStruct <$> qInfos } + dev <- + createDeviceFromRequirements + extraReqs + [] + phys + zero{queueCreateInfos = SomeStruct <$> qInfos} qs <- liftIO (getQs dev) pure (phys, dev, qs) --- | Suitability probe used by 'pickPhysicalDevice'. Returns the discovered --- @(graphics+present, compute, transfer)@ family triple plus a memory score. +{- | Suitability probe used by 'pickPhysicalDevice'. Returns the discovered +@(graphics+present, compute, transfer)@ family triple plus a memory score. +-} discoverFamilies - :: MonadIO m + :: (MonadIO m) => SurfaceKHR -> PhysicalDevice -> m (Maybe (Queues QueueFamilyIndex, Word64)) discoverFamilies surf phys = do qProps <- getPhysicalDeviceQueueFamilyProperties phys - let withIndex = V.toList (V.indexed qProps) - asQfi i = QueueFamilyIndex (fromIntegral i) + let + withIndex = V.toList (V.indexed qProps) + asQfi i = QueueFamilyIndex (fromIntegral i) - graphicsFamilies = - [ asQfi i | (i, q) <- withIndex, isGraphicsQueueFamily q ] - asyncCompute = - [ asQfi i - | (i, q) <- withIndex - , isComputeQueueFamily q && not (isGraphicsQueueFamily q) - ] - anyCompute = - [ asQfi i | (i, q) <- withIndex, isComputeQueueFamily q ] - dedicatedTransfer = - [ asQfi i | (i, q) <- withIndex, isTransferOnlyQueueFamily q ] + graphicsFamilies = + [asQfi i | (i, q) <- withIndex, isGraphicsQueueFamily q] + asyncCompute = + [ asQfi i + | (i, q) <- withIndex + , isComputeQueueFamily q && not (isGraphicsQueueFamily q) + ] + anyCompute = + [asQfi i | (i, q) <- withIndex, isComputeQueueFamily q] + dedicatedTransfer = + [asQfi i | (i, q) <- withIndex, isTransferOnlyQueueFamily q] - presentResults <- mapM - (\qfi -> (qfi, ) <$> isPresentQueueFamily phys surf qfi) - graphicsFamilies - let mGp = case [ qfi | (qfi, True) <- presentResults ] of - qfi : _ -> Just qfi - [] -> Nothing - mCp = case asyncCompute of + presentResults <- + mapM + (\qfi -> (qfi,) <$> isPresentQueueFamily phys surf qfi) + graphicsFamilies + let + mGp = case [qfi | (qfi, True) <- presentResults] of + qfi : _ -> Just qfi + [] -> Nothing + mCp = case asyncCompute of + qfi : _ -> Just qfi + [] -> case anyCompute of qfi : _ -> Just qfi - [] -> case anyCompute of - qfi : _ -> Just qfi - [] -> Nothing + [] -> Nothing case (mGp, mCp) of (Just gp, Just cp) -> do let tf = case dedicatedTransfer of qfi : _ -> qfi - [] -> cp + [] -> cp heaps <- memoryHeaps <$> getPhysicalDeviceMemoryProperties phys let score = sum (DI.size <$> heaps) :: Word64 pure (Just (Queues gp cp tf, score)) diff --git a/examples/lib/Orphans.hs b/examples/lib/Orphans.hs index fbbbc4cdc..2802b2a21 100644 --- a/examples/lib/Orphans.hs +++ b/examples/lib/Orphans.hs @@ -1,27 +1,27 @@ {-# LANGUAGE DerivingVia #-} {-# OPTIONS_GHC -Wno-orphans #-} -module Orphans - () where - -import Control.Monad.Trans.Resource -import Control.Monad.Trans.Resource.Internal - ( ReleaseKey(..) - , ReleaseMap(..) - ) -import Data.Typeable ( Typeable ) -import Foreign.Ptr ( Ptr ) -import NoThunks.Class -import SDL ( Window ) -import Vulkan.Core10 -import Vulkan.Extensions.VK_KHR_acceleration_structure -import Vulkan.Extensions.VK_KHR_surface -import Vulkan.Extensions.VK_KHR_swapchain - ( SwapchainKHR ) -import VulkanMemoryAllocator +module Orphans () where + +import Control.Monad.Trans.Resource +import Control.Monad.Trans.Resource.Internal + ( ReleaseKey (..) + , ReleaseMap (..) + ) +import Data.Typeable (Typeable) +import Foreign.Ptr (Ptr) +import NoThunks.Class +import SDL (Window) +import Vulkan.Core10 +import Vulkan.Extensions.VK_KHR_acceleration_structure +import Vulkan.Extensions.VK_KHR_surface +import Vulkan.Extensions.VK_KHR_swapchain + ( SwapchainKHR + ) +import VulkanMemoryAllocator -- Handles -deriving via OnlyCheckWhnf (Ptr a) instance Typeable a => NoThunks (Ptr a) +deriving via OnlyCheckWhnf (Ptr a) instance (Typeable a) => NoThunks (Ptr a) deriving via OnlyCheckWhnf AccelerationStructureKHR instance NoThunks AccelerationStructureKHR deriving via OnlyCheckWhnf Allocation instance NoThunks Allocation deriving via OnlyCheckWhnf Buffer instance NoThunks Buffer @@ -48,11 +48,11 @@ deriving via OnlyCheckWhnf Extent2D instance NoThunks Extent2D instance NoThunks ReleaseMap where noThunks c = \case (ReleaseMap n r i) -> noThunks c (n, r, i) - ReleaseMapClosed -> noThunks c () + ReleaseMapClosed -> noThunks c () showTypeOf _ = "ReleaseMap" wNoThunks c = \case (ReleaseMap n r i) -> wNoThunks c (n, r, i) - ReleaseMapClosed -> wNoThunks c () + ReleaseMapClosed -> wNoThunks c () instance NoThunks ReleaseKey where noThunks c (ReleaseKey r i) = noThunks c (r, i) diff --git a/examples/lib/RefCounted.hs b/examples/lib/RefCounted.hs index e8264f768..5b1bdbb2c 100644 --- a/examples/lib/RefCounted.hs +++ b/examples/lib/RefCounted.hs @@ -1,54 +1,62 @@ {-# LANGUAGE DerivingVia #-} + module RefCounted where -import Control.Exception ( throwIO ) -import Control.Monad -import Control.Monad.IO.Class ( MonadIO - , liftIO - ) -import Control.Monad.Trans.Resource ( MonadResource - , allocate_ - ) -import Data.IORef -import GHC.IO.Exception ( IOErrorType(UserError) - , IOException(IOError) - ) -import NoThunks.Class -import UnliftIO.Exception ( mask ) +import Control.Exception (throwIO) +import Control.Monad +import Control.Monad.IO.Class + ( MonadIO + , liftIO + ) +import Control.Monad.Trans.Resource + ( MonadResource + , allocate_ + ) +import Data.IORef +import GHC.IO.Exception + ( IOErrorType (UserError) + , IOException (IOError) + ) +import NoThunks.Class +import UnliftIO.Exception (mask) -- | A 'RefCounted' will perform the specified action when the count reaches 0 data RefCounted = RefCounted - { rcCount :: IORef Int + { rcCount :: IORef Int , rcAction :: IO () } - deriving NoThunks via InspectHeap RefCounted + deriving (NoThunks) via InspectHeap RefCounted -- | Create a counter with a value of 1 -newRefCounted :: MonadIO m => IO () -> m RefCounted +newRefCounted :: (MonadIO m) => IO () -> m RefCounted newRefCounted rcAction = do rcCount <- liftIO $ newIORef 1 - pure RefCounted { .. } + pure RefCounted{..} --- | Decrement the value, the action will be run promptly and in --- this thread if the counter reached 0. -releaseRefCounted :: MonadIO m => RefCounted -> m () -releaseRefCounted RefCounted {..} = liftIO $ mask $ \_ -> +{- | Decrement the value, the action will be run promptly and in +this thread if the counter reached 0. +-} +releaseRefCounted :: (MonadIO m) => RefCounted -> m () +releaseRefCounted RefCounted{..} = liftIO $ mask $ \_ -> atomicModifyIORef' rcCount (\c -> (pred c, pred c)) >>= \case - 0 -> rcAction - n | n < 0 -> liftIO . throwIO $ IOError - Nothing - UserError - "" - "Ref counted value decremented below 0" - Nothing - Nothing + 0 -> rcAction + n + | n < 0 -> + liftIO . throwIO $ + IOError + Nothing + UserError + "" + "Ref counted value decremented below 0" + Nothing + Nothing _ -> pure () -- | Increment the counter by 1 -takeRefCounted :: MonadIO m => RefCounted -> m () -takeRefCounted RefCounted {..} = +takeRefCounted :: (MonadIO m) => RefCounted -> m () +takeRefCounted RefCounted{..} = liftIO $ atomicModifyIORef' rcCount (\c -> (succ c, ())) -- | Hold a reference for the duration of the 'MonadResource' action -resourceTRefCount :: MonadResource f => RefCounted -> f () +resourceTRefCount :: (MonadResource f) => RefCounted -> f () resourceTRefCount r = void $ allocate_ (takeRefCounted r) (releaseRefCounted r) diff --git a/examples/lib/Swapchain.hs b/examples/lib/Swapchain.hs index f00bbd37d..7f0002bd8 100644 --- a/examples/lib/Swapchain.hs +++ b/examples/lib/Swapchain.hs @@ -2,55 +2,60 @@ {-# LANGUAGE DeriveGeneric #-} {-# OPTIONS_GHC -Wno-missing-signatures #-} --- | Swapchain creation, recreation, and the small helper for catching --- swapchain-out-of-date exceptions thrown elsewhere. +{-| Swapchain creation, recreation, and the small helper for catching +swapchain-out-of-date exceptions thrown elsewhere. +-} module Swapchain - ( Swapchain(..) + ( Swapchain (..) , allocSwapchain , recreateSwapchain , threwSwapchainError ) where -import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Trans.Resource -import Data.Bits -import Data.Either -import Data.Foldable ( for_ - , traverse_ - ) -import qualified Data.Vector as V -import Data.Vector ( Vector ) +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Resource +import Data.Bits +import Data.Either +import Data.Foldable + ( for_ + , traverse_ + ) +import Data.Vector (Vector) +import qualified Data.Vector as V import qualified Framebuffer -import GHC.Generics ( Generic ) -import NoThunks.Class -import Orphans ( ) -import RefCounted -import UnliftIO.Exception ( throwString - , tryJust - ) -import VkResources ( VkResources(..) ) -import Vulkan.Core10 -import Vulkan.Exception -import Vulkan.Extensions.VK_KHR_surface -import Vulkan.Extensions.VK_KHR_surface as SurfaceCapabilitiesKHR - ( SurfaceCapabilitiesKHR(..) ) -import Vulkan.Extensions.VK_KHR_surface as SurfaceFormatKHR - ( SurfaceFormatKHR(..) ) -import Vulkan.Extensions.VK_KHR_swapchain -import Vulkan.Utils.Misc ( (.&&.) ) -import Vulkan.Zero +import GHC.Generics (Generic) +import NoThunks.Class +import Orphans () +import RefCounted +import UnliftIO.Exception + ( throwString + , tryJust + ) +import VkResources (VkResources (..)) +import Vulkan.Core10 +import Vulkan.Exception +import Vulkan.Extensions.VK_KHR_surface +import Vulkan.Extensions.VK_KHR_surface as SurfaceCapabilitiesKHR + ( SurfaceCapabilitiesKHR (..) + ) +import Vulkan.Extensions.VK_KHR_surface as SurfaceFormatKHR + ( SurfaceFormatKHR (..) + ) +import Vulkan.Extensions.VK_KHR_swapchain +import Vulkan.Utils.Misc ((.&&.)) +import Vulkan.Zero data Swapchain = Swapchain - { sSwapchain :: SwapchainKHR - , sSurface :: SurfaceKHR - , sFormat :: SurfaceFormatKHR - , sExtent :: Extent2D - , sPresentMode :: PresentModeKHR - , sImages :: Vector Image - , sImageViews :: Vector ImageView - , sRelease :: RefCounted - -- ^ Held until no in-flight frame still uses this swapchain. + { sSwapchain :: SwapchainKHR + , sSurface :: SurfaceKHR + , sFormat :: SurfaceFormatKHR + , sExtent :: Extent2D + , sPresentMode :: PresentModeKHR + , sImages :: Vector Image + , sImageViews :: Vector ImageView + , sRelease :: RefCounted + -- ^ Held until no in-flight frame still uses this swapchain. } deriving (Generic, NoThunks) @@ -62,8 +67,10 @@ data Swapchain = Swapchain allocSwapchain :: (MonadUnliftIO m, MonadResource m) => VkResources - -> SwapchainKHR -- ^ Previous swapchain ('NULL_HANDLE' for first) - -> Extent2D -- ^ Fallback size when the surface lets us pick + -> SwapchainKHR + -- ^ Previous swapchain ('NULL_HANDLE' for first) + -> Extent2D + -- ^ Fallback size when the surface lets us pick -> SurfaceKHR -> m Swapchain allocSwapchain vr oldSwapchain windowSize surface = do @@ -73,23 +80,26 @@ allocSwapchain vr oldSwapchain windowSize surface = do (_, sImages) <- getSwapchainImagesKHR (vrDevice vr) sSwapchain (imageViewKeys, sImageViews) <- fmap V.unzip . V.forM sImages $ \image -> - Framebuffer.createImageView (vrDevice vr) - (SurfaceFormatKHR.format sFormat) - image + Framebuffer.createImageView + (vrDevice vr) + (SurfaceFormatKHR.format sFormat) + image -- Released by the next 'recreateSwapchain' (when frames stop using it). sRelease <- newRefCounted $ do traverse_ release imageViewKeys release swapchainKey - pure Swapchain { sSurface = surface, .. } + pure Swapchain{sSurface = surface, ..} --- | Build a new swapchain at a new size, dropping the reference to the old --- one so its resources can be released once in-flight frames complete. +{- | Build a new swapchain at a new size, dropping the reference to the old +one so its resources can be released once in-flight frames complete. +-} recreateSwapchain :: (MonadUnliftIO m, MonadResource m) => VkResources - -> Extent2D -- ^ New window size + -> Extent2D + -- ^ New window size -> Swapchain -> m Swapchain recreateSwapchain vr newSize old = do @@ -109,21 +119,22 @@ createSwapchain -> SurfaceKHR -> m (SwapchainKHR, SurfaceFormatKHR, Extent2D, PresentModeKHR, ReleaseKey) createSwapchain vr oldSwapchain explicitSize surf = do - let phys = vrPhysicalDevice vr - dev = vrDevice vr + let + phys = vrPhysicalDevice vr + dev = vrDevice vr surfaceCaps <- getPhysicalDeviceSurfaceCapabilitiesKHR phys surf -- Sanity-check that the surface advertises the usages we need. for_ requiredUsageFlags $ \f -> - unless (supportedUsageFlags surfaceCaps .&&. f) - $ throwString ("Surface images do not support " <> show f) + unless (supportedUsageFlags surfaceCaps .&&. f) $ + throwString ("Surface images do not support " <> show f) -- Pick a present mode in our preference order. (_, availablePresentModes) <- getPhysicalDeviceSurfacePresentModesKHR phys surf presentMode <- case filter (`V.elem` availablePresentModes) desiredPresentModes of - [] -> throwString "Unable to find a suitable present mode for swapchain" + [] -> throwString "Unable to find a suitable present mode for swapchain" x : _ -> pure x -- Pick a surface format. Vulkan guarantees at least one. @@ -141,7 +152,7 @@ createSwapchain vr oldSwapchain explicitSize surf = do limit = case maxImageCount (surfaceCaps :: SurfaceCapabilitiesKHR) of 0 -> maxBound n -> n - buffer = 1 -- request one extra to avoid waiting on the driver + buffer = 1 -- request one extra to avoid waiting on the driver desired = buffer + SurfaceCapabilitiesKHR.minImageCount surfaceCaps in min limit desired @@ -151,24 +162,25 @@ createSwapchain vr oldSwapchain explicitSize surf = do then pure COMPOSITE_ALPHA_OPAQUE_BIT_KHR else throwString "Surface doesn't support COMPOSITE_ALPHA_OPAQUE_BIT_KHR" - let swapchainCreateInfo = SwapchainCreateInfoKHR - { surface = surf - , next = () - , flags = zero - , queueFamilyIndices = mempty - , minImageCount = imageCount - , imageFormat = SurfaceFormatKHR.format surfaceFormat - , imageColorSpace = colorSpace surfaceFormat - , imageExtent = imageExtent - , imageArrayLayers = 1 - , imageUsage = foldr (.|.) zero requiredUsageFlags - , imageSharingMode = SHARING_MODE_EXCLUSIVE - , preTransform = SurfaceCapabilitiesKHR.currentTransform surfaceCaps - , compositeAlpha = compositeAlphaMode - , presentMode = presentMode - , clipped = True - , oldSwapchain = oldSwapchain - } + let swapchainCreateInfo = + SwapchainCreateInfoKHR + { surface = surf + , next = () + , flags = zero + , queueFamilyIndices = mempty + , minImageCount = imageCount + , imageFormat = SurfaceFormatKHR.format surfaceFormat + , imageColorSpace = colorSpace surfaceFormat + , imageExtent = imageExtent + , imageArrayLayers = 1 + , imageUsage = foldr (.|.) zero requiredUsageFlags + , imageSharingMode = SHARING_MODE_EXCLUSIVE + , preTransform = SurfaceCapabilitiesKHR.currentTransform surfaceCaps + , compositeAlpha = compositeAlphaMode + , presentMode = presentMode + , clipped = True + , oldSwapchain = oldSwapchain + } (key, swapchain) <- withSwapchainKHR dev swapchainCreateInfo Nothing allocate @@ -178,16 +190,19 @@ createSwapchain vr oldSwapchain explicitSize surf = do -- Format selection ---------------------------------------------------------------- --- | Prefer formats whose 'optimalTilingFeatures' satisfy --- 'requiredFormatFeatures'; SRGB formats typically omit --- 'FORMAT_FEATURE_STORAGE_IMAGE_BIT' and would otherwise cause --- @vkCreateSwapchainKHR@ to fail. +{- | Prefer formats whose 'optimalTilingFeatures' satisfy +'requiredFormatFeatures'; SRGB formats typically omit +'FORMAT_FEATURE_STORAGE_IMAGE_BIT' and would otherwise cause +@vkCreateSwapchainKHR@ to fail. +-} selectSurfaceFormat - :: MonadIO m => PhysicalDevice -> Vector SurfaceFormatKHR -> m SurfaceFormatKHR + :: (MonadIO m) => PhysicalDevice -> Vector SurfaceFormatKHR -> m SurfaceFormatKHR selectSurfaceFormat phys fmts = do let suitable f = do - props <- getPhysicalDeviceFormatProperties phys - (SurfaceFormatKHR.format f) + props <- + getPhysicalDeviceFormatProperties + phys + (SurfaceFormatKHR.format f) pure $ all (optimalTilingFeatures props .&&.) requiredFormatFeatures good <- V.filterM suitable fmts pure $ if V.null good then V.head fmts else V.head good @@ -197,13 +212,13 @@ selectSurfaceFormat phys fmts = do ---------------------------------------------------------------- -- | Catch an 'ERROR_OUT_OF_DATE_KHR' exception and return 'True' when caught. -threwSwapchainError :: MonadUnliftIO f => f b -> f Bool +threwSwapchainError :: (MonadUnliftIO f) => f b -> f Bool threwSwapchainError = fmap isLeft . tryJust swapchainError - where - swapchainError = \case - VulkanException e@ERROR_OUT_OF_DATE_KHR -> Just e - -- TODO: handle ERROR_SURFACE_LOST_KHR too - VulkanException _ -> Nothing + where + swapchainError = \case + VulkanException e@ERROR_OUT_OF_DATE_KHR -> Just e + -- TODO: handle ERROR_SURFACE_LOST_KHR too + VulkanException _ -> Nothing -- | Present-mode preference, best first. desiredPresentModes :: [PresentModeKHR] diff --git a/examples/lib/Triangle.hs b/examples/lib/Triangle.hs index 94f35d203..da92fe292 100644 --- a/examples/lib/Triangle.hs +++ b/examples/lib/Triangle.hs @@ -3,95 +3,108 @@ {-# LANGUAGE QuasiQuotes #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} --- | Backend-independent triangle renderer using the recycling 'Frame' loop --- from "Frame". Each backend (SDL2, GLFW) builds 'VkResources' + an initial --- 'Swapchain', supplies callbacks for "current drawable size" and "should --- quit", and hands off to 'runTriangle'. +{-| Backend-independent triangle renderer using the recycling 'Frame' loop +from "Frame". Each backend (SDL2, GLFW) builds 'VkResources' + an initial +'Swapchain', supplies callbacks for "current drawable size" and "should +quit", and hands off to 'runTriangle'. +-} module Triangle ( runTriangle ) where -import Control.Exception ( throwIO ) -import Control.Monad.IO.Class -import Control.Monad.Trans.Resource -import Data.Bits ( (.|.) ) -import Data.Foldable ( traverse_ ) -import qualified Data.Vector as V -import Data.Vector ( Vector ) +import Control.Exception (throwIO) +import Control.Monad.IO.Class +import Control.Monad.Trans.Resource +import Data.Bits ((.|.)) +import Data.Foldable (traverse_) +import Data.Vector (Vector) +import qualified Data.Vector as V -import Frame ( Frame(..) - , advanceFrame - , initialFrame - , queueSubmitFrame - , runFrame - ) +import Data.IORef +import Frame + ( Frame (..) + , advanceFrame + , initialFrame + , queueSubmitFrame + , runFrame + ) import qualified Framebuffer -import Data.IORef -import RefCounted ( releaseRefCounted ) -import Swapchain ( Swapchain(..) - , recreateSwapchain - , threwSwapchainError - ) -import Utils ( loopJust ) -import VkResources ( Queues(..) - , RecycledResources(..) - , VkResources(..) - ) +import RefCounted (releaseRefCounted) +import Swapchain + ( Swapchain (..) + , recreateSwapchain + , threwSwapchainError + ) +import Utils (loopJust) +import VkResources + ( Queues (..) + , RecycledResources (..) + , VkResources (..) + ) -import Vulkan.CStruct.Extends -import Vulkan.Core10 as Vk - hiding ( withImage - , createRenderPass - ) -import qualified Vulkan.Core10 as CommandBufferBeginInfo (CommandBufferBeginInfo(..)) -import Vulkan.Core12.Promoted_From_VK_KHR_timeline_semaphore -import Vulkan.Exception ( VulkanException(..) ) -import Vulkan.Extensions.VK_KHR_surface as SurfaceFormatKHR - ( SurfaceFormatKHR(..) ) -import Vulkan.Extensions.VK_KHR_swapchain - as Swap -import Vulkan.Utils.ShaderQQ.GLSL.Glslang -import Vulkan.Zero +import Vulkan.CStruct.Extends +import Vulkan.Core10 as Vk hiding + ( createRenderPass + , withImage + ) +import qualified Vulkan.Core10 as CommandBufferBeginInfo (CommandBufferBeginInfo (..)) +import Vulkan.Core12.Promoted_From_VK_KHR_timeline_semaphore +import Vulkan.Exception (VulkanException (..)) +import Vulkan.Extensions.VK_KHR_surface as SurfaceFormatKHR + ( SurfaceFormatKHR (..) + ) +import Vulkan.Extensions.VK_KHR_swapchain as Swap +import Vulkan.Utils.ShaderQQ.GLSL.Glslang +import Vulkan.Zero -- | Drive a recycling-Frame render loop drawing the colored triangle. runTriangle :: VkResources - -> Swapchain -- ^ Initial swapchain - -> IO Extent2D -- ^ Get current drawable size (for resize) - -> IO Bool -- ^ Per-frame poller; 'True' means quit + -> Swapchain + -- ^ Initial swapchain + -> IO Extent2D + -- ^ Get current drawable size (for resize) + -> IO Bool + -- ^ Per-frame poller; 'True' means quit -> ResourceT IO () runTriangle vr initialSC getDrawableSize shouldQuit = do let dev = vrDevice vr (_, renderPass) <- createRenderPass dev (SurfaceFormatKHR.format (sFormat initialSC)) - (_, pipeline) <- createGraphicsPipeline dev renderPass - initialFBs <- Framebuffer.createFramebuffers dev renderPass (sImageViews initialSC) (sExtent initialSC) + (_, pipeline) <- createGraphicsPipeline dev renderPass + initialFBs <- Framebuffer.createFramebuffers dev renderPass (sImageViews initialSC) (sExtent initialSC) - scRef <- liftIO $ newIORef initialSC + scRef <- liftIO $ newIORef initialSC fbsRef <- liftIO $ newIORef initialFBs initial <- initialFrame vr initialSC - let perFrame f = do - currentSC <- liftIO $ readIORef scRef - (currentFBs, _rel) <- liftIO $ readIORef fbsRef - let f' = f { fSwapchain = currentSC } - needsNew <- threwSwapchainError $ liftIO $ runFrame vr f' $ - drawTriangle vr renderPass pipeline currentFBs f' - sc' <- if needsNew + let + perFrame f = do + currentSC <- liftIO $ readIORef scRef + (currentFBs, _rel) <- liftIO $ readIORef fbsRef + let f' = f{fSwapchain = currentSC} + needsNew <- + threwSwapchainError $ + liftIO $ + runFrame vr f' $ + drawTriangle vr renderPass pipeline currentFBs f' + sc' <- + if needsNew then do - newSize <- liftIO getDrawableSize - sc' <- recreateSwapchain vr newSize currentSC - newFBs <- Framebuffer.createFramebuffers dev renderPass (sImageViews sc') (sExtent sc') + newSize <- liftIO getDrawableSize + sc' <- recreateSwapchain vr newSize currentSC + newFBs <- Framebuffer.createFramebuffers dev renderPass (sImageViews sc') (sExtent sc') (_oldFbs, oldRel) <- liftIO $ readIORef fbsRef releaseRefCounted oldRel - liftIO $ writeIORef scRef sc' + liftIO $ writeIORef scRef sc' liftIO $ writeIORef fbsRef newFBs pure sc' else pure currentSC - advanceFrame vr sc' f' + advanceFrame vr sc' f' - loop f = liftIO shouldQuit >>= \case - True -> do + loop f = + liftIO shouldQuit >>= \case + True -> do deviceWaitIdle dev pure Nothing False -> Just <$> perFrame f @@ -110,125 +123,146 @@ drawTriangle -> Frame -> ResourceT IO () drawTriangle vr renderPass pipeline framebuffers f = do - let RecycledResources {..} = fRecycled f - sc = fSwapchain f - dev = vrDevice vr - gQ = snd (qGraphics (vrQueues vr)) - oneSecond = 1e9 + let + RecycledResources{..} = fRecycled f + sc = fSwapchain f + dev = vrDevice vr + gQ = snd (qGraphics (vrQueues vr)) + oneSecond = 1e9 (acquireResult, imageIndex) <- acquireNextImageKHRSafe dev (sSwapchain sc) oneSecond rrImageAvailable NULL_HANDLE >>= \case - r@(SUCCESS, _) -> pure r - r@(SUBOPTIMAL_KHR, _) -> pure r - (TIMEOUT, _) -> liftIO . throwIO $ VulkanException ERROR_OUT_OF_DATE_KHR - _ -> liftIO . throwIO $ VulkanException ERROR_OUT_OF_DATE_KHR + r@(SUCCESS, _) -> pure r + r@(SUBOPTIMAL_KHR, _) -> pure r + (TIMEOUT, _) -> liftIO . throwIO $ VulkanException ERROR_OUT_OF_DATE_KHR + _ -> liftIO . throwIO $ VulkanException ERROR_OUT_OF_DATE_KHR - (_, ~[commandBuffer]) <- withCommandBuffers - dev - zero { commandPool = rrCommandPool - , level = COMMAND_BUFFER_LEVEL_PRIMARY - , commandBufferCount = 1 - } - allocate - - let renderPassBeginInfo = zero - { renderPass = renderPass - , framebuffer = framebuffers V.! fromIntegral imageIndex - , renderArea = Rect2D { offset = zero, extent = sExtent sc } - , clearValues = [Color (Float32 0.1 0.1 0.1 0)] + (_, ~[commandBuffer]) <- + withCommandBuffers + dev + zero + { commandPool = rrCommandPool + , level = COMMAND_BUFFER_LEVEL_PRIMARY + , commandBufferCount = 1 } + allocate + + let renderPassBeginInfo = + zero + { renderPass = renderPass + , framebuffer = framebuffers V.! fromIntegral imageIndex + , renderArea = Rect2D{offset = zero, extent = sExtent sc} + , clearValues = [Color (Float32 0.1 0.1 0.1 0)] + } useCommandBuffer - commandBuffer - zero { CommandBufferBeginInfo.flags = COMMAND_BUFFER_USAGE_ONE_TIME_SUBMIT_BIT } + commandBuffer + zero{CommandBufferBeginInfo.flags = COMMAND_BUFFER_USAGE_ONE_TIME_SUBMIT_BIT} $ do - cmdUseRenderPass commandBuffer renderPassBeginInfo SUBPASS_CONTENTS_INLINE $ do - let Extent2D w h = sExtent sc - cmdSetViewport commandBuffer 0 - [ Viewport { x = 0 - , y = 0 - , width = realToFrac w - , height = realToFrac h - , minDepth = 0 - , maxDepth = 1 - } - ] - cmdSetScissor commandBuffer 0 - [Rect2D { offset = Offset2D 0 0, extent = sExtent sc }] - cmdBindPipeline commandBuffer PIPELINE_BIND_POINT_GRAPHICS pipeline - cmdDraw commandBuffer 3 1 0 0 + cmdUseRenderPass commandBuffer renderPassBeginInfo SUBPASS_CONTENTS_INLINE $ do + let Extent2D w h = sExtent sc + cmdSetViewport + commandBuffer + 0 + [ Viewport + { x = 0 + , y = 0 + , width = realToFrac w + , height = realToFrac h + , minDepth = 0 + , maxDepth = 1 + } + ] + cmdSetScissor + commandBuffer + 0 + [Rect2D{offset = Offset2D 0 0, extent = sExtent sc}] + cmdBindPipeline commandBuffer PIPELINE_BIND_POINT_GRAPHICS pipeline + cmdDraw commandBuffer 3 1 0 0 let submitInfo = - zero { Vk.waitSemaphores = [rrImageAvailable] - , waitDstStageMask = [PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT] - , commandBuffers = [commandBufferHandle commandBuffer] - , signalSemaphores = [rrRenderFinished, fHostTimeline f] - } - ::& zero { waitSemaphoreValues = [1] - , signalSemaphoreValues = [1, fIndex f] - } - :& () - liftIO $ queueSubmitFrame gQ - f - [SomeStruct submitInfo] - (fHostTimeline f) - (fIndex f) + zero + { Vk.waitSemaphores = [rrImageAvailable] + , waitDstStageMask = [PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT] + , commandBuffers = [commandBufferHandle commandBuffer] + , signalSemaphores = [rrRenderFinished, fHostTimeline f] + } + ::& zero + { waitSemaphoreValues = [1] + , signalSemaphoreValues = [1, fIndex f] + } + :& () + liftIO $ + queueSubmitFrame + gQ + f + [SomeStruct submitInfo] + (fHostTimeline f) + (fIndex f) - presentResult <- queuePresentKHR - gQ - zero { Swap.waitSemaphores = [rrRenderFinished] - , swapchains = [sSwapchain sc] - , imageIndices = [imageIndex] - } + presentResult <- + queuePresentKHR + gQ + zero + { Swap.waitSemaphores = [rrRenderFinished] + , swapchains = [sSwapchain sc] + , imageIndices = [imageIndex] + } case (acquireResult, presentResult) of (SUBOPTIMAL_KHR, _) -> liftIO . throwIO $ VulkanException ERROR_OUT_OF_DATE_KHR (_, SUBOPTIMAL_KHR) -> liftIO . throwIO $ VulkanException ERROR_OUT_OF_DATE_KHR - _ -> pure () + _ -> pure () ---------------------------------------------------------------- -- Render pass + pipeline (long-lived) ---------------------------------------------------------------- createRenderPass - :: MonadResource m => Device -> Format -> m (ReleaseKey, RenderPass) -createRenderPass dev imageFormat = withRenderPass - dev - zero { attachments = [attachmentDescription] - , subpasses = [subpass] - , dependencies = [subpassDependency] - } - Nothing - allocate - where - attachmentDescription :: AttachmentDescription - attachmentDescription = zero - { format = imageFormat - , samples = SAMPLE_COUNT_1_BIT - , loadOp = ATTACHMENT_LOAD_OP_CLEAR - , storeOp = ATTACHMENT_STORE_OP_STORE - , stencilLoadOp = ATTACHMENT_LOAD_OP_DONT_CARE - , stencilStoreOp = ATTACHMENT_STORE_OP_DONT_CARE - , initialLayout = IMAGE_LAYOUT_UNDEFINED - , finalLayout = IMAGE_LAYOUT_PRESENT_SRC_KHR - } - subpass :: SubpassDescription - subpass = zero - { pipelineBindPoint = PIPELINE_BIND_POINT_GRAPHICS - , colorAttachments = - [zero { attachment = 0, layout = IMAGE_LAYOUT_COLOR_ATTACHMENT_OPTIMAL }] - } - subpassDependency :: SubpassDependency - subpassDependency = zero - { srcSubpass = SUBPASS_EXTERNAL - , dstSubpass = 0 - , srcStageMask = PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT - , srcAccessMask = zero - , dstStageMask = PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT - , dstAccessMask = ACCESS_COLOR_ATTACHMENT_READ_BIT - .|. ACCESS_COLOR_ATTACHMENT_WRITE_BIT - } + :: (MonadResource m) => Device -> Format -> m (ReleaseKey, RenderPass) +createRenderPass dev imageFormat = + withRenderPass + dev + zero + { attachments = [attachmentDescription] + , subpasses = [subpass] + , dependencies = [subpassDependency] + } + Nothing + allocate + where + attachmentDescription :: AttachmentDescription + attachmentDescription = + zero + { format = imageFormat + , samples = SAMPLE_COUNT_1_BIT + , loadOp = ATTACHMENT_LOAD_OP_CLEAR + , storeOp = ATTACHMENT_STORE_OP_STORE + , stencilLoadOp = ATTACHMENT_LOAD_OP_DONT_CARE + , stencilStoreOp = ATTACHMENT_STORE_OP_DONT_CARE + , initialLayout = IMAGE_LAYOUT_UNDEFINED + , finalLayout = IMAGE_LAYOUT_PRESENT_SRC_KHR + } + subpass :: SubpassDescription + subpass = + zero + { pipelineBindPoint = PIPELINE_BIND_POINT_GRAPHICS + , colorAttachments = + [zero{attachment = 0, layout = IMAGE_LAYOUT_COLOR_ATTACHMENT_OPTIMAL}] + } + subpassDependency :: SubpassDependency + subpassDependency = + zero + { srcSubpass = SUBPASS_EXTERNAL + , dstSubpass = 0 + , srcStageMask = PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT + , srcAccessMask = zero + , dstStageMask = PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT + , dstAccessMask = + ACCESS_COLOR_ATTACHMENT_READ_BIT + .|. ACCESS_COLOR_ATTACHMENT_WRITE_BIT + } createGraphicsPipeline :: (MonadResource m, MonadFail m) @@ -237,72 +271,89 @@ createGraphicsPipeline -> m (ReleaseKey, Pipeline) createGraphicsPipeline dev renderPass = do (shaderKeys, shaderStages) <- V.unzip <$> createShaders dev - (layoutKey , pipelineLayout) <- withPipelineLayout dev zero Nothing allocate - let pipelineCreateInfo :: GraphicsPipelineCreateInfo '[] - pipelineCreateInfo = zero - { stages = shaderStages - , vertexInputState = Just zero - , inputAssemblyState = Just zero - { topology = PRIMITIVE_TOPOLOGY_TRIANGLE_LIST - , primitiveRestartEnable = False - } - , viewportState = Just - $ SomeStruct zero { viewportCount = 1, scissorCount = 1 } - , rasterizationState = Just . SomeStruct $ zero - { depthClampEnable = False - , rasterizerDiscardEnable = False - , lineWidth = 1 - , polygonMode = POLYGON_MODE_FILL - , cullMode = CULL_MODE_NONE - , frontFace = FRONT_FACE_CLOCKWISE - , depthBiasEnable = False - } - , multisampleState = Just . SomeStruct $ zero - { sampleShadingEnable = False - , rasterizationSamples = SAMPLE_COUNT_1_BIT - , minSampleShading = 1 - , sampleMask = [maxBound] - } - , depthStencilState = Nothing - , colorBlendState = Just . SomeStruct $ zero - { logicOpEnable = False - , attachments = - [ zero - { colorWriteMask = - COLOR_COMPONENT_R_BIT - .|. COLOR_COMPONENT_G_BIT - .|. COLOR_COMPONENT_B_BIT - .|. COLOR_COMPONENT_A_BIT - , blendEnable = False - } - ] - } - , dynamicState = Just zero - { dynamicStates = [ DYNAMIC_STATE_VIEWPORT - , DYNAMIC_STATE_SCISSOR - ] - } - , layout = pipelineLayout - , renderPass = renderPass - , subpass = 0 + (layoutKey, pipelineLayout) <- withPipelineLayout dev zero Nothing allocate + let + pipelineCreateInfo :: GraphicsPipelineCreateInfo '[] + pipelineCreateInfo = + zero + { stages = shaderStages + , vertexInputState = Just zero + , inputAssemblyState = + Just + zero + { topology = PRIMITIVE_TOPOLOGY_TRIANGLE_LIST + , primitiveRestartEnable = False + } + , viewportState = + Just $ + SomeStruct zero{viewportCount = 1, scissorCount = 1} + , rasterizationState = + Just . SomeStruct $ + zero + { depthClampEnable = False + , rasterizerDiscardEnable = False + , lineWidth = 1 + , polygonMode = POLYGON_MODE_FILL + , cullMode = CULL_MODE_NONE + , frontFace = FRONT_FACE_CLOCKWISE + , depthBiasEnable = False + } + , multisampleState = + Just . SomeStruct $ + zero + { sampleShadingEnable = False + , rasterizationSamples = SAMPLE_COUNT_1_BIT + , minSampleShading = 1 + , sampleMask = [maxBound] + } + , depthStencilState = Nothing + , colorBlendState = + Just . SomeStruct $ + zero + { logicOpEnable = False + , attachments = + [ zero + { colorWriteMask = + COLOR_COMPONENT_R_BIT + .|. COLOR_COMPONENT_G_BIT + .|. COLOR_COMPONENT_B_BIT + .|. COLOR_COMPONENT_A_BIT + , blendEnable = False + } + ] + } + , dynamicState = + Just + zero + { dynamicStates = + [ DYNAMIC_STATE_VIEWPORT + , DYNAMIC_STATE_SCISSOR + ] + } + , layout = pipelineLayout + , renderPass = renderPass + , subpass = 0 , basePipelineHandle = zero } - (key, (_, [graphicsPipeline])) <- withGraphicsPipelines - dev - zero - [SomeStruct pipelineCreateInfo] - Nothing - allocate + (key, (_, [graphicsPipeline])) <- + withGraphicsPipelines + dev + zero + [SomeStruct pipelineCreateInfo] + Nothing + allocate release layoutKey traverse_ release shaderKeys pure (key, graphicsPipeline) createShaders - :: MonadResource m + :: (MonadResource m) => Device -> m (V.Vector (ReleaseKey, SomeStruct PipelineShaderStageCreateInfo)) createShaders dev = do - let fragCode = [frag| + let + fragCode = + [frag| #version 450 #extension GL_ARB_separate_shader_objects : enable @@ -313,7 +364,8 @@ createShaders dev = do outColor = vec4(fragColor, 1.0); } |] - vertCode = [vert| + vertCode = + [vert| #version 450 #extension GL_ARB_separate_shader_objects : enable @@ -335,18 +387,22 @@ createShaders dev = do fragColor = colors[gl_VertexIndex]; } |] - (fragKey, fragModule) <- withShaderModule dev zero { code = fragCode } Nothing allocate - (vertKey, vertModule) <- withShaderModule dev zero { code = vertCode } Nothing allocate - let vertShaderStageCreateInfo = zero { stage = SHADER_STAGE_VERTEX_BIT - , module' = vertModule - , name = "main" - } - fragShaderStageCreateInfo = zero { stage = SHADER_STAGE_FRAGMENT_BIT - , module' = fragModule - , name = "main" - } + (fragKey, fragModule) <- withShaderModule dev zero{code = fragCode} Nothing allocate + (vertKey, vertModule) <- withShaderModule dev zero{code = vertCode} Nothing allocate + let + vertShaderStageCreateInfo = + zero + { stage = SHADER_STAGE_VERTEX_BIT + , module' = vertModule + , name = "main" + } + fragShaderStageCreateInfo = + zero + { stage = SHADER_STAGE_FRAGMENT_BIT + , module' = fragModule + , name = "main" + } pure [ (vertKey, SomeStruct vertShaderStageCreateInfo) , (fragKey, SomeStruct fragShaderStageCreateInfo) ] - diff --git a/examples/lib/Utils.hs b/examples/lib/Utils.hs index eb8c893ac..19ad67f90 100644 --- a/examples/lib/Utils.hs +++ b/examples/lib/Utils.hs @@ -4,26 +4,29 @@ module Utils , noSuchThing ) where -import Control.Concurrent ( ) -import Control.Monad ( unless ) -import Control.Monad.IO.Class ( MonadIO, liftIO ) -import GHC.IO.Exception ( IOErrorType(NoSuchThing) - , IOException(IOError) - ) -import UnliftIO.Exception ( throwIO ) +import Control.Concurrent () +import Control.Monad (unless) +import Control.Monad.IO.Class (MonadIO, liftIO) +import GHC.IO.Exception + ( IOErrorType (NoSuchThing) + , IOException (IOError) + ) +import UnliftIO.Exception (throwIO) -loopJust :: Monad m => (a -> m (Maybe a)) -> a -> m () -loopJust f x = f x >>= \case - Nothing -> pure () - Just x' -> loopJust f x' +loopJust :: (Monad m) => (a -> m (Maybe a)) -> a -> m () +loopJust f x = + f x >>= \case + Nothing -> pure () + Just x' -> loopJust f x' -loopUntilM :: Monad m => m Bool -> m () +loopUntilM :: (Monad m) => m Bool -> m () loopUntilM m = do q <- m unless q $ loopUntilM m --- | Throw 'IOError' with 'NoSuchThing' as the error type. Mirrors the small --- helper duplicated across several example executables. -noSuchThing :: MonadIO m => String -> m a +{- | Throw 'IOError' with 'NoSuchThing' as the error type. Mirrors the small +helper duplicated across several example executables. +-} +noSuchThing :: (MonadIO m) => String -> m a noSuchThing message = liftIO . throwIO $ IOError Nothing NoSuchThing "" message Nothing Nothing diff --git a/examples/lib/VkResources.hs b/examples/lib/VkResources.hs index ed4c171b5..277827104 100644 --- a/examples/lib/VkResources.hs +++ b/examples/lib/VkResources.hs @@ -1,71 +1,83 @@ --- | Application-static Vulkan handles plus the recycle channel ends used by --- the recycling 'Frame' machinery in "Frame". +{-| Application-static Vulkan handles plus the recycle channel ends used by +the recycling 'Frame' machinery in "Frame". +-} module VkResources - ( VkResources(..) - , Queues(..) - , RecycledResources(..) + ( VkResources (..) + , Queues (..) + , RecycledResources (..) , mkVkResources ) where -import Control.Concurrent.Chan.Unagi -import Vulkan.Core10 ( CommandPool - , Device - , Instance - , PhysicalDevice - , Queue - , Semaphore - ) -import Vulkan.Utils.QueueAssignment ( QueueFamilyIndex ) -import VulkanMemoryAllocator ( Allocator ) +import Control.Concurrent.Chan.Unagi +import Vulkan.Core10 + ( CommandPool + , Device + , Instance + , PhysicalDevice + , Queue + , Semaphore + ) +import Vulkan.Utils.QueueAssignment (QueueFamilyIndex) +import VulkanMemoryAllocator (Allocator) --- | A bunch of long-lived handles that the application carries around. --- Constructed once, never modified. +{- | A bunch of long-lived handles that the application carries around. +Constructed once, never modified. +-} data VkResources = VkResources - { vrInstance :: Instance + { vrInstance :: Instance , vrPhysicalDevice :: PhysicalDevice - , vrDevice :: Device - , vrAllocator :: Allocator - , vrQueues :: Queues (QueueFamilyIndex, Queue) - , vrRecycleBin :: RecycledResources -> IO () - -- ^ Drop a frame's reusable bits back into the pool. Called from the - -- per-frame wait thread once the GPU is done with the frame. - , vrRecycleNib :: IO (Either (IO RecycledResources) RecycledResources) - -- ^ Pull a frame's reusable bits out. 'Right' if available immediately; - -- 'Left' is a blocking read. + , vrDevice :: Device + , vrAllocator :: Allocator + , vrQueues :: Queues (QueueFamilyIndex, Queue) + , vrRecycleBin :: RecycledResources -> IO () + {- ^ Drop a frame's reusable bits back into the pool. Called from the + per-frame wait thread once the GPU is done with the frame. + -} + , vrRecycleNib :: IO (Either (IO RecycledResources) RecycledResources) + {- ^ Pull a frame's reusable bits out. 'Right' if available immediately; + 'Left' is a blocking read. + -} } --- | The full G/C/T queue kit each windowed example gets. Fields are filled --- from 'InitDevice.withDevice' with priorities 1.0/0.5/0.2; on hardware that --- exposes dedicated families they target async-compute and DMA-only families, --- otherwise they alias the graphics+present family (with distinct 'Queue' --- handles allocated within that shared family). --- --- The same shape is used internally by 'InitDevice' to feed --- 'Vulkan.Utils.QueueAssignment.assignQueues' (as @Queues (QueueSpec m)@). +{- | The full G/C/T queue kit each windowed example gets. Fields are filled +from 'InitDevice.withDevice' with priorities 1.0/0.5/0.2; on hardware that +exposes dedicated families they target async-compute and DMA-only families, +otherwise they alias the graphics+present family (with distinct 'Queue' +handles allocated within that shared family). + +The same shape is used internally by 'InitDevice' to feed +'Vulkan.Utils.QueueAssignment.assignQueues' (as @Queues (QueueSpec m)@). +-} data Queues a = Queues - { qGraphics :: a -- ^ graphics + present, priority 1.0 - , qCompute :: a -- ^ compute (prefers compute-only family), priority 0.5 - , qTransfer :: a -- ^ transfer (prefers transfer-only family), priority 0.2 + { qGraphics :: a + -- ^ graphics + present, priority 1.0 + , qCompute :: a + -- ^ compute (prefers compute-only family), priority 0.5 + , qTransfer :: a + -- ^ transfer (prefers transfer-only family), priority 0.2 } deriving (Functor, Foldable, Traversable) --- | Elementwise zip — handy for combining priorities with predicates when --- building a @Queues (QueueSpec m)@. +{- | Elementwise zip — handy for combining priorities with predicates when +building a @Queues (QueueSpec m)@. +-} instance Applicative Queues where pure x = Queues x x x Queues f g h <*> Queues x y z = Queues (f x) (g y) (h z) --- | The bits of state recycled between frames: two binary semaphores used --- for image-acquire / render-done synchronisation, and the command pool the --- frame's commands are recorded into. +{- | The bits of state recycled between frames: two binary semaphores used +for image-acquire / render-done synchronisation, and the command pool the +frame's commands are recorded into. +-} data RecycledResources = RecycledResources { rrImageAvailable :: Semaphore , rrRenderFinished :: Semaphore - , rrCommandPool :: CommandPool + , rrCommandPool :: CommandPool } --- | Assemble a 'VkResources' from already-constructed handles. Builds the --- recycle channel internally. +{- | Assemble a 'VkResources' from already-constructed handles. Builds the +recycle channel internally. +-} mkVkResources :: Instance -> PhysicalDevice @@ -75,8 +87,9 @@ mkVkResources -> IO VkResources mkVkResources vrInstance vrPhysicalDevice vrDevice vrAllocator vrQueues = do (binW, binR) <- newChan - let vrRecycleBin = writeChan binW - vrRecycleNib = do - (try, block) <- tryReadChan binR - maybe (Left block) Right <$> tryRead try - pure VkResources { .. } + let + vrRecycleBin = writeChan binW + vrRecycleNib = do + (try, block) <- tryReadChan binR + maybe (Left block) Right <$> tryRead try + pure VkResources{..} diff --git a/examples/lib/Vma.hs b/examples/lib/Vma.hs index 549df9d70..1216fa8ac 100644 --- a/examples/lib/Vma.hs +++ b/examples/lib/Vma.hs @@ -1,36 +1,41 @@ {-# LANGUAGE RecordWildCards #-} --- | Shared 'Allocator' construction for VMA-using examples. Each caller passes --- its own create flags and target Vulkan API version. +{-| Shared 'Allocator' construction for VMA-using examples. Each caller passes +its own create flags and target Vulkan API version. +-} module Vma ( createVMA ) where -import Control.Monad.Trans.Resource ( MonadResource, allocate ) -import Data.Word ( Word32 ) -import Foreign.Ptr ( castFunPtr ) -import Vulkan.Core10 ( Device(..) - , Instance(..) - , PhysicalDevice - , deviceHandle - , instanceHandle - , physicalDeviceHandle - ) -import Vulkan.Dynamic ( DeviceCmds(DeviceCmds, pVkGetDeviceProcAddr) - , InstanceCmds(InstanceCmds, pVkGetInstanceProcAddr) - ) -import Vulkan.Zero ( zero ) -import VulkanMemoryAllocator ( Allocator - , AllocatorCreateFlags - , AllocatorCreateInfo(..) - , VulkanFunctions(..) - , withAllocator - ) +import Control.Monad.Trans.Resource (MonadResource, allocate) +import Data.Word (Word32) +import Foreign.Ptr (castFunPtr) +import Vulkan.Core10 + ( Device (..) + , Instance (..) + , PhysicalDevice + , deviceHandle + , instanceHandle + , physicalDeviceHandle + ) +import Vulkan.Dynamic + ( DeviceCmds (DeviceCmds, pVkGetDeviceProcAddr) + , InstanceCmds (InstanceCmds, pVkGetInstanceProcAddr) + ) +import Vulkan.Zero (zero) +import VulkanMemoryAllocator + ( Allocator + , AllocatorCreateFlags + , AllocatorCreateInfo (..) + , VulkanFunctions (..) + , withAllocator + ) createVMA - :: MonadResource m + :: (MonadResource m) => AllocatorCreateFlags - -> Word32 -- ^ Target Vulkan API version + -> Word32 + -- ^ Target Vulkan API version -> Instance -> PhysicalDevice -> Device @@ -38,17 +43,18 @@ createVMA createVMA flags' apiVer inst phys dev = snd <$> withAllocator - zero - { flags = flags' - , physicalDevice = physicalDeviceHandle phys - , device = deviceHandle dev - , instance' = instanceHandle inst - , vulkanApiVersion = apiVer - , vulkanFunctions = Just $ case inst of - Instance _ InstanceCmds {..} -> case dev of - Device _ DeviceCmds {..} -> zero + zero + { flags = flags' + , physicalDevice = physicalDeviceHandle phys + , device = deviceHandle dev + , instance' = instanceHandle inst + , vulkanApiVersion = apiVer + , vulkanFunctions = Just $ case inst of + Instance _ InstanceCmds{..} -> case dev of + Device _ DeviceCmds{..} -> + zero { vkGetInstanceProcAddr = castFunPtr pVkGetInstanceProcAddr - , vkGetDeviceProcAddr = castFunPtr pVkGetDeviceProcAddr + , vkGetDeviceProcAddr = castFunPtr pVkGetDeviceProcAddr } - } - allocate + } + allocate diff --git a/examples/lib/Window/GLFW.hs b/examples/lib/Window/GLFW.hs index f7387b3aa..266d83fe3 100644 --- a/examples/lib/Window/GLFW.hs +++ b/examples/lib/Window/GLFW.hs @@ -1,5 +1,6 @@ --- | GLFW windowing helpers used by the @glfw@ triangle example. Mirrors --- the SDL2 helpers in "Window". +{-| GLFW windowing helpers used by the @glfw@ triangle example. Mirrors +the SDL2 helpers in "Window". +-} module Window.GLFW ( withGLFW , createWindow @@ -8,61 +9,68 @@ module Window.GLFW , shouldQuit ) where -import Control.Monad ( unless, void ) -import Control.Monad.IO.Class ( MonadIO, liftIO ) -import Control.Monad.Trans.Resource ( MonadResource - , allocate - , allocate_ - ) -import qualified Data.Text as T -import Data.Text ( Text ) -import qualified Graphics.UI.GLFW as GLFW -import Vulkan.Core10 ( Extent2D(..) ) +import Control.Monad (unless, void) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Trans.Resource + ( MonadResource + , allocate + , allocate_ + ) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Graphics.UI.GLFW as GLFW +import Vulkan.Core10 (Extent2D (..)) -- | Initialise GLFW and tear it down with the resource scope. -withGLFW :: MonadResource m => m () +withGLFW :: (MonadResource m) => m () withGLFW = void $ allocate_ initGLFW GLFW.terminate - where - initGLFW = do - ok <- GLFW.init - unless ok (fail "GLFW.init failed") + where + initGLFW = do + ok <- GLFW.init + unless ok (fail "GLFW.init failed") --- | Create a GLFW window configured for Vulkan rendering. The window is --- created hidden so the caller can call 'showWindow' once the swapchain is --- ready. +{- | Create a GLFW window configured for Vulkan rendering. The window is +created hidden so the caller can call 'showWindow' once the swapchain is +ready. +-} createWindow - :: MonadResource m - => Text -- ^ Title - -> Int -- ^ Width - -> Int -- ^ Height + :: (MonadResource m) + => Text + -- ^ Title + -> Int + -- ^ Width + -> Int + -- ^ Height -> m GLFW.Window createWindow title width height = do liftIO $ do GLFW.windowHint (GLFW.WindowHint'ClientAPI GLFW.ClientAPI'NoAPI) GLFW.windowHint (GLFW.WindowHint'Resizable True) GLFW.windowHint (GLFW.WindowHint'Visible False) - (_, mWin) <- allocate - (GLFW.createWindow width height (T.unpack title) Nothing Nothing) - (maybe (pure ()) GLFW.destroyWindow) + (_, mWin) <- + allocate + (GLFW.createWindow width height (T.unpack title) Nothing Nothing) + (maybe (pure ()) GLFW.destroyWindow) case mWin of - Just w -> pure w + Just w -> pure w Nothing -> liftIO (fail "GLFW.createWindow returned Nothing") showWindow :: GLFW.Window -> IO () showWindow = GLFW.showWindow -- | Current framebuffer size, suitable as the swapchain extent fallback. -drawableSize :: MonadIO m => GLFW.Window -> m Extent2D +drawableSize :: (MonadIO m) => GLFW.Window -> m Extent2D drawableSize win = do (w, h) <- liftIO $ GLFW.getFramebufferSize win pure $ Extent2D (fromIntegral w) (fromIntegral h) --- | Poll events and report whether the user requested to close the window --- (X button, Q, or Escape). +{- | Poll events and report whether the user requested to close the window +(X button, Q, or Escape). +-} shouldQuit :: GLFW.Window -> IO Bool shouldQuit win = do GLFW.pollEvents closeRequested <- GLFW.windowShouldClose win - qPressed <- (== GLFW.KeyState'Pressed) <$> GLFW.getKey win GLFW.Key'Q - escPressed <- (== GLFW.KeyState'Pressed) <$> GLFW.getKey win GLFW.Key'Escape + qPressed <- (== GLFW.KeyState'Pressed) <$> GLFW.getKey win GLFW.Key'Q + escPressed <- (== GLFW.KeyState'Pressed) <$> GLFW.getKey win GLFW.Key'Escape pure (closeRequested || qPressed || escPressed) diff --git a/examples/lib/Window/SDL2.hs b/examples/lib/Window/SDL2.hs index 9d719768e..620009166 100644 --- a/examples/lib/Window/SDL2.hs +++ b/examples/lib/Window/SDL2.hs @@ -4,27 +4,27 @@ module Window.SDL2 , createSurface , drawableSize , showWindow - , RefreshLimit(..) + , RefreshLimit (..) , shouldQuit ) where -import Control.Monad ( void ) -import Control.Monad.IO.Class -import Control.Monad.Trans.Resource -import Data.Maybe ( maybeToList ) -import Data.Text ( Text ) -import Foreign.Ptr ( castPtr ) +import Control.Monad (void) +import Control.Monad.IO.Class +import Control.Monad.Trans.Resource +import Data.Maybe (maybeToList) +import Data.Text (Text) +import Foreign.Ptr (castPtr) import qualified SDL -import qualified SDL.Video.Vulkan as SDL -import Vulkan.Core10 -import Vulkan.Extensions.VK_KHR_surface +import qualified SDL.Video.Vulkan as SDL +import Vulkan.Core10 +import Vulkan.Extensions.VK_KHR_surface -withSDL :: MonadResource m => m () +withSDL :: (MonadResource m) => m () withSDL = void $ allocate_ (SDL.initialize @[] [SDL.InitEvents]) SDL.quit -- | The caller is responsible to initializing SDL createWindow - :: MonadResource m + :: (MonadResource m) => Text -- ^ Title -> Int @@ -34,38 +34,43 @@ createWindow -> m SDL.Window createWindow title width height = do SDL.initialize @[] [SDL.InitVideo] - _ <- allocate_ (SDL.vkLoadLibrary Nothing) SDL.vkUnloadLibrary - (_, window) <- allocate - (SDL.createWindow - title - (SDL.defaultWindow - { SDL.windowInitialSize = SDL.V2 (fromIntegral width) - (fromIntegral height) - , SDL.windowGraphicsContext = SDL.VulkanContext - , SDL.windowResizable = True - , SDL.windowHighDPI = True - , SDL.windowVisible = False - } + _ <- allocate_ (SDL.vkLoadLibrary Nothing) SDL.vkUnloadLibrary + (_, window) <- + allocate + ( SDL.createWindow + title + ( SDL.defaultWindow + { SDL.windowInitialSize = + SDL.V2 + (fromIntegral width) + (fromIntegral height) + , SDL.windowGraphicsContext = SDL.VulkanContext + , SDL.windowResizable = True + , SDL.windowHighDPI = True + , SDL.windowVisible = False + } + ) ) - ) - SDL.destroyWindow + SDL.destroyWindow pure window createSurface - :: MonadResource m => Instance -> SDL.Window -> m (ReleaseKey, SurfaceKHR) -createSurface inst window = allocate - (SurfaceKHR <$> SDL.vkCreateSurface window (castPtr (instanceHandle inst))) - (\s -> destroySurfaceKHR inst s Nothing) + :: (MonadResource m) => Instance -> SDL.Window -> m (ReleaseKey, SurfaceKHR) +createSurface inst window = + allocate + (SurfaceKHR <$> SDL.vkCreateSurface window (castPtr (instanceHandle inst))) + (\s -> destroySurfaceKHR inst s Nothing) -- | Current drawable size, suitable as the swapchain extent fallback. -drawableSize :: MonadIO m => SDL.Window -> m Extent2D +drawableSize :: (MonadIO m) => SDL.Window -> m Extent2D drawableSize win = do SDL.V2 w h <- SDL.vkGetDrawableSize win pure $ Extent2D (fromIntegral w) (fromIntegral h) --- | Make the window visible. The window is created hidden so the swapchain --- can be brought up first. -showWindow :: MonadIO m => SDL.Window -> m () +{- | Make the window visible. The window is created hidden so the swapchain +can be brought up first. +-} +showWindow :: (MonadIO m) => SDL.Window -> m () showWindow = SDL.showWindow ---------------------------------------------------------------- @@ -74,30 +79,34 @@ showWindow = SDL.showWindow data RefreshLimit = NoLimit - | TimeLimit Int -- ^ Time in ms - | EventLimit -- ^ Indefinite timeout + | -- | Time in ms + TimeLimit Int + | -- | Indefinite timeout + EventLimit --- | Consumes all events in the queue and reports if any of them instruct the --- application to quit. -shouldQuit :: MonadIO m => RefreshLimit -> m Bool +{- | Consumes all events in the queue and reports if any of them instruct the +application to quit. +-} +shouldQuit :: (MonadIO m) => RefreshLimit -> m Bool shouldQuit limit = any isQuitEvent <$> awaitSDLEvents limit - where - isQuitEvent :: SDL.Event -> Bool - isQuitEvent = \case - (SDL.Event _ SDL.QuitEvent) -> True - SDL.Event _ (SDL.KeyboardEvent (SDL.KeyboardEventData _ SDL.Released False (SDL.Keysym _ code _))) - | code == SDL.KeycodeQ || code == SDL.KeycodeEscape - -> True - _ -> False + where + isQuitEvent :: SDL.Event -> Bool + isQuitEvent = \case + (SDL.Event _ SDL.QuitEvent) -> True + SDL.Event _ (SDL.KeyboardEvent (SDL.KeyboardEventData _ SDL.Released False (SDL.Keysym _ code _))) + | code == SDL.KeycodeQ || code == SDL.KeycodeEscape -> + True + _ -> False --- | Return the SDL events which have become available --- --- Optionally wait for a timeout or forever. -awaitSDLEvents :: MonadIO m => RefreshLimit -> m [SDL.Event] +{- | Return the SDL events which have become available + +Optionally wait for a timeout or forever. +-} +awaitSDLEvents :: (MonadIO m) => RefreshLimit -> m [SDL.Event] awaitSDLEvents limit = do first <- case limit of - NoLimit -> pure Nothing + NoLimit -> pure Nothing TimeLimit ms -> SDL.waitEventTimeout (fromIntegral ms) - EventLimit -> Just <$> SDL.waitEvent + EventLimit -> Just <$> SDL.waitEvent next <- SDL.pollEvents pure $ maybeToList first <> next diff --git a/examples/rays/AccelerationStructure.hs b/examples/rays/AccelerationStructure.hs index e91307570..3e9ed0ef3 100644 --- a/examples/rays/AccelerationStructure.hs +++ b/examples/rays/AccelerationStructure.hs @@ -4,27 +4,29 @@ module AccelerationStructure ( createTLAS ) where -import Control.Monad.IO.Class -import Control.Monad.Trans.Resource -import Data.Bits -import Data.Coerce ( coerce ) -import Data.Vector ( Vector ) -import Foreign.Storable ( Storable(poke, sizeOf) ) -import Scene -import UnliftIO.Foreign ( castPtr ) -import VkResources ( Queues(..) - , VkResources(..) - ) -import Vulkan.CStruct -import Vulkan.CStruct.Extends -import Vulkan.Core10 -import Vulkan.Core12.Promoted_From_VK_KHR_buffer_device_address -import Vulkan.Extensions.VK_KHR_acceleration_structure -import Vulkan.Utils.Debug ( nameObject ) -import Vulkan.Utils.QueueAssignment -import Vulkan.Zero -import VulkanMemoryAllocator as VMA - hiding ( getPhysicalDeviceProperties ) +import Control.Monad.IO.Class +import Control.Monad.Trans.Resource +import Data.Bits +import Data.Coerce (coerce) +import Data.Vector (Vector) +import Foreign.Storable (Storable (poke, sizeOf)) +import Scene +import UnliftIO.Foreign (castPtr) +import VkResources + ( Queues (..) + , VkResources (..) + ) +import Vulkan.CStruct +import Vulkan.CStruct.Extends +import Vulkan.Core10 +import Vulkan.Core12.Promoted_From_VK_KHR_buffer_device_address +import Vulkan.Extensions.VK_KHR_acceleration_structure +import Vulkan.Utils.Debug (nameObject) +import Vulkan.Utils.QueueAssignment +import Vulkan.Zero +import VulkanMemoryAllocator as VMA hiding + ( getPhysicalDeviceProperties + ) ---------------------------------------------------------------- -- TLAS @@ -36,82 +38,101 @@ createTLAS -> SceneBuffers -> m (ReleaseKey, AccelerationStructureKHR) createTLAS vr sceneBuffers = do - let dev = vrDevice vr - vma = vrAllocator vr + let + dev = vrDevice vr + vma = vrAllocator vr -- -- Create the bottom level acceleration structure. -- (_blasReleaseKey, blas) <- createBLAS vr sceneBuffers - blasAddress <- getAccelerationStructureDeviceAddressKHR dev zero - { accelerationStructure = blas - } - let identity = TransformMatrixKHR (1, 0, 0, 0) (0, 1, 0, 0) (0, 0, 1, 0) - inst :: AccelerationStructureInstanceKHR - inst = zero - { transform = identity - , instanceCustomIndex = 0 - , mask = complement 0 + blasAddress <- + getAccelerationStructureDeviceAddressKHR + dev + zero + { accelerationStructure = blas + } + let + identity = TransformMatrixKHR (1, 0, 0, 0) (0, 1, 0, 0) (0, 0, 1, 0) + inst :: AccelerationStructureInstanceKHR + inst = + zero + { transform = identity + , instanceCustomIndex = 0 + , mask = complement 0 , instanceShaderBindingTableRecordOffset = 0 , flags = GEOMETRY_INSTANCE_TRIANGLE_FACING_CULL_DISABLE_BIT_KHR - , accelerationStructureReference = coerce blasAddress + , accelerationStructureReference = coerce blasAddress } - let numInstances = 1 - instanceDescsSize = - numInstances * cStructSize @AccelerationStructureInstanceKHR - (_instBufferReleaseKey, (instBuffer, instBufferAllocation, _)) <- VMA.withBuffer - vma - zero - { usage = - BUFFER_USAGE_ACCELERATION_STRUCTURE_BUILD_INPUT_READ_ONLY_BIT_KHR - .|. BUFFER_USAGE_SHADER_DEVICE_ADDRESS_BIT - , size = fromIntegral instanceDescsSize - } - zero - { requiredFlags = MEMORY_PROPERTY_HOST_VISIBLE_BIT - .|. MEMORY_PROPERTY_HOST_COHERENT_BIT - } - allocate + let + numInstances = 1 + instanceDescsSize = + numInstances * cStructSize @AccelerationStructureInstanceKHR + (_instBufferReleaseKey, (instBuffer, instBufferAllocation, _)) <- + VMA.withBuffer + vma + zero + { usage = + BUFFER_USAGE_ACCELERATION_STRUCTURE_BUILD_INPUT_READ_ONLY_BIT_KHR + .|. BUFFER_USAGE_SHADER_DEVICE_ADDRESS_BIT + , size = fromIntegral instanceDescsSize + } + zero + { requiredFlags = + MEMORY_PROPERTY_HOST_VISIBLE_BIT + .|. MEMORY_PROPERTY_HOST_COHERENT_BIT + } + allocate nameObject dev instBuffer "TLAS instances" - instBufferDeviceAddress <- getBufferDeviceAddress dev zero - { buffer = instBuffer - } + instBufferDeviceAddress <- + getBufferDeviceAddress + dev + zero + { buffer = instBuffer + } (instMapKey, instMapPtr) <- VMA.withMappedMemory vma instBufferAllocation allocate liftIO $ poke (castPtr @_ @AccelerationStructureInstanceKHR instMapPtr) inst release instMapKey - let buildGeometries = - [ SomeStruct zero + let + buildGeometries = + [ SomeStruct + zero { geometryType = GEOMETRY_TYPE_INSTANCES_KHR - , geometry = Instances AccelerationStructureGeometryInstancesDataKHR - { arrayOfPointers = False - , data' = DeviceAddressConst instBufferDeviceAddress - } + , geometry = + Instances + AccelerationStructureGeometryInstancesDataKHR + { arrayOfPointers = False + , data' = DeviceAddressConst instBufferDeviceAddress + } , flags = GEOMETRY_OPAQUE_BIT_KHR } - ] - buildInfo = zero - { type' = ACCELERATION_STRUCTURE_TYPE_TOP_LEVEL_KHR - , mode = BUILD_ACCELERATION_STRUCTURE_MODE_BUILD_KHR + ] + buildInfo = + zero + { type' = ACCELERATION_STRUCTURE_TYPE_TOP_LEVEL_KHR + , mode = BUILD_ACCELERATION_STRUCTURE_MODE_BUILD_KHR , srcAccelerationStructure = NULL_HANDLE , dstAccelerationStructure = NULL_HANDLE - , geometries = buildGeometries - , scratchData = zero + , geometries = buildGeometries + , scratchData = zero } - maxPrimitiveCounts = [1] - rangeInfos = [zero { primitiveCount = 1, primitiveOffset = 0 }] - sizes <- getAccelerationStructureBuildSizesKHR - dev - ACCELERATION_STRUCTURE_BUILD_TYPE_DEVICE_KHR - buildInfo - maxPrimitiveCounts + maxPrimitiveCounts = [1] + rangeInfos = [zero{primitiveCount = 1, primitiveOffset = 0}] + sizes <- + getAccelerationStructureBuildSizesKHR + dev + ACCELERATION_STRUCTURE_BUILD_TYPE_DEVICE_KHR + buildInfo + maxPrimitiveCounts - (_tlasBufferKey, tlasKey, tlas) <- buildAccelerationStructure - vr - buildInfo - rangeInfos - sizes + (_tlasBufferKey, tlasKey, tlas) <- + buildAccelerationStructure + vr + buildInfo + rangeInfos + sizes nameObject dev tlas "TLAS" pure (tlasKey, tlas) @@ -123,42 +144,53 @@ buildAccelerationStructure -> AccelerationStructureBuildSizesInfoKHR -> m (ReleaseKey, ReleaseKey, AccelerationStructureKHR) buildAccelerationStructure vr geom ranges sizes = do - let dev = vrDevice vr - vma = vrAllocator vr - bufferSize = accelerationStructureSize sizes + let + dev = vrDevice vr + vma = vrAllocator vr + bufferSize = accelerationStructureSize sizes - (asBufferKey, (asBuffer, _, _)) <- VMA.withBuffer - vma - zero { size = bufferSize - , usage = BUFFER_USAGE_ACCELERATION_STRUCTURE_STORAGE_BIT_KHR - } - zero { usage = MEMORY_USAGE_GPU_ONLY } - allocate + (asBufferKey, (asBuffer, _, _)) <- + VMA.withBuffer + vma + zero + { size = bufferSize + , usage = BUFFER_USAGE_ACCELERATION_STRUCTURE_STORAGE_BIT_KHR + } + zero{usage = MEMORY_USAGE_GPU_ONLY} + allocate - (scratchBufferKey, (scratchBuffer, _, _)) <- VMA.withBuffer - vma - zero { size = buildScratchSize sizes - , usage = BUFFER_USAGE_SHADER_DEVICE_ADDRESS_BIT - } - zero { usage = MEMORY_USAGE_GPU_ONLY } - allocate - scratchBufferDeviceAddress <- getBufferDeviceAddress dev zero - { buffer = scratchBuffer - } + (scratchBufferKey, (scratchBuffer, _, _)) <- + VMA.withBuffer + vma + zero + { size = buildScratchSize sizes + , usage = BUFFER_USAGE_SHADER_DEVICE_ADDRESS_BIT + } + zero{usage = MEMORY_USAGE_GPU_ONLY} + allocate + scratchBufferDeviceAddress <- + getBufferDeviceAddress + dev + zero + { buffer = scratchBuffer + } - let asci = zero { type' = ACCELERATION_STRUCTURE_TYPE_TOP_LEVEL_KHR - , buffer = asBuffer - , offset = 0 - , size = bufferSize - } + let asci = + zero + { type' = ACCELERATION_STRUCTURE_TYPE_TOP_LEVEL_KHR + , buffer = asBuffer + , offset = 0 + , size = bufferSize + } (asKey, as) <- withAccelerationStructureKHR dev asci Nothing allocate oneShotComputeCommands vr $ \cmd -> cmdBuildAccelerationStructuresKHR cmd - [ geom { dstAccelerationStructure = as - , scratchData = DeviceAddress scratchBufferDeviceAddress - } + [ geom + { dstAccelerationStructure = as + , scratchData = DeviceAddress scratchBufferDeviceAddress + } ] [ranges] @@ -175,49 +207,57 @@ createBLAS vr sceneBuffers = do let dev = vrDevice vr (sceneGeom, sceneOffsets) <- sceneGeometry vr sceneBuffers - let buildInfo = zero - { type' = ACCELERATION_STRUCTURE_TYPE_BOTTOM_LEVEL_KHR - , mode = BUILD_ACCELERATION_STRUCTURE_MODE_BUILD_KHR + let + buildInfo = + zero + { type' = ACCELERATION_STRUCTURE_TYPE_BOTTOM_LEVEL_KHR + , mode = BUILD_ACCELERATION_STRUCTURE_MODE_BUILD_KHR , srcAccelerationStructure = NULL_HANDLE , dstAccelerationStructure = NULL_HANDLE - , geometries = [SomeStruct sceneGeom] - , scratchData = zero + , geometries = [SomeStruct sceneGeom] + , scratchData = zero } - maxPrimitiveCounts = [sceneSize sceneBuffers] - sizes <- getAccelerationStructureBuildSizesKHR - dev - ACCELERATION_STRUCTURE_BUILD_TYPE_DEVICE_KHR - buildInfo - maxPrimitiveCounts + maxPrimitiveCounts = [sceneSize sceneBuffers] + sizes <- + getAccelerationStructureBuildSizesKHR + dev + ACCELERATION_STRUCTURE_BUILD_TYPE_DEVICE_KHR + buildInfo + maxPrimitiveCounts - (_blasBufferKey, blasKey, blas) <- buildAccelerationStructure - vr - buildInfo - sceneOffsets - sizes + (_blasBufferKey, blasKey, blas) <- + buildAccelerationStructure + vr + buildInfo + sceneOffsets + sizes nameObject dev blas "BLAS" pure (blasKey, blas) sceneGeometry - :: MonadIO m + :: (MonadIO m) => VkResources -> SceneBuffers -> m ( AccelerationStructureGeometryKHR '[] , Vector AccelerationStructureBuildRangeInfoKHR ) -sceneGeometry vr SceneBuffers {..} = do - boxAddr <- getBufferDeviceAddress (vrDevice vr) zero { buffer = sceneAabbs } - let boxData = AccelerationStructureGeometryAabbsDataKHR - { data' = DeviceAddressConst boxAddr +sceneGeometry vr SceneBuffers{..} = do + boxAddr <- getBufferDeviceAddress (vrDevice vr) zero{buffer = sceneAabbs} + let + boxData = + AccelerationStructureGeometryAabbsDataKHR + { data' = DeviceAddressConst boxAddr , stride = fromIntegral (sizeOf (undefined :: AabbPositionsKHR)) } - geom :: AccelerationStructureGeometryKHR '[] - geom = zero { geometryType = GEOMETRY_TYPE_AABBS_KHR - , flags = GEOMETRY_OPAQUE_BIT_KHR - , geometry = Aabbs boxData - } - let offsetInfo = [zero { primitiveCount = sceneSize, primitiveOffset = 0 }] + geom :: AccelerationStructureGeometryKHR '[] + geom = + zero + { geometryType = GEOMETRY_TYPE_AABBS_KHR + , flags = GEOMETRY_OPAQUE_BIT_KHR + , geometry = Aabbs boxData + } + let offsetInfo = [zero{primitiveCount = sceneSize, primitiveOffset = 0}] pure (geom, offsetInfo) ---------------------------------------------------------------- @@ -230,33 +270,38 @@ oneShotComputeCommands -> (CommandBuffer -> IO ()) -> m () oneShotComputeCommands vr cmds = do - let dev = vrDevice vr - (QueueFamilyIndex graphicsQueueFamilyIndex, graphicsQueue) = - qGraphics (vrQueues vr) - (poolKey, commandPool) <- withCommandPool - dev - zero { queueFamilyIndex = graphicsQueueFamilyIndex } - Nothing - allocate - ~[commandBuffer] <- allocateCommandBuffers - dev - zero { commandPool = commandPool - , level = COMMAND_BUFFER_LEVEL_PRIMARY - , commandBufferCount = 1 - } + let + dev = vrDevice vr + (QueueFamilyIndex graphicsQueueFamilyIndex, graphicsQueue) = + qGraphics (vrQueues vr) + (poolKey, commandPool) <- + withCommandPool + dev + zero{queueFamilyIndex = graphicsQueueFamilyIndex} + Nothing + allocate + ~[commandBuffer] <- + allocateCommandBuffers + dev + zero + { commandPool = commandPool + , level = COMMAND_BUFFER_LEVEL_PRIMARY + , commandBufferCount = 1 + } - useCommandBuffer commandBuffer - zero { flags = COMMAND_BUFFER_USAGE_ONE_TIME_SUBMIT_BIT } - (liftIO (cmds commandBuffer)) + useCommandBuffer + commandBuffer + zero{flags = COMMAND_BUFFER_USAGE_ONE_TIME_SUBMIT_BIT} + (liftIO (cmds commandBuffer)) (fenceKey, fence) <- withFence dev zero Nothing allocate queueSubmit graphicsQueue - [SomeStruct zero { commandBuffers = [commandBufferHandle commandBuffer] }] + [SomeStruct zero{commandBuffers = [commandBufferHandle commandBuffer]}] fence let oneSecond = 1e9 waitForFencesSafe dev [fence] True oneSecond >>= \case SUCCESS -> pure () TIMEOUT -> error "Timed out running one shot commands" - _ -> error "Unhandled exit code in oneShotComputeCommands" + _ -> error "Unhandled exit code in oneShotComputeCommands" release fenceKey release poolKey diff --git a/examples/rays/Init.hs b/examples/rays/Init.hs index 406786a61..9cccc0b85 100644 --- a/examples/rays/Init.hs +++ b/examples/rays/Init.hs @@ -4,60 +4,67 @@ module Init ( myApiVersion , instanceRequirements , deviceRequirements - , RTInfo(..) + , RTInfo (..) , getDeviceRTProps , createVMA ) where -import Control.Monad.IO.Class -import Control.Monad.Trans.Resource -import Data.Word +import Control.Monad.IO.Class +import Control.Monad.Trans.Resource +import Data.Word -import Frame ( frameDeviceRequirements - , frameInstanceRequirements - ) +import Frame + ( frameDeviceRequirements + , frameInstanceRequirements + ) import qualified Vma -import Vulkan.CStruct.Extends ( pattern (:&) - , pattern (::&) - ) -import Vulkan.Core10 -import Vulkan.Core11 ( pattern API_VERSION_1_1 ) -import Vulkan.Core12.Promoted_From_VK_KHR_buffer_device_address - ( PhysicalDeviceBufferDeviceAddressFeatures(..) - ) -import Vulkan.Extensions.VK_EXT_debug_utils - ( pattern EXT_DEBUG_UTILS_EXTENSION_NAME ) -import Vulkan.Extensions.VK_KHR_acceleration_structure - ( PhysicalDeviceAccelerationStructureFeaturesKHR(..) - ) -import Vulkan.Extensions.VK_KHR_get_physical_device_properties2 - ( getPhysicalDeviceProperties2KHR - ) -import Vulkan.Extensions.VK_KHR_ray_tracing_pipeline - ( PhysicalDeviceRayTracingPipelineFeaturesKHR(..) - , PhysicalDeviceRayTracingPipelinePropertiesKHR(..) - ) -import Vulkan.Requirement ( DeviceRequirement - , InstanceRequirement(..) - ) -import qualified Vulkan.Utils.Requirements.TH as U -import VulkanMemoryAllocator ( Allocator - , AllocatorCreateFlagBits(..) - ) +import Vulkan.CStruct.Extends + ( pattern (:&) + , pattern (::&) + ) +import Vulkan.Core10 +import Vulkan.Core11 (pattern API_VERSION_1_1) +import Vulkan.Core12.Promoted_From_VK_KHR_buffer_device_address + ( PhysicalDeviceBufferDeviceAddressFeatures (..) + ) +import Vulkan.Extensions.VK_EXT_debug_utils + ( pattern EXT_DEBUG_UTILS_EXTENSION_NAME + ) +import Vulkan.Extensions.VK_KHR_acceleration_structure + ( PhysicalDeviceAccelerationStructureFeaturesKHR (..) + ) +import Vulkan.Extensions.VK_KHR_get_physical_device_properties2 + ( getPhysicalDeviceProperties2KHR + ) +import Vulkan.Extensions.VK_KHR_ray_tracing_pipeline + ( PhysicalDeviceRayTracingPipelineFeaturesKHR (..) + , PhysicalDeviceRayTracingPipelinePropertiesKHR (..) + ) +import Vulkan.Requirement + ( DeviceRequirement + , InstanceRequirement (..) + ) +import qualified Vulkan.Utils.Requirements.TH as U +import VulkanMemoryAllocator + ( Allocator + , AllocatorCreateFlagBits (..) + ) myApiVersion :: Word32 myApiVersion = API_VERSION_1_1 --- | Instance requirements: Frame's bits plus debug-utils so the @nameObject@ --- calls scattered through the example can load their function pointer (we --- don't enable the messenger though). +{- | Instance requirements: Frame's bits plus debug-utils so the @nameObject@ +calls scattered through the example can load their function pointer (we +don't enable the messenger though). +-} instanceRequirements :: [InstanceRequirement] instanceRequirements = frameInstanceRequirements ++ [RequireInstanceExtension Nothing EXT_DEBUG_UTILS_EXTENSION_NAME minBound] --- | Device requirements: API version, swapchain, Frame's timeline-semaphore --- bits, plus the full ray-tracing extension family. +{- | Device requirements: API version, swapchain, Frame's timeline-semaphore +bits, plus the full ray-tracing extension family. +-} deviceRequirements :: [DeviceRequirement] deviceRequirements = [U.reqs| @@ -77,22 +84,25 @@ deviceRequirements = VK_KHR_get_memory_requirements2 VK_KHR_maintenance3 VK_KHR_pipeline_library - |] ++ frameDeviceRequirements + |] + ++ frameDeviceRequirements -- | Information for ray tracing (queried from device properties). data RTInfo = RTInfo - { rtiShaderGroupHandleSize :: Word32 + { rtiShaderGroupHandleSize :: Word32 , rtiShaderGroupBaseAlignment :: Word32 } -getDeviceRTProps :: MonadIO m => PhysicalDevice -> m RTInfo +getDeviceRTProps :: (MonadIO m) => PhysicalDevice -> m RTInfo getDeviceRTProps phys = do props <- getPhysicalDeviceProperties2KHR phys - let _ ::& PhysicalDeviceRayTracingPipelinePropertiesKHR {..} :& () = props - pure RTInfo { rtiShaderGroupHandleSize = shaderGroupHandleSize - , rtiShaderGroupBaseAlignment = shaderGroupBaseAlignment - } + let _ ::& PhysicalDeviceRayTracingPipelinePropertiesKHR{..} :& () = props + pure + RTInfo + { rtiShaderGroupHandleSize = shaderGroupHandleSize + , rtiShaderGroupBaseAlignment = shaderGroupBaseAlignment + } createVMA - :: MonadResource m => Instance -> PhysicalDevice -> Device -> m Allocator + :: (MonadResource m) => Instance -> PhysicalDevice -> Device -> m Allocator createVMA = Vma.createVMA ALLOCATOR_CREATE_BUFFER_DEVICE_ADDRESS_BIT myApiVersion diff --git a/examples/rays/Main.hs b/examples/rays/Main.hs index 478322fa6..2e2d8fbea 100644 --- a/examples/rays/Main.hs +++ b/examples/rays/Main.hs @@ -2,154 +2,171 @@ module Main where -import AccelerationStructure ( createTLAS ) -import Camera ( CameraMatrices ) -import Control.Monad.IO.Class -import Control.Monad.Trans.Resource -import Data.Foldable ( for_ ) -import Data.IORef -import Data.Text.Encoding ( decodeUtf8 ) -import Data.Word ( Word64 ) -import Foreign.Ptr ( castPtr ) -import Foreign.Storable ( sizeOf ) -import Frame ( Frame(..) - , advanceFrame - , initialFrame - , numConcurrentFrames - , runFrame - ) -import Init ( createVMA - , deviceRequirements - , getDeviceRTProps - , instanceRequirements - , myApiVersion - ) -import InitDevice ( withDevice ) +import AccelerationStructure (createTLAS) +import Camera (CameraMatrices) +import Control.Monad.IO.Class +import Control.Monad.Trans.Resource +import Data.Foldable (for_) +import Data.IORef +import Data.Text.Encoding (decodeUtf8) +import Data.Word (Word64) +import Foreign.Ptr (castPtr) +import Foreign.Storable (sizeOf) +import Frame + ( Frame (..) + , advanceFrame + , initialFrame + , numConcurrentFrames + , runFrame + ) +import Init + ( createVMA + , deviceRequirements + , getDeviceRTProps + , instanceRequirements + , myApiVersion + ) +import InitDevice (withDevice) import qualified Pipeline -import Render ( RenderState(..) - , renderFrame - ) -import Say ( sayErr ) +import Render + ( RenderState (..) + , renderFrame + ) import qualified SDL -import Scene ( makeSceneBuffers ) -import Swapchain ( allocSwapchain - , recreateSwapchain - , threwSwapchainError - ) -import Utils ( loopJust ) -import VkResources ( mkVkResources ) -import Vulkan.Core10 hiding ( withDevice ) -import Vulkan.Zero ( zero ) -import Vulkan.Core12.Promoted_From_VK_KHR_buffer_device_address - ( BufferDeviceAddressInfo(..) - , getBufferDeviceAddress - ) -import qualified Vulkan.Utils.Init.SDL2 as VkInit -import VulkanMemoryAllocator as VMA - hiding ( getPhysicalDeviceProperties ) -import Window.SDL2 ( RefreshLimit(..) - , createSurface - , createWindow - , drawableSize - , shouldQuit - , withSDL - ) +import Say (sayErr) +import Scene (makeSceneBuffers) +import Swapchain + ( allocSwapchain + , recreateSwapchain + , threwSwapchainError + ) +import Utils (loopJust) +import VkResources (mkVkResources) +import Vulkan.Core10 hiding (withDevice) +import Vulkan.Core12.Promoted_From_VK_KHR_buffer_device_address + ( BufferDeviceAddressInfo (..) + , getBufferDeviceAddress + ) +import qualified Vulkan.Utils.Init.SDL2 as VkInit +import Vulkan.Zero (zero) +import VulkanMemoryAllocator as VMA hiding + ( getPhysicalDeviceProperties + ) +import Window.SDL2 + ( RefreshLimit (..) + , createSurface + , createWindow + , drawableSize + , shouldQuit + , withSDL + ) main :: IO () main = runResourceT $ do withSDL - win <- createWindow "Vulkan ⚡ Haskell" 1280 720 - inst <- VkInit.withInstance - win - (Just zero { applicationName = Nothing, apiVersion = myApiVersion }) - instanceRequirements - [] - (_, surf) <- createSurface inst win + win <- createWindow "Vulkan ⚡ Haskell" 1280 720 + inst <- + VkInit.withInstance + win + (Just zero{applicationName = Nothing, apiVersion = myApiVersion}) + instanceRequirements + [] + (_, surf) <- createSurface inst win (phys, dev, qs) <- withDevice inst surf deviceRequirements - vma <- createVMA inst phys dev - props <- getPhysicalDeviceProperties phys + vma <- createVMA inst phys dev + props <- getPhysicalDeviceProperties phys sayErr $ "Using device: " <> decodeUtf8 (deviceName props) vr <- liftIO $ mkVkResources inst phys dev vma qs -- Initial swapchain initialSize <- liftIO $ drawableSize win - initialSC <- allocSwapchain vr NULL_HANDLE initialSize surf + initialSC <- allocSwapchain vr NULL_HANDLE initialSize surf -- Scene + acceleration structure sceneBuffers <- makeSceneBuffers vma - (_, tlas) <- createTLAS vr sceneBuffers + (_, tlas) <- createTLAS vr sceneBuffers -- RT pipeline + descriptor sets rtInfo <- getDeviceRTProps phys - (_, descSetLayout) <- Pipeline.createRTDescriptorSetLayout dev - (_, pipelineLayout) <- Pipeline.createRTPipelineLayout dev descSetLayout - (_, pipeline, numGroups) <- Pipeline.createPipeline dev pipelineLayout - (_, sbtBuffer) <- Pipeline.createShaderBindingTable dev vma rtInfo pipeline numGroups - sbtAddress <- getBufferDeviceAddress dev zero { buffer = sbtBuffer } - descSets <- Pipeline.createRTDescriptorSets - dev - descSetLayout - tlas - sceneBuffers - (fromIntegral numConcurrentFrames) + (_, descSetLayout) <- Pipeline.createRTDescriptorSetLayout dev + (_, pipelineLayout) <- Pipeline.createRTPipelineLayout dev descSetLayout + (_, pipeline, numGroups) <- Pipeline.createPipeline dev pipelineLayout + (_, sbtBuffer) <- Pipeline.createShaderBindingTable dev vma rtInfo pipeline numGroups + sbtAddress <- getBufferDeviceAddress dev zero{buffer = sbtBuffer} + descSets <- + Pipeline.createRTDescriptorSets + dev + descSetLayout + tlas + sceneBuffers + (fromIntegral numConcurrentFrames) -- Camera matrices buffer (one slot per concurrent frame). - let cmSize = fromIntegral numConcurrentFrames - * fromIntegral (sizeOf (undefined :: CameraMatrices)) - (_, (cmBuffer, cmAlloc, cmAllocInfo)) <- VMA.withBuffer - vma - zero { size = cmSize - , usage = BUFFER_USAGE_UNIFORM_BUFFER_BIT - } - zero - { flags = ALLOCATION_CREATE_MAPPED_BIT - , usage = MEMORY_USAGE_CPU_TO_GPU - , requiredFlags = MEMORY_PROPERTY_HOST_VISIBLE_BIT - } - allocate + let cmSize = + fromIntegral numConcurrentFrames + * fromIntegral (sizeOf (undefined :: CameraMatrices)) + (_, (cmBuffer, cmAlloc, cmAllocInfo)) <- + VMA.withBuffer + vma + zero + { size = cmSize + , usage = BUFFER_USAGE_UNIFORM_BUFFER_BIT + } + zero + { flags = ALLOCATION_CREATE_MAPPED_BIT + , usage = MEMORY_USAGE_CPU_TO_GPU + , requiredFlags = MEMORY_PROPERTY_HOST_VISIBLE_BIT + } + allocate let cmBufferData = castPtr @() @CameraMatrices (mappedData cmAllocInfo) - let renderState = RenderState - { rsPipeline = pipeline - , rsPipelineLayout = pipelineLayout - , rsDescriptorSets = descSets - , rsShaderBindingTableAddress = sbtAddress - , rsCameraMatricesBuffer = cmBuffer - , rsCameraMatricesAllocation = cmAlloc - , rsCameraMatricesBufferData = cmBufferData - , rsRTInfo = rtInfo - } + let renderState = + RenderState + { rsPipeline = pipeline + , rsPipelineLayout = pipelineLayout + , rsDescriptorSets = descSets + , rsShaderBindingTableAddress = sbtAddress + , rsCameraMatricesBuffer = cmBuffer + , rsCameraMatricesAllocation = cmAlloc + , rsCameraMatricesBufferData = cmBufferData + , rsRTInfo = rtInfo + } - scRef <- liftIO $ newIORef initialSC + scRef <- liftIO $ newIORef initialSC initial <- initialFrame vr initialSC - liftIO $ for_ descSets (\_ -> pure ()) -- descSets is used; silence unused - + liftIO $ for_ descSets (\_ -> pure ()) -- descSets is used; silence unused SDL.showWindow win start <- SDL.time @Double let perFrame f = do currentSC <- liftIO $ readIORef scRef - let f' = f { fSwapchain = currentSC } - needsNew <- threwSwapchainError $ liftIO $ runFrame vr f' $ - renderFrame vr renderState f' - sc' <- if needsNew - then do - newSize <- liftIO $ drawableSize win - sc' <- recreateSwapchain vr newSize currentSC - liftIO $ writeIORef scRef sc' - pure sc' - else pure currentSC + let f' = f{fSwapchain = currentSC} + needsNew <- + threwSwapchainError $ + liftIO $ + runFrame vr f' $ + renderFrame vr renderState f' + sc' <- + if needsNew + then do + newSize <- liftIO $ drawableSize win + sc' <- recreateSwapchain vr newSize currentSC + liftIO $ writeIORef scRef sc' + pure sc' + else pure currentSC advanceFrame vr sc' f' - loop f = shouldQuit NoLimit >>= \case - True -> do - end <- SDL.time - let frames = fIndex f :: Word64 - mean = realToFrac frames / (end - start) :: Double - liftIO $ putStrLn $ "Average: " <> show mean - pure Nothing - False -> Just <$> perFrame f + loop f = + shouldQuit NoLimit >>= \case + True -> do + end <- SDL.time + let + frames = fIndex f :: Word64 + mean = realToFrac frames / (end - start) :: Double + liftIO $ putStrLn $ "Average: " <> show mean + pure Nothing + False -> Just <$> perFrame f loopJust loop initial diff --git a/examples/rays/Pipeline.hs b/examples/rays/Pipeline.hs index 44f02a5ee..92d22ce61 100644 --- a/examples/rays/Pipeline.hs +++ b/examples/rays/Pipeline.hs @@ -1,7 +1,7 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} module Pipeline ( createPipeline @@ -11,37 +11,41 @@ module Pipeline , createShaderBindingTable ) where -import Control.Monad.IO.Class -import Control.Monad.Trans.Resource -import Data.Bits -import Data.Foldable ( for_ - , traverse_ - ) -import qualified Data.Vector as V -import Data.Vector ( Vector ) -import Data.Word -import Foreign ( nullPtr ) -import Foreign.Marshal.Utils ( moveBytes ) -import Foreign.Ptr ( Ptr - , plusPtr - ) -import Init ( RTInfo(..) ) -import Say -import Scene ( SceneBuffers(..) ) -import Vulkan.CStruct.Extends -import Vulkan.Core10 as Vk - hiding ( withBuffer - , withImage - ) -import Vulkan.Extensions.VK_KHR_acceleration_structure -import Vulkan.Extensions.VK_KHR_ray_tracing_pipeline -import Vulkan.Utils.Debug ( nameObject ) -import Vulkan.Utils.ShaderQQ.GLSL.Glslang ( compileShaderQ - , glsl - ) -import Vulkan.Zero -import VulkanMemoryAllocator as VMA - hiding ( getPhysicalDeviceProperties ) +import Control.Monad.IO.Class +import Control.Monad.Trans.Resource +import Data.Bits +import Data.Foldable + ( for_ + , traverse_ + ) +import Data.Vector (Vector) +import qualified Data.Vector as V +import Data.Word +import Foreign (nullPtr) +import Foreign.Marshal.Utils (moveBytes) +import Foreign.Ptr + ( Ptr + , plusPtr + ) +import Init (RTInfo (..)) +import Say +import Scene (SceneBuffers (..)) +import Vulkan.CStruct.Extends +import Vulkan.Core10 as Vk hiding + ( withBuffer + , withImage + ) +import Vulkan.Extensions.VK_KHR_acceleration_structure +import Vulkan.Extensions.VK_KHR_ray_tracing_pipeline +import Vulkan.Utils.Debug (nameObject) +import Vulkan.Utils.ShaderQQ.GLSL.Glslang + ( compileShaderQ + , glsl + ) +import Vulkan.Zero +import VulkanMemoryAllocator as VMA hiding + ( getPhysicalDeviceProperties + ) -- | Create the RT pipeline; returns the number of shader groups. createPipeline @@ -50,166 +54,201 @@ createPipeline -> PipelineLayout -> m (ReleaseKey, Pipeline, Word32) createPipeline dev pipelineLayout = do - (shaderKeys, shaderStages) <- V.unzip <$> sequence - [ createRayGenerationShader dev - , createRayIntShader dev - , createRayMissShader dev - , createRayHitShader dev - ] - - let genGroup = RayTracingShaderGroupCreateInfoKHR + (shaderKeys, shaderStages) <- + V.unzip + <$> sequence + [ createRayGenerationShader dev + , createRayIntShader dev + , createRayMissShader dev + , createRayHitShader dev + ] + + let + genGroup = + RayTracingShaderGroupCreateInfoKHR RAY_TRACING_SHADER_GROUP_TYPE_GENERAL_KHR 0 SHADER_UNUSED_KHR SHADER_UNUSED_KHR SHADER_UNUSED_KHR nullPtr - intGroup = RayTracingShaderGroupCreateInfoKHR + intGroup = + RayTracingShaderGroupCreateInfoKHR RAY_TRACING_SHADER_GROUP_TYPE_PROCEDURAL_HIT_GROUP_KHR SHADER_UNUSED_KHR 3 SHADER_UNUSED_KHR 1 nullPtr - missGroup = RayTracingShaderGroupCreateInfoKHR + missGroup = + RayTracingShaderGroupCreateInfoKHR RAY_TRACING_SHADER_GROUP_TYPE_GENERAL_KHR 2 SHADER_UNUSED_KHR SHADER_UNUSED_KHR SHADER_UNUSED_KHR nullPtr - shaderGroups = [genGroup, intGroup, missGroup] - - let pipelineCreateInfo :: RayTracingPipelineCreateInfoKHR '[] - pipelineCreateInfo = zero { flags = zero - , stages = shaderStages - , groups = shaderGroups - , maxPipelineRayRecursionDepth = 1 - , layout = pipelineLayout - } - (key, (_, ~[rtPipeline])) <- withRayTracingPipelinesKHR - dev - NULL_HANDLE - NULL_HANDLE - [SomeStruct pipelineCreateInfo] - Nothing - allocate + shaderGroups = [genGroup, intGroup, missGroup] + + let + pipelineCreateInfo :: RayTracingPipelineCreateInfoKHR '[] + pipelineCreateInfo = + zero + { flags = zero + , stages = shaderStages + , groups = shaderGroups + , maxPipelineRayRecursionDepth = 1 + , layout = pipelineLayout + } + (key, (_, ~[rtPipeline])) <- + withRayTracingPipelinesKHR + dev + NULL_HANDLE + NULL_HANDLE + [SomeStruct pipelineCreateInfo] + Nothing + allocate traverse_ release shaderKeys pure (key, rtPipeline, fromIntegral (V.length shaderGroups)) createRTPipelineLayout - :: MonadResource m => Device -> DescriptorSetLayout -> m (ReleaseKey, PipelineLayout) -createRTPipelineLayout dev descriptorSetLayout = withPipelineLayout - dev - zero { setLayouts = [descriptorSetLayout] } - Nothing - allocate + :: (MonadResource m) => Device -> DescriptorSetLayout -> m (ReleaseKey, PipelineLayout) +createRTPipelineLayout dev descriptorSetLayout = + withPipelineLayout + dev + zero{setLayouts = [descriptorSetLayout]} + Nothing + allocate createRTDescriptorSetLayout - :: MonadResource m => Device -> m (ReleaseKey, DescriptorSetLayout) -createRTDescriptorSetLayout dev = withDescriptorSetLayout - dev - zero - { bindings = [ zero - { binding = 0 - , descriptorType = DESCRIPTOR_TYPE_ACCELERATION_STRUCTURE_KHR - , descriptorCount = 1 - , stageFlags = SHADER_STAGE_RAYGEN_BIT_KHR - } - , zero { binding = 1 - , descriptorType = DESCRIPTOR_TYPE_STORAGE_IMAGE - , descriptorCount = 1 - , stageFlags = SHADER_STAGE_RAYGEN_BIT_KHR - } - , zero - { binding = 2 - , descriptorType = DESCRIPTOR_TYPE_STORAGE_BUFFER - , descriptorCount = 1 - , stageFlags = SHADER_STAGE_INTERSECTION_BIT_KHR - .|. SHADER_STAGE_CLOSEST_HIT_BIT_KHR - } - , zero { binding = 3 - , descriptorType = DESCRIPTOR_TYPE_UNIFORM_BUFFER - , descriptorCount = 1 - , stageFlags = SHADER_STAGE_RAYGEN_BIT_KHR - } - ] - } - Nothing - allocate + :: (MonadResource m) => Device -> m (ReleaseKey, DescriptorSetLayout) +createRTDescriptorSetLayout dev = + withDescriptorSetLayout + dev + zero + { bindings = + [ zero + { binding = 0 + , descriptorType = DESCRIPTOR_TYPE_ACCELERATION_STRUCTURE_KHR + , descriptorCount = 1 + , stageFlags = SHADER_STAGE_RAYGEN_BIT_KHR + } + , zero + { binding = 1 + , descriptorType = DESCRIPTOR_TYPE_STORAGE_IMAGE + , descriptorCount = 1 + , stageFlags = SHADER_STAGE_RAYGEN_BIT_KHR + } + , zero + { binding = 2 + , descriptorType = DESCRIPTOR_TYPE_STORAGE_BUFFER + , descriptorCount = 1 + , stageFlags = + SHADER_STAGE_INTERSECTION_BIT_KHR + .|. SHADER_STAGE_CLOSEST_HIT_BIT_KHR + } + , zero + { binding = 3 + , descriptorType = DESCRIPTOR_TYPE_UNIFORM_BUFFER + , descriptorCount = 1 + , stageFlags = SHADER_STAGE_RAYGEN_BIT_KHR + } + ] + } + Nothing + allocate createRTDescriptorSets - :: MonadResource m + :: (MonadResource m) => Device -> DescriptorSetLayout -> AccelerationStructureKHR -> SceneBuffers -> Word32 -> m (Vector DescriptorSet) -createRTDescriptorSets dev descriptorSetLayout tlas SceneBuffers {..} numDescriptorSets - = do - let numImagesPerSet = 1 - numAccelerationStructuresPerSet = 1 - numStorageBuffersPerSet = 1 - numUniformBuffersPerSet = 1 - (_, descriptorPool) <- withDescriptorPool - dev - zero - { maxSets = numDescriptorSets - , poolSizes = - [ DescriptorPoolSize DESCRIPTOR_TYPE_STORAGE_IMAGE - (numDescriptorSets * numImagesPerSet) - , DescriptorPoolSize - DESCRIPTOR_TYPE_ACCELERATION_STRUCTURE_KHR - (numDescriptorSets * numAccelerationStructuresPerSet) - , DescriptorPoolSize DESCRIPTOR_TYPE_STORAGE_BUFFER - (numDescriptorSets * numStorageBuffersPerSet) - , DescriptorPoolSize DESCRIPTOR_TYPE_UNIFORM_BUFFER - (numDescriptorSets * numUniformBuffersPerSet) - ] - } - Nothing - allocate - - sets <- allocateDescriptorSets - dev - zero { descriptorPool = descriptorPool - , setLayouts = V.replicate (fromIntegral numDescriptorSets) - descriptorSetLayout - } - - for_ sets $ \set -> updateDescriptorSets - dev - [ SomeStruct - $ zero { dstSet = set - , dstBinding = 0 - , descriptorType = DESCRIPTOR_TYPE_ACCELERATION_STRUCTURE_KHR - , descriptorCount = 1 - } - ::& zero { accelerationStructures = [tlas] } - :& () - , SomeStruct $ zero - { dstSet = set - , dstBinding = 2 - , descriptorType = DESCRIPTOR_TYPE_STORAGE_BUFFER - , descriptorCount = 1 - , bufferInfo = [ DescriptorBufferInfo { buffer = sceneSpheres - , offset = 0 - , range = WHOLE_SIZE - } - ] - } - ] - [] +createRTDescriptorSets dev descriptorSetLayout tlas SceneBuffers{..} numDescriptorSets = + do + let + numImagesPerSet = 1 + numAccelerationStructuresPerSet = 1 + numStorageBuffersPerSet = 1 + numUniformBuffersPerSet = 1 + (_, descriptorPool) <- + withDescriptorPool + dev + zero + { maxSets = numDescriptorSets + , poolSizes = + [ DescriptorPoolSize + DESCRIPTOR_TYPE_STORAGE_IMAGE + (numDescriptorSets * numImagesPerSet) + , DescriptorPoolSize + DESCRIPTOR_TYPE_ACCELERATION_STRUCTURE_KHR + (numDescriptorSets * numAccelerationStructuresPerSet) + , DescriptorPoolSize + DESCRIPTOR_TYPE_STORAGE_BUFFER + (numDescriptorSets * numStorageBuffersPerSet) + , DescriptorPoolSize + DESCRIPTOR_TYPE_UNIFORM_BUFFER + (numDescriptorSets * numUniformBuffersPerSet) + ] + } + Nothing + allocate + + sets <- + allocateDescriptorSets + dev + zero + { descriptorPool = descriptorPool + , setLayouts = + V.replicate + (fromIntegral numDescriptorSets) + descriptorSetLayout + } + + for_ sets $ \set -> + updateDescriptorSets + dev + [ SomeStruct $ + zero + { dstSet = set + , dstBinding = 0 + , descriptorType = DESCRIPTOR_TYPE_ACCELERATION_STRUCTURE_KHR + , descriptorCount = 1 + } + ::& zero{accelerationStructures = [tlas]} + :& () + , SomeStruct $ + zero + { dstSet = set + , dstBinding = 2 + , descriptorType = DESCRIPTOR_TYPE_STORAGE_BUFFER + , descriptorCount = 1 + , bufferInfo = + [ DescriptorBufferInfo + { buffer = sceneSpheres + , offset = 0 + , range = WHOLE_SIZE + } + ] + } + ] + [] pure sets createRayGenerationShader - :: MonadResource m => Device -> m (ReleaseKey, SomeStruct PipelineShaderStageCreateInfo) + :: (MonadResource m) => Device -> m (ReleaseKey, SomeStruct PipelineShaderStageCreateInfo) createRayGenerationShader dev = do - let code = $(compileShaderQ (Just "spirv1.4") "rgen" Nothing [glsl| + let code = + $( compileShaderQ + (Just "spirv1.4") + "rgen" + Nothing + [glsl| #version 460 #extension GL_EXT_ray_tracing : require @@ -252,17 +291,23 @@ createRayGenerationShader dev = do 0); imageStore(image, ivec2(gl_LaunchIDEXT.xy), vec4(prd, 1.0)); } - |]) + |] + ) - (key, module') <- withShaderModule dev zero { code } Nothing allocate + (key, module') <- withShaderModule dev zero{code} Nothing allocate let shaderStageCreateInfo = - zero { stage = SHADER_STAGE_RAYGEN_BIT_KHR, module', name = "main" } + zero{stage = SHADER_STAGE_RAYGEN_BIT_KHR, module', name = "main"} pure (key, SomeStruct shaderStageCreateInfo) createRayHitShader - :: MonadResource m => Device -> m (ReleaseKey, SomeStruct PipelineShaderStageCreateInfo) + :: (MonadResource m) => Device -> m (ReleaseKey, SomeStruct PipelineShaderStageCreateInfo) createRayHitShader dev = do - let code = $(compileShaderQ (Just "spirv1.4") "rchit" Nothing [glsl| + let code = + $( compileShaderQ + (Just "spirv1.4") + "rchit" + Nothing + [glsl| #version 460 #extension GL_EXT_ray_tracing : require @@ -284,17 +329,23 @@ createRayHitShader dev = do const Sphere sphere = spheres[i]; hitValue = vec3(sphere.color.xyz); } - |]) + |] + ) - (key, module') <- withShaderModule dev zero { code } Nothing allocate + (key, module') <- withShaderModule dev zero{code} Nothing allocate let shaderStageCreateInfo = - zero { stage = SHADER_STAGE_CLOSEST_HIT_BIT_KHR, module', name = "main" } + zero{stage = SHADER_STAGE_CLOSEST_HIT_BIT_KHR, module', name = "main"} pure (key, SomeStruct shaderStageCreateInfo) createRayIntShader - :: MonadResource m => Device -> m (ReleaseKey, SomeStruct PipelineShaderStageCreateInfo) + :: (MonadResource m) => Device -> m (ReleaseKey, SomeStruct PipelineShaderStageCreateInfo) createRayIntShader dev = do - let code = $(compileShaderQ (Just "spirv1.4") "rint" Nothing [glsl| + let code = + $( compileShaderQ + (Just "spirv1.4") + "rint" + Nothing + [glsl| #version 460 #extension GL_EXT_ray_tracing : require @@ -327,17 +378,23 @@ createRayIntShader dev = do reportIntersectionEXT(m - sqrt(x), 0); reportIntersectionEXT(m + sqrt(x), 0); } - |]) + |] + ) - (key, module') <- withShaderModule dev zero { code } Nothing allocate + (key, module') <- withShaderModule dev zero{code} Nothing allocate let shaderStageCreateInfo = - zero { stage = SHADER_STAGE_INTERSECTION_BIT_KHR, module', name = "main" } + zero{stage = SHADER_STAGE_INTERSECTION_BIT_KHR, module', name = "main"} pure (key, SomeStruct shaderStageCreateInfo) createRayMissShader - :: MonadResource m => Device -> m (ReleaseKey, SomeStruct PipelineShaderStageCreateInfo) + :: (MonadResource m) => Device -> m (ReleaseKey, SomeStruct PipelineShaderStageCreateInfo) createRayMissShader dev = do - let code = $(compileShaderQ (Just "spirv1.4") "rmiss" Nothing [glsl| + let code = + $( compileShaderQ + (Just "spirv1.4") + "rmiss" + Nothing + [glsl| #version 460 #extension GL_EXT_ray_tracing : require @@ -347,11 +404,12 @@ createRayMissShader dev = do { hitValue = vec3(0.1, 0.15, 0.15); } - |]) + |] + ) - (key, module') <- withShaderModule dev zero { code } Nothing allocate + (key, module') <- withShaderModule dev zero{code} Nothing allocate let shaderStageCreateInfo = - zero { stage = SHADER_STAGE_MISS_BIT_KHR, module', name = "main" } + zero{stage = SHADER_STAGE_MISS_BIT_KHR, module', name = "main"} pure (key, SomeStruct shaderStageCreateInfo) ---------------------------------------------------------------- @@ -359,29 +417,32 @@ createRayMissShader dev = do ---------------------------------------------------------------- createShaderBindingTable - :: MonadResource m + :: (MonadResource m) => Device -> Allocator -> RTInfo -> Pipeline -> Word32 -> m (ReleaseKey, Buffer) -createShaderBindingTable dev vma RTInfo {..} pipeline numGroups = do - let handleSize = rtiShaderGroupHandleSize - baseAlignment = rtiShaderGroupBaseAlignment - handleStride = max handleSize baseAlignment - sbtSize = fromIntegral $ handleStride * (numGroups - 1) + handleSize +createShaderBindingTable dev vma RTInfo{..} pipeline numGroups = do + let + handleSize = rtiShaderGroupHandleSize + baseAlignment = rtiShaderGroupBaseAlignment + handleStride = max handleSize baseAlignment + sbtSize = fromIntegral $ handleStride * (numGroups - 1) + handleSize sayErrShow (handleStride, baseAlignment) - (bufferReleaseKey, (sbtBuffer, sbtAllocation, _)) <- VMA.withBuffer - vma - zero { usage = BUFFER_USAGE_SHADER_DEVICE_ADDRESS_BIT, size = sbtSize } - zero - { requiredFlags = MEMORY_PROPERTY_HOST_VISIBLE_BIT - .|. MEMORY_PROPERTY_HOST_COHERENT_BIT - } - allocate + (bufferReleaseKey, (sbtBuffer, sbtAllocation, _)) <- + VMA.withBuffer + vma + zero{usage = BUFFER_USAGE_SHADER_DEVICE_ADDRESS_BIT, size = sbtSize} + zero + { requiredFlags = + MEMORY_PROPERTY_HOST_VISIBLE_BIT + .|. MEMORY_PROPERTY_HOST_COHERENT_BIT + } + allocate nameObject dev sbtBuffer "SBT" (memKey, mem) <- VMA.withMappedMemory vma sbtAllocation allocate @@ -391,7 +452,7 @@ createShaderBindingTable dev vma RTInfo {..} pipeline numGroups = do pure (bufferReleaseKey, sbtBuffer) unpackObjects - :: MonadIO m + :: (MonadIO m) => Word32 -> Word32 -> Word32 @@ -401,8 +462,10 @@ unpackObjects numObjs size desiredStride buf = do let objectInitalPosition n = buf `plusPtr` fromIntegral (size * n) objectFinalPosition n = buf `plusPtr` fromIntegral (desiredStride * n) - moveObject n = moveBytes (objectFinalPosition n) - (objectInitalPosition n) - (fromIntegral size) + moveObject n = + moveBytes + (objectFinalPosition n) + (objectInitalPosition n) + (fromIntegral size) indicesToMove = drop 1 [numObjs, numObjs - 1 .. 1] liftIO $ traverse_ moveObject indicesToMove diff --git a/examples/rays/Render.hs b/examples/rays/Render.hs index 03b97f26e..5da8e80c3 100644 --- a/examples/rays/Render.hs +++ b/examples/rays/Render.hs @@ -1,64 +1,69 @@ {-# LANGUAGE OverloadedLists #-} module Render - ( RenderState(..) + ( RenderState (..) , renderFrame ) where -import Camera -import Control.Exception ( throwIO ) -import Control.Monad.IO.Class -import Control.Monad.Trans.Resource -import Data.Vector ( (!) ) -import qualified Data.Vector as V -import Data.Word -import Foreign.Ptr ( Ptr - , plusPtr - ) -import Foreign.Storable -import Frame ( Frame(..) - , numConcurrentFrames - , queueSubmitFrame - ) -import GHC.Clock ( getMonotonicTime ) -import GHC.IO.Exception ( IOErrorType(TimeExpired) - , IOException(IOError) - ) -import Init ( RTInfo(..) ) -import Linear.Matrix -import Linear.Quaternion -import Linear.V3 -import Swapchain ( Swapchain(..) ) -import UnliftIO.Exception ( throwString ) -import VkResources ( Queues(..) - , RecycledResources(..) - , VkResources(..) - ) -import Vulkan.CStruct.Extends -import Vulkan.Core10 as Core10 -import qualified Vulkan.Core10 as Extent2D (Extent2D(..)) -import qualified Vulkan.Core10 as CommandBufferBeginInfo (CommandBufferBeginInfo(..)) -import Vulkan.Core12.Promoted_From_VK_KHR_timeline_semaphore -import Vulkan.Exception ( VulkanException(..) ) -import Vulkan.Extensions.VK_KHR_ray_tracing_pipeline -import Vulkan.Extensions.VK_KHR_swapchain - as Swap -import VulkanMemoryAllocator as VMA - hiding ( getPhysicalDeviceProperties ) -import Vulkan.Zero +import Camera +import Control.Exception (throwIO) +import Control.Monad.IO.Class +import Control.Monad.Trans.Resource +import Data.Vector ((!)) +import qualified Data.Vector as V +import Data.Word +import Foreign.Ptr + ( Ptr + , plusPtr + ) +import Foreign.Storable +import Frame + ( Frame (..) + , numConcurrentFrames + , queueSubmitFrame + ) +import GHC.Clock (getMonotonicTime) +import GHC.IO.Exception + ( IOErrorType (TimeExpired) + , IOException (IOError) + ) +import Init (RTInfo (..)) +import Linear.Matrix +import Linear.Quaternion +import Linear.V3 +import Swapchain (Swapchain (..)) +import UnliftIO.Exception (throwString) +import VkResources + ( Queues (..) + , RecycledResources (..) + , VkResources (..) + ) +import Vulkan.CStruct.Extends +import Vulkan.Core10 as Core10 +import qualified Vulkan.Core10 as CommandBufferBeginInfo (CommandBufferBeginInfo (..)) +import qualified Vulkan.Core10 as Extent2D (Extent2D (..)) +import Vulkan.Core12.Promoted_From_VK_KHR_timeline_semaphore +import Vulkan.Exception (VulkanException (..)) +import Vulkan.Extensions.VK_KHR_ray_tracing_pipeline +import Vulkan.Extensions.VK_KHR_swapchain as Swap +import Vulkan.Zero +import VulkanMemoryAllocator as VMA hiding + ( getPhysicalDeviceProperties + ) --- | Long-lived per-app render state. Built once during setup; threaded into --- 'renderFrame' each frame. +{- | Long-lived per-app render state. Built once during setup; threaded into +'renderFrame' each frame. +-} data RenderState = RenderState - { rsPipeline :: Pipeline - , rsPipelineLayout :: PipelineLayout - , rsDescriptorSets :: V.Vector DescriptorSet - -- ^ One per concurrent-frame slot. Picked by @fIndex `mod` numConcurrentFrames@. + { rsPipeline :: Pipeline + , rsPipelineLayout :: PipelineLayout + , rsDescriptorSets :: V.Vector DescriptorSet + -- ^ One per concurrent-frame slot. Picked by @fIndex `mod` numConcurrentFrames@. , rsShaderBindingTableAddress :: DeviceAddress - , rsCameraMatricesBuffer :: Buffer + , rsCameraMatricesBuffer :: Buffer , rsCameraMatricesAllocation :: Allocation , rsCameraMatricesBufferData :: Ptr CameraMatrices - , rsRTInfo :: RTInfo + , rsRTInfo :: RTInfo } renderFrame @@ -67,69 +72,79 @@ renderFrame -> Frame -> ResourceT IO () renderFrame vr rs f = do - let RecycledResources {..} = fRecycled f - sc = fSwapchain f - dev = vrDevice vr - gQ = snd (qGraphics (vrQueues vr)) - RTInfo {..} = rsRTInfo rs - slot = fromIntegral (fIndex f) `mod` numConcurrentFrames - descriptorSet = rsDescriptorSets rs ! slot - cameraMatricesOffset = fromIntegral slot - * fromIntegral (sizeOf (undefined :: CameraMatrices)) - oneSecond = 1e9 + let + RecycledResources{..} = fRecycled f + sc = fSwapchain f + dev = vrDevice vr + gQ = snd (qGraphics (vrQueues vr)) + RTInfo{..} = rsRTInfo rs + slot = fromIntegral (fIndex f) `mod` numConcurrentFrames + descriptorSet = rsDescriptorSets rs ! slot + cameraMatricesOffset = + fromIntegral slot + * fromIntegral (sizeOf (undefined :: CameraMatrices)) + oneSecond = 1e9 -- Acquire next image (acquireResult, imageIndex) <- acquireNextImageKHRSafe dev (sSwapchain sc) oneSecond rrImageAvailable NULL_HANDLE >>= \case - r@(SUCCESS, _) -> pure r - r@(SUBOPTIMAL_KHR, _) -> pure r - (TIMEOUT, _) -> timeoutError "Timed out (1s) acquiring next image" - _ -> throwString "Unexpected Result from acquireNextImageKHR" + r@(SUCCESS, _) -> pure r + r@(SUBOPTIMAL_KHR, _) -> pure r + (TIMEOUT, _) -> timeoutError "Timed out (1s) acquiring next image" + _ -> throwString "Unexpected Result from acquireNextImageKHR" -- Bind the per-slot descriptor set's image view + camera buffer slot. updateDescriptorSets dev - [ SomeStruct zero - { dstSet = descriptorSet - , dstBinding = 1 - , descriptorType = DESCRIPTOR_TYPE_STORAGE_IMAGE - , descriptorCount = 1 - , imageInfo = [ DescriptorImageInfo - { sampler = NULL_HANDLE - , imageView = sImageViews sc ! fromIntegral imageIndex - , imageLayout = IMAGE_LAYOUT_GENERAL - } - ] - } - , SomeStruct zero - { dstSet = descriptorSet - , dstBinding = 3 - , descriptorType = DESCRIPTOR_TYPE_UNIFORM_BUFFER - , descriptorCount = 1 - , bufferInfo = [ DescriptorBufferInfo - { buffer = rsCameraMatricesBuffer rs - , offset = cameraMatricesOffset - , range = fromIntegral - (sizeOf (undefined :: CameraMatrices)) - } - ] - } + [ SomeStruct + zero + { dstSet = descriptorSet + , dstBinding = 1 + , descriptorType = DESCRIPTOR_TYPE_STORAGE_IMAGE + , descriptorCount = 1 + , imageInfo = + [ DescriptorImageInfo + { sampler = NULL_HANDLE + , imageView = sImageViews sc ! fromIntegral imageIndex + , imageLayout = IMAGE_LAYOUT_GENERAL + } + ] + } + , SomeStruct + zero + { dstSet = descriptorSet + , dstBinding = 3 + , descriptorType = DESCRIPTOR_TYPE_UNIFORM_BUFFER + , descriptorCount = 1 + , bufferInfo = + [ DescriptorBufferInfo + { buffer = rsCameraMatricesBuffer rs + , offset = cameraMatricesOffset + , range = + fromIntegral + (sizeOf (undefined :: CameraMatrices)) + } + ] + } ] [] -- Update camera matrices for this frame. time <- realToFrac <$> liftIO getMonotonicTime - let spin = axisAngle (V3 0 1 0) (sin time + 1) - forwards = axisAngle (V3 0 0 1) 0 - camera = Camera (V3 0 0 (-10)) (spin * forwards) (16 / 9) 1.4 - cameraMats = CameraMatrices + let + spin = axisAngle (V3 0 1 0) (sin time + 1) + forwards = axisAngle (V3 0 0 1) 0 + camera = Camera (V3 0 0 (-10)) (spin * forwards) (16 / 9) 1.4 + cameraMats = + CameraMatrices { cmViewInverse = transpose $ inv44 (viewMatrix camera) , cmProjInverse = transpose $ inv44 (projectionMatrix camera) } - liftIO $ poke - (rsCameraMatricesBufferData rs `plusPtr` fromIntegral cameraMatricesOffset) - cameraMats + liftIO $ + poke + (rsCameraMatricesBufferData rs `plusPtr` fromIntegral cameraMatricesOffset) + cameraMats flushAllocation (vrAllocator vr) (rsCameraMatricesAllocation rs) @@ -137,58 +152,65 @@ renderFrame vr rs f = do (fromIntegral (sizeOf (undefined :: CameraMatrices))) -- Allocate per-frame command buffer from the recycled pool. - let commandBufferAllocateInfo = zero - { commandPool = rrCommandPool - , level = COMMAND_BUFFER_LEVEL_PRIMARY - , commandBufferCount = 1 - } + let commandBufferAllocateInfo = + zero + { commandPool = rrCommandPool + , level = COMMAND_BUFFER_LEVEL_PRIMARY + , commandBufferCount = 1 + } (_, ~[commandBuffer]) <- withCommandBuffers dev commandBufferAllocateInfo allocate useCommandBuffer - commandBuffer - zero { CommandBufferBeginInfo.flags = COMMAND_BUFFER_USAGE_ONE_TIME_SUBMIT_BIT } + commandBuffer + zero{CommandBufferBeginInfo.flags = COMMAND_BUFFER_USAGE_ONE_TIME_SUBMIT_BIT} $ recordCommandBuffer - commandBuffer - rs - sc - descriptorSet - imageIndex + commandBuffer + rs + sc + descriptorSet + imageIndex -- Submit and record GPU work for the frame's wait thread. let submitInfo = - zero { Core10.waitSemaphores = [rrImageAvailable] - , waitDstStageMask = [PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT] - , commandBuffers = [commandBufferHandle commandBuffer] - , signalSemaphores = [rrRenderFinished, fHostTimeline f] - } - ::& zero { waitSemaphoreValues = [1] - , signalSemaphoreValues = [1, fIndex f] - } - :& () - liftIO $ queueSubmitFrame gQ - f - [SomeStruct submitInfo] - (fHostTimeline f) - (fIndex f) + zero + { Core10.waitSemaphores = [rrImageAvailable] + , waitDstStageMask = [PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT] + , commandBuffers = [commandBufferHandle commandBuffer] + , signalSemaphores = [rrRenderFinished, fHostTimeline f] + } + ::& zero + { waitSemaphoreValues = [1] + , signalSemaphoreValues = [1, fIndex f] + } + :& () + liftIO $ + queueSubmitFrame + gQ + f + [SomeStruct submitInfo] + (fHostTimeline f) + (fIndex f) - presentResult <- queuePresentKHR - gQ - zero { Swap.waitSemaphores = [rrRenderFinished] - , swapchains = [sSwapchain sc] - , imageIndices = [imageIndex] - } + presentResult <- + queuePresentKHR + gQ + zero + { Swap.waitSemaphores = [rrRenderFinished] + , swapchains = [sSwapchain sc] + , imageIndices = [imageIndex] + } case (acquireResult, presentResult) of (SUBOPTIMAL_KHR, _) -> liftIO . throwIO $ VulkanException ERROR_OUT_OF_DATE_KHR (_, SUBOPTIMAL_KHR) -> liftIO . throwIO $ VulkanException ERROR_OUT_OF_DATE_KHR - _ -> pure () + _ -> pure () ---------------------------------------------------------------- -- Command buffer recording ---------------------------------------------------------------- recordCommandBuffer - :: MonadIO m + :: (MonadIO m) => CommandBuffer -> RenderState -> Swapchain @@ -196,39 +218,47 @@ recordCommandBuffer -> Word32 -> m () recordCommandBuffer commandBuffer rs sc descriptorSet imageIndex = do - let RTInfo {..} = rsRTInfo rs - image = sImages sc ! fromIntegral imageIndex - imageWidth = Extent2D.width (sExtent sc) - imageHeight = Extent2D.height (sExtent sc) - imageSubresourceRange = ImageSubresourceRange - { aspectMask = IMAGE_ASPECT_COLOR_BIT - , baseMipLevel = 0 - , levelCount = 1 + let + RTInfo{..} = rsRTInfo rs + image = sImages sc ! fromIntegral imageIndex + imageWidth = Extent2D.width (sExtent sc) + imageHeight = Extent2D.height (sExtent sc) + imageSubresourceRange = + ImageSubresourceRange + { aspectMask = IMAGE_ASPECT_COLOR_BIT + , baseMipLevel = 0 + , levelCount = 1 , baseArrayLayer = 0 - , layerCount = 1 + , layerCount = 1 } - numRayGenShaderGroups = 1 - rayGenRegion = StridedDeviceAddressRegionKHR + numRayGenShaderGroups = 1 + rayGenRegion = + StridedDeviceAddressRegionKHR { deviceAddress = rsShaderBindingTableAddress rs - , stride = fromIntegral rtiShaderGroupBaseAlignment - , size = fromIntegral rtiShaderGroupBaseAlignment - * numRayGenShaderGroups + , stride = fromIntegral rtiShaderGroupBaseAlignment + , size = + fromIntegral rtiShaderGroupBaseAlignment + * numRayGenShaderGroups } - numHitShaderGroups = 1 - hitRegion = StridedDeviceAddressRegionKHR - { deviceAddress = rsShaderBindingTableAddress rs - + (1 * fromIntegral rtiShaderGroupBaseAlignment) + numHitShaderGroups = 1 + hitRegion = + StridedDeviceAddressRegionKHR + { deviceAddress = + rsShaderBindingTableAddress rs + + (1 * fromIntegral rtiShaderGroupBaseAlignment) , stride = fromIntegral rtiShaderGroupBaseAlignment , size = fromIntegral rtiShaderGroupBaseAlignment * numHitShaderGroups } - numMissShaderGroups = 1 - missRegion = StridedDeviceAddressRegionKHR - { deviceAddress = rsShaderBindingTableAddress rs - + (2 * fromIntegral rtiShaderGroupBaseAlignment) + numMissShaderGroups = 1 + missRegion = + StridedDeviceAddressRegionKHR + { deviceAddress = + rsShaderBindingTableAddress rs + + (2 * fromIntegral rtiShaderGroupBaseAlignment) , stride = fromIntegral rtiShaderGroupBaseAlignment , size = fromIntegral rtiShaderGroupBaseAlignment * numMissShaderGroups } - callableRegion = zero + callableRegion = zero -- Transition image to general (write target for raygen). cmdPipelineBarrier @@ -238,13 +268,15 @@ recordCommandBuffer commandBuffer rs sc descriptorSet imageIndex = do zero [] [] - [ SomeStruct zero { srcAccessMask = zero - , dstAccessMask = ACCESS_SHADER_WRITE_BIT - , oldLayout = IMAGE_LAYOUT_UNDEFINED - , newLayout = IMAGE_LAYOUT_GENERAL - , image = image - , subresourceRange = imageSubresourceRange - } + [ SomeStruct + zero + { srcAccessMask = zero + , dstAccessMask = ACCESS_SHADER_WRITE_BIT + , oldLayout = IMAGE_LAYOUT_UNDEFINED + , newLayout = IMAGE_LAYOUT_GENERAL + , image = image + , subresourceRange = imageSubresourceRange + } ] cmdBindPipeline commandBuffer PIPELINE_BIND_POINT_RAY_TRACING_KHR (rsPipeline rs) @@ -263,23 +295,25 @@ recordCommandBuffer commandBuffer rs sc descriptorSet imageIndex = do zero [] [ SomeStruct - zero { srcAccessMask = ACCESS_HOST_WRITE_BIT - , dstAccessMask = ACCESS_SHADER_READ_BIT - , buffer = rsCameraMatricesBuffer rs - , offset = 0 -- TODO: per-slot - , size = WHOLE_SIZE - } + zero + { srcAccessMask = ACCESS_HOST_WRITE_BIT + , dstAccessMask = ACCESS_SHADER_READ_BIT + , buffer = rsCameraMatricesBuffer rs + , offset = 0 -- TODO: per-slot + , size = WHOLE_SIZE + } ] [] - cmdTraceRaysKHR commandBuffer - rayGenRegion - missRegion - hitRegion - callableRegion - imageWidth - imageHeight - 1 + cmdTraceRaysKHR + commandBuffer + rayGenRegion + missRegion + hitRegion + callableRegion + imageWidth + imageHeight + 1 cmdPipelineBarrier commandBuffer @@ -288,19 +322,21 @@ recordCommandBuffer commandBuffer rs sc descriptorSet imageIndex = do zero [] [] - [ SomeStruct zero { srcAccessMask = ACCESS_SHADER_WRITE_BIT - , dstAccessMask = zero - , oldLayout = IMAGE_LAYOUT_GENERAL - , newLayout = IMAGE_LAYOUT_PRESENT_SRC_KHR - , image = image - , subresourceRange = imageSubresourceRange - } + [ SomeStruct + zero + { srcAccessMask = ACCESS_SHADER_WRITE_BIT + , dstAccessMask = zero + , oldLayout = IMAGE_LAYOUT_GENERAL + , newLayout = IMAGE_LAYOUT_PRESENT_SRC_KHR + , image = image + , subresourceRange = imageSubresourceRange + } ] ---------------------------------------------------------------- -- Utils ---------------------------------------------------------------- -timeoutError :: MonadIO m => String -> m a +timeoutError :: (MonadIO m) => String -> m a timeoutError message = liftIO . throwIO $ IOError Nothing TimeExpired "" message Nothing Nothing diff --git a/examples/rays/Scene.hs b/examples/rays/Scene.hs index d7b0b7695..0df395da8 100644 --- a/examples/rays/Scene.hs +++ b/examples/rays/Scene.hs @@ -1,95 +1,106 @@ -{-# LANGUAGE ParallelListComp #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveAnyClass #-} -{-# OPTIONS_GHC -fplugin=Foreign.Storable.Generic.Plugin #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ParallelListComp #-} {-# OPTIONS_GHC -fplugin-opt=Foreign.Storable.Generic.Plugin:-v0 #-} +{-# OPTIONS_GHC -fplugin=Foreign.Storable.Generic.Plugin #-} module Scene where -import Control.Lens -import Control.Monad.IO.Class -import Control.Monad.Trans.Resource -import Data.Bits -import Data.Colour.RGBSpace -import Data.Colour.RGBSpace.HSV -import Data.Word -import Foreign.Marshal.Array -import Foreign.Ptr -import Foreign.Storable.Generic -import GHC.Generics ( Generic ) -import Linear.V3 -import Linear.V4 -import System.Random -import Vulkan.Core10 -import Vulkan.Extensions.VK_KHR_acceleration_structure -import Vulkan.Zero -import VulkanMemoryAllocator as VMA - hiding ( getPhysicalDeviceProperties ) +import Control.Lens +import Control.Monad.IO.Class +import Control.Monad.Trans.Resource +import Data.Bits +import Data.Colour.RGBSpace +import Data.Colour.RGBSpace.HSV +import Data.Word +import Foreign.Marshal.Array +import Foreign.Ptr +import Foreign.Storable.Generic +import GHC.Generics (Generic) +import Linear.V3 +import Linear.V4 +import System.Random +import Vulkan.Core10 +import Vulkan.Extensions.VK_KHR_acceleration_structure +import Vulkan.Zero +import VulkanMemoryAllocator as VMA hiding + ( getPhysicalDeviceProperties + ) scene :: [Sphere] scene = let n = 2000 - in - [ Sphere (V4 (x*radius) - (radius**2.4 * sin x) - (radius**2.4 * cos x) - (radius**1.3)) - (V4 r g b 1) - | radius <- (**1.3) <$> [1, 1.1 ..] - | x <- take n [0 ..] - | V3 r g b <- pastels - ] + in [ Sphere + ( V4 + (x * radius) + (radius ** 2.4 * sin x) + (radius ** 2.4 * cos x) + (radius ** 1.3) + ) + (V4 r g b 1) + | radius <- (** 1.3) <$> [1, 1.1 ..] + | x <- take n [0 ..] + | V3 r g b <- pastels + ] pastels :: [V3 Float] pastels = - let (g1, (g2, g3)) = split <$> split (mkStdGen 2) - hues = randomRs (0, 360) g1 - sats = randomRs (0.3, 0.5) g2 - vals = randomRs (0.8, 1) g3 - cs = zipWith3 hsv hues sats vals - in uncurryRGB V3 <$> cs + let + (g1, (g2, g3)) = split <$> split (mkStdGen 2) + hues = randomRs (0, 360) g1 + sats = randomRs (0.3, 0.5) g2 + vals = randomRs (0.8, 1) g3 + cs = zipWith3 hsv hues sats vals + in + uncurryRGB V3 <$> cs ---------------------------------------------------------------- -- Vulkan ---------------------------------------------------------------- data SceneBuffers = SceneBuffers - { sceneAabbs :: Buffer + { sceneAabbs :: Buffer , sceneSpheres :: Buffer - , sceneSize :: Word32 + , sceneSize :: Word32 } -makeSceneBuffers :: MonadResource m => Allocator -> m SceneBuffers +makeSceneBuffers :: (MonadResource m) => Allocator -> m SceneBuffers makeSceneBuffers vma = do - sceneAabbs <- initBuffer vma - ( BUFFER_USAGE_ACCELERATION_STRUCTURE_BUILD_INPUT_READ_ONLY_BIT_KHR - .|. BUFFER_USAGE_SHADER_DEVICE_ADDRESS_BIT - ) - (sphereAABB <$> scene) + sceneAabbs <- + initBuffer + vma + ( BUFFER_USAGE_ACCELERATION_STRUCTURE_BUILD_INPUT_READ_ONLY_BIT_KHR + .|. BUFFER_USAGE_SHADER_DEVICE_ADDRESS_BIT + ) + (sphereAABB <$> scene) sceneSpheres <- initBuffer vma BUFFER_USAGE_STORAGE_BUFFER_BIT scene let sceneSize = fromIntegral (length scene) - pure SceneBuffers { .. } + pure SceneBuffers{..} ---------------------------------------------------------------- -- Buffer tools ---------------------------------------------------------------- -initBuffer :: forall a m . (Storable a, MonadResource m) - => Allocator -> BufferUsageFlags -> [a] -> m Buffer +initBuffer + :: forall a m + . (Storable a, MonadResource m) + => Allocator -> BufferUsageFlags -> [a] -> m Buffer initBuffer vma usage xs = do let bufferSize = sizeOf (head xs) * length xs - (_, (buf, allocation, _)) <- VMA.withBuffer - vma - zero { flags = zero, size = fromIntegral bufferSize, usage } - zero - { requiredFlags = MEMORY_PROPERTY_HOST_VISIBLE_BIT - .|. MEMORY_PROPERTY_HOST_COHERENT_BIT - } - allocate + (_, (buf, allocation, _)) <- + VMA.withBuffer + vma + zero{flags = zero, size = fromIntegral bufferSize, usage} + zero + { requiredFlags = + MEMORY_PROPERTY_HOST_VISIBLE_BIT + .|. MEMORY_PROPERTY_HOST_COHERENT_BIT + } + allocate (unmapKey, p) <- VMA.withMappedMemory vma allocation allocate liftIO $ pokeArray (castPtr @() @a p) xs release unmapKey @@ -101,10 +112,10 @@ initBuffer vma usage xs = do ---------------------------------------------------------------- data Sphere = Sphere - { spherePos :: V4 Float + { spherePos :: V4 Float , sphereColor :: V4 Float } - deriving(Generic, GStorable) + deriving (Generic, GStorable) sphereRadius :: Sphere -> Float sphereRadius = view _w . spherePos @@ -114,11 +125,14 @@ sphereOrigin = view _xyz . spherePos sphereAABB :: Sphere -> AabbPositionsKHR sphereAABB s = - let mini = sphereOrigin s - pure (sphereRadius s) - maxi = sphereOrigin s + pure (sphereRadius s) - in AabbPositionsKHR (mini ^. _x) - (mini ^. _y) - (mini ^. _z) - (maxi ^. _x) - (maxi ^. _y) - (maxi ^. _z) + let + mini = sphereOrigin s - pure (sphereRadius s) + maxi = sphereOrigin s + pure (sphereRadius s) + in + AabbPositionsKHR + (mini ^. _x) + (mini ^. _y) + (mini ^. _z) + (maxi ^. _x) + (maxi ^. _y) + (maxi ^. _z) diff --git a/examples/resize/Init.hs b/examples/resize/Init.hs index a3a595df8..81fa5a21b 100644 --- a/examples/resize/Init.hs +++ b/examples/resize/Init.hs @@ -6,28 +6,31 @@ module Init , createVMA ) where -import Control.Monad.Trans.Resource -import Data.Word +import Control.Monad.Trans.Resource +import Data.Word -import Frame ( frameDeviceRequirements ) +import Frame (frameDeviceRequirements) import qualified Vma -import Vulkan.Core10 -import Vulkan.Requirement ( DeviceRequirement ) -import qualified Vulkan.Utils.Requirements.TH as U -import Vulkan.Zero -import VulkanMemoryAllocator ( Allocator ) +import Vulkan.Core10 +import Vulkan.Requirement (DeviceRequirement) +import qualified Vulkan.Utils.Requirements.TH as U +import Vulkan.Zero +import VulkanMemoryAllocator (Allocator) myApiVersion :: Word32 myApiVersion = API_VERSION_1_0 --- | Device requirements: API version, swapchain, and the timeline-semaphore --- bits the recycling 'Frame' machinery needs. +{- | Device requirements: API version, swapchain, and the timeline-semaphore +bits the recycling 'Frame' machinery needs. +-} deviceRequirements :: [DeviceRequirement] -deviceRequirements = [U.reqs| +deviceRequirements = + [U.reqs| 1.0 VK_KHR_swapchain - |] ++ frameDeviceRequirements + |] + ++ frameDeviceRequirements createVMA - :: MonadResource m => Instance -> PhysicalDevice -> Device -> m Allocator + :: (MonadResource m) => Instance -> PhysicalDevice -> Device -> m Allocator createVMA = Vma.createVMA zero myApiVersion diff --git a/examples/resize/Julia.hs b/examples/resize/Julia.hs index dd5280ce9..1e3de2d51 100644 --- a/examples/resize/Julia.hs +++ b/examples/resize/Julia.hs @@ -1,136 +1,164 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} --- | Julia-set compute shader pipeline. The pipeline + descriptor set layout --- are created once and never re-created; the descriptor sets are bound to --- swapchain image views, so they need to be recreated whenever the swapchain --- changes. +{-| Julia-set compute shader pipeline. The pipeline + descriptor set layout +are created once and never re-created; the descriptor sets are bound to +swapchain image views, so they need to be recreated whenever the swapchain +changes. +-} module Julia - ( JuliaPipeline(..) + ( JuliaPipeline (..) , createJuliaPipeline , createJuliaDescriptorSets , juliaWorkgroupX , juliaWorkgroupY ) where -import Control.Monad.Trans.Resource -import qualified Data.Vector as V -import Data.Vector ( Vector ) +import Control.Monad.Trans.Resource +import Data.Vector (Vector) +import qualified Data.Vector as V -import Vulkan.CStruct.Extends -import Vulkan.Core10 -import Vulkan.Utils.ShaderQQ.GLSL.Glslang -import Vulkan.Zero +import Vulkan.CStruct.Extends +import Vulkan.Core10 +import Vulkan.Utils.ShaderQQ.GLSL.Glslang +import Vulkan.Zero -import Julia.Constants +import Julia.Constants data JuliaPipeline = JuliaPipeline - { jpPipeline :: Pipeline - , jpPipelineLayout :: PipelineLayout + { jpPipeline :: Pipeline + , jpPipelineLayout :: PipelineLayout , jpDescriptorSetLayout :: DescriptorSetLayout } createJuliaPipeline :: (MonadResource m, MonadFail m) => Device -> m JuliaPipeline createJuliaPipeline dev = do - (_, descriptorSetLayout) <- withDescriptorSetLayout - dev - zero - { bindings = [ zero { binding = 0 - , descriptorType = DESCRIPTOR_TYPE_STORAGE_IMAGE - , descriptorCount = 1 - , stageFlags = SHADER_STAGE_COMPUTE_BIT - } - ] - } - Nothing - allocate + (_, descriptorSetLayout) <- + withDescriptorSetLayout + dev + zero + { bindings = + [ zero + { binding = 0 + , descriptorType = DESCRIPTOR_TYPE_STORAGE_IMAGE + , descriptorCount = 1 + , stageFlags = SHADER_STAGE_COMPUTE_BIT + } + ] + } + Nothing + allocate (releaseShader, shader) <- juliaShader dev - (_, pipelineLayout ) <- withPipelineLayout - dev - zero - { setLayouts = [descriptorSetLayout] - , pushConstantRanges = [ PushConstantRange SHADER_STAGE_COMPUTE_BIT - 0 - ((2 + 2 + 2 + 1) * 4) - ] - } - Nothing - allocate - let pipelineCreateInfo :: ComputePipelineCreateInfo '[] - pipelineCreateInfo = zero { layout = pipelineLayout - , stage = shader - , basePipelineHandle = zero - } - (_, (_, [computePipeline])) <- withComputePipelines - dev - zero - [SomeStruct pipelineCreateInfo] - Nothing - allocate + (_, pipelineLayout) <- + withPipelineLayout + dev + zero + { setLayouts = [descriptorSetLayout] + , pushConstantRanges = + [ PushConstantRange + SHADER_STAGE_COMPUTE_BIT + 0 + ((2 + 2 + 2 + 1) * 4) + ] + } + Nothing + allocate + let + pipelineCreateInfo :: ComputePipelineCreateInfo '[] + pipelineCreateInfo = + zero + { layout = pipelineLayout + , stage = shader + , basePipelineHandle = zero + } + (_, (_, [computePipeline])) <- + withComputePipelines + dev + zero + [SomeStruct pipelineCreateInfo] + Nothing + allocate release releaseShader - pure JuliaPipeline { jpPipeline = computePipeline - , jpPipelineLayout = pipelineLayout - , jpDescriptorSetLayout = descriptorSetLayout - } + pure + JuliaPipeline + { jpPipeline = computePipeline + , jpPipelineLayout = pipelineLayout + , jpDescriptorSetLayout = descriptorSetLayout + } --- | One descriptor set per swapchain image, bound to its image view. Allocated --- from a fresh descriptor pool so that releasing this scope frees the lot. +{- | One descriptor set per swapchain image, bound to its image view. Allocated +from a fresh descriptor pool so that releasing this scope frees the lot. +-} createJuliaDescriptorSets - :: MonadResource m + :: (MonadResource m) => Device -> DescriptorSetLayout -> Vector ImageView -> m (Vector DescriptorSet) createJuliaDescriptorSets dev descriptorSetLayout imageViews = do - (_, descriptorPool) <- withDescriptorPool - dev - zero - { maxSets = fromIntegral (V.length imageViews) - , poolSizes = [ DescriptorPoolSize DESCRIPTOR_TYPE_STORAGE_IMAGE - (fromIntegral (V.length imageViews)) - ] - } - Nothing - allocate + (_, descriptorPool) <- + withDescriptorPool + dev + zero + { maxSets = fromIntegral (V.length imageViews) + , poolSizes = + [ DescriptorPoolSize + DESCRIPTOR_TYPE_STORAGE_IMAGE + (fromIntegral (V.length imageViews)) + ] + } + Nothing + allocate -- Sets are freed automatically when the pool is destroyed. - descriptorSets <- allocateDescriptorSets - dev - zero { descriptorPool = descriptorPool - , setLayouts = V.replicate (V.length imageViews) descriptorSetLayout - } + descriptorSets <- + allocateDescriptorSets + dev + zero + { descriptorPool = descriptorPool + , setLayouts = V.replicate (V.length imageViews) descriptorSetLayout + } updateDescriptorSets dev - (V.zipWith - (\set view -> SomeStruct zero - { dstSet = set - , dstBinding = 0 - , descriptorType = DESCRIPTOR_TYPE_STORAGE_IMAGE - , descriptorCount = 1 - , imageInfo = [ DescriptorImageInfo { sampler = NULL_HANDLE - , imageView = view - , imageLayout = IMAGE_LAYOUT_GENERAL - } - ] - } - ) - descriptorSets - imageViews + ( V.zipWith + ( \set view -> + SomeStruct + zero + { dstSet = set + , dstBinding = 0 + , descriptorType = DESCRIPTOR_TYPE_STORAGE_IMAGE + , descriptorCount = 1 + , imageInfo = + [ DescriptorImageInfo + { sampler = NULL_HANDLE + , imageView = view + , imageLayout = IMAGE_LAYOUT_GENERAL + } + ] + } + ) + descriptorSets + imageViews ) [] pure descriptorSets juliaShader - :: MonadResource m + :: (MonadResource m) => Device -> m (ReleaseKey, SomeStruct PipelineShaderStageCreateInfo) juliaShader dev = do - let compCode = $(compileShaderQ (Just "vulkan1.0") "comp" Nothing [glsl| + let compCode = + $( compileShaderQ + (Just "vulkan1.0") + "comp" + Nothing + [glsl| #version 450 #extension GL_ARB_separate_shader_objects : enable @@ -202,10 +230,13 @@ juliaShader dev = do res /= float(num_samples); imageStore(img, ivec2(gl_GlobalInvocationID.xy), vec4(res, 1)); } - |]) - (releaseKey, compModule) <- withShaderModule dev zero { code = compCode } Nothing allocate - let compShaderStageCreateInfo = zero { stage = SHADER_STAGE_COMPUTE_BIT - , module' = compModule - , name = "main" - } + |] + ) + (releaseKey, compModule) <- withShaderModule dev zero{code = compCode} Nothing allocate + let compShaderStageCreateInfo = + zero + { stage = SHADER_STAGE_COMPUTE_BIT + , module' = compModule + , name = "main" + } pure (releaseKey, SomeStruct compShaderStageCreateInfo) diff --git a/examples/resize/Julia/Constants.hs b/examples/resize/Julia/Constants.hs index 2f079af69..1296b179d 100644 --- a/examples/resize/Julia/Constants.hs +++ b/examples/resize/Julia/Constants.hs @@ -1,7 +1,7 @@ module Julia.Constants - where +where -import Data.Word +import Data.Word juliaWorkgroupX, juliaWorkgroupY :: Word32 juliaWorkgroupX = 8 diff --git a/examples/resize/Main.hs b/examples/resize/Main.hs index c51094251..c195060cc 100644 --- a/examples/resize/Main.hs +++ b/examples/resize/Main.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} @@ -7,94 +7,103 @@ module Main ( main ) where -import Control.Exception ( handle ) -import Control.Lens.Getter -import Control.Monad ( when ) -import Control.Monad.IO.Class -import Control.Monad.Trans.Resource -import Data.IORef -import qualified Data.Vector as V -import Data.Vector ( Vector ) -import Frame ( Frame(..) - , advanceFrame - , frameInstanceRequirements - , initialFrame - , queueSubmitFrame - , runFrame - ) +import Control.Exception (handle) +import Control.Lens.Getter +import Control.Monad (when) +import Control.Monad.IO.Class +import Control.Monad.Trans.Resource +import Data.IORef +import Data.Text.Encoding (decodeUtf8) +import Data.Vector (Vector) +import qualified Data.Vector as V +import Data.Word (Word64) +import Frame + ( Frame (..) + , advanceFrame + , frameInstanceRequirements + , initialFrame + , queueSubmitFrame + , runFrame + ) import qualified Framebuffer -import GHC.Clock ( getMonotonicTimeNSec ) -import Init ( createVMA - , deviceRequirements - , myApiVersion - ) -import InitDevice ( withDevice ) -import Data.Text.Encoding ( decodeUtf8 ) -import Julia ( JuliaPipeline(..) - , createJuliaDescriptorSets - , createJuliaPipeline - , juliaWorkgroupX - , juliaWorkgroupY - ) -import Linear.Affine ( Point(..) ) -import Linear.Metric ( norm ) -import Linear.V2 +import GHC.Clock (getMonotonicTimeNSec) +import Init + ( createVMA + , deviceRequirements + , myApiVersion + ) +import InitDevice (withDevice) +import Julia + ( JuliaPipeline (..) + , createJuliaDescriptorSets + , createJuliaPipeline + , juliaWorkgroupX + , juliaWorkgroupY + ) +import Linear.Affine (Point (..)) +import Linear.Metric (norm) +import Linear.V2 import qualified Pipeline -import RefCounted ( RefCounted - , newRefCounted - , releaseRefCounted - ) +import RefCounted + ( RefCounted + , newRefCounted + , releaseRefCounted + ) import qualified SDL -import Say -import Data.Word ( Word64 ) -import Swapchain ( Swapchain(..) - , allocSwapchain - , recreateSwapchain - , threwSwapchainError - ) -import UnliftIO.Exception ( displayException - , throwIO - , throwString - ) -import UnliftIO.Foreign ( allocaBytes - , plusPtr - , poke - ) -import Utils ( loopJust ) -import VkResources ( Queues(..) - , RecycledResources(..) - , VkResources(..) - , mkVkResources - ) - -import Vulkan.CStruct.Extends ( SomeStruct(..) - , pattern (:&) - , pattern (::&) - ) -import Vulkan.Core10 as Vk - hiding ( createDevice - , createFramebuffer - , createImageView - , createInstance - , withBuffer - , withDevice - , withImage - ) -import qualified Vulkan.Core10 as CommandBufferBeginInfo (CommandBufferBeginInfo(..)) -import Vulkan.Core12.Promoted_From_VK_KHR_timeline_semaphore -import Vulkan.Exception -import Vulkan.Extensions.VK_KHR_surface as SurfaceFormatKHR (SurfaceFormatKHR(..)) -import Vulkan.Extensions.VK_KHR_swapchain - as Swap -import Vulkan.Zero -import qualified Vulkan.Utils.Init.SDL2 as Init -import Window.SDL2 ( RefreshLimit(..) - , createSurface - , createWindow - , drawableSize - , shouldQuit - , withSDL - ) +import Say +import Swapchain + ( Swapchain (..) + , allocSwapchain + , recreateSwapchain + , threwSwapchainError + ) +import UnliftIO.Exception + ( displayException + , throwIO + , throwString + ) +import UnliftIO.Foreign + ( allocaBytes + , plusPtr + , poke + ) +import Utils (loopJust) +import VkResources + ( Queues (..) + , RecycledResources (..) + , VkResources (..) + , mkVkResources + ) + +import Vulkan.CStruct.Extends + ( SomeStruct (..) + , pattern (:&) + , pattern (::&) + ) +import Vulkan.Core10 as Vk hiding + ( createDevice + , createFramebuffer + , createImageView + , createInstance + , withBuffer + , withDevice + , withImage + ) +import qualified Vulkan.Core10 as CommandBufferBeginInfo (CommandBufferBeginInfo (..)) +import Vulkan.Core12.Promoted_From_VK_KHR_timeline_semaphore +import Vulkan.Exception +import Vulkan.Extensions.VK_KHR_surface as SurfaceFormatKHR (SurfaceFormatKHR (..)) +import Vulkan.Extensions.VK_KHR_swapchain as Swap +import qualified Vulkan.Utils.Init.SDL2 as Init +import Vulkan.Zero +import Window.SDL2 + ( RefreshLimit (..) + , createSurface + , createWindow + , drawableSize + , shouldQuit + , withSDL + ) ---------------------------------------------------------------- -- Main @@ -103,18 +112,20 @@ main :: IO () main = prettyError . runResourceT $ do withSDL - let initWidth = 1280 - initHeight = 720 + let + initWidth = 1280 + initHeight = 720 sdlWindow <- createWindow "Haskell ❤️ Vulkan" initWidth initHeight - inst <- Init.withInstance - sdlWindow - (Just zero { applicationName = Nothing, apiVersion = myApiVersion }) - frameInstanceRequirements - [] - (_, surface) <- createSurface inst sdlWindow + inst <- + Init.withInstance + sdlWindow + (Just zero{applicationName = Nothing, apiVersion = myApiVersion}) + frameInstanceRequirements + [] + (_, surface) <- createSurface inst sdlWindow (phys, dev, qs) <- withDevice inst surface deviceRequirements - vma <- createVMA inst phys dev + vma <- createVMA inst phys dev props <- getPhysicalDeviceProperties phys sayErr $ "Using device: " <> decodeUtf8 (deviceName props) @@ -128,13 +139,13 @@ main = prettyError . runResourceT $ do -- and the Julia compute pipeline are created up front. (_, renderPass) <- Pipeline.createRenderPass dev (SurfaceFormatKHR.format (sFormat initialSC)) -- (_, pipeline) <- Pipeline.createPipeline dev renderPass - juliaPL <- createJuliaPipeline dev + juliaPL <- createJuliaPipeline dev -- Per-swapchain bindings: framebuffers + Julia descriptor sets, both pinned -- to the current swapchain images. initialBindings <- createBindings dev renderPass juliaPL initialSC - scRef <- liftIO $ newIORef initialSC + scRef <- liftIO $ newIORef initialSC bindingsRef <- liftIO $ newIORef initialBindings initial <- initialFrame vr initialSC @@ -143,28 +154,33 @@ main = prettyError . runResourceT $ do let perFrame f = do currentSC <- liftIO $ readIORef scRef - bindings <- liftIO $ readIORef bindingsRef - let f' = f { fSwapchain = currentSC } + bindings <- liftIO $ readIORef bindingsRef + let f' = f{fSwapchain = currentSC} startNs <- liftIO getMonotonicTimeNSec - needsNew <- threwSwapchainError $ liftIO $ runFrame vr f' $ - renderJulia vr juliaPL bindings f' - sc' <- if needsNew - then do - newSize <- liftIO $ drawableSize sdlWindow - sc' <- recreateSwapchain vr newSize currentSC - newBindings <- createBindings dev renderPass juliaPL sc' - liftIO $ writeIORef scRef sc' - dropBindings =<< liftIO (readIORef bindingsRef) - liftIO $ writeIORef bindingsRef newBindings - pure sc' - else pure currentSC + needsNew <- + threwSwapchainError $ + liftIO $ + runFrame vr f' $ + renderJulia vr juliaPL bindings f' + sc' <- + if needsNew + then do + newSize <- liftIO $ drawableSize sdlWindow + sc' <- recreateSwapchain vr newSize currentSC + newBindings <- createBindings dev renderPass juliaPL sc' + liftIO $ writeIORef scRef sc' + dropBindings =<< liftIO (readIORef bindingsRef) + liftIO $ writeIORef bindingsRef newBindings + pure sc' + else pure currentSC endNs <- liftIO getMonotonicTimeNSec reportFrameTime (endNs - startNs) advanceFrame vr sc' f' - loop f = shouldQuit (TimeLimit 6) >>= \case - True -> pure Nothing - False -> Just <$> perFrame f + loop f = + shouldQuit (TimeLimit 6) >>= \case + True -> pure Nothing + False -> Just <$> perFrame f loopJust loop initial @@ -177,14 +193,14 @@ prettyError = ---------------------------------------------------------------- data Bindings = Bindings - { bFramebuffers :: Vector Framebuffer - , bReleaseFramebuffers :: RefCounted - , bJuliaDescriptorSets :: Vector DescriptorSet + { bFramebuffers :: Vector Framebuffer + , bReleaseFramebuffers :: RefCounted + , bJuliaDescriptorSets :: Vector DescriptorSet , bReleaseJuliaDescSets :: RefCounted } createBindings - :: MonadResource m + :: (MonadResource m) => Device -> RenderPass -> JuliaPipeline @@ -196,23 +212,25 @@ createBindings dev renderPass jp sc = do Framebuffer.createFramebuffers dev renderPass (sImageViews sc) (sExtent sc) -- Julia descriptor sets (one per swapchain image). - juliaSets <- createJuliaDescriptorSets - dev - (jpDescriptorSetLayout jp) - (sImageViews sc) + juliaSets <- + createJuliaDescriptorSets + dev + (jpDescriptorSetLayout jp) + (sImageViews sc) -- The whole pool is freed when its allocate-frame closes; mirror that with -- a dummy refcount so swapping bindings releases the previous pool. (poolKey, _) <- allocate (pure ()) (\_ -> pure ()) - poolRel <- newRefCounted (release poolKey) + poolRel <- newRefCounted (release poolKey) - pure Bindings - { bFramebuffers = framebuffers - , bReleaseFramebuffers = fbRel - , bJuliaDescriptorSets = juliaSets - , bReleaseJuliaDescSets = poolRel - } + pure + Bindings + { bFramebuffers = framebuffers + , bReleaseFramebuffers = fbRel + , bJuliaDescriptorSets = juliaSets + , bReleaseJuliaDescSets = poolRel + } -dropBindings :: MonadIO m => Bindings -> m () +dropBindings :: (MonadIO m) => Bindings -> m () dropBindings b = do releaseRefCounted (bReleaseFramebuffers b) releaseRefCounted (bReleaseJuliaDescSets b) @@ -228,180 +246,206 @@ renderJulia -> Frame -> ResourceT IO () renderJulia vr jp bindings f = do - let RecycledResources {..} = fRecycled f - sc = fSwapchain f - gQ = snd (qGraphics (vrQueues vr)) - dev = vrDevice vr - oneSecond = 1e9 - Extent2D imageWidth imageHeight = sExtent sc - imageSubresourceRange = ImageSubresourceRange - { aspectMask = IMAGE_ASPECT_COLOR_BIT - , baseMipLevel = 0 - , levelCount = 1 + let + RecycledResources{..} = fRecycled f + sc = fSwapchain f + gQ = snd (qGraphics (vrQueues vr)) + dev = vrDevice vr + oneSecond = 1e9 + Extent2D imageWidth imageHeight = sExtent sc + imageSubresourceRange = + ImageSubresourceRange + { aspectMask = IMAGE_ASPECT_COLOR_BIT + , baseMipLevel = 0 + , levelCount = 1 , baseArrayLayer = 0 - , layerCount = 1 + , layerCount = 1 } (acquireResult, imageIndex) <- acquireNextImageKHRSafe dev (sSwapchain sc) oneSecond rrImageAvailable NULL_HANDLE >>= \case - r@(SUCCESS, _) -> pure r - r@(SUBOPTIMAL_KHR, _) -> pure r - (TIMEOUT, _) -> throwString "Couldn't acquire next image after 1 second" - _ -> throwString "Unexpected Result from acquireNextImageKHR" + r@(SUCCESS, _) -> pure r + r@(SUBOPTIMAL_KHR, _) -> pure r + (TIMEOUT, _) -> throwString "Couldn't acquire next image after 1 second" + _ -> throwString "Unexpected Result from acquireNextImageKHR" - let image = sImages sc V.! fromIntegral imageIndex - descriptorSet = bJuliaDescriptorSets bindings V.! fromIntegral imageIndex + let + image = sImages sc V.! fromIntegral imageIndex + descriptorSet = bJuliaDescriptorSets bindings V.! fromIntegral imageIndex -- Allocate a per-frame command buffer from the recycled pool. - (_, ~[commandBuffer]) <- withCommandBuffers - dev - zero { commandPool = rrCommandPool - , level = COMMAND_BUFFER_LEVEL_PRIMARY - , commandBufferCount = 1 - } - allocate + (_, ~[commandBuffer]) <- + withCommandBuffers + dev + zero + { commandPool = rrCommandPool + , level = COMMAND_BUFFER_LEVEL_PRIMARY + , commandBufferCount = 1 + } + allocate let julia = True useCommandBuffer - commandBuffer - zero { CommandBufferBeginInfo.flags = COMMAND_BUFFER_USAGE_ONE_TIME_SUBMIT_BIT } + commandBuffer + zero{CommandBufferBeginInfo.flags = COMMAND_BUFFER_USAGE_ONE_TIME_SUBMIT_BIT} $ if julia - then do - -- Transition image to general (compute write target). - cmdPipelineBarrier - commandBuffer - PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT - PIPELINE_STAGE_COMPUTE_SHADER_BIT - zero - [] - [] - [ SomeStruct zero { srcAccessMask = zero - , dstAccessMask = ACCESS_SHADER_WRITE_BIT - , oldLayout = IMAGE_LAYOUT_UNDEFINED - , newLayout = IMAGE_LAYOUT_GENERAL - , image = image - , subresourceRange = imageSubresourceRange - } - ] - - cmdBindPipeline commandBuffer PIPELINE_BIND_POINT_COMPUTE (jpPipeline jp) - - -- Mouse-driven push constants. - P m <- SDL.getAbsoluteMouseLocation - let m' :: V2 Float - m' = fmap realToFrac m - / fmap realToFrac (V2 imageWidth imageHeight) - c :: V2 Float - c = (m' * 2) - 1 - r = 0.5 * (1 + sqrt (4 * norm c + 1)) - imageSizeF = realToFrac <$> V2 imageWidth imageHeight - aspect = pure (recip (min (imageSizeF ^. _x) (imageSizeF ^. _y))) - frameScale = aspect * 2 * pure r - frameOffset = negate (imageSizeF * aspect) * pure r - constantBytes = 4 * (2 + 2 + 2 + 1) - escapeRadius = 12 :: Float - allocaBytes constantBytes $ \p -> do - liftIO $ poke (p `plusPtr` 0) frameScale - liftIO $ poke (p `plusPtr` 8) frameOffset - liftIO $ poke (p `plusPtr` 16) c - liftIO $ poke (p `plusPtr` 24) escapeRadius - cmdPushConstants commandBuffer - (jpPipelineLayout jp) - SHADER_STAGE_COMPUTE_BIT - 0 - (fromIntegral constantBytes) - p - cmdBindDescriptorSets commandBuffer - PIPELINE_BIND_POINT_COMPUTE - (jpPipelineLayout jp) - 0 - [descriptorSet] - [] - cmdDispatch - commandBuffer - ((imageWidth + juliaWorkgroupX - 1) `quot` juliaWorkgroupX) - ((imageHeight + juliaWorkgroupY - 1) `quot` juliaWorkgroupY) - 1 - - -- Transition image back to present. - cmdPipelineBarrier + then do + -- Transition image to general (compute write target). + cmdPipelineBarrier + commandBuffer + PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT + PIPELINE_STAGE_COMPUTE_SHADER_BIT + zero + [] + [] + [ SomeStruct + zero + { srcAccessMask = zero + , dstAccessMask = ACCESS_SHADER_WRITE_BIT + , oldLayout = IMAGE_LAYOUT_UNDEFINED + , newLayout = IMAGE_LAYOUT_GENERAL + , image = image + , subresourceRange = imageSubresourceRange + } + ] + + cmdBindPipeline commandBuffer PIPELINE_BIND_POINT_COMPUTE (jpPipeline jp) + + -- Mouse-driven push constants. + P m <- SDL.getAbsoluteMouseLocation + let + m' :: V2 Float + m' = + fmap realToFrac m + / fmap realToFrac (V2 imageWidth imageHeight) + c :: V2 Float + c = (m' * 2) - 1 + r = 0.5 * (1 + sqrt (4 * norm c + 1)) + imageSizeF = realToFrac <$> V2 imageWidth imageHeight + aspect = pure (recip (min (imageSizeF ^. _x) (imageSizeF ^. _y))) + frameScale = aspect * 2 * pure r + frameOffset = negate (imageSizeF * aspect) * pure r + constantBytes = 4 * (2 + 2 + 2 + 1) + escapeRadius = 12 :: Float + allocaBytes constantBytes $ \p -> do + liftIO $ poke (p `plusPtr` 0) frameScale + liftIO $ poke (p `plusPtr` 8) frameOffset + liftIO $ poke (p `plusPtr` 16) c + liftIO $ poke (p `plusPtr` 24) escapeRadius + cmdPushConstants commandBuffer - PIPELINE_STAGE_COMPUTE_SHADER_BIT - PIPELINE_STAGE_BOTTOM_OF_PIPE_BIT - zero - [] - [] - [ SomeStruct zero { srcAccessMask = ACCESS_SHADER_WRITE_BIT - , dstAccessMask = zero - , oldLayout = IMAGE_LAYOUT_GENERAL - , newLayout = IMAGE_LAYOUT_PRESENT_SRC_KHR - , image = image - , subresourceRange = imageSubresourceRange - } - ] - else do - -- Dormant graphics pipeline path; preserved for reference. - let renderPassBeginInfo = zero - { renderPass = NULL_HANDLE -- intentionally invalid; see note + (jpPipelineLayout jp) + SHADER_STAGE_COMPUTE_BIT + 0 + (fromIntegral constantBytes) + p + cmdBindDescriptorSets + commandBuffer + PIPELINE_BIND_POINT_COMPUTE + (jpPipelineLayout jp) + 0 + [descriptorSet] + [] + cmdDispatch + commandBuffer + ((imageWidth + juliaWorkgroupX - 1) `quot` juliaWorkgroupX) + ((imageHeight + juliaWorkgroupY - 1) `quot` juliaWorkgroupY) + 1 + + -- Transition image back to present. + cmdPipelineBarrier + commandBuffer + PIPELINE_STAGE_COMPUTE_SHADER_BIT + PIPELINE_STAGE_BOTTOM_OF_PIPE_BIT + zero + [] + [] + [ SomeStruct + zero + { srcAccessMask = ACCESS_SHADER_WRITE_BIT + , dstAccessMask = zero + , oldLayout = IMAGE_LAYOUT_GENERAL + , newLayout = IMAGE_LAYOUT_PRESENT_SRC_KHR + , image = image + , subresourceRange = imageSubresourceRange + } + ] + else do + -- Dormant graphics pipeline path; preserved for reference. + let renderPassBeginInfo = + zero + { renderPass = NULL_HANDLE -- intentionally invalid; see note , framebuffer = bFramebuffers bindings V.! fromIntegral imageIndex - , renderArea = Rect2D zero (sExtent sc) + , renderArea = Rect2D zero (sExtent sc) , clearValues = [Color (Float32 0.1 0.1 0.1 1)] } - cmdSetViewport commandBuffer 0 - [ Viewport { x = 0 - , y = 0 - , width = realToFrac imageWidth - , height = realToFrac imageHeight - , minDepth = 0 - , maxDepth = 1 - } - ] - cmdSetScissor commandBuffer 0 - [Rect2D { offset = Offset2D 0 0, extent = sExtent sc }] - cmdUseRenderPass commandBuffer renderPassBeginInfo SUBPASS_CONTENTS_INLINE $ do - cmdBindPipeline commandBuffer PIPELINE_BIND_POINT_GRAPHICS NULL_HANDLE - cmdDraw commandBuffer 3 1 0 0 + cmdSetViewport + commandBuffer + 0 + [ Viewport + { x = 0 + , y = 0 + , width = realToFrac imageWidth + , height = realToFrac imageHeight + , minDepth = 0 + , maxDepth = 1 + } + ] + cmdSetScissor + commandBuffer + 0 + [Rect2D{offset = Offset2D 0 0, extent = sExtent sc}] + cmdUseRenderPass commandBuffer renderPassBeginInfo SUBPASS_CONTENTS_INLINE $ do + cmdBindPipeline commandBuffer PIPELINE_BIND_POINT_GRAPHICS NULL_HANDLE + cmdDraw commandBuffer 3 1 0 0 -- Submit (and record GPU work for the wait thread). let submitInfo = - zero { Vk.waitSemaphores = [rrImageAvailable] - , waitDstStageMask = [PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT] - , commandBuffers = [commandBufferHandle commandBuffer] - , signalSemaphores = [rrRenderFinished, fHostTimeline f] - } - ::& zero { waitSemaphoreValues = [1] - , signalSemaphoreValues = [1, fIndex f] - } - :& () - liftIO $ queueSubmitFrame gQ - f - [SomeStruct submitInfo] - (fHostTimeline f) - (fIndex f) - - presentResult <- queuePresentKHR - gQ - zero { Swap.waitSemaphores = [rrRenderFinished] - , swapchains = [sSwapchain sc] - , imageIndices = [imageIndex] - } + zero + { Vk.waitSemaphores = [rrImageAvailable] + , waitDstStageMask = [PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT] + , commandBuffers = [commandBufferHandle commandBuffer] + , signalSemaphores = [rrRenderFinished, fHostTimeline f] + } + ::& zero + { waitSemaphoreValues = [1] + , signalSemaphoreValues = [1, fIndex f] + } + :& () + liftIO $ + queueSubmitFrame + gQ + f + [SomeStruct submitInfo] + (fHostTimeline f) + (fIndex f) + + presentResult <- + queuePresentKHR + gQ + zero + { Swap.waitSemaphores = [rrRenderFinished] + , swapchains = [sSwapchain sc] + , imageIndices = [imageIndex] + } case (acquireResult, presentResult) of (SUBOPTIMAL_KHR, _) -> liftIO . throwIO $ VulkanException ERROR_OUT_OF_DATE_KHR (_, SUBOPTIMAL_KHR) -> liftIO . throwIO $ VulkanException ERROR_OUT_OF_DATE_KHR - _ -> pure () + _ -> pure () ---------------------------------------------------------------- -- Frame timing ---------------------------------------------------------------- -reportFrameTime :: MonadIO m => Word64 -> m () +reportFrameTime :: (MonadIO m) => Word64 -> m () reportFrameTime nsec = do - let frameTimeNSec = realToFrac nsec :: Double - targetHz = 60 - frameTimeBudgetMSec = recip targetHz * 1e3 - frameTimeMSec = frameTimeNSec / 1e6 - frameBudgetPercent = ceiling (100 * frameTimeMSec / frameTimeBudgetMSec) :: Int + let + frameTimeNSec = realToFrac nsec :: Double + targetHz = 60 + frameTimeBudgetMSec = recip targetHz * 1e3 + frameTimeMSec = frameTimeNSec / 1e6 + frameBudgetPercent = ceiling (100 * frameTimeMSec / frameTimeBudgetMSec) :: Int when (frameBudgetPercent > 50) $ sayErrString (show frameTimeMSec <> "ms \t" <> show frameBudgetPercent <> "%") diff --git a/examples/resize/Pipeline.hs b/examples/resize/Pipeline.hs index 20f3ffa6a..ec47dc8e6 100644 --- a/examples/resize/Pipeline.hs +++ b/examples/resize/Pipeline.hs @@ -1,24 +1,24 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} module Pipeline ( createPipeline , Pipeline.createRenderPass ) where -import Control.Monad.Trans.Resource -import Data.Bits -import Data.Foldable ( traverse_ ) -import qualified Data.Vector as V +import Control.Monad.Trans.Resource +import Data.Bits +import Data.Foldable (traverse_) +import qualified Data.Vector as V -import Vulkan.CStruct.Extends -import Vulkan.Core10 as Vk - hiding ( withBuffer - , withImage - ) -import Vulkan.Utils.ShaderQQ.GLSL.Glslang -import Vulkan.Zero +import Vulkan.CStruct.Extends +import Vulkan.Core10 as Vk hiding + ( withBuffer + , withImage + ) +import Vulkan.Utils.ShaderQQ.GLSL.Glslang +import Vulkan.Zero createPipeline :: (MonadResource m, MonadFail m) @@ -26,115 +26,139 @@ createPipeline -> RenderPass -> m (ReleaseKey, Pipeline) createPipeline dev renderPass = do - (shaderKeys, shaderStages ) <- V.unzip <$> createShaders dev - (layoutKey , pipelineLayout) <- withPipelineLayout dev zero Nothing allocate - let pipelineCreateInfo :: GraphicsPipelineCreateInfo '[] - pipelineCreateInfo = zero - { stages = shaderStages - , vertexInputState = Just zero - , inputAssemblyState = Just zero - { topology = PRIMITIVE_TOPOLOGY_TRIANGLE_LIST - , primitiveRestartEnable = False - } - , viewportState = Just - $ SomeStruct zero { viewportCount = 1, scissorCount = 1 } - , rasterizationState = Just . SomeStruct $ zero - { depthClampEnable = False - , rasterizerDiscardEnable = False - , lineWidth = 1 - , polygonMode = POLYGON_MODE_FILL - , cullMode = CULL_MODE_NONE - , frontFace = FRONT_FACE_CLOCKWISE - , depthBiasEnable = False - } - , multisampleState = Just . SomeStruct $ zero - { sampleShadingEnable = False - , rasterizationSamples = SAMPLE_COUNT_1_BIT - , minSampleShading = 1 - , sampleMask = [maxBound] - } - , depthStencilState = Nothing - , colorBlendState = Just . SomeStruct $ zero - { logicOpEnable = False - , attachments = - [ zero - { colorWriteMask = - COLOR_COMPONENT_R_BIT - .|. COLOR_COMPONENT_G_BIT - .|. COLOR_COMPONENT_B_BIT - .|. COLOR_COMPONENT_A_BIT - , blendEnable = False - } - ] - } - , dynamicState = Just zero - { dynamicStates = [ DYNAMIC_STATE_VIEWPORT - , DYNAMIC_STATE_SCISSOR - ] - } - , layout = pipelineLayout - , renderPass = renderPass - , subpass = 0 + (shaderKeys, shaderStages) <- V.unzip <$> createShaders dev + (layoutKey, pipelineLayout) <- withPipelineLayout dev zero Nothing allocate + let + pipelineCreateInfo :: GraphicsPipelineCreateInfo '[] + pipelineCreateInfo = + zero + { stages = shaderStages + , vertexInputState = Just zero + , inputAssemblyState = + Just + zero + { topology = PRIMITIVE_TOPOLOGY_TRIANGLE_LIST + , primitiveRestartEnable = False + } + , viewportState = + Just $ + SomeStruct zero{viewportCount = 1, scissorCount = 1} + , rasterizationState = + Just . SomeStruct $ + zero + { depthClampEnable = False + , rasterizerDiscardEnable = False + , lineWidth = 1 + , polygonMode = POLYGON_MODE_FILL + , cullMode = CULL_MODE_NONE + , frontFace = FRONT_FACE_CLOCKWISE + , depthBiasEnable = False + } + , multisampleState = + Just . SomeStruct $ + zero + { sampleShadingEnable = False + , rasterizationSamples = SAMPLE_COUNT_1_BIT + , minSampleShading = 1 + , sampleMask = [maxBound] + } + , depthStencilState = Nothing + , colorBlendState = + Just . SomeStruct $ + zero + { logicOpEnable = False + , attachments = + [ zero + { colorWriteMask = + COLOR_COMPONENT_R_BIT + .|. COLOR_COMPONENT_G_BIT + .|. COLOR_COMPONENT_B_BIT + .|. COLOR_COMPONENT_A_BIT + , blendEnable = False + } + ] + } + , dynamicState = + Just + zero + { dynamicStates = + [ DYNAMIC_STATE_VIEWPORT + , DYNAMIC_STATE_SCISSOR + ] + } + , layout = pipelineLayout + , renderPass = renderPass + , subpass = 0 , basePipelineHandle = zero } - (key, (_, [graphicsPipeline])) <- withGraphicsPipelines - dev - zero - [SomeStruct pipelineCreateInfo] - Nothing - allocate + (key, (_, [graphicsPipeline])) <- + withGraphicsPipelines + dev + zero + [SomeStruct pipelineCreateInfo] + Nothing + allocate release layoutKey traverse_ release shaderKeys pure (key, graphicsPipeline) createRenderPass - :: MonadResource m => Device -> Format -> m (ReleaseKey, RenderPass) -createRenderPass dev imageFormat = withRenderPass - dev - zero { attachments = [attachmentDescription] - , subpasses = [subpass] - , dependencies = [subpassDependency] - } - Nothing - allocate - where - attachmentDescription :: AttachmentDescription - attachmentDescription = zero - { format = imageFormat - , samples = SAMPLE_COUNT_1_BIT - , loadOp = ATTACHMENT_LOAD_OP_CLEAR - , storeOp = ATTACHMENT_STORE_OP_STORE - , stencilLoadOp = ATTACHMENT_LOAD_OP_DONT_CARE - , stencilStoreOp = ATTACHMENT_STORE_OP_DONT_CARE - , initialLayout = IMAGE_LAYOUT_UNDEFINED - , finalLayout = IMAGE_LAYOUT_PRESENT_SRC_KHR - } - subpass :: SubpassDescription - subpass = zero - { pipelineBindPoint = PIPELINE_BIND_POINT_GRAPHICS - , colorAttachments = - [ zero { attachment = 0 - , layout = IMAGE_LAYOUT_COLOR_ATTACHMENT_OPTIMAL - } - ] - } - subpassDependency :: SubpassDependency - subpassDependency = zero - { srcSubpass = SUBPASS_EXTERNAL - , dstSubpass = 0 - , srcStageMask = PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT - , srcAccessMask = zero - , dstStageMask = PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT - , dstAccessMask = ACCESS_COLOR_ATTACHMENT_READ_BIT - .|. ACCESS_COLOR_ATTACHMENT_WRITE_BIT - } + :: (MonadResource m) => Device -> Format -> m (ReleaseKey, RenderPass) +createRenderPass dev imageFormat = + withRenderPass + dev + zero + { attachments = [attachmentDescription] + , subpasses = [subpass] + , dependencies = [subpassDependency] + } + Nothing + allocate + where + attachmentDescription :: AttachmentDescription + attachmentDescription = + zero + { format = imageFormat + , samples = SAMPLE_COUNT_1_BIT + , loadOp = ATTACHMENT_LOAD_OP_CLEAR + , storeOp = ATTACHMENT_STORE_OP_STORE + , stencilLoadOp = ATTACHMENT_LOAD_OP_DONT_CARE + , stencilStoreOp = ATTACHMENT_STORE_OP_DONT_CARE + , initialLayout = IMAGE_LAYOUT_UNDEFINED + , finalLayout = IMAGE_LAYOUT_PRESENT_SRC_KHR + } + subpass :: SubpassDescription + subpass = + zero + { pipelineBindPoint = PIPELINE_BIND_POINT_GRAPHICS + , colorAttachments = + [ zero + { attachment = 0 + , layout = IMAGE_LAYOUT_COLOR_ATTACHMENT_OPTIMAL + } + ] + } + subpassDependency :: SubpassDependency + subpassDependency = + zero + { srcSubpass = SUBPASS_EXTERNAL + , dstSubpass = 0 + , srcStageMask = PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT + , srcAccessMask = zero + , dstStageMask = PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT + , dstAccessMask = + ACCESS_COLOR_ATTACHMENT_READ_BIT + .|. ACCESS_COLOR_ATTACHMENT_WRITE_BIT + } createShaders - :: MonadResource m + :: (MonadResource m) => Device -> m (V.Vector (ReleaseKey, SomeStruct PipelineShaderStageCreateInfo)) createShaders dev = do - let fragCode = [frag| + let + fragCode = + [frag| #version 450 #extension GL_ARB_separate_shader_objects : enable @@ -146,7 +170,8 @@ createShaders dev = do outColor = vec4(fragColor, 1.0); } |] - vertCode = [vert| + vertCode = + [vert| #version 450 #extension GL_ARB_separate_shader_objects : enable @@ -168,16 +193,21 @@ createShaders dev = do fragColor = colors[gl_VertexIndex]; } |] - (fragKey, fragModule) <- withShaderModule dev zero { code = fragCode } Nothing allocate - (vertKey, vertModule) <- withShaderModule dev zero { code = vertCode } Nothing allocate - let vertShaderStageCreateInfo = zero { stage = SHADER_STAGE_VERTEX_BIT - , module' = vertModule - , name = "main" - } - fragShaderStageCreateInfo = zero { stage = SHADER_STAGE_FRAGMENT_BIT - , module' = fragModule - , name = "main" - } + (fragKey, fragModule) <- withShaderModule dev zero{code = fragCode} Nothing allocate + (vertKey, vertModule) <- withShaderModule dev zero{code = vertCode} Nothing allocate + let + vertShaderStageCreateInfo = + zero + { stage = SHADER_STAGE_VERTEX_BIT + , module' = vertModule + , name = "main" + } + fragShaderStageCreateInfo = + zero + { stage = SHADER_STAGE_FRAGMENT_BIT + , module' = fragModule + , name = "main" + } pure [ (vertKey, SomeStruct vertShaderStageCreateInfo) , (fragKey, SomeStruct fragShaderStageCreateInfo) diff --git a/examples/triangle-glfw/Main.hs b/examples/triangle-glfw/Main.hs index 16e012e88..d49daca9b 100644 --- a/examples/triangle-glfw/Main.hs +++ b/examples/triangle-glfw/Main.hs @@ -2,54 +2,57 @@ module Main where -import Control.Monad.IO.Class -import Control.Monad.Trans.Resource -import qualified Data.Text as Text -import Data.String ( IsString ) -import Data.Text.Encoding ( decodeUtf8 ) -import InitDevice ( withDevice ) -import Say +import Control.Monad.IO.Class +import Control.Monad.Trans.Resource +import Data.String (IsString) +import qualified Data.Text as Text +import Data.Text.Encoding (decodeUtf8) +import Frame + ( frameDeviceRequirements + , frameInstanceRequirements + ) +import InitDevice (withDevice) +import Say +import Swapchain (allocSwapchain) import qualified Triangle +import VkResources (mkVkResources) import qualified Vma -import VkResources ( mkVkResources ) -import Vulkan.Core10 hiding ( withDevice ) -import Vulkan.Requirement ( DeviceRequirement(..) ) -import Vulkan.Zero ( zero ) -import qualified Vulkan.Utils.Init.GLFW as Init -import Frame ( frameDeviceRequirements - , frameInstanceRequirements - ) -import Swapchain ( allocSwapchain ) -import qualified Window.GLFW as Window +import Vulkan.Core10 hiding (withDevice) +import Vulkan.Requirement (DeviceRequirement (..)) +import qualified Vulkan.Utils.Init.GLFW as Init +import Vulkan.Zero (zero) +import qualified Window.GLFW as Window main :: IO () main = runResourceT $ do Window.withGLFW window <- Window.createWindow (Text.pack appName) windowWidth windowHeight - inst <- Init.withInstance - window - (Just zero { applicationName = Just appName, apiVersion = API_VERSION_1_0 }) - frameInstanceRequirements - [] - surface <- Init.withSurface inst window + inst <- + Init.withInstance + window + (Just zero{applicationName = Just appName, apiVersion = API_VERSION_1_0}) + frameInstanceRequirements + [] + surface <- Init.withSurface inst window let deviceReqs = [ RequireDeviceExtension Nothing e minBound | e <- Init.getRequiredDeviceExtensions - ] ++ frameDeviceRequirements + ] + ++ frameDeviceRequirements (phys, dev, qs) <- withDevice inst surface deviceReqs - vma <- Vma.createVMA zero API_VERSION_1_0 inst phys dev + vma <- Vma.createVMA zero API_VERSION_1_0 inst phys dev props <- getPhysicalDeviceProperties phys sayErr $ "Using device: " <> decodeUtf8 (deviceName props) vr <- liftIO $ mkVkResources inst phys dev vma qs initialSize <- Window.drawableSize window - initialSC <- allocSwapchain vr NULL_HANDLE initialSize surface + initialSC <- allocSwapchain vr NULL_HANDLE initialSize surface liftIO $ Window.showWindow window Triangle.runTriangle vr initialSC (Window.drawableSize window) (Window.shouldQuit window) -appName :: IsString a => a +appName :: (IsString a) => a appName = "Haskell Vulkan triangle example (GLFW)" windowWidth, windowHeight :: Int diff --git a/examples/triangle-sdl2/Main.hs b/examples/triangle-sdl2/Main.hs index d97e502d4..bd17969b5 100644 --- a/examples/triangle-sdl2/Main.hs +++ b/examples/triangle-sdl2/Main.hs @@ -2,53 +2,56 @@ module Main where -import Control.Monad.IO.Class -import Control.Monad.Trans.Resource -import Data.String ( IsString ) -import Data.Text.Encoding ( decodeUtf8 ) -import InitDevice ( withDevice ) -import Say +import Control.Monad.IO.Class +import Control.Monad.Trans.Resource +import Data.String (IsString) +import Data.Text.Encoding (decodeUtf8) +import Frame + ( frameDeviceRequirements + , frameInstanceRequirements + ) +import InitDevice (withDevice) +import Say +import Swapchain (allocSwapchain) import qualified Triangle +import VkResources (mkVkResources) import qualified Vma -import VkResources ( mkVkResources ) -import Vulkan.Core10 hiding ( withDevice ) -import Vulkan.Requirement ( DeviceRequirement(..) ) -import Vulkan.Zero ( zero ) -import qualified Vulkan.Utils.Init.SDL2 as Init -import Frame ( frameDeviceRequirements - , frameInstanceRequirements - ) -import Swapchain ( allocSwapchain ) -import qualified Window.SDL2 as Window +import Vulkan.Core10 hiding (withDevice) +import Vulkan.Requirement (DeviceRequirement (..)) +import qualified Vulkan.Utils.Init.SDL2 as Init +import Vulkan.Zero (zero) +import qualified Window.SDL2 as Window main :: IO () main = runResourceT $ do Window.withSDL window <- Window.createWindow appName windowWidth windowHeight - inst <- Init.withInstance - window - (Just zero { applicationName = Just appName, apiVersion = API_VERSION_1_0 }) - frameInstanceRequirements - [] - surface <- Init.withSurface inst window + inst <- + Init.withInstance + window + (Just zero{applicationName = Just appName, apiVersion = API_VERSION_1_0}) + frameInstanceRequirements + [] + surface <- Init.withSurface inst window let deviceReqs = [ RequireDeviceExtension Nothing e minBound | e <- Init.getRequiredDeviceExtensions - ] ++ frameDeviceRequirements + ] + ++ frameDeviceRequirements (phys, dev, qs) <- withDevice inst surface deviceReqs - vma <- Vma.createVMA zero API_VERSION_1_0 inst phys dev + vma <- Vma.createVMA zero API_VERSION_1_0 inst phys dev props <- getPhysicalDeviceProperties phys sayErr $ "Using device: " <> decodeUtf8 (deviceName props) vr <- liftIO $ mkVkResources inst phys dev vma qs initialSize <- Window.drawableSize window - initialSC <- allocSwapchain vr NULL_HANDLE initialSize surface + initialSC <- allocSwapchain vr NULL_HANDLE initialSize surface Window.showWindow window Triangle.runTriangle vr initialSC (Window.drawableSize window) (Window.shouldQuit Window.NoLimit) -appName :: IsString a => a +appName :: (IsString a) => a appName = "Haskell Vulkan triangle example" windowWidth, windowHeight :: Int