diff --git a/examples/compute/Main.hs b/examples/compute/Main.hs index 9316ff21b..de9bbdba8 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 #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} {-# OPTIONS_GHC -Wno-missing-signatures #-} module Main @@ -10,152 +8,55 @@ 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 -import Data.Functor.Identity ( Identity(..) ) -import qualified Data.Vector as V -import Data.Word -import Foreign.Marshal.Array ( peekArray ) -import Foreign.Ptr -import Foreign.Storable ( sizeOf ) -import Say - -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 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 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 ) -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(..)) - ----------------------------------------------------------------- --- 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 - ] +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 @@ -163,174 +64,197 @@ autoapplyDecs 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. - 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' - 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 - } + 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. 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 -- 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' - [ SomeStruct zero { dstSet = descriptorSet - , dstBinding = 0 - , descriptorType = DESCRIPTOR_TYPE_STORAGE_BUFFER - , descriptorCount = 1 - , bufferInfo = [DescriptorBufferInfo buffer 0 WHOLE_SIZE] - } + updateDescriptorSets + dev + [ 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 - (_, pipelineLayout) <- withPipelineLayout' zero { PipelineLayoutCreateInfo.setLayouts = [descriptorSetLayout] } - let pipelineCreateInfo :: ComputePipelineCreateInfo '[] - pipelineCreateInfo = zero { layout = pipelineLayout - , stage = shader - , basePipelineHandle = zero - } - (_, (_, [computePipeline])) <- withComputePipelines' - zero - [SomeStruct pipelineCreateInfo] + 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 - 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 - cmdBindDescriptorSets commandBuffer - PIPELINE_BIND_POINT_COMPUTE - pipelineLayout - 0 - [descriptorSet] - [] - - -- Dispatch the compute shader - 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' 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 () + _ -> 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) - 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 :: V (SomeStruct PipelineShaderStageCreateInfo) -createShader = do - let compCode = [comp| +createShader + :: Device + -> ResourceT IO (SomeStruct PipelineShaderStageCreateInfo) +createShader dev = do + let compCode = + [comp| #version 450 #extension GL_ARB_separate_shader_objects : enable @@ -393,11 +317,13 @@ createShader = do } } |] - (_, compModule) <- withShaderModule' zero { code = compCode } - 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 ---------------------------------------------------------------- @@ -408,69 +334,72 @@ 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 createDevice :: (MonadResource m, MonadThrow m) => Instance - -> m (PhysicalDevice, PhysicalDeviceInfo, Device) + -> m (PhysicalDevice, Word32, Device) createDevice inst = do mPd <- pickPhysicalDevice inst hasComputeQueue id - (_, phys) <- maybe (throwString "Unable to find appropriate PhysicalDevice") - pure - mPd + (_, 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, PhysicalDeviceInfo 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 - -newtype PhysicalDeviceInfo = PhysicalDeviceInfo - { pdiComputeQueueFamilyIndex :: Word32 - -- ^ The queue family index of the first compute queue - } - deriving (Eq, Ord) - + 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 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..df5ea74af 100644 --- a/examples/hlsl/Init.hs +++ b/examples/hlsl/Init.hs @@ -1,258 +1,36 @@ {-# LANGUAGE QuasiQuotes #-} + module Init - ( Init.createInstance - , Init.createDevice + ( myApiVersion + , deviceRequirements , createVMA - , createCommandPools ) where -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.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.Monad.Trans.Resource +import Data.Word -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 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 -import Vulkan.Requirement -import qualified Vulkan.Utils.Init.SDL2 as VkInit -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 Window.SDL2 -import Foreign.Ptr (castFunPtr) +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) 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 - requireCommands inst dev - 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) - - -- - -- 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 { .. } - --- | 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) - where - isGraphicsPresentQueue queueFamilyIndex queueFamilyProperties = - pure (isGraphicsQueueFamily queueFamilyProperties) - <&&> isPresentQueueFamily phys surf queueFamilyIndex - ----------------------------------------------------------------- --- Physical device tools ----------------------------------------------------------------- - -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 -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 (&&) + :: (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 e0ba1c7a9..d8b644c71 100644 --- a/examples/hlsl/Main.hs +++ b/examples/hlsl/Main.hs @@ -1,18 +1,56 @@ +{-# 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 SDL ( showWindow - , time - ) -import Swapchain ( threwSwapchainError ) -import Utils -import Window.SDL2 +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 qualified Pipeline +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 @@ -20,31 +58,66 @@ 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 + 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 - -- - -- Go - -- - start <- SDL.time @Double - let reportFPS f = 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 + -- 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) + + 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 <- 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 + + loopJust loop initial 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..1add01af4 100644 --- a/examples/hlsl/Pipeline.hs +++ b/examples/hlsl/Pipeline.hs @@ -1,137 +1,124 @@ -{-# 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 MonadVulkan -import Vulkan.CStruct.Extends -import Vulkan.Core10 as Vk - hiding ( withBuffer - , withImage - ) -import Vulkan.Utils.ShaderQQ.HLSL.Shaderc ( vert - , frag ) -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 --- Create the most vanilla rendering pipeline -createPipeline :: RenderPass -> V (ReleaseKey, Pipeline) -createPipeline renderPass = do - (shaderKeys, shaderStages ) <- V.unzip <$> createShaders - (layoutKey , pipelineLayout) <- withPipelineLayout' zero +-- | 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' - zero - [SomeStruct pipelineCreateInfo] + 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 - let fragCode = [frag| + :: (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 { return float4(col, 1); } |] - vertCode = [vert| + vertCode = + [vert| const static float2 positions[3] = { {0.0, -0.5}, {0.5, 0.5}, @@ -158,16 +145,21 @@ createShaders = do return output; } |] - (fragKey, fragModule) <- withShaderModule' zero { code = fragCode } - (vertKey, vertModule) <- withShaderModule' zero { code = vertCode } - 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 88c53a692..dfde9541d 100644 --- a/examples/hlsl/Render.hs +++ b/examples/hlsl/Render.hs @@ -4,126 +4,151 @@ module Render ( renderFrame ) where -import Control.Exception ( throwIO ) -import Control.Monad.IO.Class -import Data.Vector ( (!) ) -import Data.Word -import Frame -import GHC.IO.Exception ( IOErrorType(TimeExpired) - , IOException(IOError) - ) -import HasVulkan -import MonadFrame -import MonadVulkan -import Swapchain -import UnliftIO ( MonadUnliftIO ) -import UnliftIO.Exception ( throwString ) -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.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 -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 + gQ = snd (qGraphics (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 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 - - -- Submit the work - let -- Wait for the 'imageAvailableSemaphore' before outputting to the color - -- attachment - submitInfo = + -- Allocate a per-frame command buffer from the recycled pool. + (_, ~[commandBuffer]) <- + withCommandBuffers + dev zero - { Core10.waitSemaphores = [fImageAvailableSemaphore] - , waitDstStageMask = [PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT] - , commandBuffers = [commandBufferHandle commandBuffer] - , signalSemaphores = [ fRenderFinishedSemaphore - , fRenderFinishedHostSemaphore - ] + { 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)] } - ::& zero { waitSemaphoreValues = [1] - , signalSemaphoreValues = [1, fIndex] - } - :& () - graphicsQueue <- getGraphicsQueue - queueSubmitFrame graphicsQueue - [SomeStruct submitInfo] - fRenderFinishedHostSemaphore - fIndex - -- 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] - , imageIndices = [imageIndex] - } - pure () + 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 --- | 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)] + 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) + + presentResult <- + queuePresentKHR + gQ + zero + { Swap.waitSemaphores = [rrRenderFinished] + , swapchains = [sSwapchain sc] + , imageIndices = [imageIndex] } - 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 ---------------------------------------------------------------- -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 0e083fa73..8da5c810b 100644 --- a/examples/hlsl/RenderPass.hs +++ b/examples/hlsl/RenderPass.hs @@ -1,55 +1,62 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedLists #-} module RenderPass ( RenderPass.createRenderPass ) where -import Control.Monad.Trans.Resource -import Data.Bits -import MonadVulkan -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 -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 +-- | 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 - } - ] - } + 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] - } + 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/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/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 new file mode 100644 index 000000000..a141aa623 --- /dev/null +++ b/examples/lib/Frame.hs @@ -0,0 +1,305 @@ +{-# 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 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). + +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 (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. +-} +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..bd69bef44 100644 --- a/examples/lib/Framebuffer.hs +++ b/examples/lib/Framebuffer.hs @@ -1,75 +1,100 @@ {-# 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 + , Framebuffer.createFramebuffers ) where -import AutoApply -import Control.Monad.Trans.Resource -import HasVulkan -import Vulkan.Core10 as Vk - hiding ( withBuffer - , 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 - ] +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 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 - let framebufferCreateInfo :: FramebufferCreateInfo '[] - framebufferCreateInfo = zero { renderPass = renderPass - , attachments = [imageView] - , width = Extent2D.width imageSize - , height = Extent2D.height imageSize - , layers = 1 - } - withFramebuffer' framebufferCreateInfo +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 + +{- | 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) --- | 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 } - 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 - } - } +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 + } + } 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/InitDevice.hs b/examples/lib/InitDevice.hs new file mode 100644 index 000000000..511599440 --- /dev/null +++ b/examples/lib/InitDevice.hs @@ -0,0 +1,132 @@ +{-| 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) + +{- | 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 + -> SurfaceKHR + -> [DeviceRequirement] + -> 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 and compute" + + 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} + 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/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/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 8b84e8ea8..7f0002bd8 100644 --- a/examples/lib/Swapchain.hs +++ b/examples/lib/Swapchain.hs @@ -1,264 +1,239 @@ {-# 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 -import Data.Bits -import Data.Either -import Data.Foldable ( for_ - , traverse_ - ) -import qualified Data.Vector as V -import Data.Vector ( Vector ) -import 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 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 - -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 +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 + +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 +-- | Allocate a new swapchain plus its image views. +allocSwapchain + :: (MonadUnliftIO m, MonadResource m) + => VkResources + -> SwapchainKHR + -- ^ Previous swapchain ('NULL_HANDLE' for first) -> Extent2D - -- ^ If the swapchain size determines the surface size, use this size + -- ^ 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 -> + -> 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 - (SurfaceFormatKHR.format siSurfaceFormat) + (vrDevice vr) + (SurfaceFormatKHR.format sFormat) image - -- This refcount is released in 'recreateSwapchainResources' - releaseResources <- newRefCounted $ do + -- Released by the next 'recreateSwapchain' (when frames stop using it). + sRelease <- newRefCounted $ do traverse_ release imageViewKeys - release siSwapchainReleaseKey + release swapchainKey - pure $ SwapchainResources info imageViews swapchainImages releaseResources + pure Swapchain{sSurface = surface, ..} -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 +{- | 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) + 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" 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 - } - - (key, swapchain) <- withSwapchainKHR' swapchainCreateInfo + 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) - pure $ SwapchainInfo swapchain key presentMode surfaceFormat imageExtent surf - ----------------------------------------------------------------- --- Utils ---------------------------------------------------------------- - --- | Catch an ERROR_OUT_OF_DATE_KHR exception and return 'True' if that happened -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 - VulkanException _ -> Nothing - ----------------------------------------------------------------- --- Specifications +-- Format selection ---------------------------------------------------------------- --- 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. +{- | 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 + :: (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 --- | An ordered list of the present mode to be chosen for the swapchain. +---------------------------------------------------------------- +-- Specifications +---------------------------------------------------------------- + +-- | 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 ERROR_SURFACE_LOST_KHR too + VulkanException _ -> Nothing + +-- | 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..da92fe292 100644 --- a/examples/lib/Triangle.hs +++ b/examples/lib/Triangle.hs @@ -3,271 +3,406 @@ {-# 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 Data.Bits ( (.|.) ) -import Data.Traversable ( for ) -import qualified Data.Vector as V -import Data.Word ( Word32 ) +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 Vulkan.CStruct.Extends ( SomeStruct(..) ) -import Vulkan.Core10 hiding ( createRenderPass ) -import qualified Vulkan.Core10 as CommandBufferBeginInfo (CommandBufferBeginInfo(..)) -import qualified Vulkan.Core10 as CommandPoolCreateInfo (CommandPoolCreateInfo(..)) -import Vulkan.Extensions.VK_KHR_swapchain -import Vulkan.Utils.ShaderQQ.GLSL.Glslang - ( frag, vert ) -import Vulkan.Zero ( zero ) +import Data.IORef +import Frame + ( Frame (..) + , advanceFrame + , initialFrame + , queueSubmitFrame + , runFrame + ) +import qualified Framebuffer +import RefCounted (releaseRefCounted) +import Swapchain + ( Swapchain (..) + , recreateSwapchain + , threwSwapchainError + ) +import Utils (loopJust) +import VkResources + ( Queues (..) + , RecycledResources (..) + , VkResources (..) + ) -import Window ( VulkanWindow(..) ) +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 --- | 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 +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) -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 () + scRef <- liftIO $ newIORef initialSC + fbsRef <- liftIO $ newIORef initialFBs -allocate' :: IO a -> (a -> IO ()) -> ResourceT IO a -allocate' c d = snd <$> allocate c d + initial <- initialFrame vr initialSC -createSemaphores :: Device -> ResourceT IO (Semaphore, Semaphore) -createSemaphores dev = do - imageAvailableSemaphore <- withSemaphore dev zero Nothing allocate' - renderFinishedSemaphore <- withSemaphore dev zero Nothing allocate' - pure (imageAvailableSemaphore, renderFinishedSemaphore) + 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') + (_oldFbs, oldRel) <- liftIO $ readIORef fbsRef + releaseRefCounted oldRel + liftIO $ writeIORef scRef sc' + liftIO $ writeIORef fbsRef newFBs + pure sc' + else pure currentSC + advanceFrame vr sc' f' -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 + loop f = + liftIO shouldQuit >>= \case + True -> do + deviceWaitIdle dev + pure Nothing + False -> Just <$> perFrame f -createShaders - :: Device -> ResourceT IO (V.Vector (SomeStruct PipelineShaderStageCreateInfo)) -createShaders dev = do + loopJust loop initial + +---------------------------------------------------------------- +-- Per-frame draw +---------------------------------------------------------------- + +drawTriangle + :: VkResources + -> RenderPass + -> Pipeline + -> Vector Framebuffer + -> Frame + -> ResourceT IO () +drawTriangle vr renderPass pipeline framebuffers f = do let - fragCode = [frag| - #version 450 - #extension GL_ARB_separate_shader_objects : enable + RecycledResources{..} = fRecycled f + sc = fSwapchain f + dev = vrDevice vr + gQ = snd (qGraphics (vrQueues vr)) + oneSecond = 1e9 - layout(location = 0) in vec3 fragColor; - layout(location = 0) out vec4 outColor; + (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 - void main() { - outColor = vec4(fragColor, 1.0); - } - |] - vertCode = [vert| - #version 450 - #extension GL_ARB_separate_shader_objects : enable + (_, ~[commandBuffer]) <- + withCommandBuffers + dev + zero + { commandPool = rrCommandPool + , level = COMMAND_BUFFER_LEVEL_PRIMARY + , commandBufferCount = 1 + } + allocate - layout(location = 0) out vec3 fragColor; + 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)] + } - vec2 positions[3] = vec2[]( - vec2(0.0, -0.5), - vec2(0.5, 0.5), - vec2(-0.5, 0.5) - ); + 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 - 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) - ); + 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) - 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" + presentResult <- + queuePresentKHR + gQ + zero + { Swap.waitSemaphores = [rrRenderFinished] + , swapchains = [sSwapchain sc] + , imageIndices = [imageIndex] } - 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 + 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 + , initialLayout = IMAGE_LAYOUT_UNDEFINED + , finalLayout = IMAGE_LAYOUT_PRESENT_SRC_KHR } - subpass :: SubpassDescription - subpass = zero + subpass :: SubpassDescription + subpass = + zero { pipelineBindPoint = PIPELINE_BIND_POINT_GRAPHICS - , colorAttachments = - [ zero { attachment = 0, layout = IMAGE_LAYOUT_COLOR_ATTACHMENT_OPTIMAL } ] + , 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 + 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 + , 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' 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 '[] - 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 } ] - } - , 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 = Nothing - , layout = pipelineLayout - , renderPass = renderPass - , subpass = 0 + :: (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{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 } - 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) -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' +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) + ] diff --git a/examples/lib/Utils.hs b/examples/lib/Utils.hs index d3197ae55..19ad67f90 100644 --- a/examples/lib/Utils.hs +++ b/examples/lib/Utils.hs @@ -1,14 +1,32 @@ -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 - 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 +noSuchThing message = + liftIO . throwIO $ IOError Nothing NoSuchThing "" message Nothing Nothing diff --git a/examples/lib/VkResources.hs b/examples/lib/VkResources.hs new file mode 100644 index 000000000..277827104 --- /dev/null +++ b/examples/lib/VkResources.hs @@ -0,0 +1,95 @@ +{-| 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 + , 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. +-} +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 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. +-} +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..1216fa8ac --- /dev/null +++ b/examples/lib/Vma.hs @@ -0,0 +1,60 @@ +{-# 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/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..266d83fe3 100644 --- a/examples/lib/Window/GLFW.hs +++ b/examples/lib/Window/GLFW.hs @@ -1,60 +1,76 @@ --- | 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 , showWindow + , drawableSize , shouldQuit ) where -import Control.Monad ( unless, void ) -import Control.Monad.IO.Class ( 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 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 --- | Poll events and report whether the user requested to close the window --- (X button, Q, or Escape). +-- | 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 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 acd0819bd..620009166 100644 --- a/examples/lib/Window/SDL2.hs +++ b/examples/lib/Window/SDL2.hs @@ -2,27 +2,29 @@ module Window.SDL2 ( withSDL , createWindow , createSurface - , RefreshLimit(..) + , drawableSize + , showWindow + , 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 @@ -32,28 +34,44 @@ 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 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 @@ -61,30 +79,34 @@ createSurface inst window = allocate 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 --- | Return the SDL events which have become available --- --- Optionally wait for a timeout or forever. -awaitSDLEvents :: MonadIO m => RefreshLimit -> m [SDL.Event] +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/package.yaml b/examples/package.yaml index 161602815..8ca011f27 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,24 +152,20 @@ 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: - condition: '!flag(have-shaderc)' buildable: false - ghc-options: -eventlog rays: main: Main.hs @@ -197,13 +176,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,17 +187,14 @@ executables: - template-haskell - text - transformers - - unagi-chan - unliftio - vector - vulkan >= 3.7 - - vulkan-examples - vulkan-init-sdl2 - vulkan-utils >= 0.3 when: - condition: '!flag(raytracing)' buildable: false - ghc-options: -eventlog vrcube: main: Main.hs @@ -256,7 +229,6 @@ executables: when: - condition: '!flag(vr)' buildable: false - ghc-options: -eventlog when: - condition: os(windows) diff --git a/examples/rays/AccelerationStructure.hs b/examples/rays/AccelerationStructure.hs index c5504f952..3e9ed0ef3 100644 --- a/examples/rays/AccelerationStructure.hs +++ b/examples/rays/AccelerationStructure.hs @@ -1,156 +1,196 @@ {-# LANGUAGE OverloadedLists #-} -module AccelerationStructure 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 HasVulkan -import MonadVulkan -import Scene -import UnliftIO.Foreign ( castPtr ) -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.QueueAssignment -import Vulkan.Zero -import VulkanMemoryAllocator ( AllocationCreateInfo - ( requiredFlags - , usage - ) - , MemoryUsage - ( MEMORY_USAGE_GPU_ONLY - ) - ) +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 + ) ---------------------------------------------------------------- -- 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 - { 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 + (_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 , instanceShaderBindingTableRecordOffset = 0 , flags = GEOMETRY_INSTANCE_TRIANGLE_FACING_CULL_DISABLE_BIT_KHR , accelerationStructureReference = coerce blasAddress } - -- - -- Create the buffer for the top level instances - -- - let numInstances = 1 - instanceDescsSize = - numInstances * cStructSize @AccelerationStructureInstanceKHR - (_instBufferReleaseKey, (instBuffer, instBufferAllocation, _)) <- withBuffer' - zero - { usage = - 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 - } + 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 + } - -- - -- populate the instance buffer - -- - (instMapKey, instMapPtr) <- withMappedMemory' instBufferAllocation + (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 -- ignored but used later - , srcAccelerationStructure = NULL_HANDLE -- ignored - , dstAccelerationStructure = NULL_HANDLE -- ignored - , geometries = buildGeometries - , scratchData = zero - } - maxPrimitiveCounts = [1] - rangeInfos = [zero { primitiveCount = 1, primitiveOffset = 0 }] - sizes <- getAccelerationStructureBuildSizesKHR' - ACCELERATION_STRUCTURE_BUILD_TYPE_DEVICE_KHR - buildInfo - maxPrimitiveCounts - - (_tlasBufferKey, tlasKey, tlas) <- buildAccelerationStructure buildInfo - rangeInfos - sizes - nameObject' tlas "TLAS" + ] + 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 + dev + ACCELERATION_STRUCTURE_BUILD_TYPE_DEVICE_KHR + buildInfo + maxPrimitiveCounts + + (_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' - zero { size = bufferSize - , usage = BUFFER_USAGE_ACCELERATION_STRUCTURE_STORAGE_BIT_KHR - } - zero { usage = MEMORY_USAGE_GPU_ONLY } + -> m (ReleaseKey, ReleaseKey, AccelerationStructureKHR) +buildAccelerationStructure vr geom ranges sizes = do + let + dev = vrDevice vr + vma = vrAllocator vr + bufferSize = accelerationStructureSize sizes - -- - -- Allocate scratch space for building - -- - (scratchBufferKey, (scratchBuffer, _, _)) <- withBuffer' - zero { size = buildScratchSize sizes - , usage = BUFFER_USAGE_SHADER_DEVICE_ADDRESS_BIT - } - zero { usage = MEMORY_USAGE_GPU_ONLY } - scratchBufferDeviceAddress <- getBufferDeviceAddress' zero - { buffer = scratchBuffer - } - - let asci = zero { type' = ACCELERATION_STRUCTURE_TYPE_TOP_LEVEL_KHR - , buffer = asBuffer - , offset = 0 - , size = bufferSize - } - (asKey, as) <- withAccelerationStructureKHR' asci - - oneShotComputeCommands $ do - cmdBuildAccelerationStructuresKHR' - [ geom { dstAccelerationStructure = as - , scratchData = DeviceAddress scratchBufferDeviceAddress - } + (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 + } + + 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 + } ] [ranges] @@ -158,88 +198,110 @@ 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 - } - maxPrimitiveCounts = [sceneSize sceneBuffers] - sizes <- getAccelerationStructureBuildSizesKHR' - ACCELERATION_STRUCTURE_BUILD_TYPE_DEVICE_KHR - buildInfo - maxPrimitiveCounts - - (_blasBufferKey, blasKey, blas) <- buildAccelerationStructure buildInfo - sceneOffsets - sizes - nameObject' blas "BLAS" +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 + dev + ACCELERATION_STRUCTURE_BUILD_TYPE_DEVICE_KHR + buildInfo + maxPrimitiveCounts + + (_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 } - 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) ---------------------------------------------------------------- --- 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 + (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 + } - -- - -- 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] }] + [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" + _ -> error "Unhandled exit code in oneShotComputeCommands" release fenceKey release poolKey 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..9cccc0b85 100644 --- a/examples/rays/Init.hs +++ b/examples/rays/Init.hs @@ -1,290 +1,108 @@ {-# LANGUAGE QuasiQuotes #-} module Init - ( Init.createInstance - , Init.createDevice - , PhysicalDeviceInfo(..) + ( myApiVersion + , instanceRequirements + , deviceRequirements + , RTInfo (..) + , getDeviceRTProps , createVMA - , createCommandPools ) where -import Control.Applicative -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.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 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 -import Vulkan.Extensions.VK_KHR_get_physical_device_properties2 -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 -import VulkanMemoryAllocator ( Allocator - , AllocatorCreateFlagBits(..) - , AllocatorCreateInfo(..) - , VulkanFunctions(..) - , vkGetInstanceProcAddr - , withAllocator - ) -import Window.SDL2 -import Foreign.Ptr (castFunPtr) +import Control.Monad.IO.Class +import Control.Monad.Trans.Resource +import Data.Word + +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 (..) + ) 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 - ] - [] - ----------------------------------------------------------------- --- Device creation ----------------------------------------------------------------- - --- TODO: check VkPhysicalDeviceBufferDeviceAddressFeatures::bufferDeviceAddress. -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 - - requireCommands inst dev - - queues <- liftIO $ pdiGetQueues pdi dev - - pure (phys, pdi, dev, queues, surf) - +{- | 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. +-} 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 - -- ^ The relevant information from PhysicalDeviceProperties2KHR - , pdiQueueCreateInfos :: Vector (DeviceQueueCreateInfo '[]) - , pdiGetQueues :: Device -> IO (Queues (QueueFamilyIndex, Queue)) +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 + { rtiShaderGroupHandleSize :: Word32 + , rtiShaderGroupBaseAlignment :: Word32 } -pdiScore :: PhysicalDeviceInfo -> Word64 -pdiScore = pdiTotalMemory - -physicalDeviceInfo - :: MonadIO m - => SurfaceKHR - -> 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 - 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) - where - isGraphicsPresentQueue queueFamilyIndex queueFamilyProperties = - pure (isGraphicsQueueFamily queueFamilyProperties) - <&&> isPresentQueueFamily phys surf queueFamilyIndex - ----------------------------------------------------------------- --- Physical device tools ----------------------------------------------------------------- - -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 - } - ----------------------------------------------------------------- --- VulkanMemoryAllocator ----------------------------------------------------------------- + let _ ::& PhysicalDeviceRayTracingPipelinePropertiesKHR{..} :& () = props + pure + RTInfo + { rtiShaderGroupHandleSize = shaderGroupHandleSize + , rtiShaderGroupBaseAlignment = shaderGroupBaseAlignment + } 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 (&&) + :: (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 2d716e9da..2e2d8fbea 100644 --- a/examples/rays/Main.hs +++ b/examples/rays/Main.hs @@ -1,52 +1,172 @@ +{-# 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 SDL ( showWindow - , time - ) -import Swapchain ( threwSwapchainError ) -import Utils -import Window.SDL2 +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 qualified SDL +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 - -- - -- 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 - - -- - -- Go - -- - start <- SDL.time @Double - let reportFPS f = do - end <- SDL.time - let frames = fIndex f - mean = realToFrac frames / (end - start) - liftIO $ putStrLn $ "Average: " <> show mean - - let rtInfo = pdiRTInfo pdi - - 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 + 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 + initialSC <- allocSwapchain vr NULL_HANDLE initialSize surf + + -- Scene + acceleration structure + sceneBuffers <- makeSceneBuffers vma + (_, 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) + + -- 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 :: 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/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..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,184 +11,244 @@ 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 MonadVulkan -import Say -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.ShaderQQ.GLSL.Glslang ( glsl - , compileShaderQ ) -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 - (shaderKeys, shaderStages) <- V.unzip <$> sequence - [ createRayGenerationShader - , createRayIntShader - , createRayMissShader - , createRayHitShader - ] - - let genGroup = RayTracingShaderGroupCreateInfoKHR +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 + :: (MonadResource m, MonadFail m) + => Device + -> 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 RAY_TRACING_SHADER_GROUP_TYPE_GENERAL_KHR - 0 -- The index of our general shader + 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 -- closest hit + 3 SHADER_UNUSED_KHR - 1 -- intersection + 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' - zero - [SomeStruct pipelineCreateInfo] + 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 :: 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 - = 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) + -> 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 + } + ] + } ] - } - - -- 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' - [ 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 - :: V (ReleaseKey, SomeStruct PipelineShaderStageCreateInfo) -createRayGenerationShader = do - let code = $(compileShaderQ (Just "spirv1.4") "rgen" Nothing [glsl| + :: (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 @@ -231,16 +291,23 @@ createRayGenerationShader = do 0); imageStore(image, ivec2(gl_LaunchIDEXT.xy), vec4(prd, 1.0)); } - |]) + |] + ) - (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" } + zero{stage = SHADER_STAGE_RAYGEN_BIT_KHR, module', name = "main"} pure (key, SomeStruct shaderStageCreateInfo) -createRayHitShader :: V (ReleaseKey, SomeStruct PipelineShaderStageCreateInfo) -createRayHitShader = do - let code = $(compileShaderQ (Just "spirv1.4") "rchit" Nothing [glsl| +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 @@ -262,16 +329,23 @@ createRayHitShader = do const Sphere sphere = spheres[i]; hitValue = vec3(sphere.color.xyz); } - |]) + |] + ) - (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" } + zero{stage = SHADER_STAGE_CLOSEST_HIT_BIT_KHR, module', name = "main"} pure (key, SomeStruct shaderStageCreateInfo) -createRayIntShader :: V (ReleaseKey, SomeStruct PipelineShaderStageCreateInfo) -createRayIntShader = do - let code = $(compileShaderQ (Just "spirv1.4") "rint" Nothing [glsl| +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 @@ -304,16 +378,23 @@ createRayIntShader = do reportIntersectionEXT(m - sqrt(x), 0); reportIntersectionEXT(m + sqrt(x), 0); } - |]) + |] + ) - (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" } + zero{stage = SHADER_STAGE_INTERSECTION_BIT_KHR, module', name = "main"} pure (key, SomeStruct shaderStageCreateInfo) -createRayMissShader :: V (ReleaseKey, SomeStruct PipelineShaderStageCreateInfo) -createRayMissShader = do - let code = $(compileShaderQ (Just "spirv1.4") "rmiss" Nothing [glsl| +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 @@ -323,62 +404,68 @@ createRayMissShader = do { hitValue = vec3(0.1, 0.15, 0.15); } - |]) + |] + ) - (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" } + 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 - 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) - - (bufferReleaseKey, (sbtBuffer, sbtAllocation, _sbtAllocationInfo)) <- - withBuffer' - zero { usage = BUFFER_USAGE_SHADER_DEVICE_ADDRESS_BIT, size = sbtSize } +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 + 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 + { requiredFlags = + MEMORY_PROPERTY_HOST_VISIBLE_BIT + .|. MEMORY_PROPERTY_HOST_COHERENT_BIT } - nameObject' sbtBuffer "SBT" + 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 + :: (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 objectInitalPosition n = buf `plusPtr` fromIntegral (size * n) objectFinalPosition n = buf `plusPtr` fromIntegral (desiredStride * n) - moveObject n = moveBytes (objectFinalPosition n) - (objectInitalPosition n) - (fromIntegral size) - -- Move the object last to first + 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 05100e686..5da8e80c3 100644 --- a/examples/rays/Render.hs +++ b/examples/rays/Render.hs @@ -1,271 +1,342 @@ {-# 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 Data.Vector ( (!) ) -import Data.Word -import Foreign.Ptr ( plusPtr ) -import Foreign.Storable -import Frame -import GHC.Clock ( getMonotonicTime ) -import GHC.IO.Exception ( IOErrorType(TimeExpired) - , IOException(IOError) - ) -import HasVulkan -import Linear.Matrix -import Linear.Quaternion -import Linear.V3 -import MonadFrame -import MonadVulkan -import Swapchain -import UnliftIO.Exception ( throwString ) -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.Extensions.VK_KHR_ray_tracing_pipeline -import Vulkan.Extensions.VK_KHR_swapchain - as Swap -import Vulkan.Zero -import InstrumentDecs ( withSpan_ ) +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 + ) -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 + 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 - -- 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' - [ SomeStruct zero - { dstSet = fDescriptorSet - , dstBinding = 1 - , descriptorType = DESCRIPTOR_TYPE_STORAGE_IMAGE - , descriptorCount = 1 - , imageInfo = [ DescriptorImageInfo - { sampler = NULL_HANDLE - , imageView = srImageViews ! fromIntegral imageIndex - , imageLayout = IMAGE_LAYOUT_GENERAL - } - ] - } - , SomeStruct zero -- TODO, only set this once - { dstSet = fDescriptorSet - , dstBinding = 3 - , descriptorType = DESCRIPTOR_TYPE_UNIFORM_BUFFER - , descriptorCount = 1 - , bufferInfo = [ DescriptorBufferInfo - { buffer = fCameraMatricesBuffer - , offset = fCameraMatricesOffset - , range = fromIntegral - (sizeOf (undefined :: CameraMatrices)) - } - ] - } + -- 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)) + } + ] + } ] [] + -- 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 - (fCameraMatricesBufferData `plusPtr` fromIntegral fCameraMatricesOffset) - cameraMats - withSpan_ "flush" $ flushAllocation' - fCameraMatricesAllocation - fCameraMatricesOffset + liftIO $ + poke + (rsCameraMatricesBufferData rs `plusPtr` fromIntegral cameraMatricesOffset) + cameraMats + 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 - ] + useCommandBuffer + commandBuffer + zero{CommandBufferBeginInfo.flags = COMMAND_BUFFER_USAGE_ONE_TIME_SUBMIT_BIT} + $ recordCommandBuffer + 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] - } - :& () - graphicsQueue <- getGraphicsQueue + ::& zero + { waitSemaphoreValues = [1] + , signalSemaphoreValues = [1, fIndex f] + } + :& () + liftIO $ + queueSubmitFrame + gQ + f + [SomeStruct submitInfo] + (fHostTimeline f) + (fIndex f) - withSpan_ "submit" $ finalQueueSubmitFrame [SomeStruct submitInfo] + presentResult <- + queuePresentKHR + gQ + zero + { Swap.waitSemaphores = [rrRenderFinished] + , swapchains = [sSwapchain sc] + , imageIndices = [imageIndex] + } - -- 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] - , 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 - imageSubresourceRange = ImageSubresourceRange - { aspectMask = IMAGE_ASPECT_COLOR_BIT - , baseMipLevel = 0 - , levelCount = 1 +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 + , levelCount = 1 , baseArrayLayer = 0 - , layerCount = 1 + , layerCount = 1 } - numRayGenShaderGroups = 1 - rayGenRegion = StridedDeviceAddressRegionKHR - { deviceAddress = fShaderBindingTableAddress - , stride = fromIntegral rtiShaderGroupBaseAlignment - , size = fromIntegral rtiShaderGroupBaseAlignment - * numRayGenShaderGroups + numRayGenShaderGroups = 1 + rayGenRegion = + StridedDeviceAddressRegionKHR + { deviceAddress = rsShaderBindingTableAddress rs + , stride = fromIntegral rtiShaderGroupBaseAlignment + , size = + fromIntegral rtiShaderGroupBaseAlignment + * numRayGenShaderGroups } - numHitShaderGroups = 1 - hitRegion = StridedDeviceAddressRegionKHR - { deviceAddress = fShaderBindingTableAddress - + (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 = fShaderBindingTableAddress - + (2 * fromIntegral rtiShaderGroupBaseAlignment) + numMissShaderGroups = 1 + missRegion = + StridedDeviceAddressRegionKHR + { 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 - } - ] + callableRegion = zero - -- 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 + } + ] - 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)) - } - ] - [] + cmdBindPipeline commandBuffer PIPELINE_BIND_POINT_RAY_TRACING_KHR (rsPipeline rs) + cmdBindDescriptorSets + commandBuffer + PIPELINE_BIND_POINT_RAY_TRACING_KHR + (rsPipelineLayout rs) + 0 + [descriptorSet] + [] + + 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 ---------------------------------------------------------------- -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 2c9e02825..0df395da8 100644 --- a/examples/rays/Scene.hs +++ b/examples/rays/Scene.hs @@ -1,94 +1,107 @@ -{-# 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 MonadVulkan -import System.Random -import Vulkan.Core10 -import Vulkan.Extensions.VK_KHR_acceleration_structure -import Vulkan.Zero -import VulkanMemoryAllocator +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 + ) 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 :: V SceneBuffers -makeSceneBuffers = do - sceneAabbs <- initBuffer - ( BUFFER_USAGE_ACCELERATION_STRUCTURE_BUILD_INPUT_READ_ONLY_BIT_KHR - .|. BUFFER_USAGE_SHADER_DEVICE_ADDRESS_BIT - ) - (sphereAABB <$> scene) +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) - pure SceneBuffers { .. } + pure SceneBuffers{..} ---------------------------------------------------------------- -- 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' - zero { flags = zero, size = fromIntegral bufferSize, usage } - zero - { requiredFlags = MEMORY_PROPERTY_HOST_VISIBLE_BIT - .|. MEMORY_PROPERTY_HOST_COHERENT_BIT - } - (unmapKey, p) <- withMappedMemory' allocation + (_, (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 @@ -99,10 +112,10 @@ initBuffer 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 @@ -112,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/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..81fa5a21b 100644 --- a/examples/resize/Init.hs +++ b/examples/resize/Init.hs @@ -1,170 +1,36 @@ -{-# 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.Bits -import Data.Text ( Text ) -import qualified Data.Vector as V -import Data.Word -import UnliftIO.Exception +import Control.Monad.Trans.Resource +import Data.Word -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 ( physicalDeviceName - , pickPhysicalDevice - ) -import Vulkan.Zero -import VulkanMemoryAllocator ( Allocator - , AllocatorCreateInfo(..) - , VulkanFunctions(..) - , withAllocator - ) - -import Foreign.Ptr ( castFunPtr ) -import Vulkan.Dynamic ( DeviceCmds - ( DeviceCmds - , pVkGetDeviceProcAddr - ) - , InstanceCmds - ( InstanceCmds - , pVkGetInstanceProcAddr - ) - ) +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) 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] - } - ] - , enabledExtensionNames = [KHR_SWAPCHAIN_EXTENSION_NAME] - } - (_, dev) <- withDevice phys deviceCreateInfo Nothing allocate - 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 -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) + :: (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 df8f593e5..1e3de2d51 100644 --- a/examples/resize/Julia.hs +++ b/examples/resize/Julia.hs @@ -1,106 +1,164 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE CPP #-} +{-# 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. +-} 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 Vulkan.CStruct.Extends -import Vulkan.Core10 -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) - ] - } - let pipelineCreateInfo :: ComputePipelineCreateInfo '[] - pipelineCreateInfo = zero { layout = pipelineLayout - , stage = shader - , basePipelineHandle = zero - } - (_, (_, [computePipeline])) <- withComputePipelines' - zero - [SomeStruct pipelineCreateInfo] - 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 - } - ] + ) where + +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 Julia.Constants + +data JuliaPipeline = JuliaPipeline + { jpPipeline :: Pipeline + , jpPipelineLayout :: PipelineLayout + , jpDescriptorSetLayout :: DescriptorSetLayout } -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' - (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 - } - ] +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) + ] } - ) - descriptorSets - imageViews + 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 + } + +{- | 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 + , 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 :: V (ReleaseKey, SomeStruct PipelineShaderStageCreateInfo) -juliaShader = do - let compCode = $(compileShaderQ (Just "vulkan1.0") "comp" Nothing [glsl| +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 +211,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) @@ -191,10 +230,13 @@ juliaShader = do res /= float(num_samples); imageStore(img, ivec2(gl_GlobalInvocationID.xy), vec4(res, 1)); } - |]) - (releaseKey, compModule) <- withShaderModule' zero { code = compCode } - 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 df763c1c2..c195060cc 100644 --- a/examples/resize/Main.hs +++ b/examples/resize/Main.hs @@ -1,420 +1,451 @@ -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} module Main ( main ) where -import Control.Exception ( handle ) -import Control.Lens.Getter -import Control.Monad.Extra ( unlessM - , when - ) -import Control.Monad.IO.Class -import Control.Monad.Trans.Resource -import Data.Bool ( bool ) -import qualified Data.Vector as V -import GHC.Clock ( getMonotonicTimeNSec ) -import Linear.Affine ( Point(..) ) -import Linear.Metric ( norm ) -import Linear.V2 +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 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 Say -import UnliftIO.Exception ( displayException - , throwIO - , throwString - ) -import UnliftIO.Foreign ( allocaBytes - , plusPtr - , poke - ) -import UnliftIO.IORef -import UnliftIO.MVar -import Utils - -import Vulkan.CStruct.Extends ( SomeStruct(..) ) -import Vulkan.Core10 as Vk - hiding ( createDevice - , createFramebuffer - , createImageView - , createInstance - , withBuffer - , withImage - ) -import qualified Vulkan.Core10 as CommandBufferBeginInfo (CommandBufferBeginInfo(..)) -import qualified Vulkan.Core10 as CommandPoolCreateInfo (CommandPoolCreateInfo(..)) -import Vulkan.Exception -import Vulkan.Extensions.VK_KHR_surface -import Vulkan.Extensions.VK_KHR_swapchain -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 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 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 withSDL - let initWidth = 1280 - initHeight = 720 - - -- Create everything up to the device - sdlWindow <- createWindow "Haskell ❤️ Vulkan" initWidth initHeight - inst <- Init.withInstance - sdlWindow - (Just zero { applicationName = Nothing, apiVersion = myApiVersion }) - [] - [] - 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 - - 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 + 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 + (phys, dev, qs) <- withDevice inst surface 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 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 +---------------------------------------------------------------- +-- Per-swapchain bindings +---------------------------------------------------------------- - frameResources <- allocate createInternalState closeInternalState - fences <- newIORef mempty +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. + (framebuffers, fbRel) <- + Framebuffer.createFramebuffers dev renderPass (sImageViews sc) (sExtent sc) + + -- 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 - (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 - } - --- | Submit GPU commands for a frame -draw :: F (Fence, ()) -draw = do - Frame {..} <- askFrame + 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 - { aspectMask = IMAGE_ASPECT_COLOR_BIT - , baseMipLevel = 0 - , levelCount = 1 +---------------------------------------------------------------- +-- Per-frame rendering +---------------------------------------------------------------- + +renderJulia + :: VkResources + -> JuliaPipeline + -> Bindings + -> 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 , baseArrayLayer = 0 - , layerCount = 1 + , 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 - 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' PIPELINE_BIND_POINT_COMPUTE fJuliaPipeline - - -- Get the mouse position in the window (in [-1..1]) and send it as a - -- push constant. - 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' fJuliaPipelineLayout - SHADER_STAGE_COMPUTE_BIT - 0 - constantBytes - p - cmdBindDescriptorSets' PIPELINE_BIND_POINT_COMPUTE - fJuliaPipelineLayout - 0 - [fJuliaDescriptorSets imageIndex] - [] - cmdDispatch' - ((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 - -- 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 - } - ] - else do - let renderPassBeginInfo = zero - { renderPass = fRenderPass - , framebuffer = fFramebuffers imageIndex - , renderArea = Rect2D zero fImageExtent + (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) , clearValues = [Color (Float32 0.1 0.1 0.1 1)] } - cmdSetViewport' - 0 - [ Viewport { x = 0 - , y = 0 - , width = realToFrac imageWidth - , height = realToFrac imageHeight - , minDepth = 0 - , 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] + 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] } - 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'. - case (acquireResult, presentResult) of - (SUBOPTIMAL_KHR, _) -> throwIO (VulkanException ERROR_OUT_OF_DATE_KHR) - (_, SUBOPTIMAL_KHR) -> throwIO (VulkanException ERROR_OUT_OF_DATE_KHR) - _ -> pure () - pure (renderFence, ()) + 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 +-- Frame timing ---------------------------------------------------------------- --- | 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 +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 <> "%") 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..ec47dc8e6 100644 --- a/examples/resize/Pipeline.hs +++ b/examples/resize/Pipeline.hs @@ -1,132 +1,164 @@ -{-# 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 qualified Data.Vector as V -import Data.Foldable ( traverse_ ) - -import Vulkan.CStruct.Extends -import Vulkan.Core10 as Vk - hiding ( withBuffer - , withImage - ) -import Vulkan.Utils.ShaderQQ.GLSL.Glslang -import Vulkan.Zero +import Control.Monad.Trans.Resource +import Data.Bits +import Data.Foldable (traverse_) +import qualified Data.Vector as V -import MonadVulkan +import Vulkan.CStruct.Extends +import Vulkan.Core10 as Vk hiding + ( withBuffer + , withImage + ) +import Vulkan.Utils.ShaderQQ.GLSL.Glslang +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 +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' - zero - [SomeStruct pipelineCreateInfo] + 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 +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 - } - ] - } + 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] - } + 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 - let fragCode = [frag| + :: (MonadResource m) + => Device + -> m (V.Vector (ReleaseKey, SomeStruct PipelineShaderStageCreateInfo)) +createShaders dev = do + let + fragCode = + [frag| #version 450 #extension GL_ARB_separate_shader_objects : enable @@ -138,7 +170,8 @@ createShaders = do outColor = vec4(fragColor, 1.0); } |] - vertCode = [vert| + vertCode = + [vert| #version 450 #extension GL_ARB_separate_shader_objects : enable @@ -160,16 +193,21 @@ createShaders = do fragColor = colors[gl_VertexIndex]; } |] - (fragKey, fragModule) <- withShaderModule' zero { code = fragCode } - (vertKey, vertModule) <- withShaderModule' zero { code = vertCode } - 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/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..d49daca9b 100644 --- a/examples/triangle-glfw/Main.hs +++ b/examples/triangle-glfw/Main.hs @@ -1,242 +1,60 @@ {-# LANGUAGE OverloadedLists #-} -{-# OPTIONS_GHC -Wno-name-shadowing #-} 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 qualified Data.Text as Text +import Data.Text.Encoding (decodeUtf8) +import Frame + ( frameDeviceRequirements + , frameInstanceRequirements + ) +import InitDevice (withDevice) 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 Swapchain (allocSwapchain) +import qualified Triangle +import VkResources (mkVkResources) +import qualified Vma +import Vulkan.Core10 hiding (withDevice) 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 qualified Triangle -import Window ( VulkanWindow(..) ) -import qualified Window.GLFW as Window +import Vulkan.Zero (zero) +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 - (Just zero{applicationName = Just appName, apiVersion = API_VERSION_1_0}) - [] - [] + 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 - (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 - -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 - ) - -pickGraphicalPhysicalDevice - :: Instance - -> SurfaceKHR - -> SurfaceFormatKHR - -> ResourceT - IO - ( PhysicalDevice - , Word32 - , Word32 - , SurfaceFormatKHR - , PresentModeKHR - , SurfaceCapabilitiesKHR - , Queue - , Queue - , Device - ) -pickGraphicalPhysicalDevice inst surface desiredFormat = 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 - 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 ] - dev <- createDeviceFromRequirements deviceReqs [] phys - zero{queueCreateInfos = SomeStruct <$> qInfos} - Identity (QueueFamilyIndex familyIdx, queue) <- liftIO (getQs dev) - pure - ( phys - , familyIdx - , familyIdx - , bestFormat - , presentMode - , surfaceCaps - , queue - , queue - , dev - ) - where - suitable :: PhysicalDevice -> ResourceT IO (Maybe Word64) - suitable phys = runMaybeT $ do - (_, exts) <- enumerateDeviceExtensionProperties phys Nothing - guard (V.any ((KHR_SWAPCHAIN_EXTENSION_NAME ==) . extensionName) exts) - qProps <- getPhysicalDeviceQueueFamilyProperties phys - guard (V.any isGraphicsQueueFamily qProps) - let presentSupport i = - isPresentQueueFamily phys surface (QueueFamilyIndex (fromIntegral i)) - hasPresent <- V.or <$> V.imapM (\i _ -> presentSupport i) qProps - guard hasPresent - heaps <- memoryHeaps <$> getPhysicalDeviceMemoryProperties phys - pure (sum $ DI.size <$> heaps) + ++ frameDeviceRequirements + (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) + + vr <- liftIO $ mkVkResources inst phys dev vma qs - headMay = \case - [] -> Nothing - xs -> Just (V.unsafeHead xs) + initialSize <- Window.drawableSize window + initialSC <- allocSwapchain vr NULL_HANDLE initialSize surface - 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 + liftIO $ Window.showWindow window + Triangle.runTriangle vr initialSC (Window.drawableSize window) (Window.shouldQuit window) - 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 +appName :: (IsString a) => a +appName = "Haskell Vulkan triangle example (GLFW)" + +windowWidth, windowHeight :: Int +windowWidth = 800 +windowHeight = 600 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..bd17969b5 100644 --- a/examples/triangle-sdl2/Main.hs +++ b/examples/triangle-sdl2/Main.hs @@ -1,246 +1,59 @@ {-# LANGUAGE OverloadedLists #-} -{-# OPTIONS_GHC -Wno-name-shadowing #-} 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 qualified SDL +import Data.Text.Encoding (decodeUtf8) +import Frame + ( frameDeviceRequirements + , frameInstanceRequirements + ) +import InitDevice (withDevice) 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 Swapchain (allocSwapchain) +import qualified Triangle +import VkResources (mkVkResources) +import qualified Vma +import Vulkan.Core10 hiding (withDevice) 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 Triangle -import Window ( VulkanWindow(..) ) -import qualified Window.SDL2 as Window +import Vulkan.Zero (zero) +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 - (Just zero{applicationName = Just appName, apiVersion = API_VERSION_1_0}) - [] - [] + 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 - (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 - -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 - ) - -pickGraphicalPhysicalDevice - :: Instance - -> SurfaceKHR - -> SurfaceFormatKHR - -> ResourceT - IO - ( PhysicalDevice - , Word32 - , Word32 - , SurfaceFormatKHR - , PresentModeKHR - , SurfaceCapabilitiesKHR - , Queue - , Queue - , Device - ) -pickGraphicalPhysicalDevice inst surface desiredFormat = 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. - 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 ] - dev <- createDeviceFromRequirements deviceReqs [] phys - zero{queueCreateInfos = SomeStruct <$> qInfos} - Identity (QueueFamilyIndex familyIdx, queue) <- liftIO (getQs dev) - pure - ( phys - , familyIdx - , familyIdx - , bestFormat - , presentMode - , surfaceCaps - , queue - , queue - , dev - ) - where - suitable :: PhysicalDevice -> ResourceT IO (Maybe Word64) - suitable phys = runMaybeT $ do - (_, exts) <- enumerateDeviceExtensionProperties phys Nothing - guard (V.any ((KHR_SWAPCHAIN_EXTENSION_NAME ==) . extensionName) exts) - qProps <- getPhysicalDeviceQueueFamilyProperties phys - guard (V.any isGraphicsQueueFamily qProps) - let presentSupport i = - isPresentQueueFamily phys surface (QueueFamilyIndex (fromIntegral i)) - hasPresent <- V.or <$> V.imapM (\i _ -> presentSupport i) qProps - guard hasPresent - heaps <- memoryHeaps <$> getPhysicalDeviceMemoryProperties phys - pure (sum $ DI.size <$> heaps) + ++ frameDeviceRequirements + (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) + + vr <- liftIO $ mkVkResources inst phys dev vma qs - headMay = \case - [] -> Nothing - xs -> Just (V.unsafeHead xs) + initialSize <- Window.drawableSize window + initialSC <- allocSwapchain vr NULL_HANDLE initialSize surface - 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 + Window.showWindow window + Triangle.runTriangle vr initialSC (Window.drawableSize window) (Window.shouldQuit Window.NoLimit) - -- 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 +appName :: (IsString a) => a +appName = "Haskell Vulkan triangle example" + +windowWidth, windowHeight :: Int +windowWidth = 800 +windowHeight = 600 diff --git a/examples/vulkan-examples.cabal b/examples/vulkan-examples.cabal index 2b602748f..d731e3328 100644 --- a/examples/vulkan-examples.cabal +++ b/examples/vulkan-examples.cabal @@ -43,17 +43,17 @@ flag vr library exposed-modules: - AutoApply Camera + Frame Framebuffer - HasVulkan - InstrumentDecs + InitDevice Orphans RefCounted Swapchain Triangle Utils - Window + VkResources + Vma Window.GLFW Window.SDL2 other-modules: @@ -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 @@ -235,20 +230,18 @@ 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 , 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 @@ -363,19 +352,16 @@ 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 , 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: @@ -753,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