diff --git a/.gitignore b/.gitignore index 062cf7404..3bacb5456 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,7 @@ +triangle.png +julia.png + +stack.yaml.lock dist dist-* cabal-dev diff --git a/cabal.project b/cabal.project index 26cc0009d..dee63d1c1 100644 --- a/cabal.project +++ b/cabal.project @@ -3,6 +3,8 @@ packages: ./openxr ./VulkanMemoryAllocator ./utils + ./utils-init/vulkan-init-sdl2 + ./utils-init/vulkan-init-glfw ./examples ./generate-new/ diff --git a/default.nix b/default.nix index efcfffe0d..0f25677ac 100644 --- a/default.nix +++ b/default.nix @@ -21,7 +21,7 @@ let (pkgs.haskell.lib.dontCheck vulkan) (pkgs.haskell.lib.dontCheck VulkanMemoryAllocator) ] else - [ vulkan vulkan-utils VulkanMemoryAllocator vulkan-examples openxr ] + [ vulkan vulkan-utils vulkan-init-sdl2 vulkan-init-glfw VulkanMemoryAllocator vulkan-examples openxr ] ++ pkgs.lib.optional (p.ghc.version == generator-ghc-version) generate-new; in if forShell then diff --git a/examples/compute/Main.hs b/examples/compute/Main.hs index 1e1157b9a..9316ff21b 100644 --- a/examples/compute/Main.hs +++ b/examples/compute/Main.hs @@ -14,18 +14,11 @@ import AutoApply import qualified Codec.Picture as JP import Control.Exception.Safe import Control.Monad.IO.Class -import Control.Monad.Trans.Maybe ( MaybeT(..) ) import Control.Monad.Trans.Reader import Control.Monad.Trans.Resource import Data.Bits import qualified Data.ByteString.Lazy as BSL -import Data.Foldable -import Data.List ( partition ) -import Data.Maybe ( catMaybes ) -import Data.Ord ( comparing ) -import Data.Text ( Text ) -import qualified Data.Text as T -import Data.Text.Encoding ( decodeUtf8 ) +import Data.Functor.Identity ( Identity(..) ) import qualified Data.Vector as V import Data.Word import Foreign.Marshal.Array ( peekArray ) @@ -55,8 +48,18 @@ import Vulkan.Dynamic ( DeviceCmds ) ) import Vulkan.Extensions.VK_EXT_debug_utils -import Vulkan.Extensions.VK_EXT_validation_features -import Vulkan.Utils.Debug +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 @@ -146,7 +149,6 @@ autoapplyDecs , 'withCommandPool , 'withFence , 'withComputePipelines - , 'withInstance , 'withPipelineLayout , 'withShaderModule , 'withDescriptorPool @@ -405,31 +407,22 @@ createShader = do myApiVersion :: Word32 myApiVersion = API_VERSION_1_0 --- | Create an instance with a debug messenger +-- | Create an instance with a debug messenger and validation layer. createInstance :: MonadResource m => m Instance createInstance = do - availableExtensionNames <- - toList - . fmap extensionName - . snd - <$> enumerateInstanceExtensionProperties Nothing - availableLayerNames <- - toList . fmap layerName . snd <$> enumerateInstanceLayerProperties - - let requiredLayers = [] - optionalLayers = ["VK_LAYER_KHRONOS_validation"] - requiredExtensions = [EXT_DEBUG_UTILS_EXTENSION_NAME] - optionalExtensions = [EXT_VALIDATION_FEATURES_EXTENSION_NAME] - - extensions <- partitionOptReq "extension" - availableExtensionNames - optionalExtensions - requiredExtensions - layers <- partitionOptReq "layer" - availableLayerNames - optionalLayers - requiredLayers - + 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 @@ -438,20 +431,6 @@ createInstance = do .|. DEBUG_UTILS_MESSAGE_TYPE_PERFORMANCE_BIT_EXT , pfnUserCallback = debugCallbackPtr } - instanceCreateInfo = - zero - { applicationInfo = Just zero { applicationName = Nothing - , apiVersion = myApiVersion - } - , enabledLayerNames = V.fromList layers - , enabledExtensionNames = V.fromList extensions - } - ::& debugMessengerCreateInfo - :& ValidationFeaturesEXT - [VALIDATION_FEATURE_ENABLE_BEST_PRACTICES_EXT] - [] - :& () - (_, inst) <- withInstance' instanceCreateInfo _ <- withDebugUtilsMessengerEXT inst debugMessengerCreateInfo Nothing allocate pure inst @@ -460,89 +439,38 @@ createDevice => Instance -> m (PhysicalDevice, PhysicalDeviceInfo, Device) createDevice inst = do - (pdi, phys) <- pickPhysicalDevice inst physicalDeviceInfo + mPd <- pickPhysicalDevice inst hasComputeQueue id + (_, phys) <- maybe (throwString "Unable to find appropriate PhysicalDevice") + pure + mPd sayErr . ("Using device: " <>) =<< physicalDeviceName phys - let deviceCreateInfo = zero - { queueCreateInfos = - [ SomeStruct zero { queueFamilyIndex = pdiComputeQueueFamilyIndex pdi - , queuePriorities = [1] - } - ] - } - - (_, dev) <- withDevice phys deviceCreateInfo Nothing allocate - pure (phys, pdi, dev) - ----------------------------------------------------------------- --- Physical device tools ----------------------------------------------------------------- - --- | Get a single PhysicalDevice deciding with a scoring function -pickPhysicalDevice - :: (MonadIO m, MonadThrow m, Ord a) - => Instance - -> (PhysicalDevice -> m (Maybe a)) - -- ^ Some "score" for a PhysicalDevice, Nothing if it is not to be chosen. - -> m (a, PhysicalDevice) -pickPhysicalDevice inst devScore = do - (_, devs) <- enumeratePhysicalDevices inst - scores <- catMaybes - <$> sequence [ fmap (, d) <$> devScore d | d <- toList devs ] - case scores of - [] -> throwString "Unable to find appropriate PhysicalDevice" - _ -> pure (maximumBy (comparing fst) scores) - --- | The Ord instance prioritises devices with more memory -data PhysicalDeviceInfo = PhysicalDeviceInfo - { pdiTotalMemory :: Word64 - , pdiComputeQueueFamilyIndex :: Word32 + 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) -physicalDeviceInfo - :: MonadIO m => PhysicalDevice -> m (Maybe PhysicalDeviceInfo) -physicalDeviceInfo phys = runMaybeT $ do - pdiTotalMemory <- do - heaps <- memoryHeaps <$> getPhysicalDeviceMemoryProperties phys - pure $ sum (DI.size <$> heaps) - pdiComputeQueueFamilyIndex <- do - queueFamilyProperties <- getPhysicalDeviceQueueFamilyProperties phys - let isComputeQueue q = - (QUEUE_COMPUTE_BIT .&&. queueFlags q) && (queueCount q > 0) - computeQueueIndices = fromIntegral . fst <$> V.filter - (isComputeQueue . snd) - (V.indexed queueFamilyProperties) - MaybeT (pure $ computeQueueIndices V.!? 0) - pure PhysicalDeviceInfo { .. } - -physicalDeviceName :: MonadIO m => PhysicalDevice -> m Text -physicalDeviceName phys = do - props <- getPhysicalDeviceProperties phys - pure $ decodeUtf8 (deviceName props) - ----------------------------------------------------------------- --- Utils ----------------------------------------------------------------- - -partitionOptReq - :: (Show a, Eq a, MonadIO m) => Text -> [a] -> [a] -> [a] -> m [a] -partitionOptReq type' available optional required = do - let (optHave, optMissing) = partition (`elem` available) optional - (reqHave, reqMissing) = partition (`elem` available) required - tShow = T.pack . show - for_ optMissing - $ \n -> sayErr $ "Missing optional " <> type' <> ": " <> tShow n - case reqMissing of - [] -> pure () - [x] -> sayErr $ "Missing required " <> type' <> ": " <> tShow x - xs -> sayErr $ "Missing required " <> type' <> "s: " <> tShow xs - pure (reqHave <> optHave) - ----------------------------------------------------------------- --- Bit utils ----------------------------------------------------------------- - -(.&&.) :: Bits a => a -> a -> Bool -x .&&. y = (/= zeroBits) (x .&. y) diff --git a/examples/hie.yaml b/examples/hie.yaml index e68a30dc0..0ba292af9 100644 --- a/examples/hie.yaml +++ b/examples/hie.yaml @@ -6,11 +6,14 @@ cradle: - path: "./info/" component: "exe:info" - - path: "./sdl-triangle/" - component: "exe:sdl-triangle" + - path: "./triangle-sdl2/" + component: "exe:triangle-sdl2" - - path: "./offscreen/" - component: "exe:offscreen" + - path: "./triangle-glfw/" + component: "exe:triangle-glfw" + + - path: "./triangle-headless/" + component: "exe:triangle-headless" - path: "./compute/" component: "exe:compute" diff --git a/examples/hlsl/Init.hs b/examples/hlsl/Init.hs index 68d6a791b..e89a8ae41 100644 --- a/examples/hlsl/Init.hs +++ b/examples/hlsl/Init.hs @@ -19,7 +19,6 @@ import Vulkan.Core12.Promoted_From_VK_KHR_timeline_semaphore import Vulkan.Extensions.VK_KHR_timeline_semaphore import Control.Applicative -import qualified Data.ByteString as BS import Data.Foldable ( for_ ) import Data.Vector ( Vector ) import GHC.IO.Exception ( IOErrorType(NoSuchThing) @@ -29,7 +28,6 @@ import MonadVulkan ( Queues(..) , checkCommands ) import qualified SDL.Video as SDL -import qualified SDL.Video.Vulkan as SDL import Vulkan.CStruct.Extends import Vulkan.Core10 as Vk hiding ( withBuffer @@ -44,6 +42,7 @@ 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 @@ -53,7 +52,7 @@ import VulkanMemoryAllocator ( Allocator , VulkanFunctions(..) , withAllocator ) -import Window +import Window.SDL2 import Foreign.Ptr (castFunPtr) myApiVersion :: Word32 @@ -63,22 +62,16 @@ myApiVersion = API_VERSION_1_0 -- Instance Creation ---------------------------------------------------------------- --- | Create an instance with a debug messenger createInstance :: MonadResource m => SDL.Window -> m Instance -createInstance win = do - windowExtensions <- - liftIO $ traverse BS.packCString =<< SDL.vkGetInstanceExtensions win - let createInfo = zero - { applicationInfo = Just zero { applicationName = Nothing - , apiVersion = myApiVersion - } - } - reqs = - (\n -> RequireInstanceExtension Nothing n minBound) - <$> ( KHR_GET_PHYSICAL_DEVICE_PROPERTIES_2_EXTENSION_NAME - : windowExtensions - ) - createDebugInstanceFromRequirements reqs [] createInfo +createInstance win = VkInit.withInstance + win + (Just zero { applicationName = Nothing, apiVersion = myApiVersion }) + [ RequireInstanceExtension + Nothing + KHR_GET_PHYSICAL_DEVICE_PROPERTIES_2_EXTENSION_NAME + minBound + ] + [] ---------------------------------------------------------------- -- Device creation diff --git a/examples/hlsl/Main.hs b/examples/hlsl/Main.hs index ace5e7908..e0ba1c7a9 100644 --- a/examples/hlsl/Main.hs +++ b/examples/hlsl/Main.hs @@ -12,7 +12,7 @@ import SDL ( showWindow ) import Swapchain ( threwSwapchainError ) import Utils -import Window +import Window.SDL2 main :: IO () main = runResourceT $ do diff --git a/examples/lib/Swapchain.hs b/examples/lib/Swapchain.hs index 3fbc06a95..8b84e8ea8 100644 --- a/examples/lib/Swapchain.hs +++ b/examples/lib/Swapchain.hs @@ -13,13 +13,13 @@ module Swapchain 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 Data.Ord ( comparing ) import qualified Data.Vector as V import Data.Vector ( Vector ) import Framebuffer @@ -158,7 +158,7 @@ createSwapchain oldSwapchain explicitSize surf = do -- Select a surface format -- getPhysicalDeviceSurfaceFormatsKHR doesn't return an empty list (_, availableFormats) <- getPhysicalDeviceSurfaceFormatsKHR' surf - let surfaceFormat = selectSurfaceFormat availableFormats + surfaceFormat <- selectSurfaceFormat availableFormats -- Calculate the extent let imageExtent = @@ -227,15 +227,21 @@ threwSwapchainError = fmap isLeft . tryJust swapchainError -- Specifications ---------------------------------------------------------------- --- The vector passed will have at least one element -selectSurfaceFormat :: Vector SurfaceFormatKHR -> SurfaceFormatKHR -selectSurfaceFormat = V.maximumBy (comparing surfaceFormatScore) - where - -- An ordered list of formats to choose for the swapchain images, if none - -- match then the first available format will be chosen. - surfaceFormatScore :: SurfaceFormatKHR -> Int - surfaceFormatScore = \case - _ -> 0 +-- The vector passed will have at least one element. Prefer formats whose +-- 'optimalTilingFeatures' satisfy 'requiredFormatFeatures'; SRGB formats +-- typically omit 'FORMAT_FEATURE_STORAGE_IMAGE_BIT' and would otherwise +-- cause @vkCreateSwapchainKHR@ to fail. +selectSurfaceFormat + :: (MonadIO m, HasVulkan m) => Vector SurfaceFormatKHR -> m SurfaceFormatKHR +selectSurfaceFormat fmts = do + phys <- getPhysicalDevice + let suitable f = do + props <- getPhysicalDeviceFormatProperties + phys + (SurfaceFormatKHR.format f) + pure $ all (optimalTilingFeatures props .&&.) requiredFormatFeatures + good <- V.filterM suitable fmts + pure $ if V.null good then V.head fmts else V.head good -- | An ordered list of the present mode to be chosen for the swapchain. desiredPresentModes :: [PresentModeKHR] @@ -249,3 +255,10 @@ desiredPresentModes = 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'. +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 new file mode 100644 index 000000000..a80b5e689 --- /dev/null +++ b/examples/lib/Triangle.hs @@ -0,0 +1,273 @@ +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# 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'. +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 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 Window ( VulkanWindow(..) ) + +-- | Render a static triangle into the swapchain inside the given +-- 'VulkanWindow' until @shouldQuit@ reports 'True'. +runTriangle + :: VulkanWindow w + -> IO Bool -- ^ Per-frame poller; 'True' = exit + -> ResourceT IO () +runTriangle VulkanWindow{..} shouldQuit = do + renderPass <- createRenderPass vwDevice vwFormat + graphicsPipeline <- createGraphicsPipeline vwDevice renderPass vwExtent + framebuffers <- createFramebuffers vwDevice vwImageViews renderPass vwExtent + commandBuffers <- createCommandBuffers vwDevice renderPass graphicsPipeline vwGraphicsQueueFamilyIndex framebuffers vwExtent + (imageAvailableSemaphore, renderFinishedSemaphore) <- createSemaphores vwDevice + liftIO $ mainLoop $ + drawFrame vwDevice vwSwapchain vwGraphicsQueue vwPresentQueue imageAvailableSemaphore renderFinishedSemaphore commandBuffers + deviceWaitIdle vwDevice + where + mainLoop draw = do + quit <- shouldQuit + if quit then pure () else draw >> mainLoop draw + +drawFrame + :: Device + -> SwapchainKHR + -> Queue + -> Queue + -> Semaphore + -> Semaphore + -> V.Vector CommandBuffer + -> IO () +drawFrame dev swapchain graphicsQueue presentQueue imageAvailableSemaphore renderFinishedSemaphore commandBuffers = do + (_, imageIndex) <- acquireNextImageKHR dev swapchain maxBound imageAvailableSemaphore zero + let submitInfo = zero + { waitSemaphores = [imageAvailableSemaphore] + , waitDstStageMask = [PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT] + , commandBuffers = [commandBufferHandle (commandBuffers V.! fromIntegral imageIndex)] + , signalSemaphores = [renderFinishedSemaphore] + } + presentInfo = zero + { waitSemaphores = [renderFinishedSemaphore] + , swapchains = [swapchain] + , imageIndices = [imageIndex] + } + queueSubmit graphicsQueue [SomeStruct submitInfo] zero + _ <- queuePresentKHR presentQueue presentInfo + pure () + +allocate' :: IO a -> (a -> IO ()) -> ResourceT IO a +allocate' c d = snd <$> allocate c d + +createSemaphores :: Device -> ResourceT IO (Semaphore, Semaphore) +createSemaphores dev = do + imageAvailableSemaphore <- withSemaphore dev zero Nothing allocate' + renderFinishedSemaphore <- withSemaphore dev zero Nothing allocate' + pure (imageAvailableSemaphore, renderFinishedSemaphore) + +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 + +createShaders + :: Device -> ResourceT IO (V.Vector (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]; + } + |] + 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" + } + fragShaderStageCreateInfo = zero + { stage = SHADER_STAGE_FRAGMENT_BIT + , module' = fragModule + , name = "main" + } + pure [SomeStruct vertShaderStageCreateInfo, SomeStruct fragShaderStageCreateInfo] + +createRenderPass :: Device -> Format -> ResourceT IO RenderPass +createRenderPass dev swapchainImageFormat = do + let attachmentDescription :: AttachmentDescription + attachmentDescription = zero + { format = swapchainImageFormat + , samples = SAMPLE_COUNT_1_BIT + , loadOp = ATTACHMENT_LOAD_OP_CLEAR + , storeOp = ATTACHMENT_STORE_OP_STORE + , stencilLoadOp = ATTACHMENT_LOAD_OP_DONT_CARE + , stencilStoreOp = ATTACHMENT_STORE_OP_DONT_CARE + , initialLayout = IMAGE_LAYOUT_UNDEFINED + , finalLayout = IMAGE_LAYOUT_PRESENT_SRC_KHR + } + subpass :: SubpassDescription + subpass = zero + { pipelineBindPoint = PIPELINE_BIND_POINT_GRAPHICS + , colorAttachments = + [ zero { attachment = 0, layout = IMAGE_LAYOUT_COLOR_ATTACHMENT_OPTIMAL } ] + } + subpassDependency :: SubpassDependency + subpassDependency = zero + { srcSubpass = SUBPASS_EXTERNAL + , dstSubpass = 0 + , srcStageMask = PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT + , srcAccessMask = zero + , dstStageMask = PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT + , dstAccessMask = ACCESS_COLOR_ATTACHMENT_READ_BIT .|. ACCESS_COLOR_ATTACHMENT_WRITE_BIT + } + withRenderPass dev zero + { attachments = [attachmentDescription] + , subpasses = [subpass] + , dependencies = [subpassDependency] + } Nothing allocate' + +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 + , basePipelineHandle = zero + } + V.head . snd <$> withGraphicsPipelines dev zero [SomeStruct pipelineCreateInfo] Nothing allocate' + +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' diff --git a/examples/lib/Window.hs b/examples/lib/Window.hs index 6b8069aa5..38a4388e5 100644 --- a/examples/lib/Window.hs +++ b/examples/lib/Window.hs @@ -1,90 +1,29 @@ module Window - ( withSDL - , createWindow - , createSurface - , RefreshLimit(..) - , shouldQuit + ( VulkanWindow(..) ) 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 qualified SDL -import qualified SDL.Video.Vulkan as SDL -import Vulkan.Core10 +import Data.Word ( Word32 ) +import qualified Data.Vector as V +import Vulkan.Core10 ( Device + , Extent2D + , Format + , ImageView + , Queue + ) import Vulkan.Extensions.VK_KHR_surface - -withSDL :: MonadResource m => m () -withSDL = void $ allocate_ (SDL.initialize @[] [SDL.InitEvents]) SDL.quit - --- | The caller is responsible to initializing SDL -createWindow - :: MonadResource m - => Text - -- ^ Title - -> Int - -- ^ Width - -> Int - -- ^ Height - -> 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 - } - ) - ) - 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) - ----------------------------------------------------------------- --- SDL helpers ----------------------------------------------------------------- - -data RefreshLimit - = NoLimit - | TimeLimit Int -- ^ Time in ms - | EventLimit -- ^ Indefinite timeout - --- | 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 - --- | Return the SDL events which have become available --- --- Optionally wait for a timeout or forever. -awaitSDLEvents :: MonadIO m => RefreshLimit -> m [SDL.Event] -awaitSDLEvents limit = do - first <- case limit of - NoLimit -> pure Nothing - TimeLimit ms -> SDL.waitEventTimeout (fromIntegral ms) - EventLimit -> Just <$> SDL.waitEvent - next <- SDL.pollEvents - pure $ maybeToList first <> next + ( 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 new file mode 100644 index 000000000..74577bfdc --- /dev/null +++ b/examples/lib/Window/GLFW.hs @@ -0,0 +1,60 @@ +-- | GLFW windowing helpers used by the @glfw@ triangle example. Mirrors +-- the SDL2 helpers in "Window". +module Window.GLFW + ( withGLFW + , createWindow + , showWindow + , 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 + +-- | Initialise GLFW and tear it down with the resource scope. +withGLFW :: MonadResource m => m () +withGLFW = void $ allocate_ initGLFW GLFW.terminate + 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. +createWindow + :: 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) + case mWin of + 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). +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 + pure (closeRequested || qPressed || escPressed) diff --git a/examples/lib/Window/SDL2.hs b/examples/lib/Window/SDL2.hs new file mode 100644 index 000000000..acd0819bd --- /dev/null +++ b/examples/lib/Window/SDL2.hs @@ -0,0 +1,90 @@ +module Window.SDL2 + ( withSDL + , createWindow + , createSurface + , 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 qualified SDL +import qualified SDL.Video.Vulkan as SDL +import Vulkan.Core10 +import Vulkan.Extensions.VK_KHR_surface + +withSDL :: MonadResource m => m () +withSDL = void $ allocate_ (SDL.initialize @[] [SDL.InitEvents]) SDL.quit + +-- | The caller is responsible to initializing SDL +createWindow + :: MonadResource m + => Text + -- ^ Title + -> Int + -- ^ Width + -> Int + -- ^ Height + -> 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 + } + ) + ) + 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) + +---------------------------------------------------------------- +-- SDL helpers +---------------------------------------------------------------- + +data RefreshLimit + = NoLimit + | TimeLimit Int -- ^ Time in ms + | EventLimit -- ^ Indefinite timeout + +-- | 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 + +-- | Return the SDL events which have become available +-- +-- Optionally wait for a timeout or forever. +awaitSDLEvents :: MonadIO m => RefreshLimit -> m [SDL.Event] +awaitSDLEvents limit = do + first <- case limit of + NoLimit -> pure Nothing + TimeLimit ms -> SDL.waitEventTimeout (fromIntegral ms) + EventLimit -> Just <$> SDL.waitEvent + next <- SDL.pollEvents + pure $ maybeToList first <> next diff --git a/examples/package.yaml b/examples/package.yaml index 19f38668d..161602815 100644 --- a/examples/package.yaml +++ b/examples/package.yaml @@ -11,17 +11,6 @@ license: BSD-3-Clause library: source-dirs: lib - exposed-modules: - - AutoApply - - Camera - - Framebuffer - - HasVulkan - - InstrumentDecs - - Orphans - - RefCounted - - Swapchain - - Utils - - Window verbatim: ghc-options: -Wall dependencies: @@ -35,6 +24,7 @@ library: - bytestring - derive-storable >= 0.3 - derive-storable-plugin >= 0.2.3.3 + - GLFW-b - lens - linear - nothunks >= 0.1.2 @@ -58,13 +48,11 @@ executables: - vulkan - pretty-simple >= 3.3 - sdl-triangle: + triangle-sdl2: main: Main.hs - source-dirs: sdl-triangle + source-dirs: triangle-sdl2 dependencies: - base <5 - - bytestring - - extra - resourcet - say - sdl2 @@ -73,11 +61,28 @@ executables: - vector - vulkan - vulkan-examples + - vulkan-init-sdl2 + - vulkan-utils + + triangle-glfw: + main: Main.hs + source-dirs: triangle-glfw + dependencies: + - base <5 + - GLFW-b + - resourcet + - say + - text + - transformers + - vector + - vulkan + - vulkan-examples + - vulkan-init-glfw - vulkan-utils - offscreen: + triangle-headless: main: Main.hs - source-dirs: offscreen + source-dirs: triangle-headless dependencies: - JuicyPixels - VulkanMemoryAllocator @@ -138,6 +143,7 @@ executables: - vector - vulkan - vulkan-examples + - vulkan-init-sdl2 - vulkan-utils timeline-semaphore: @@ -175,6 +181,7 @@ executables: - vector - vulkan - vulkan-examples + - vulkan-init-sdl2 - vulkan-utils >= 0.3 when: - condition: '!flag(have-shaderc)' @@ -209,6 +216,7 @@ executables: - vector - vulkan >= 3.7 - vulkan-examples + - vulkan-init-sdl2 - vulkan-utils >= 0.3 when: - condition: '!flag(raytracing)' diff --git a/examples/rays/Init.hs b/examples/rays/Init.hs index 809ffeea1..3663586a6 100644 --- a/examples/rays/Init.hs +++ b/examples/rays/Init.hs @@ -12,7 +12,6 @@ import Control.Applicative import Control.Monad.IO.Class import Control.Monad.Trans.Maybe ( MaybeT(..) ) import Control.Monad.Trans.Resource -import qualified Data.ByteString as BS import Data.Foldable ( for_ , traverse_ ) @@ -28,7 +27,6 @@ import MonadVulkan ( Queues(..) , checkCommands ) import qualified SDL.Video as SDL -import qualified SDL.Video.Vulkan as SDL import Say import UnliftIO.Exception import Vulkan.CStruct.Extends @@ -52,11 +50,14 @@ import Vulkan.Dynamic ( DeviceCmds , 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 @@ -69,7 +70,7 @@ import VulkanMemoryAllocator ( Allocator , vkGetInstanceProcAddr , withAllocator ) -import Window +import Window.SDL2 import Foreign.Ptr (castFunPtr) myApiVersion :: Word32 @@ -79,22 +80,19 @@ myApiVersion = API_VERSION_1_1 -- Instance Creation ---------------------------------------------------------------- --- | Create an instance with a debug messenger createInstance :: MonadResource m => SDL.Window -> m Instance -createInstance win = do - windowExtensions <- - liftIO $ traverse BS.packCString =<< SDL.vkGetInstanceExtensions win - let createInfo = zero - { applicationInfo = Just zero { applicationName = Nothing - , apiVersion = myApiVersion - } - } - requirements = - (\n -> RequireInstanceExtension Nothing n minBound) - <$> ( KHR_GET_PHYSICAL_DEVICE_PROPERTIES_2_EXTENSION_NAME - : windowExtensions - ) - createInstanceFromRequirements requirements [] createInfo +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 diff --git a/examples/rays/Main.hs b/examples/rays/Main.hs index a7251a1a3..2d716e9da 100644 --- a/examples/rays/Main.hs +++ b/examples/rays/Main.hs @@ -12,7 +12,7 @@ import SDL ( showWindow ) import Swapchain ( threwSwapchainError ) import Utils -import Window +import Window.SDL2 main :: IO () main = runResourceT $ do diff --git a/examples/readme.md b/examples/readme.md index 3fa1dcf6c..40f107510 100644 --- a/examples/readme.md +++ b/examples/readme.md @@ -11,7 +11,7 @@ devices. ### `resize` A nice example of rendering into a window which can be resized. It's not a -single file `triangle` like `sdl-triangle`, but rather builds a couple of nice +single file `triangle` like `triangle-sdl2`, but rather builds a couple of nice abstractions to make the code a little nicer. It renders a Julia set according the mouse position in the window. @@ -46,7 +46,7 @@ functions. An example of using the `VK_KHR_ray_tracing_pipeline` extension. Needs quite a new driver to run! -### `offscreen` +### `triangle-headless` This example: @@ -80,7 +80,7 @@ Like the `resize` example, an internal `AutoApply` module are used to make resource and global management less painful. -### `sdl-triangle` +### `triangle-sdl2` This opens a window using SDL and renders a triangle. @@ -88,6 +88,14 @@ The `managed` package is used for ensuring resources are deallocated. Exit with `q`, `escape` or the window exit button. +### `triangle-glfw` + +This opens a window using GLFW and renders a triangle. + +The `managed` package is used for ensuring resources are deallocated. + +Exit with `q`, `escape` or the window exit button. + ## Building and Running You'll need to have `glslangValidator` in `$PATH` when compiling as shaders are @@ -127,7 +135,7 @@ If you run into ``` error: XDG_RUNTIME_DIR not set in the environment. -sdl-triangle: SDLCallFailed {sdlExceptionCaller = "SDL.Init.init", sdlFunction = "SDL_Init", sdlExceptionError = "No available video device"} +triangle-sdl2: SDLCallFailed {sdlExceptionCaller = "SDL.Init.init", sdlFunction = "SDL_Init", sdlExceptionError = "No available video device"} ``` It's because the pure shell instantiated by `stack --nix` doesn't include the @@ -135,7 +143,7 @@ It's because the pure shell instantiated by `stack --nix` doesn't include the fix this pass the `--no-nix-pure` flag to stack thusly: ```bash -stack --system-ghc --nix --no-nix-pure run sdl-triangle +stack --system-ghc --nix --no-nix-pure run triangle-sdl2 ``` ### Running the examples with SwiftShader @@ -152,11 +160,11 @@ cabal run hlsl ### Troubleshooting -For the examples using SDL (`resize`, `sdl-triangle`): +For the examples using SDL (`resize`, `triangle-sdl2`): - If SDL is unable to find `libvulkan.so`, you can set either `LD_LIBRARY_PATH` or `SDL_VULKAN_LIBRARY`, it must find the same `libvulkan.so` that the - `sdl-triangle` binary was compiled against. + `triangle-sdl2` binary was compiled against. - If you run into the exception `DLCallFailed {sdlExceptionCaller = "SDL.Video.Vulkan.vkLoadLibrary", sdlFunction = "SDL_Vulkan_LoadLibrary", diff --git a/examples/resize/Init.hs b/examples/resize/Init.hs index dc47f2114..466bd223e 100644 --- a/examples/resize/Init.hs +++ b/examples/resize/Init.hs @@ -2,9 +2,9 @@ {-# LANGUAGE OverloadedLists #-} module Init - ( Init.createInstance - , Init.createDevice + ( Init.createDevice , DeviceParams(..) + , myApiVersion , createVMA ) where @@ -13,12 +13,7 @@ import Control.Monad.IO.Class import Control.Monad.Trans.Maybe ( MaybeT(..) ) import Control.Monad.Trans.Resource import Data.Bits -import Data.ByteString ( ByteString ) -import Data.Foldable -import Data.Maybe ( catMaybes ) -import Data.Ord ( comparing ) import Data.Text ( Text ) -import Data.Text.Encoding ( decodeUtf8 ) import qualified Data.Vector as V import Data.Word import UnliftIO.Exception @@ -31,6 +26,9 @@ import Vulkan.Core10 as Vk import qualified Vulkan.Core10 as MemoryHeap (MemoryHeap(..)) import Vulkan.Extensions.VK_KHR_surface import Vulkan.Extensions.VK_KHR_swapchain +import Vulkan.Utils.Initialization ( physicalDeviceName + , pickPhysicalDevice + ) import Vulkan.Zero import VulkanMemoryAllocator ( Allocator , AllocatorCreateInfo(..) @@ -48,29 +46,10 @@ import Vulkan.Dynamic ( DeviceCmds , pVkGetInstanceProcAddr ) ) -import Vulkan.Requirement -import Vulkan.Utils.Initialization ( createDebugInstanceFromRequirements - ) myApiVersion :: Word32 myApiVersion = API_VERSION_1_0 ----------------------------------------------------------------- --- Instance Creation ----------------------------------------------------------------- - --- | Create an instance with a debug messenger and validation -createInstance :: forall m . MonadResource m => [ByteString] -> m Instance -createInstance extraExtensions = do - createDebugInstanceFromRequirements - [ RequireInstanceExtension Nothing n minBound | n <- extraExtensions ] - [] - zero - { applicationInfo = Just zero { applicationName = Nothing - , apiVersion = myApiVersion - } - } - ---------------------------------------------------------------- -- Device Creation ---------------------------------------------------------------- @@ -93,7 +72,7 @@ createDevice inst surf = do -- -- Get a physical device -- - (pdi, phys) <- pickPhysicalDevice inst (physicalDeviceInfo surf) >>= \case + (pdi, phys) <- pickPhysicalDevice inst (physicalDeviceInfo surf) id >>= \case Nothing -> throwString "Unable to find suitable physical device" Just x -> pure x devName <- physicalDeviceName phys @@ -119,21 +98,6 @@ createDevice inst surf = do -- Physical device tools ---------------------------------------------------------------- --- | Get a single PhysicalDevice deciding with a scoring function -pickPhysicalDevice - :: (MonadIO m, MonadThrow m, Ord a) - => Instance - -> (PhysicalDevice -> m (Maybe a)) - -- ^ Some "score" for a PhysicalDevice, Nothing if it is not to be chosen. - -> m (Maybe (a, PhysicalDevice)) - -- ^ Throws if no device could be found -pickPhysicalDevice inst devScore = do - (_, devs) <- enumeratePhysicalDevices inst - scores <- catMaybes - <$> sequence [ fmap (, d) <$> devScore d | d <- toList devs ] - pure - $ if null scores then Nothing else Just $ maximumBy (comparing fst) scores - -- | The Ord instance prioritises devices with more memory data PhysicalDeviceInfo = PhysicalDeviceInfo { pdiTotalMemory :: Word64 @@ -174,12 +138,6 @@ deviceHasSwapchain dev = do (_, extensions) <- enumerateDeviceExtensionProperties dev Nothing pure $ V.any ((KHR_SWAPCHAIN_EXTENSION_NAME ==) . extensionName) extensions -physicalDeviceName :: MonadIO m => PhysicalDevice -> m Text -physicalDeviceName phys = do - props <- getPhysicalDeviceProperties phys - pure $ decodeUtf8 (deviceName props) - - ---------------------------------------------------------------- -- VulkanMemoryAllocator ---------------------------------------------------------------- diff --git a/examples/resize/Main.hs b/examples/resize/Main.hs index f40e4553d..df763c1c2 100644 --- a/examples/resize/Main.hs +++ b/examples/resize/Main.hs @@ -22,6 +22,7 @@ import Linear.V2 import qualified SDL import Say import UnliftIO.Exception ( displayException + , throwIO , throwString ) import UnliftIO.Foreign ( allocaBytes @@ -48,16 +49,15 @@ import Vulkan.Extensions.VK_KHR_surface import Vulkan.Extensions.VK_KHR_swapchain import Vulkan.Zero -import qualified Data.ByteString as BS import Frame import HasVulkan import Init import Julia import MonadVulkan import Pipeline -import qualified SDL.Video.Vulkan as SDL import Swapchain -import Window +import qualified Vulkan.Utils.Init.SDL2 as Init +import Window.SDL2 ---------------------------------------------------------------- -- Main performs some one time initialization of the windowing system and @@ -67,17 +67,18 @@ import Window ---------------------------------------------------------------- main :: IO () main = prettyError . runResourceT $ do - -- Start SDL - _ <- allocate_ (SDL.initialize @[] [SDL.InitEvents]) SDL.quit + withSDL let initWidth = 1280 initHeight = 720 -- Create everything up to the device sdlWindow <- createWindow "Haskell ❤️ Vulkan" initWidth initHeight - windowExts <- - liftIO $ traverse BS.packCString =<< SDL.vkGetInstanceExtensions sdlWindow - inst <- createInstance windowExts + inst <- Init.withInstance + sdlWindow + (Just zero { applicationName = Nothing, apiVersion = myApiVersion }) + [] + [] surface <- createSurface inst sdlWindow DeviceParams devName phys dev graphicsQueue graphicsQueueFamilyIndex <- createDevice inst (snd surface) @@ -230,9 +231,10 @@ draw :: F (Fence, ()) draw = do Frame {..} <- askFrame - imageIndex <- + (acquireResult, imageIndex) <- acquireNextImageKHR' fSwapchain 1e9 fImageAvailableSemaphore zero >>= \case - (SUCCESS, imageIndex) -> pure imageIndex + r@(SUCCESS, _) -> pure r + r@(SUBOPTIMAL_KHR, _) -> pure r (TIMEOUT, _) -> throwString "Couldn't acquire next image after 1 second" _ -> throwString "Unexpected Result from acquireNextImageKHR" @@ -389,7 +391,16 @@ draw = do , swapchains = [fSwapchain] , imageIndices = [imageIndex] } - _ <- queuePresentKHR graphicsQueue presentInfo + 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, ()) diff --git a/examples/resize/Swapchain.hs b/examples/resize/Swapchain.hs index 4d0238c60..4bc3519c4 100644 --- a/examples/resize/Swapchain.hs +++ b/examples/resize/Swapchain.hs @@ -30,6 +30,7 @@ import Vulkan.Zero import Frame import Framebuffer +import HasVulkan ( getPhysicalDevice ) import MonadVulkan import Pipeline @@ -63,11 +64,16 @@ createSwapchain oldSwapchain explicitSize surf = do sayErrString $ "Using present mode " <> show presentMode (_, availableFormats) <- getPhysicalDeviceSurfaceFormatsKHR' surf - let desiredFormats = [] - surfaceFormat = case filter (`V.elem` availableFormats) desiredFormats of - -- Use the first available format if we don't have our desired one - [] -> V.head availableFormats - x : _ -> x + -- 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 = @@ -187,3 +193,7 @@ allocSwapchainResources windowSize oldSwapchain surface = do 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/sdl-triangle/Main.hs b/examples/sdl-triangle/Main.hs deleted file mode 100644 index 8cd600971..000000000 --- a/examples/sdl-triangle/Main.hs +++ /dev/null @@ -1,684 +0,0 @@ -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE QuasiQuotes #-} -{-# OPTIONS_GHC -Wno-name-shadowing #-} - -module Main where - -import Control.Monad -import Control.Monad.Extra -import Control.Monad.IO.Class -import Control.Monad.Trans.Maybe -import Control.Monad.Trans.Resource -import Data.Bits -import qualified Data.ByteString as BS -import Data.List (nub) -import Data.Ord -import Data.String (IsString) -import Data.Text.Encoding -import Data.Traversable -import qualified Data.Vector as V -import Data.Word -import qualified SDL -import qualified SDL.Video.Vulkan as SDL -import Say -import System.Exit -import Vulkan.CStruct.Extends -import Vulkan.Core10 -import qualified Vulkan.Core10 as CommandBufferBeginInfo (CommandBufferBeginInfo (..)) -import qualified Vulkan.Core10 as CommandPoolCreateInfo (CommandPoolCreateInfo (..)) -import qualified Vulkan.Core10.DeviceInitialization as DI -import Vulkan.Extensions.VK_EXT_debug_utils -import Vulkan.Extensions.VK_KHR_portability_enumeration -import Vulkan.Extensions.VK_KHR_surface -import qualified Vulkan.Extensions.VK_KHR_surface as SF -import Vulkan.Extensions.VK_KHR_swapchain -import qualified Vulkan.Extensions.VK_KHR_swapchain as SW -import Vulkan.Requirement (InstanceRequirement (..)) -import Vulkan.Utils.Debug -import Vulkan.Utils.Initialization (createDebugInstanceFromRequirements) -import Vulkan.Utils.ShaderQQ.GLSL.Glslang - ( frag - , vert - ) -import Vulkan.Zero -import qualified Window - -main :: IO () -main = runResourceT $ do - Window.withSDL - - VulkanWindow{..} <- withVulkanWindow windowWidth windowHeight - renderPass <- Main.createRenderPass vwDevice vwFormat - graphicsPipeline <- - createGraphicsPipeline - vwDevice - renderPass - vwExtent - vwFormat - framebuffers <- createFramebuffers vwDevice vwImageViews renderPass vwExtent - commandBuffers <- - createCommandBuffers - vwDevice - renderPass - graphicsPipeline - vwGraphicsQueueFamilyIndex - framebuffers - vwExtent - (imageAvailableSemaphore, renderFinishedSemaphore) <- - createSemaphores - vwDevice - SDL.showWindow vwSdlWindow - liftIO $ - mainLoop $ - drawFrame - vwDevice - vwSwapchain - vwGraphicsQueue - vwPresentQueue - imageAvailableSemaphore - renderFinishedSemaphore - commandBuffers - deviceWaitIdle vwDevice - -mainLoop :: IO () -> IO () -mainLoop draw = whileM $ do - quit <- Window.shouldQuit Window.NoLimit - if quit - then pure False - else do - draw - pure True - -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 () - -createSemaphores :: Device -> ResourceT IO (Semaphore, Semaphore) -createSemaphores dev = do - imageAvailableSemaphore <- withSemaphore dev zero Nothing allocate' - renderFinishedSemaphore <- withSemaphore dev zero Nothing allocate' - pure (imageAvailableSemaphore, renderFinishedSemaphore) - -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 :: CommandBufferAllocateInfo - 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 . for (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 - -createShaders - :: Device -> ResourceT IO (V.Vector (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]; - } - |] - 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" - } - fragShaderStageCreateInfo = - zero - { stage = SHADER_STAGE_FRAGMENT_BIT - , module' = fragModule - , name = "main" - } - pure - [SomeStruct vertShaderStageCreateInfo, SomeStruct fragShaderStageCreateInfo] - -createRenderPass :: Device -> Format -> ResourceT IO RenderPass -createRenderPass dev swapchainImageFormat = do - let - attachmentDescription :: AttachmentDescription - attachmentDescription = - zero - { format = swapchainImageFormat - , samples = SAMPLE_COUNT_1_BIT - , loadOp = ATTACHMENT_LOAD_OP_CLEAR - , storeOp = ATTACHMENT_STORE_OP_STORE - , stencilLoadOp = ATTACHMENT_LOAD_OP_DONT_CARE - , stencilStoreOp = ATTACHMENT_STORE_OP_DONT_CARE - , initialLayout = IMAGE_LAYOUT_UNDEFINED - , finalLayout = IMAGE_LAYOUT_PRESENT_SRC_KHR - } - subpass :: SubpassDescription - subpass = - zero - { pipelineBindPoint = PIPELINE_BIND_POINT_GRAPHICS - , colorAttachments = - [ zero - { attachment = 0 - , layout = IMAGE_LAYOUT_COLOR_ATTACHMENT_OPTIMAL - } - ] - } - subpassDependency :: SubpassDependency - subpassDependency = - zero - { srcSubpass = SUBPASS_EXTERNAL - , dstSubpass = 0 - , srcStageMask = PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT - , srcAccessMask = zero - , dstStageMask = PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT - , dstAccessMask = - ACCESS_COLOR_ATTACHMENT_READ_BIT - .|. ACCESS_COLOR_ATTACHMENT_WRITE_BIT - } - withRenderPass - dev - zero - { attachments = [attachmentDescription] - , subpasses = [subpass] - , dependencies = [subpassDependency] - } - Nothing - allocate' - -createGraphicsPipeline - :: Device -> RenderPass -> Extent2D -> Format -> ResourceT IO Pipeline -createGraphicsPipeline dev renderPass swapchainExtent _swapchainImageFormat = 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 - , basePipelineHandle = zero - } - V.head . snd <$> withGraphicsPipelines dev zero [SomeStruct pipelineCreateInfo] Nothing allocate' - -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 - , height - , layers = 1 - } - withFramebuffer dev framebufferCreateInfo Nothing allocate' - -data VulkanWindow = VulkanWindow - { vwSdlWindow :: SDL.Window - , vwDevice :: Device - , vwSurface :: SurfaceKHR - , vwSwapchain :: SwapchainKHR - , vwExtent :: Extent2D - , vwFormat :: Format - , vwImageViews :: V.Vector ImageView - , vwGraphicsQueue :: Queue - , vwGraphicsQueueFamilyIndex :: Word32 - , vwPresentQueue :: Queue - } - -withVulkanWindow :: Int -> Int -> ResourceT IO VulkanWindow -withVulkanWindow width height = do - window <- Window.createWindow appName width height - windowExtensions <- liftIO $ traverse BS.packCString =<< SDL.vkGetInstanceExtensions window - - let - instanceCreateInfo = - zero - { applicationInfo = - Just - zero - { applicationName = Just appName - , apiVersion = API_VERSION_1_0 - } - , enabledExtensionNames = V.fromList windowExtensions - , flags = INSTANCE_CREATE_ENUMERATE_PORTABILITY_BIT_KHR - } - portabilityEnum = - RequireInstanceExtension - Nothing - KHR_PORTABILITY_ENUMERATION_EXTENSION_NAME - minBound - inst <- createDebugInstanceFromRequirements [] [portabilityEnum] instanceCreateInfo - void $ - withDebugUtilsMessengerEXT - inst - debugUtilsMessengerCreateInfo - Nothing - allocate' - submitDebugUtilsMessageEXT - inst - DEBUG_UTILS_MESSAGE_SEVERITY_WARNING_BIT_EXT - DEBUG_UTILS_MESSAGE_TYPE_GENERAL_BIT_EXT - zero{message = Just "Debug Message Test"} - (_, surface) <- Window.createSurface inst window - (dev, graphicsQueue, graphicsQueueFamilyIndex, presentQueue, swapchainFormat, swapchainExtent, swapchain) <- - createGraphicalDevice inst surface - (_, 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 -> 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 - -> ResourceT - IO - (Device, Queue, Word32, Queue, Format, Extent2D, SwapchainKHR) -createGraphicalDevice inst surface = do - let requiredDeviceExtensions = [KHR_SWAPCHAIN_EXTENSION_NAME] - (physicalDevice, graphicsQueueFamilyIndex, presentQueueFamilyIndex, surfaceFormat, presentMode, surfaceCaps) <- - pickGraphicalPhysicalDevice - inst - surface - requiredDeviceExtensions - (SurfaceFormatKHR FORMAT_B8G8R8_UNORM COLOR_SPACE_SRGB_NONLINEAR_KHR) - props <- getPhysicalDeviceProperties physicalDevice - sayErr $ "Using device: " <> decodeUtf8 (deviceName props) - let - deviceCreateInfo :: DeviceCreateInfo '[] - deviceCreateInfo = - zero - { queueCreateInfos = - V.fromList - [ SomeStruct $ zero{queueFamilyIndex = i, queuePriorities = [1]} - | i <- nub [graphicsQueueFamilyIndex, presentQueueFamilyIndex] - ] - , enabledExtensionNames = requiredDeviceExtensions - } - dev <- withDevice physicalDevice deviceCreateInfo Nothing allocate' - graphicsQueue <- getDeviceQueue dev graphicsQueueFamilyIndex 0 - presentQueue <- getDeviceQueue dev presentQueueFamilyIndex 0 - 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 windowWidth) - (fromIntegral windowHeight) - 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 <- withSwapchainKHR dev swapchainCreateInfo Nothing allocate' - pure - ( dev - , graphicsQueue - , graphicsQueueFamilyIndex - , presentQueue - , SF.format surfaceFormat - , SW.imageExtent swapchainCreateInfo - , swapchain - ) - --- | Find the device which has the most memory and a graphics queue family index -pickGraphicalPhysicalDevice - :: (MonadIO m) - => Instance - -> SurfaceKHR - -> V.Vector BS.ByteString - -> SurfaceFormatKHR - -> m - ( PhysicalDevice - , Word32 - , Word32 - , SurfaceFormatKHR - , PresentModeKHR - , SurfaceCapabilitiesKHR - ) -pickGraphicalPhysicalDevice inst surface _requiredExtensions desiredFormat = do - (_, devs) <- enumeratePhysicalDevices inst - -- All devices with support for all the graphical features we want - graphicsDevs <- fmap (V.mapMaybe id) . for devs $ \dev -> runMaybeT $ do - graphicsQueue <- MaybeT $ headMay <$> getGraphicsQueueIndices dev - presentQueue <- MaybeT $ headMay <$> getPresentQueueIndices dev - guard =<< deviceHasSwapchain dev - bestFormat <- getFormat dev - presentMode <- getPresentMode dev - surfaceCaps <- getPhysicalDeviceSurfaceCapabilitiesKHR dev surface - score <- deviceScore dev - pure - ( score - , (dev, graphicsQueue, presentQueue, bestFormat, presentMode, surfaceCaps) - ) - if V.null graphicsDevs - then do - sayErr "No suitable devices found" - liftIO exitFailure - else pure . snd . V.maximumBy (comparing fst) $ graphicsDevs - where - headMay = \case - [] -> Nothing - xs -> Just (V.unsafeHead xs) - - deviceScore :: (MonadIO m) => PhysicalDevice -> m Word64 - deviceScore dev = do - heaps <- memoryHeaps <$> getPhysicalDeviceMemoryProperties dev - let totalSize = sum $ DI.size <$> heaps - pure totalSize - - deviceHasSwapchain :: (MonadIO m) => PhysicalDevice -> m Bool - deviceHasSwapchain dev = do - (_, extensions) <- enumerateDeviceExtensionProperties dev Nothing - pure $ V.any ((KHR_SWAPCHAIN_EXTENSION_NAME ==) . extensionName) extensions - - getGraphicsQueueIndices :: (MonadIO m) => PhysicalDevice -> m (V.Vector Word32) - getGraphicsQueueIndices dev = do - queueFamilyProperties <- getPhysicalDeviceQueueFamilyProperties dev - let - isGraphicsQueue q = - (QUEUE_GRAPHICS_BIT .&&. queueFlags q) && (queueCount q > 0) - graphicsQueueIndices = - fromIntegral . fst - <$> V.filter - (isGraphicsQueue . snd) - (V.indexed queueFamilyProperties) - pure graphicsQueueIndices - - getPresentQueueIndices :: (MonadIO m) => PhysicalDevice -> m (V.Vector Word32) - getPresentQueueIndices dev = do - queueFamilyProperties <- getPhysicalDeviceQueueFamilyProperties dev - let isPresentQueue i = getPhysicalDeviceSurfaceSupportKHR dev i surface - V.filterM - isPresentQueue - (V.generate (V.length queueFamilyProperties) fromIntegral) - - getFormat :: (MonadIO m) => PhysicalDevice -> m SurfaceFormatKHR - getFormat dev = do - (_, formats) <- getPhysicalDeviceSurfaceFormatsKHR dev surface - pure $ case formats of - [] -> desiredFormat - [SurfaceFormatKHR FORMAT_UNDEFINED _] -> desiredFormat - _ - | V.any - ( \f -> - SF.format f == SF.format desiredFormat - && SF.colorSpace f == SF.colorSpace desiredFormat - ) - formats -> - desiredFormat - _ -> V.head formats - - getPresentMode :: (MonadIO m) => PhysicalDevice -> MaybeT m PresentModeKHR - getPresentMode dev = do - (_, presentModes) <- getPhysicalDeviceSurfacePresentModesKHR dev surface - let desiredPresentModes = - [ PRESENT_MODE_MAILBOX_KHR - , PRESENT_MODE_FIFO_KHR - , PRESENT_MODE_IMMEDIATE_KHR - ] - MaybeT - . pure - . headMay - . V.filter (`V.elem` presentModes) - $ desiredPresentModes - ----------------------------------------------------------------- --- Debugging ----------------------------------------------------------------- - -debugUtilsMessengerCreateInfo :: DebugUtilsMessengerCreateInfoEXT -debugUtilsMessengerCreateInfo = - 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 - } - ----------------------------------------------------------------- --- Resource handling with 'resourcet' ----------------------------------------------------------------- - -allocate' :: IO a -> (a -> IO ()) -> ResourceT IO a -allocate' c d = snd <$> allocate c d - ----------------------------------------------------------------- --- Bit utils ----------------------------------------------------------------- - -(.&&.) :: (Bits a) => a -> a -> Bool -x .&&. y = (/= zeroBits) (x .&. y) diff --git a/examples/timeline-semaphore/Main.hs b/examples/timeline-semaphore/Main.hs index 2af737f4a..71f47596d 100644 --- a/examples/timeline-semaphore/Main.hs +++ b/examples/timeline-semaphore/Main.hs @@ -31,6 +31,7 @@ import Vulkan.Core12.Promoted_From_VK_KHR_timeline_semaphore 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 @@ -80,21 +81,15 @@ timelineTest dev computeQueue = do -- Vulkan utils ---------------------------------------------------------------- --- | Create an instance with a debug messenger createInstance :: MonadResource m => m Instance -createInstance = - let createInfo = zero - { applicationInfo = Just zero { applicationName = Nothing - , apiVersion = API_VERSION_1_0 - } - } - reqs = - [ RequireInstanceExtension - Nothing - KHR_GET_PHYSICAL_DEVICE_PROPERTIES_2_EXTENSION_NAME - minBound - ] - in createDebugInstanceFromRequirements reqs [] createInfo +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 diff --git a/examples/triangle-glfw/Main.hs b/examples/triangle-glfw/Main.hs new file mode 100644 index 000000000..7c1ecf73b --- /dev/null +++ b/examples/triangle-glfw/Main.hs @@ -0,0 +1,242 @@ +{-# 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 Say +import System.Exit +import Vulkan.CStruct.Extends +import Vulkan.Core10 +import qualified Vulkan.Core10.DeviceInitialization as DI +import Vulkan.Extensions.VK_KHR_surface +import qualified Vulkan.Extensions.VK_KHR_surface as SF +import Vulkan.Extensions.VK_KHR_swapchain +import qualified Vulkan.Extensions.VK_KHR_swapchain as SW +import Vulkan.Requirement (DeviceRequirement (..)) +import qualified Vulkan.Utils.Init.GLFW as Init +import Vulkan.Utils.Initialization (createDeviceFromRequirements, pickPhysicalDevice) +import Vulkan.Utils.QueueAssignment + ( QueueFamilyIndex (..) + , QueueSpec (..) + , assignQueues + , isGraphicsQueueFamily + , isPresentQueueFamily + ) +import Vulkan.Zero +import qualified Triangle +import Window ( VulkanWindow(..) ) +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}) + [] + [] + 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) + + headMay = \case + [] -> Nothing + xs -> Just (V.unsafeHead xs) + + getFormat :: (MonadIO m) => PhysicalDevice -> m SurfaceFormatKHR + getFormat dev = do + (_, formats) <- getPhysicalDeviceSurfaceFormatsKHR dev surface + pure $ case formats of + [] -> desiredFormat + [SurfaceFormatKHR FORMAT_UNDEFINED _] -> desiredFormat + _ + | V.any + ( \f -> + SF.format f == SF.format desiredFormat + && SF.colorSpace f == SF.colorSpace desiredFormat + ) + formats -> + desiredFormat + _ -> V.head formats + + getPresentMode :: (MonadIO m) => PhysicalDevice -> m PresentModeKHR + getPresentMode dev = do + (_, presentModes) <- getPhysicalDeviceSurfacePresentModesKHR dev surface + let desiredPresentModes = + [ PRESENT_MODE_MAILBOX_KHR + , PRESENT_MODE_FIFO_KHR + , PRESENT_MODE_IMMEDIATE_KHR + ] + match = V.filter (`V.elem` presentModes) desiredPresentModes + pure $ case headMay match of + Just m -> m + Nothing -> case presentModes V.!? 0 of + Just m -> m + Nothing -> PRESENT_MODE_FIFO_KHR diff --git a/examples/offscreen/Main.hs b/examples/triangle-headless/Main.hs similarity index 83% rename from examples/offscreen/Main.hs rename to examples/triangle-headless/Main.hs index ce4621310..b67cf9c0b 100644 --- a/examples/offscreen/Main.hs +++ b/examples/triangle-headless/Main.hs @@ -15,18 +15,11 @@ 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.Maybe ( MaybeT(..) ) import Control.Monad.Trans.Reader import Control.Monad.Trans.Resource import Data.Bits import qualified Data.ByteString.Lazy as BSL -import Data.Foldable -import Data.List ( partition ) -import Data.Maybe ( catMaybes ) -import Data.Ord ( comparing ) -import Data.Text ( Text ) -import qualified Data.Text as T -import Data.Text.Encoding ( decodeUtf8 ) +import Data.Functor.Identity ( Identity(..) ) import qualified Data.Vector as V import Data.Word import Foreign.Ptr @@ -60,8 +53,20 @@ import Vulkan.Dynamic ( DeviceCmds ) ) import Vulkan.Extensions.VK_EXT_debug_utils -import Vulkan.Extensions.VK_EXT_validation_features -import Vulkan.Utils.Debug +import Vulkan.Requirement ( InstanceRequirement(..) ) +import Vulkan.Utils.Debug ( debugCallbackPtr + , nameObject + ) +import qualified Vulkan.Utils.Init.Headless as Init +import Vulkan.Utils.Initialization ( createDeviceFromRequirements + , physicalDeviceName + , pickPhysicalDevice + ) +import Vulkan.Utils.QueueAssignment ( QueueFamilyIndex(..) + , QueueSpec(..) + , assignQueues + , isGraphicsQueueFamily + ) import Vulkan.Utils.ShaderQQ.GLSL.Glslang import Vulkan.Zero import VulkanMemoryAllocator as VMA @@ -167,7 +172,6 @@ autoapplyDecs , 'withFramebuffer , 'withGraphicsPipelines , 'withImageView - , 'withInstance , 'withPipelineLayout , 'withRenderPass , 'withShaderModule @@ -639,31 +643,22 @@ createShaders = do myApiVersion :: Word32 myApiVersion = API_VERSION_1_0 --- | Create an instance with a debug messenger +-- | Create an instance with a debug messenger and validation layer. createInstance :: MonadResource m => m Instance createInstance = do - availableExtensionNames <- - toList - . fmap extensionName - . snd - <$> enumerateInstanceExtensionProperties Nothing - availableLayerNames <- - toList . fmap layerName . snd <$> enumerateInstanceLayerProperties - - let requiredLayers = [] - optionalLayers = ["VK_LAYER_KHRONOS_validation"] - requiredExtensions = [EXT_DEBUG_UTILS_EXTENSION_NAME] - optionalExtensions = [EXT_VALIDATION_FEATURES_EXTENSION_NAME] - - extensions <- partitionOptReq "extension" - availableExtensionNames - optionalExtensions - requiredExtensions - layers <- partitionOptReq "layer" - availableLayerNames - optionalLayers - requiredLayers - + 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 @@ -672,20 +667,6 @@ createInstance = do .|. DEBUG_UTILS_MESSAGE_TYPE_PERFORMANCE_BIT_EXT , pfnUserCallback = debugCallbackPtr } - instanceCreateInfo = - zero - { applicationInfo = Just zero { applicationName = Nothing - , apiVersion = myApiVersion - } - , enabledLayerNames = V.fromList layers - , enabledExtensionNames = V.fromList extensions - } - ::& debugMessengerCreateInfo - :& ValidationFeaturesEXT - [VALIDATION_FEATURE_ENABLE_BEST_PRACTICES_EXT] - [] - :& () - (_, inst) <- withInstance' instanceCreateInfo _ <- withDebugUtilsMessengerEXT inst debugMessengerCreateInfo Nothing allocate pure inst @@ -694,88 +675,36 @@ createDevice => Instance -> m (PhysicalDevice, PhysicalDeviceInfo, Device) createDevice inst = do - (pdi, phys) <- pickPhysicalDevice inst physicalDeviceInfo + mPd <- pickPhysicalDevice inst hasGraphicsQueue id + (_, phys) <- maybe (throwString "Unable to find appropriate PhysicalDevice") + pure + mPd sayErr . ("Using device: " <>) =<< physicalDeviceName phys - let deviceCreateInfo = zero - { queueCreateInfos = - [ SomeStruct zero { queueFamilyIndex = pdiGraphicsQueueFamilyIndex pdi - , queuePriorities = [1] - } - ] - } - - (_, dev) <- withDevice phys deviceCreateInfo Nothing allocate - pure (phys, pdi, dev) - ----------------------------------------------------------------- --- Physical device tools ----------------------------------------------------------------- - --- | Get a single PhysicalDevice deciding with a scoring function -pickPhysicalDevice - :: (MonadIO m, MonadThrow m, Ord a) - => Instance - -> (PhysicalDevice -> m (Maybe a)) - -- ^ Some "score" for a PhysicalDevice, Nothing if it is not to be chosen. - -> m (a, PhysicalDevice) -pickPhysicalDevice inst devScore = do - (_, devs) <- enumeratePhysicalDevices inst - scores <- catMaybes - <$> sequence [ fmap (, d) <$> devScore d | d <- toList devs ] - case scores of - [] -> throwString "Unable to find appropriate PhysicalDevice" - _ -> pure (maximumBy (comparing fst) scores) - --- | The Ord instance prioritises devices with more memory -data PhysicalDeviceInfo = PhysicalDeviceInfo - { pdiTotalMemory :: Word64 - , pdiGraphicsQueueFamilyIndex :: Word32 + mAssign <- assignQueues + phys + (Identity (QueueSpec 1 (\_ q -> pure (isGraphicsQueueFamily q)))) + (qInfos, getQs) <- maybe (throwString "Unable to assign graphics queue") + pure + mAssign + dev <- createDeviceFromRequirements + [] + [] + phys + zero { queueCreateInfos = SomeStruct <$> qInfos } + Identity (QueueFamilyIndex graphicsFamilyIdx, _q) <- liftIO (getQs dev) + pure (phys, PhysicalDeviceInfo graphicsFamilyIdx, dev) + where + hasGraphicsQueue :: MonadIO m => PhysicalDevice -> m (Maybe Word64) + hasGraphicsQueue phys = do + qProps <- getPhysicalDeviceQueueFamilyProperties phys + if V.any isGraphicsQueueFamily qProps + then do + heaps <- memoryHeaps <$> getPhysicalDeviceMemoryProperties phys + pure (Just (sum (DI.size <$> heaps))) + else pure Nothing + +newtype PhysicalDeviceInfo = PhysicalDeviceInfo + { pdiGraphicsQueueFamilyIndex :: Word32 } deriving (Eq, Ord) - -physicalDeviceInfo - :: MonadIO m => PhysicalDevice -> m (Maybe PhysicalDeviceInfo) -physicalDeviceInfo phys = runMaybeT $ do - pdiTotalMemory <- do - heaps <- memoryHeaps <$> getPhysicalDeviceMemoryProperties phys - pure $ sum (DI.size <$> heaps) - 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) - MaybeT (pure $ graphicsQueueIndices V.!? 0) - pure PhysicalDeviceInfo { .. } - -physicalDeviceName :: MonadIO m => PhysicalDevice -> m Text -physicalDeviceName phys = do - props <- getPhysicalDeviceProperties phys - pure $ decodeUtf8 (deviceName props) - ----------------------------------------------------------------- --- Utils ----------------------------------------------------------------- - -partitionOptReq - :: (Show a, Eq a, MonadIO m) => Text -> [a] -> [a] -> [a] -> m [a] -partitionOptReq type' available optional required = do - let (optHave, optMissing) = partition (`elem` available) optional - (reqHave, reqMissing) = partition (`elem` available) required - tShow = T.pack . show - for_ optMissing - $ \n -> sayErr $ "Missing optional " <> type' <> ": " <> tShow n - case reqMissing of - [] -> pure () - [x] -> sayErr $ "Missing required " <> type' <> ": " <> tShow x - xs -> sayErr $ "Missing required " <> type' <> "s: " <> tShow xs - pure (reqHave <> optHave) - ----------------------------------------------------------------- --- Bit utils ----------------------------------------------------------------- - -(.&&.) :: Bits a => a -> a -> Bool -x .&&. y = (/= zeroBits) (x .&. y) diff --git a/examples/triangle-sdl2/Main.hs b/examples/triangle-sdl2/Main.hs new file mode 100644 index 000000000..4364b30ae --- /dev/null +++ b/examples/triangle-sdl2/Main.hs @@ -0,0 +1,246 @@ +{-# 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 Say +import System.Exit +import Vulkan.CStruct.Extends +import Vulkan.Core10 +import qualified Vulkan.Core10.DeviceInitialization as DI +import Vulkan.Extensions.VK_KHR_surface +import qualified Vulkan.Extensions.VK_KHR_surface as SF +import Vulkan.Extensions.VK_KHR_swapchain +import qualified Vulkan.Extensions.VK_KHR_swapchain as SW +import Vulkan.Requirement (DeviceRequirement (..)) +import qualified Vulkan.Utils.Init.SDL2 as Init +import Vulkan.Utils.Initialization (createDeviceFromRequirements, pickPhysicalDevice) +import Vulkan.Utils.QueueAssignment + ( QueueFamilyIndex (..) + , QueueSpec (..) + , assignQueues + , isGraphicsQueueFamily + , isPresentQueueFamily + ) +import Vulkan.Zero +import qualified Triangle +import Window ( VulkanWindow(..) ) +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}) + [] + [] + 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) + + headMay = \case + [] -> Nothing + xs -> Just (V.unsafeHead xs) + + getFormat :: (MonadIO m) => PhysicalDevice -> m SurfaceFormatKHR + getFormat dev = do + (_, formats) <- getPhysicalDeviceSurfaceFormatsKHR dev surface + pure $ case formats of + [] -> desiredFormat + [SurfaceFormatKHR FORMAT_UNDEFINED _] -> desiredFormat + _ + | V.any + ( \f -> + SF.format f == SF.format desiredFormat + && SF.colorSpace f == SF.colorSpace desiredFormat + ) + formats -> + desiredFormat + _ -> V.head formats + + -- Returns the first preferred present mode the driver supports, falling + -- back to whatever it offers (FIFO_KHR is guaranteed by the spec). + getPresentMode :: (MonadIO m) => PhysicalDevice -> m PresentModeKHR + getPresentMode dev = do + (_, presentModes) <- getPhysicalDeviceSurfacePresentModesKHR dev surface + let desiredPresentModes = + [ PRESENT_MODE_MAILBOX_KHR + , PRESENT_MODE_FIFO_KHR + , PRESENT_MODE_IMMEDIATE_KHR + ] + match = V.filter (`V.elem` presentModes) desiredPresentModes + pure $ case headMay match of + Just m -> m + Nothing -> case presentModes V.!? 0 of + Just m -> m + Nothing -> PRESENT_MODE_FIFO_KHR diff --git a/examples/vulkan-examples.cabal b/examples/vulkan-examples.cabal index e4a8389d0..2b602748f 100644 --- a/examples/vulkan-examples.cabal +++ b/examples/vulkan-examples.cabal @@ -51,8 +51,11 @@ library Orphans RefCounted Swapchain + Triangle Utils Window + Window.GLFW + Window.SDL2 other-modules: Paths_vulkan_examples autogen-modules: @@ -93,9 +96,9 @@ library TypeOperators TypeSynonymInstances ViewPatterns - ghc-options: -Wall build-depends: - VulkanMemoryAllocator + GLFW-b + , VulkanMemoryAllocator , base <5 , bytestring , derive-storable >=0.3 @@ -120,6 +123,7 @@ library default-language: Haskell2010 if os(windows) ghc-options: -optl-mconsole + ghc-options: -Wall executable compute main-is: Main.hs @@ -249,6 +253,7 @@ executable hlsl , vector , vulkan , vulkan-examples + , vulkan-init-sdl2 , vulkan-utils >=0.3 default-language: Haskell2010 if os(windows) @@ -307,14 +312,23 @@ executable info if os(windows) ghc-options: -optl-mconsole -executable offscreen +executable rays main-is: Main.hs other-modules: + AccelerationStructure + Cleanup + Frame + Init + MonadFrame + MonadVulkan + Pipeline + Render + Scene Paths_vulkan_examples autogen-modules: Paths_vulkan_examples hs-source-dirs: - offscreen + rays default-extensions: DataKinds DefaultSignatures @@ -349,49 +363,54 @@ executable offscreen TypeOperators TypeSynonymInstances ViewPatterns - ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -eventlog build-depends: - JuicyPixels - , VulkanMemoryAllocator + VulkanMemoryAllocator , base <5 , bytestring - , resourcet - , safe-exceptions + , 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 + , sdl2 + , template-haskell , text , transformers + , unagi-chan + , unliftio , vector - , vulkan + , vulkan >=3.7 , vulkan-examples - , vulkan-utils + , vulkan-init-sdl2 + , vulkan-utils >=0.3 default-language: Haskell2010 if os(windows) ghc-options: -optl-mconsole - if flag(renderdoc) - cpp-options: -DRENDERDOC - extra-libraries: - dl - build-depends: - containers - , inline-c + if !flag(raytracing) + buildable: False -executable rays +executable resize main-is: Main.hs other-modules: - AccelerationStructure - Cleanup Frame Init - MonadFrame + Julia + Julia.Constants MonadVulkan Pipeline - Render - Scene + Swapchain Paths_vulkan_examples autogen-modules: Paths_vulkan_examples hs-source-dirs: - rays + resize default-extensions: DataKinds DefaultSignatures @@ -426,53 +445,94 @@ 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 + , extra , lens , linear - , nothunks >=0.1.2 - , opentelemetry - , random , resourcet >=1.2.4 , say , sdl2 - , template-haskell , text , transformers - , unagi-chan , unliftio , vector - , vulkan >=3.7 + , vulkan + , vulkan-examples + , vulkan-init-sdl2 + , vulkan-utils + default-language: Haskell2010 + 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 - if !flag(raytracing) - buildable: False -executable resize +executable triangle-glfw main-is: Main.hs other-modules: - Frame - Init - Julia - Julia.Constants - MonadVulkan - Pipeline - Swapchain Paths_vulkan_examples autogen-modules: Paths_vulkan_examples hs-source-dirs: - resize + triangle-glfw default-extensions: DataKinds DefaultSignatures @@ -509,34 +569,29 @@ executable resize ViewPatterns ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N build-depends: - VulkanMemoryAllocator + GLFW-b , base <5 - , bytestring - , extra - , lens - , linear - , resourcet >=1.2.4 + , resourcet , say - , sdl2 , text , transformers - , unliftio , vector , vulkan , vulkan-examples + , vulkan-init-glfw , vulkan-utils default-language: Haskell2010 if os(windows) ghc-options: -optl-mconsole -executable sdl-triangle +executable triangle-headless main-is: Main.hs other-modules: Paths_vulkan_examples autogen-modules: Paths_vulkan_examples hs-source-dirs: - sdl-triangle + triangle-headless default-extensions: DataKinds DefaultSignatures @@ -573,12 +628,13 @@ executable sdl-triangle ViewPatterns ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N build-depends: - base <5 + JuicyPixels + , VulkanMemoryAllocator + , base <5 , bytestring - , extra , resourcet + , safe-exceptions , say - , sdl2 , text , transformers , vector @@ -588,15 +644,22 @@ executable sdl-triangle default-language: Haskell2010 if os(windows) ghc-options: -optl-mconsole + if flag(renderdoc) + cpp-options: -DRENDERDOC + extra-libraries: + dl + build-depends: + containers + , inline-c -executable timeline-semaphore +executable triangle-sdl2 main-is: Main.hs other-modules: Paths_vulkan_examples autogen-modules: Paths_vulkan_examples hs-source-dirs: - timeline-semaphore + triangle-sdl2 default-extensions: DataKinds DefaultSignatures @@ -636,12 +699,14 @@ executable timeline-semaphore base <5 , resourcet , say + , sdl2 + , text , transformers - , unliftio , vector , vulkan , vulkan-examples - , vulkan-utils >=0.3 + , vulkan-init-sdl2 + , vulkan-utils default-language: Haskell2010 if os(windows) ghc-options: -optl-mconsole diff --git a/nix/haskell-packages.nix b/nix/haskell-packages.nix index 9cd7b159c..1e75f8d39 100644 --- a/nix/haskell-packages.nix +++ b/nix/haskell-packages.nix @@ -53,6 +53,18 @@ let modifier = drv: addExtraLibrary pkgs.vulkan-headers (mod drv); returnShellEnv = false; }; + vulkan-init-sdl2 = self.developPackage { + name = "vulkan-init-sdl2"; + root = gitignore ../utils-init/vulkan-init-sdl2; + modifier = mod; + returnShellEnv = false; + }; + vulkan-init-glfw = self.developPackage { + name = "vulkan-init-glfw"; + root = gitignore ../utils-init/vulkan-init-glfw; + modifier = mod; + returnShellEnv = false; + }; VulkanMemoryAllocator = self.developPackage { name = "VukanMemoryAllocator"; root = gitignore ../VulkanMemoryAllocator; diff --git a/release-checklist.md b/release-checklist.md index 3599625fb..0b42a87bb 100644 --- a/release-checklist.md +++ b/release-checklist.md @@ -37,7 +37,7 @@ - `cabal haddock --haddock-for-hackage --haddock-option="--hyperlinked-source"` - sdist - unpack sdist elsewhere -- build sdl-triangle +- build triangle-sdl2 - Observe it running ## VulkanMemoryAllocator diff --git a/stack.yaml b/stack.yaml index 69b537b29..311a2f390 100644 --- a/stack.yaml +++ b/stack.yaml @@ -2,6 +2,8 @@ resolver: lts-22.44 packages: - . - utils +- utils-init/vulkan-init-sdl2 +- utils-init/vulkan-init-glfw - examples - VulkanMemoryAllocator - openxr diff --git a/utils-init/vulkan-init-glfw/LICENSE b/utils-init/vulkan-init-glfw/LICENSE new file mode 100644 index 000000000..afec2193f --- /dev/null +++ b/utils-init/vulkan-init-glfw/LICENSE @@ -0,0 +1,30 @@ +Copyright Ellie Hermaszewska (c) 2016 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Ellie Hermaszewska nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. \ No newline at end of file diff --git a/utils-init/vulkan-init-glfw/Setup.hs b/utils-init/vulkan-init-glfw/Setup.hs new file mode 100644 index 000000000..9a994af67 --- /dev/null +++ b/utils-init/vulkan-init-glfw/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/utils-init/vulkan-init-glfw/changelog.md b/utils-init/vulkan-init-glfw/changelog.md new file mode 100644 index 000000000..1713fa4a2 --- /dev/null +++ b/utils-init/vulkan-init-glfw/changelog.md @@ -0,0 +1,4 @@ +# Change Log + +## [0.1.0.0] +- Initial release. diff --git a/utils-init/vulkan-init-glfw/package.yaml b/utils-init/vulkan-init-glfw/package.yaml new file mode 100644 index 000000000..165d8f517 --- /dev/null +++ b/utils-init/vulkan-init-glfw/package.yaml @@ -0,0 +1,37 @@ +name: vulkan-init-glfw +version: "0.1.0.0" +synopsis: Vulkan initialization helpers for GLFW +category: Graphics +maintainer: Ellie Hermaszewska +github: expipiplus1/vulkan +license: BSD3 +license-file: LICENSE +extra-source-files: +- readme.md +- changelog.md +- package.yaml + +library: + source-dirs: src + dependencies: + - base <5 + - bytestring + - GLFW-b >= 3.3 && < 3.4 + - resourcet >= 1.2.4 + - vector + - vulkan >= 3.6.14 && < 3.28 + - vulkan-utils + +ghc-options: +- -Wall + +default-extensions: +- DerivingStrategies +- FlexibleContexts +- LambdaCase +- NamedFieldPuns +- OverloadedStrings +- PatternSynonyms +- RankNTypes +- RecordWildCards +- ScopedTypeVariables diff --git a/utils-init/vulkan-init-glfw/readme.md b/utils-init/vulkan-init-glfw/readme.md new file mode 100644 index 000000000..9b2666337 --- /dev/null +++ b/utils-init/vulkan-init-glfw/readme.md @@ -0,0 +1,5 @@ +# vulkan-init-glfw + +Vulkan initialization helpers for GLFW windows. Provides the GLFW-specific +glue around `vulkan-utils` so apps can build a Vulkan `Instance` and a +`SurfaceKHR` from a `GLFW.Window` with a couple of calls. diff --git a/utils-init/vulkan-init-glfw/src/Vulkan/Utils/Init/GLFW.hs b/utils-init/vulkan-init-glfw/src/Vulkan/Utils/Init/GLFW.hs new file mode 100644 index 000000000..da6b15eae --- /dev/null +++ b/utils-init/vulkan-init-glfw/src/Vulkan/Utils/Init/GLFW.hs @@ -0,0 +1,81 @@ +-- | Vulkan initialization glue for GLFW windows. Compose with +-- 'Vulkan.Utils.Init.withVulkanInstance' (or just call 'withInstance' here) +-- and the rest of @vulkan-utils@ to get a ready-to-render setup. +module Vulkan.Utils.Init.GLFW + ( -- * Required extensions + getRequiredInstanceExtensions + , getRequiredDeviceExtensions + -- * Surface + , createSurface + , destroySurface + , withSurface + -- * Instance + , withInstance + ) where + +import Control.Exception ( throwIO ) +import Control.Monad ( when ) +import Control.Monad.IO.Class ( MonadIO, liftIO ) +import Control.Monad.Trans.Resource ( MonadResource, allocate ) +import qualified Data.ByteString as BS +import Data.ByteString ( ByteString ) +import qualified Data.Vector as V +import Data.Vector ( Vector ) +import Data.Int ( Int32 ) +import Foreign.Marshal.Alloc ( alloca ) +import Foreign.Ptr ( nullPtr ) +import Foreign.Storable ( peek ) +import qualified Graphics.UI.GLFW as GLFW +import Vulkan.Core10 ( Instance, ApplicationInfo + , instanceHandle ) +import Vulkan.Core10.Enums.Result ( Result(..) ) +import Vulkan.Exception ( VulkanException(..) ) +import Vulkan.Extensions.VK_KHR_surface ( SurfaceKHR(..) + , destroySurfaceKHR ) +import Vulkan.Extensions.VK_KHR_swapchain + ( pattern KHR_SWAPCHAIN_EXTENSION_NAME ) +import Vulkan.Requirement ( InstanceRequirement ) +import Vulkan.Utils.Initialization ( withVulkanInstance ) + +-- | Vulkan instance extensions GLFW requires. The window argument is unused +-- (GLFW's API is global) but kept for symmetry with the SDL2 module. +getRequiredInstanceExtensions :: MonadIO m => GLFW.Window -> m (Vector ByteString) +getRequiredInstanceExtensions _ = liftIO $ + V.fromList <$> (traverse BS.packCString =<< GLFW.getRequiredInstanceExtensions) + +-- | Device extensions a GLFW-presenting application needs. Currently just +-- @VK_KHR_swapchain@. +getRequiredDeviceExtensions :: [ByteString] +getRequiredDeviceExtensions = [KHR_SWAPCHAIN_EXTENSION_NAME] + +-- | Create a 'SurfaceKHR' for the given GLFW window. Throws 'VulkanException' +-- if GLFW reports a non-success result. +createSurface :: Instance -> GLFW.Window -> IO SurfaceKHR +createSurface inst w = alloca $ \surfPtr -> do + r <- GLFW.createWindowSurface (instanceHandle inst) w nullPtr surfPtr :: IO Int32 + let result = Result r + when (result /= SUCCESS) (throwIO (VulkanException result)) + peek surfPtr + +-- | Destroy a 'SurfaceKHR' previously created with 'createSurface'. +destroySurface :: Instance -> SurfaceKHR -> IO () +destroySurface inst s = destroySurfaceKHR inst s Nothing + +-- | Bracketed surface creation in 'MonadResource'. +withSurface :: MonadResource m => Instance -> GLFW.Window -> m SurfaceKHR +withSurface inst w = + snd <$> allocate (createSurface inst w) (destroySurface inst) + +-- | Build a Vulkan 'Instance' wired up with GLFW's required extensions. +-- Composes 'getRequiredInstanceExtensions' and +-- 'Vulkan.Utils.Init.withVulkanInstance'. +withInstance + :: MonadResource m + => GLFW.Window + -> Maybe ApplicationInfo + -> [InstanceRequirement] + -> [InstanceRequirement] + -> m Instance +withInstance w appInfo reqs optReqs = do + exts <- getRequiredInstanceExtensions w + withVulkanInstance exts appInfo reqs optReqs diff --git a/utils-init/vulkan-init-glfw/vulkan-init-glfw.cabal b/utils-init/vulkan-init-glfw/vulkan-init-glfw.cabal new file mode 100644 index 000000000..db6e9cb9d --- /dev/null +++ b/utils-init/vulkan-init-glfw/vulkan-init-glfw.cabal @@ -0,0 +1,52 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.39.1. +-- +-- see: https://github.com/sol/hpack + +name: vulkan-init-glfw +version: 0.1.0.0 +synopsis: Vulkan initialization helpers for GLFW +category: Graphics +homepage: https://github.com/expipiplus1/vulkan#readme +bug-reports: https://github.com/expipiplus1/vulkan/issues +maintainer: Ellie Hermaszewska +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + readme.md + changelog.md + package.yaml + +source-repository head + type: git + location: https://github.com/expipiplus1/vulkan + +library + exposed-modules: + Vulkan.Utils.Init.GLFW + other-modules: + Paths_vulkan_init_glfw + hs-source-dirs: + src + default-extensions: + DerivingStrategies + FlexibleContexts + LambdaCase + NamedFieldPuns + OverloadedStrings + PatternSynonyms + RankNTypes + RecordWildCards + ScopedTypeVariables + ghc-options: -Wall + build-depends: + GLFW-b ==3.3.* + , base <5 + , bytestring + , resourcet >=1.2.4 + , vector + , vulkan >=3.6.14 && <3.28 + , vulkan-utils + default-language: Haskell2010 diff --git a/utils-init/vulkan-init-sdl2/LICENSE b/utils-init/vulkan-init-sdl2/LICENSE new file mode 100644 index 000000000..afec2193f --- /dev/null +++ b/utils-init/vulkan-init-sdl2/LICENSE @@ -0,0 +1,30 @@ +Copyright Ellie Hermaszewska (c) 2016 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Ellie Hermaszewska nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. \ No newline at end of file diff --git a/utils-init/vulkan-init-sdl2/Setup.hs b/utils-init/vulkan-init-sdl2/Setup.hs new file mode 100644 index 000000000..9a994af67 --- /dev/null +++ b/utils-init/vulkan-init-sdl2/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/utils-init/vulkan-init-sdl2/changelog.md b/utils-init/vulkan-init-sdl2/changelog.md new file mode 100644 index 000000000..1713fa4a2 --- /dev/null +++ b/utils-init/vulkan-init-sdl2/changelog.md @@ -0,0 +1,4 @@ +# Change Log + +## [0.1.0.0] +- Initial release. diff --git a/utils-init/vulkan-init-sdl2/package.yaml b/utils-init/vulkan-init-sdl2/package.yaml new file mode 100644 index 000000000..92139bd46 --- /dev/null +++ b/utils-init/vulkan-init-sdl2/package.yaml @@ -0,0 +1,37 @@ +name: vulkan-init-sdl2 +version: "0.1.0.0" +synopsis: Vulkan initialization helpers for SDL2 +category: Graphics +maintainer: Ellie Hermaszewska +github: expipiplus1/vulkan +license: BSD3 +license-file: LICENSE +extra-source-files: +- readme.md +- changelog.md +- package.yaml + +library: + source-dirs: src + dependencies: + - base <5 + - bytestring + - resourcet >= 1.2.4 + - sdl2 >= 2.5 && < 2.6 + - vector + - vulkan >= 3.6.14 && < 3.28 + - vulkan-utils + +ghc-options: +- -Wall + +default-extensions: +- DerivingStrategies +- FlexibleContexts +- LambdaCase +- NamedFieldPuns +- OverloadedStrings +- PatternSynonyms +- RankNTypes +- RecordWildCards +- ScopedTypeVariables diff --git a/utils-init/vulkan-init-sdl2/readme.md b/utils-init/vulkan-init-sdl2/readme.md new file mode 100644 index 000000000..287a753ca --- /dev/null +++ b/utils-init/vulkan-init-sdl2/readme.md @@ -0,0 +1,5 @@ +# vulkan-init-sdl2 + +Vulkan initialization helpers for SDL2 windows. Provides the SDL-specific +glue around `vulkan-utils` so apps can build a Vulkan `Instance` and a +`SurfaceKHR` from an `SDL.Window` with a couple of calls. diff --git a/utils-init/vulkan-init-sdl2/src/Vulkan/Utils/Init/SDL2.hs b/utils-init/vulkan-init-sdl2/src/Vulkan/Utils/Init/SDL2.hs new file mode 100644 index 000000000..c4836a17d --- /dev/null +++ b/utils-init/vulkan-init-sdl2/src/Vulkan/Utils/Init/SDL2.hs @@ -0,0 +1,70 @@ +-- | Vulkan initialization glue for SDL2 windows. Compose with +-- 'Vulkan.Utils.Init.withVulkanInstance' (or just call 'withInstance' here) +-- and the rest of @vulkan-utils@ to get a ready-to-render setup. +module Vulkan.Utils.Init.SDL2 + ( -- * Required extensions + getRequiredInstanceExtensions + , getRequiredDeviceExtensions + -- * Surface + , createSurface + , destroySurface + , withSurface + -- * Instance + , withInstance + ) where + +import Control.Monad.IO.Class ( MonadIO, liftIO ) +import Control.Monad.Trans.Resource ( MonadResource, allocate ) +import qualified Data.ByteString as BS +import Data.ByteString ( ByteString ) +import qualified Data.Vector as V +import Data.Vector ( Vector ) +import Foreign.Ptr ( castPtr ) +import qualified SDL +import qualified SDL.Video.Vulkan as SDL +import Vulkan.Core10 ( Instance, ApplicationInfo + , instanceHandle ) +import Vulkan.Extensions.VK_KHR_surface ( SurfaceKHR(..) + , destroySurfaceKHR ) +import Vulkan.Extensions.VK_KHR_swapchain + ( pattern KHR_SWAPCHAIN_EXTENSION_NAME ) +import Vulkan.Requirement ( InstanceRequirement ) +import Vulkan.Utils.Initialization ( withVulkanInstance ) + +-- | Vulkan instance extensions the SDL2 window requires for presentation. +getRequiredInstanceExtensions :: MonadIO m => SDL.Window -> m (Vector ByteString) +getRequiredInstanceExtensions w = liftIO $ + V.fromList <$> (traverse BS.packCString =<< SDL.vkGetInstanceExtensions w) + +-- | Device extensions an SDL2-presenting application needs. Currently just +-- @VK_KHR_swapchain@. +getRequiredDeviceExtensions :: [ByteString] +getRequiredDeviceExtensions = [KHR_SWAPCHAIN_EXTENSION_NAME] + +-- | Create a 'SurfaceKHR' for the given SDL window. +createSurface :: Instance -> SDL.Window -> IO SurfaceKHR +createSurface inst w = + SurfaceKHR <$> SDL.vkCreateSurface w (castPtr (instanceHandle inst)) + +-- | Destroy a 'SurfaceKHR' previously created with 'createSurface'. +destroySurface :: Instance -> SurfaceKHR -> IO () +destroySurface inst s = destroySurfaceKHR inst s Nothing + +-- | Bracketed surface creation in 'MonadResource'. +withSurface :: MonadResource m => Instance -> SDL.Window -> m SurfaceKHR +withSurface inst w = + snd <$> allocate (createSurface inst w) (destroySurface inst) + +-- | Build a Vulkan 'Instance' wired up with the SDL window's required +-- extensions. Composes 'getRequiredInstanceExtensions' and +-- 'Vulkan.Utils.Init.withVulkanInstance'. +withInstance + :: MonadResource m + => SDL.Window + -> Maybe ApplicationInfo + -> [InstanceRequirement] + -> [InstanceRequirement] + -> m Instance +withInstance w appInfo reqs optReqs = do + exts <- getRequiredInstanceExtensions w + withVulkanInstance exts appInfo reqs optReqs diff --git a/utils-init/vulkan-init-sdl2/vulkan-init-sdl2.cabal b/utils-init/vulkan-init-sdl2/vulkan-init-sdl2.cabal new file mode 100644 index 000000000..4c1017c2c --- /dev/null +++ b/utils-init/vulkan-init-sdl2/vulkan-init-sdl2.cabal @@ -0,0 +1,52 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.39.1. +-- +-- see: https://github.com/sol/hpack + +name: vulkan-init-sdl2 +version: 0.1.0.0 +synopsis: Vulkan initialization helpers for SDL2 +category: Graphics +homepage: https://github.com/expipiplus1/vulkan#readme +bug-reports: https://github.com/expipiplus1/vulkan/issues +maintainer: Ellie Hermaszewska +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + readme.md + changelog.md + package.yaml + +source-repository head + type: git + location: https://github.com/expipiplus1/vulkan + +library + exposed-modules: + Vulkan.Utils.Init.SDL2 + other-modules: + Paths_vulkan_init_sdl2 + hs-source-dirs: + src + default-extensions: + DerivingStrategies + FlexibleContexts + LambdaCase + NamedFieldPuns + OverloadedStrings + PatternSynonyms + RankNTypes + RecordWildCards + ScopedTypeVariables + ghc-options: -Wall + build-depends: + base <5 + , bytestring + , resourcet >=1.2.4 + , sdl2 ==2.5.* + , vector + , vulkan >=3.6.14 && <3.28 + , vulkan-utils + default-language: Haskell2010 diff --git a/utils/src/Vulkan/Utils/Init/Headless.hs b/utils/src/Vulkan/Utils/Init/Headless.hs new file mode 100644 index 000000000..2e6825662 --- /dev/null +++ b/utils/src/Vulkan/Utils/Init/Headless.hs @@ -0,0 +1,20 @@ +-- | Init helpers for headless applications — no window, no surface, no +-- window-system instance extensions. +module Vulkan.Utils.Init.Headless + ( withInstance + ) where + +import Control.Monad.Trans.Resource ( MonadResource ) +import Vulkan.Core10 ( ApplicationInfo, Instance ) +import Vulkan.Requirement ( InstanceRequirement ) +import Vulkan.Utils.Initialization ( withVulkanInstance ) + +-- | Build a Vulkan 'Instance' for a headless application. Equivalent to +-- @'withVulkanInstance' 'mempty'@. +withInstance + :: MonadResource m + => Maybe ApplicationInfo + -> [InstanceRequirement] + -> [InstanceRequirement] + -> m Instance +withInstance = withVulkanInstance mempty diff --git a/utils/src/Vulkan/Utils/Initialization.hs b/utils/src/Vulkan/Utils/Initialization.hs index 172173fd4..1005dc6a7 100644 --- a/utils/src/Vulkan/Utils/Initialization.hs +++ b/utils/src/Vulkan/Utils/Initialization.hs @@ -1,9 +1,14 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedLists #-} module Vulkan.Utils.Initialization ( -- * Instance creation createInstanceFromRequirements , createDebugInstanceFromRequirements + , withVulkanInstance + -- * macOS portability + , portabilityRequirements + , portabilityFlags -- * Device creation , createDeviceFromRequirements , -- * Physical device selection @@ -14,11 +19,13 @@ module Vulkan.Utils.Initialization import Control.Monad.IO.Class import Control.Monad.Trans.Resource import Data.Bits +import Data.ByteString ( ByteString ) import Data.Foldable import Data.Maybe import Data.Ord import Data.Text ( Text ) import Data.Text.Encoding ( decodeUtf8 ) +import Data.Vector ( Vector ) import Vulkan.CStruct.Extends import Vulkan.Core10 import qualified Vulkan.Core10 as Instance ( InstanceCreateInfo(..) ) @@ -30,6 +37,13 @@ import Vulkan.Utils.Internal import Vulkan.Utils.Requirements import Vulkan.Zero +#if defined(darwin_HOST_OS) +import Vulkan.Core10.Enums.InstanceCreateFlagBits + ( pattern INSTANCE_CREATE_ENUMERATE_PORTABILITY_BIT_KHR ) +import Vulkan.Extensions.VK_KHR_portability_enumeration + ( pattern KHR_PORTABILITY_ENUMERATION_EXTENSION_NAME ) +#endif + ---------------------------------------------------------------- -- Instance ---------------------------------------------------------------- @@ -114,6 +128,61 @@ createInstanceFromRequirements required optional baseCreateInfo = do Nothing -> liftIO $ unsatisfiedConstraints "Failed to create instance" Just ici -> snd <$> withInstance ici Nothing allocate +---------------------------------------------------------------- +-- macOS portability + windowing-friendly instance creation +---------------------------------------------------------------- + +-- | Instance requirements needed on macOS to enumerate non-conformant drivers +-- such as MoltenVK. Empty on every other platform. +portabilityRequirements :: [InstanceRequirement] + +-- | Instance create flag bits that pair with 'portabilityRequirements'. +-- 'zero' on every non-macOS platform. +portabilityFlags :: InstanceCreateFlags + +#if defined(darwin_HOST_OS) +portabilityRequirements = + [ RequireInstanceExtension + { instanceExtensionLayerName = Nothing + , instanceExtensionName = KHR_PORTABILITY_ENUMERATION_EXTENSION_NAME + , instanceExtensionMinVersion = minBound + } + ] +portabilityFlags = INSTANCE_CREATE_ENUMERATE_PORTABILITY_BIT_KHR +#else +portabilityRequirements = [] +portabilityFlags = zero +#endif + +-- | Build a Vulkan 'Instance' from a backend-supplied extension list plus +-- caller-supplied requirements. Automatically merges 'portabilityRequirements' +-- into the required list and 'portabilityFlags' into the create flags so +-- macOS apps work without per-call plumbing. +-- +-- Pass 'mempty' for the extension list when running headless; or call +-- 'Vulkan.Utils.Init.Headless.withInstance' which does so. +withVulkanInstance + :: MonadResource m + => Vector ByteString + -- ^ Backend-required instance extensions (e.g. from + -- @Vulkan.Utils.Init.SDL2.getRequiredInstanceExtensions@). 'mempty' for + -- headless. + -> Maybe ApplicationInfo + -> [InstanceRequirement] + -- ^ Caller's required requirements + -> [InstanceRequirement] + -- ^ Caller's optional requirements + -> m Instance +withVulkanInstance exts appInfo reqs optReqs = + createInstanceFromRequirements + (portabilityRequirements <> reqs) + optReqs + zero + { applicationInfo = appInfo + , enabledExtensionNames = exts + , flags = portabilityFlags + } + ---------------------------------------------------------------- -- * Device creation ---------------------------------------------------------------- @@ -174,8 +243,13 @@ pickPhysicalDevice -- ^ The score and the device pickPhysicalDevice inst devInfo score = do (_, devs) <- enumeratePhysicalDevices inst - infos <- catMaybes - <$> sequence [ fmap (, d) <$> devInfo d | d <- toList devs ] + infos <- catMaybes <$> sequence + [ do + isCPU <- (PHYSICAL_DEVICE_TYPE_CPU ==) . deviceType + <$> getPhysicalDeviceProperties d + if isCPU then pure Nothing else fmap (, d) <$> devInfo d + | d <- toList devs + ] pure $ maximumByMay (comparing (score . fst)) infos -- | Extract the name of a 'PhysicalDevice' with 'getPhysicalDeviceProperties' diff --git a/utils/vulkan-utils.cabal b/utils/vulkan-utils.cabal index 7d92dd2ca..7dfdce199 100644 --- a/utils/vulkan-utils.cabal +++ b/utils/vulkan-utils.cabal @@ -1,6 +1,6 @@ cabal-version: 1.24 --- This file has been generated from package.yaml by hpack version 0.36.1. +-- This file has been generated from package.yaml by hpack version 0.39.1. -- -- see: https://github.com/sol/hpack @@ -35,6 +35,7 @@ library Vulkan.Utils.CommandCheck Vulkan.Utils.Debug Vulkan.Utils.FromGL + Vulkan.Utils.Init.Headless Vulkan.Utils.Initialization Vulkan.Utils.Misc Vulkan.Utils.QueueAssignment