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
)

122
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
(imageResult, index) <-
Khr.acquireNextImageKHR
(engineLogicalDevice engineData)
(engineSwapchain engineData)
maxBound
(engineImageAvailableSemaphore engineData)
Vk.NULL_HANDLE
unless (imageResult == Vk.SUCCESS) $
error "drawFrame: Failed acquiring next image from swapchain"
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"
recordCommandBuffer
(commandBuffers V.! fromIntegral index)
renderPass
(framebuffers V.! fromIntegral index)
dimensions
(pipelines V.! fromIntegral index)
-- liftIO $ putStrLn "recording command buffer"
recordCommandBuffer
(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
}
let submitInfo = Vk.zero
{ 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.imageIndices = V.singleton index
}
let presentInfo = Vk.zero
{ 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"
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: