nek0/vulkan-tutorial
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

a little cleanup

Browse source
This commit is contained in:
nek0 2022-07-16 21:50:22 +02:00
parent 317d5916b0
commit 4c09e5d5a6
6 changed files with 171 additions and 192 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
src/CommandBuffer.hs
View file

@ -34,7 +34,7 @@ createCommandPool physicalDevice logicalDevice = do
commandPool <- snd <$> allocate
(Vk.createCommandPool logicalDevice poolCreateInfo Nothing)
(\commandPool -> do
putStrLn "destroying comman pool"
putStrLn "destroying command pool"
Vk.destroyCommandPool logicalDevice commandPool Nothing
)

100
src/Draw.hs
View file

@ -6,8 +6,6 @@ import Control.Monad
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Resource
import qualified Data.Vector as V
import Foreign.C.Types (CInt)
import Linear (V2(..))
import qualified Vulkan.Core10 as Vk
import qualified Vulkan.Extensions.VK_KHR_swapchain as Khr
import qualified Vulkan.CStruct.Extends as Vk
@ -16,81 +14,77 @@ import qualified Vulkan.Zero as Vk
-- internal imports
import CommandBuffer
import Types
drawFrame
:: (MonadResource m)
=> Vk.Device
-> Khr.SwapchainKHR
-> Vk.Queue
-> V.Vector Vk.CommandBuffer
-> Vk.RenderPass
-> V.Vector Vk.Framebuffer
-> V2 CInt
-> V.Vector Vk.Pipeline
-> Vk.Fence
-> Vk.Semaphore
-> Vk.Semaphore
=> EngineData
-> m ()
drawFrame
logicalDevice
swapchain
graphicsQueue
commandBuffers
renderPass
framebuffers
dimensions
pipelines
inFlightFence
imageAvailableSemaphore
renderFinishedSemaphore
= do
drawFrame engineData = do
unless (all (V.length commandBuffers ==)
[V.length commandBuffers, V.length framebuffers, V.length pipelines]) $
error ("Numbers of elements mismatch: command buffers " <> show (V.length commandBuffers) <>
", frame buffers " <> show (V.length framebuffers) <>
", pipelines " <> show (V.length pipelines))
unless (all (V.length (engineCommandBuffers engineData) ==)
[ V.length (engineCommandBuffers engineData)
, V.length (engineFramebuffers engineData)
, V.length (enginePipelines engineData)
]) $
error ("Numbers of elements mismatch: command buffers " <>
show (V.length $ engineCommandBuffers engineData) <>
", frame buffers " <> show (V.length $ engineFramebuffers engineData) <>
", pipelines " <> show (V.length $ enginePipelines engineData))
let fences = V.singleton inFlightFence
let fences = V.singleton $ engineInFlightFence engineData
void $ Vk.waitForFences logicalDevice fences True maxBound
Vk.resetFences logicalDevice fences
void $ Vk.waitForFences (engineLogicalDevice engineData) fences True maxBound
Vk.resetFences (engineLogicalDevice engineData) fences
(imageResult, index) <-
Khr.acquireNextImageKHR logicalDevice swapchain maxBound imageAvailableSemaphore Vk.NULL_HANDLE
Khr.acquireNextImageKHR
(engineLogicalDevice engineData)
(engineSwapchain engineData)
maxBound
(engineImageAvailableSemaphore engineData)
Vk.NULL_HANDLE
unless (imageResult == Vk.SUCCESS) $
error "drawFrame: Failed acquiring next image from swapchain"
liftIO $ putStrLn "resetting command buffer"
Vk.resetCommandBuffer (commandBuffers V.! fromIntegral index) (Vk.CommandBufferResetFlagBits 0)
-- liftIO $ putStrLn "resetting command buffer"
Vk.resetCommandBuffer
(engineCommandBuffers engineData V.! fromIntegral index) (Vk.CommandBufferResetFlagBits 0)
liftIO $ putStrLn "recording command buffer"
-- liftIO $ putStrLn "recording command buffer"
recordCommandBuffer
(commandBuffers V.! fromIntegral index)
renderPass
(framebuffers V.! fromIntegral index)
dimensions
(pipelines V.! fromIntegral index)
(engineCommandBuffers engineData V.! fromIntegral index)
(engineRenderPass engineData)
(engineFramebuffers engineData V.! fromIntegral index)
(engineWindowDimensions engineData)
(enginePipelines engineData V.! fromIntegral index)
let submitInfo = Vk.zero
{ Vk.waitSemaphores = V.singleton imageAvailableSemaphore
, Vk.waitDstStageMask = V.singleton Vk.PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT
, Vk.commandBuffers = V.singleton (Vk.commandBufferHandle $ commandBuffers V.! fromIntegral index)
, Vk.signalSemaphores = V.singleton renderFinishedSemaphore
{ Vk.waitSemaphores =
V.singleton $ engineImageAvailableSemaphore engineData
, Vk.waitDstStageMask =
V.singleton Vk.PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT
, Vk.commandBuffers =
V.singleton (Vk.commandBufferHandle $ engineCommandBuffers engineData V.! fromIntegral index)
, Vk.signalSemaphores =
V.singleton $ engineRenderFinishedSemaphore engineData
}
liftIO $ putStrLn "submitting to queue"
Vk.queueSubmit graphicsQueue (V.singleton (Vk.SomeStruct submitInfo)) inFlightFence
-- liftIO $ putStrLn "submitting to queue"
Vk.queueSubmit
(engineQueue engineData)
(V.singleton (Vk.SomeStruct submitInfo))
(engineInFlightFence engineData)
let presentInfo = Vk.zero
{ Khr.waitSemaphores = V.singleton renderFinishedSemaphore
, Khr.swapchains = V.singleton swapchain
{ Khr.waitSemaphores = V.singleton $ engineRenderFinishedSemaphore engineData
, Khr.swapchains = V.singleton $ engineSwapchain engineData
, Khr.imageIndices = V.singleton index
}
liftIO $ putStrLn "presenting queue"
presentResult <- Khr.queuePresentKHR graphicsQueue presentInfo
-- liftIO $ putStrLn "presenting queue"
presentResult <- Khr.queuePresentKHR (engineQueue engineData) presentInfo
unless (presentResult == Vk.SUCCESS) $
error "drawFrame: presentation failed"

145
src/GraphicsPipeline.hs
View file

@ -17,6 +17,9 @@ import qualified Vulkan.Zero as Vk
import qualified Vulkan.CStruct.Extends as Vk
import qualified Vulkan.Utils.ShaderQQ.GLSL.Shaderc as Vk
-- internal imports
import Types
loadShader
:: (MonadResource m)
=> Vk.Device
@ -49,34 +52,86 @@ loadShader logicalDevice shaderPath stage = do
Vk.destroyShaderModule logicalDevice shaderModule Nothing
)
createRenderPass
:: (MonadResource m)
=> Vk.Device
-> Vk.Format
-> m Vk.RenderPass
createRenderPass
logicalDevice
swapchainImageFormat
= do
let colorAttachmentDescription = (Vk.zero :: Vk.AttachmentDescription)
{ Vk.format = swapchainImageFormat
, Vk.samples = Vk.SAMPLE_COUNT_1_BIT
, Vk.loadOp = Vk.ATTACHMENT_LOAD_OP_CLEAR
, Vk.storeOp = Vk.ATTACHMENT_STORE_OP_STORE
, Vk.stencilLoadOp = Vk.ATTACHMENT_LOAD_OP_DONT_CARE
, Vk.stencilStoreOp = Vk.ATTACHMENT_STORE_OP_DONT_CARE
, Vk.initialLayout = Vk.IMAGE_LAYOUT_UNDEFINED
, Vk.finalLayout = Vk.IMAGE_LAYOUT_PRESENT_SRC_KHR
}
colorAttachmentReference = (Vk.zero :: Vk.AttachmentReference)
{ Vk.attachment = 0
, Vk.layout = Vk.IMAGE_LAYOUT_COLOR_ATTACHMENT_OPTIMAL
}
subpassDescriptor = (Vk.zero :: Vk.SubpassDescription)
{ Vk.pipelineBindPoint = Vk.PIPELINE_BIND_POINT_GRAPHICS
, Vk.colorAttachments = V.singleton colorAttachmentReference
}
subpassDependency = Vk.zero
{ Vk.srcSubpass = Vk.SUBPASS_EXTERNAL
, Vk.dstSubpass = 0
, Vk.srcStageMask = Vk.PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT
, Vk.dstStageMask = Vk.PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT
, Vk.srcAccessMask = Vk.ACCESS_COLOR_ATTACHMENT_WRITE_BIT
, Vk.dstAccessMask =
Vk.ACCESS_COLOR_ATTACHMENT_READ_BIT .|. Vk.ACCESS_COLOR_ATTACHMENT_WRITE_BIT
}
renderPassCreateInfo = Vk.zero
{ Vk.attachments = V.singleton colorAttachmentDescription
, Vk.subpasses = V.singleton subpassDescriptor
, Vk.dependencies = V.singleton subpassDependency
} :: Vk.RenderPassCreateInfo '[]
snd <$> allocate
(Vk.createRenderPass logicalDevice renderPassCreateInfo Nothing)
(\renderPass -> do
putStrLn "destroying render pass"
Vk.destroyRenderPass logicalDevice renderPass Nothing
)
createGraphicsPipelines
:: (MonadResource m)
=> Vk.Device
-> Vk.ShaderModule
-> Vk.ShaderModule
-> Vk.RenderPass
-> ShaderContainer
-> BS.ByteString
-> V2 CInt
-> Vk.Format
-> Int
-> m (V.Vector Vk.Pipeline, Vk.RenderPass)
-> Vk.PipelineLayout
-> m (V.Vector Vk.Pipeline)
createGraphicsPipelines
logicalDevice
vertexShaderModule
fragmentShaderModule
renderPass
shaderContainer
stageName
(V2 width height)
swapchainImageFormat
number
pipelineLayout
= do
let vertexShaderStageCreateInfo = Vk.zero
{ Vk.stage = Vk.SHADER_STAGE_VERTEX_BIT
, Vk.module' = vertexShaderModule
, Vk.module' = containedVertexShader shaderContainer
, Vk.name = stageName
}
fragmentShaderStageCreateInfo = Vk.zero
{ Vk.stage = Vk.SHADER_STAGE_FRAGMENT_BIT
, Vk.module' = fragmentShaderModule
, Vk.module' = containedFragmentShader shaderContainer
, Vk.name = stageName
}
pipelineStagesCreateInfos =
@ -150,56 +205,7 @@ createGraphicsPipelines
{ Vk.logicOpEnable = False
, Vk.attachments = V.singleton colorBlendAttachment
}
pipelineLayoutCreateInfo = Vk.zero
pipelineLayout <- snd <$> allocate
(Vk.createPipelineLayout logicalDevice pipelineLayoutCreateInfo Nothing)
(\pipelineLayout -> do
putStrLn "destroying pipeline layout"
Vk.destroyPipelineLayout logicalDevice pipelineLayout Nothing
)
let colorAttachmentDescription = (Vk.zero :: Vk.AttachmentDescription)
{ Vk.format = swapchainImageFormat
, Vk.samples = Vk.SAMPLE_COUNT_1_BIT
, Vk.loadOp = Vk.ATTACHMENT_LOAD_OP_CLEAR
, Vk.storeOp = Vk.ATTACHMENT_STORE_OP_STORE
, Vk.stencilLoadOp = Vk.ATTACHMENT_LOAD_OP_DONT_CARE
, Vk.stencilStoreOp = Vk.ATTACHMENT_STORE_OP_DONT_CARE
, Vk.initialLayout = Vk.IMAGE_LAYOUT_UNDEFINED
, Vk.finalLayout = Vk.IMAGE_LAYOUT_PRESENT_SRC_KHR
}
colorAttachmentReference = (Vk.zero :: Vk.AttachmentReference)
{ Vk.attachment = 0
, Vk.layout = Vk.IMAGE_LAYOUT_COLOR_ATTACHMENT_OPTIMAL
}
subpassDescriptor = (Vk.zero :: Vk.SubpassDescription)
{ Vk.pipelineBindPoint = Vk.PIPELINE_BIND_POINT_GRAPHICS
, Vk.colorAttachments = V.singleton colorAttachmentReference
}
subpassDependency = Vk.zero
{ Vk.srcSubpass = Vk.SUBPASS_EXTERNAL
, Vk.dstSubpass = 0
, Vk.srcStageMask = Vk.PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT
, Vk.dstStageMask = Vk.PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT
, Vk.srcAccessMask = Vk.ACCESS_COLOR_ATTACHMENT_WRITE_BIT
, Vk.dstAccessMask =
Vk.ACCESS_COLOR_ATTACHMENT_READ_BIT .|. Vk.ACCESS_COLOR_ATTACHMENT_WRITE_BIT
}
renderPassCreateInfo = Vk.zero
{ Vk.attachments = V.singleton colorAttachmentDescription
, Vk.subpasses = V.singleton subpassDescriptor
, Vk.dependencies = V.singleton subpassDependency
} :: Vk.RenderPassCreateInfo '[]
pipelineRenderPass <- snd <$> allocate
(Vk.createRenderPass logicalDevice renderPassCreateInfo Nothing)
(\renderPass -> do
putStrLn "destroying render pass"
Vk.destroyRenderPass logicalDevice renderPass Nothing
)
let pipelineCreateInfo = Vk.zero
pipelineCreateInfo = Vk.zero
{ Vk.stageCount = 2
, Vk.stages = pipelineStagesCreateInfos
, Vk.vertexInputState = Just $ Vk.SomeStruct pipelineVertexInputCreateInfo
@ -210,13 +216,13 @@ createGraphicsPipelines
, Vk.colorBlendState = Just $ Vk.SomeStruct pipelineColorBlendStateCreateInfo
, Vk.dynamicState = Just pipelineDynamicStateCreateInfo
, Vk.layout = pipelineLayout
, Vk.renderPass = pipelineRenderPass
, Vk.renderPass = renderPass
, Vk.subpass = 0
, Vk.basePipelineHandle = Vk.NULL_HANDLE
, Vk.basePipelineIndex = -1
}
pipelines <- snd <$> allocate
snd <$> allocate
(do
(result, pipelines) <- Vk.createGraphicsPipelines
logicalDevice
@ -235,4 +241,17 @@ createGraphicsPipelines
)
pipelines
)
return (pipelines, pipelineRenderPass)
createPipelineLayout
:: MonadResource m
=> Vk.Device
-> m Vk.PipelineLayout
createPipelineLayout logicalDevice = do
let pipelineLayoutCreateInfo = Vk.zero
snd <$> allocate
(Vk.createPipelineLayout logicalDevice pipelineLayoutCreateInfo Nothing)
(\pipelineLayout -> do
putStrLn "destroying pipeline layout"
Vk.destroyPipelineLayout logicalDevice pipelineLayout Nothing
)

73
src/Init.hs
View file

@ -6,11 +6,8 @@ module Init where
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Resource
import qualified Data.Vector as V
import Linear (V2)
import qualified SDL hiding (V2)
import qualified SDL.Video.Vulkan as SDL
import Foreign.C.Types (CInt)
import Foreign.Ptr
import qualified Vulkan.Core10 as Vk
import qualified Vulkan.Extensions.VK_KHR_swapchain as Khr
@ -23,23 +20,11 @@ import Devices
import GraphicsPipeline
import Framebuffers
import CommandBuffer
import Types
initEngine
:: (MonadResource m, MonadFail m)
=> m
( SDL.Window
, V2 CInt
, Vk.Device
, Khr.SwapchainKHR
, Vk.Queue
, V.Vector Vk.CommandBuffer
, V.Vector Vk.Framebuffer
, V.Vector Vk.Pipeline
, Vk.RenderPass
, Vk.Fence
, Vk.Semaphore
, Vk.Semaphore
)
=> m EngineData
initEngine = do
-- initialize SDL2 with all subsystems
void $ allocate_
@ -72,20 +57,7 @@ initEngine = do
initVulkan
:: (MonadResource m, MonadFail m)
=> SDL.Window
-> m
( SDL.Window
, V2 CInt
, Vk.Device
, Khr.SwapchainKHR
, Vk.Queue
, V.Vector Vk.CommandBuffer
, V.Vector Vk.Framebuffer
, V.Vector Vk.Pipeline
, Vk.RenderPass
, Vk.Fence
, Vk.Semaphore
, Vk.Semaphore
)
-> m EngineData
initVulkan window = do
vulkanInstance <- createInstance window
@ -108,15 +80,18 @@ initVulkan window = do
imageViews <- getImageViewHandles swapchain surfaceFormat vulkanLogicalDevice
vertexShader <- loadShader vulkanLogicalDevice "shadersrc/shader.vert" "vert"
fragmentShader <- loadShader vulkanLogicalDevice "shadersrc/shader.frag" "frag"
(pipelines, renderPass) <-
renderPass <- createRenderPass vulkanLogicalDevice (Khr.format surfaceFormat)
pipelineLayout <- createPipelineLayout vulkanLogicalDevice
let shaderContainer = ShaderContainer vertexShader fragmentShader
pipelines <-
createGraphicsPipelines
vulkanLogicalDevice
vertexShader
fragmentShader
renderPass
shaderContainer
"main"
dimensions
(Khr.format surfaceFormat)
(length imageViews)
pipelineLayout
frameBuffers <- createFramebuffer vulkanLogicalDevice renderPass imageViews dimensions
@ -126,17 +101,17 @@ initVulkan window = do
(imageAvailableSemaphore, renderFinishedSemaphore, inFlightFence) <-
createSyncObjects vulkanLogicalDevice
return
( window
, dimensions
, vulkanLogicalDevice
, swapchain
, graphicsQueue
, commandBuffer
, frameBuffers
, pipelines
, renderPass
, inFlightFence
, imageAvailableSemaphore
, renderFinishedSemaphore
)
return $ EngineData
window
dimensions
vulkanLogicalDevice
swapchain
graphicsQueue
commandBuffer
frameBuffers
pipelines
renderPass
inFlightFence
imageAvailableSemaphore
renderFinishedSemaphore

20
src/Main.hs
View file

@ -19,12 +19,13 @@ import qualified Vulkan.Zero as Vk
import Init
import Draw (drawFrame)
import Types
main :: IO ()
main = runResourceT $ do
(window, dimensions, logicalDevice, swapchain, graphicsQueue, commandBuffers, framebuffers, pipelines, renderPass, inFlightFence, imageAvailableSemaphore, renderFinishedSemaphore) <- initEngine
engineData <- initEngine
SDL.showWindow window
SDL.showWindow $ engineWindow engineData
-- create abort condition for upcoming lop
quit <- liftIO $ STM.newTMVarIO True
@ -35,18 +36,7 @@ main = runResourceT $ do
)
( do
-- draw
drawFrame
logicalDevice
swapchain
graphicsQueue
commandBuffers
renderPass
framebuffers
dimensions
pipelines
inFlightFence
imageAvailableSemaphore
renderFinishedSemaphore
drawFrame engineData
-- poll events
evs <- liftIO SDL.pollEvents
-- flip abort condition on window close
@ -59,7 +49,7 @@ main = runResourceT $ do
evs
)
Vk.deviceWaitIdle logicalDevice
Vk.deviceWaitIdle $ engineLogicalDevice engineData
createBufferView
:: (MonadResource m)

1
vulkan-tutorial.cabal
View file

@ -31,6 +31,7 @@ executable vulkan-tutorial
Framebuffers
CommandBuffer
Draw
Types
-- LANGUAGE extensions used by modules in this package.
-- other-extensions: